[BACK]Return to lonnet.pm CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom / lonnet / perl

Diff for /loncom/lonnet/perl/lonnet.pm between versions 1.1172.2.52 and 1.1172.2.60

version 1.1172.2.52, 2014/06/25 18:44:10 version 1.1172.2.60, 2015/03/11 04:21:21
Line 1647  sub dump_dom { Line 1647  sub dump_dom {
   
 sub get_dom {  sub get_dom {
     my ($namespace,$storearr,$udom,$uhome)=@_;      my ($namespace,$storearr,$udom,$uhome)=@_;
       return if ($udom eq 'public');
     my $items='';      my $items='';
     foreach my $item (@$storearr) {      foreach my $item (@$storearr) {
         $items.=&escape($item).'&';          $items.=&escape($item).'&';
Line 1654  sub get_dom { Line 1655  sub get_dom {
     $items=~s/\&$//;      $items=~s/\&$//;
     if (!$udom) {      if (!$udom) {
         $udom=$env{'user.domain'};          $udom=$env{'user.domain'};
           return if ($udom eq 'public');
         if (defined(&domain($udom,'primary'))) {          if (defined(&domain($udom,'primary'))) {
             $uhome=&domain($udom,'primary');              $uhome=&domain($udom,'primary');
         } else {          } else {
Line 2068  sub get_domain_defaults { Line 2070  sub get_domain_defaults {
         }          }
     }      }
     if (ref($domconfig{'coursedefaults'}) eq 'HASH') {      if (ref($domconfig{'coursedefaults'}) eq 'HASH') {
           $domdefaults{'usejsme'} = $domconfig{'coursedefaults'}{'usejsme'};
           $domdefaults{'uselcmath'} = $domconfig{'coursedefaults'}{'uselcmath'};
           if (ref($domconfig{'coursedefaults'}{'postsubmit'}) eq 'HASH') {
               $domdefaults{'postsubmit'} = $domconfig{'coursedefaults'}{'postsubmit'}{'client'};
           }
         foreach my $type (@coursetypes) {          foreach my $type (@coursetypes) {
             if (ref($domconfig{'coursedefaults'}{'coursecredits'}) eq 'HASH') {              if (ref($domconfig{'coursedefaults'}{'coursecredits'}) eq 'HASH') {
                 unless ($type eq 'community') {                  unless ($type eq 'community') {
Line 2077  sub get_domain_defaults { Line 2084  sub get_domain_defaults {
             if (ref($domconfig{'coursedefaults'}{'uploadquota'}) eq 'HASH') {              if (ref($domconfig{'coursedefaults'}{'uploadquota'}) eq 'HASH') {
                 $domdefaults{$type.'quota'} = $domconfig{'coursedefaults'}{'uploadquota'}{$type};                  $domdefaults{$type.'quota'} = $domconfig{'coursedefaults'}{'uploadquota'}{$type};
             }              }
               if ($domdefaults{'postsubmit'} eq 'on') {
                   if (ref($domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}) eq 'HASH') {
                       $domdefaults{$type.'postsubtimeout'} =
                           $domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}{$type};
                   }
               }
         }          }
     }      }
     if (ref($domconfig{'usersessions'}) eq 'HASH') {      if (ref($domconfig{'usersessions'}) eq 'HASH') {
Line 2715  sub ssi { Line 2728  sub ssi {
     &Apache::lonenc::check_encrypt(\$fn);      &Apache::lonenc::check_encrypt(\$fn);
     if (%form) {      if (%form) {
       $request=new HTTP::Request('POST',&absolute_url().$fn);        $request=new HTTP::Request('POST',&absolute_url().$fn);
       $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys(%form)));        $request->content(join('&',map {
               my $name = escape($_);
               "$name=" . ( ref($form{$_}) eq 'ARRAY'
               ? join("&$name=", map {escape($_) } @{$form{$_}})
               : &escape($form{$_}) );
           } keys(%form)));
     } else {      } else {
       $request=new HTTP::Request('GET',&absolute_url().$fn);        $request=new HTTP::Request('GET',&absolute_url().$fn);
     }      }
Line 5175  sub privileged { Line 5193  sub privileged {
         my %rolesdump = &dump("roles", $domain, $username) or return 0;          my %rolesdump = &dump("roles", $domain, $username) or return 0;
         my $now = time;          my $now = time;
   
         for my $role (@rolesdump{grep { ! /^rolesdef_/ } keys %rolesdump}) {          for my $role (@rolesdump{grep { ! /^rolesdef_/ } keys(%rolesdump)}) {
             my ($trole, $tend, $tstart) = split(/_/, $role);              my ($trole, $tend, $tstart) = split(/_/, $role);
             if (grep(/^\Q$trole\E$/,@{$roles})) {              if (grep(/^\Q$trole\E$/,@{$roles})) {
                 return 1 unless ($tend && $tend < $now)                  return 1 unless ($tend && $tend < $now)
Line 5264  sub rolesinit { Line 5282  sub rolesinit {
     my %allroles=();      my %allroles=();
     my %allgroups=();      my %allgroups=();
   
     for my $area (grep { ! /^rolesdef_/ } keys %rolesdump) {      for my $area (grep { ! /^rolesdef_/ } keys(%rolesdump)) {
         my $role = $rolesdump{$area};          my $role = $rolesdump{$area};
         $area =~ s/\_\w\w$//;          $area =~ s/\_\w\w$//;
   
Line 5704  sub dump { Line 5722  sub dump {
     if (!$uname) { $uname=$env{'user.name'}; }      if (!$uname) { $uname=$env{'user.name'}; }
     my $uhome=&homeserver($uname,$udomain);      my $uhome=&homeserver($uname,$udomain);
   
     my $reply;      if ($regexp) {
           $regexp=&escape($regexp);
       } else {
           $regexp='.';
       }
     if (grep { $_ eq $uhome } &current_machine_ids()) {      if (grep { $_ eq $uhome } &current_machine_ids()) {
         # user is hosted on this machine          # user is hosted on this machine
         $reply = LONCAPA::Lond::dump_with_regexp(join(':', ($udomain,          my $reply = LONCAPA::Lond::dump_with_regexp(join(':', ($udomain,
                     $uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'});                      $uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'});
         return %{&unserialize($reply, $escapedkeys)};          return %{&unserialize($reply, $escapedkeys)};
     }      }
     if ($regexp) {  
  $regexp=&escape($regexp);  
     } else {  
  $regexp='.';  
     }  
     my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);      my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
     my @pairs=split(/\&/,$rep);      my @pairs=split(/\&/,$rep);
     my %returnhash=();      my %returnhash=();
Line 5892  sub newput { Line 5909  sub newput {
 # ---------------------------------------------------------  putstore interface  # ---------------------------------------------------------  putstore interface
   
 sub putstore {  sub putstore {
    my ($namespace,$symb,$version,$storehash,$udomain,$uname)=@_;     my ($namespace,$symb,$version,$storehash,$udomain,$uname,$tolog)=@_;
    if (!$udomain) { $udomain=$env{'user.domain'}; }     if (!$udomain) { $udomain=$env{'user.domain'}; }
    if (!$uname) { $uname=$env{'user.name'}; }     if (!$uname) { $uname=$env{'user.name'}; }
    my $uhome=&homeserver($uname,$udomain);     my $uhome=&homeserver($uname,$udomain);
Line 5906  sub putstore { Line 5923  sub putstore {
    my $reply =     my $reply =
        &reply("putstore:$udomain:$uname:$namespace:$esc_symb:$esc_v:$items",         &reply("putstore:$udomain:$uname:$namespace:$esc_symb:$esc_v:$items",
       $uhome);        $uhome);
      if (($tolog) && ($reply eq 'ok')) {
          my $namevalue='';
          foreach my $key (keys(%{$storehash})) {
              $namevalue.=&escape($key).'='.&freeze_escape($storehash->{$key}).'&';
          }
          $namevalue .= 'ip='.&escape($ENV{'REMOTE_ADDR'}).
                        '&host='.&escape($perlvar{'lonHostID'}).
                        '&version='.$esc_v.
                        '&by='.&escape($env{'user.name'}.':'.$env{'user.domain'});
          &Apache::lonnet::courselog($symb.':'.$uname.':'.$udomain.':PUTSTORE:'.$namevalue);
      }
    if ($reply eq 'unknown_cmd') {     if ($reply eq 'unknown_cmd') {
        # gfall back to way things use to be done         # gfall back to way things use to be done
        return &old_putstore($namespace,$symb,$version,$storehash,$udomain,         return &old_putstore($namespace,$symb,$version,$storehash,$udomain,
Line 6064  sub get_timebased_id { Line 6092  sub get_timebased_id {
         my %inuse = &Apache::lonnet::dump('nohist_'.$namespace,$cdom,$cnum,$prefix);          my %inuse = &Apache::lonnet::dump('nohist_'.$namespace,$cdom,$cnum,$prefix);
         my $id = time;          my $id = time;
         $newid = $id;          $newid = $id;
           if ($idtype eq 'addcode') {
               $newid .= &sixnum_code();
           }
         my $idtries = 0;          my $idtries = 0;
         while (exists($inuse{$prefix."\0".$newid}) && $idtries < $maxtries) {          while (exists($inuse{$prefix."\0".$newid}) && $idtries < $maxtries) {
             if ($idtype eq 'concat') {              if ($idtype eq 'concat') {
                 $newid = $id.$idtries;                  $newid = $id.$idtries;
               } elsif ($idtype eq 'addcode') {
                   $newid = $newid.&sixnum_code();
             } else {              } else {
                 $newid ++;                  $newid ++;
             }              }
Line 6084  sub get_timebased_id { Line 6117  sub get_timebased_id {
                 $error = 'error saving new item: '.$putresult;                  $error = 'error saving new item: '.$putresult;
             }              }
         } else {          } else {
                undef($newid);
              $error = ('error: no unique suffix available for the new item ');               $error = ('error: no unique suffix available for the new item ');
         }          }
 #  remove lock  #  remove lock
Line 6092  sub get_timebased_id { Line 6126  sub get_timebased_id {
     } else {      } else {
         $error = "error: could not obtain lockfile\n";          $error = "error: could not obtain lockfile\n";
         $dellock = 'ok';          $dellock = 'ok';
           if (($prefix eq 'paste') && ($namespace eq 'courseeditor') && ($keyid eq 'num')) {
               $dellock = 'nolock';
           }
     }      }
     return ($newid,$dellock,$error);      return ($newid,$dellock,$error);
 }  }
   
   sub sixnum_code {
       my $code;
       for (0..6) {
           $code .= int( rand(9) );
       }
       return $code;
   }
   
 # -------------------------------------------------- portfolio access checking  # -------------------------------------------------- portfolio access checking
   
 sub portfolio_access {  sub portfolio_access {
Line 10558  sub metadata { Line 10603  sub metadata {
   
  $metaentry{':keys'} = join(',',keys(%metathesekeys));   $metaentry{':keys'} = join(',',keys(%metathesekeys));
  &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);   &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
  $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);   $metaentry{':allpossiblekeys'}=join(',',keys(%metathesekeys));
  &do_cache_new('meta',$uri,\%metaentry,$cachetime);   &do_cache_new('meta',$uri,\%metaentry,$cachetime);
 # this is the end of "was not already recently cached  # this is the end of "was not already recently cached
     }      }
Line 10930  sub deversion { Line 10975  sub deversion {
   
 sub symbread {  sub symbread {
     my ($thisfn,$donotrecurse)=@_;      my ($thisfn,$donotrecurse)=@_;
     my $cache_str;      my $cache_str='request.symbread.cached.'.$thisfn;
     if ($thisfn ne '') {      if (defined($env{$cache_str})) { return $env{$cache_str}; }
         $cache_str='request.symbread.cached.'.$thisfn;  
         if ($env{$cache_str} ne '') {  
             return $env{$cache_str};  
         }  
    } else {  
 # no filename provided? try from environment  # no filename provided? try from environment
       unless ($thisfn) {
         if ($env{'request.symb'}) {          if ($env{'request.symb'}) {
             return $env{$cache_str}=&symbclean($env{'request.symb'});              return $env{$cache_str}=&symbclean($env{'request.symb'});
         }          }
Line 11905  sub get_dns { Line 11946  sub get_dns {
 # ------------------------------------------------------Get DNS checksums file  # ------------------------------------------------------Get DNS checksums file
 sub parse_dns_checksums_tab {  sub parse_dns_checksums_tab {
     my ($lines,$hashref) = @_;      my ($lines,$hashref) = @_;
     my $machine_dom = &Apache::lonnet::host_domain($perlvar{'lonHostID'});      my $lonhost = $perlvar{'lonHostID'};
       my $machine_dom = &Apache::lonnet::host_domain($lonhost);
     my $loncaparev = &get_server_loncaparev($machine_dom);      my $loncaparev = &get_server_loncaparev($machine_dom);
       my $distro = (split(/\:/,&get_server_distarch($lonhost)))[0];
       my $webconfdir = '/etc/httpd/conf';
       if ($distro =~ /^(ubuntu|debian)(\d+)$/) {
           $webconfdir = '/etc/apache2';
       } elsif ($distro =~ /^sles(\d+)$/) {
           if ($1 >= 10) {
               $webconfdir = '/etc/apache2';
           }
       } elsif ($distro =~ /^suse(\d+\.\d+)$/) {
           if ($1 >= 10.0) {
               $webconfdir = '/etc/apache2';
           }
       }
     my ($release,$timestamp) = split(/\-/,$loncaparev);      my ($release,$timestamp) = split(/\-/,$loncaparev);
     my (%chksum,%revnum);      my (%chksum,%revnum);
     if (ref($lines) eq 'ARRAY') {      if (ref($lines) eq 'ARRAY') {
Line 11915  sub parse_dns_checksums_tab { Line 11970  sub parse_dns_checksums_tab {
         if ($version eq $release) {          if ($version eq $release) {
             foreach my $line (@{$lines}) {              foreach my $line (@{$lines}) {
                 my ($file,$version,$shasum) = split(/,/,$line);                  my ($file,$version,$shasum) = split(/,/,$line);
                   if ($file =~ m{^/etc/httpd/conf}) {
                       if ($webconfdir eq '/etc/apache2') {
                           $file =~ s{^\Q/etc/httpd/conf/\E}{$webconfdir/};
                       }
                   }
                 $chksum{$file} = $shasum;                  $chksum{$file} = $shasum;
                 $revnum{$file} = $version;                  $revnum{$file} = $version;
             }              }
Line 13299  $range should be either an integer '100' Line 13359  $range should be either an integer '100'
   
 =item *  =item *
   
 putstore($namespace,$symb,$version,$storehash,$udomain,$uname) :  putstore($namespace,$symb,$version,$storehash,$udomain,$uname,$tolog) :
 replaces a &store() version of data with a replacement set of data  replaces a &store() version of data with a replacement set of data
 for a particular resource in a namespace passed in the $storehash hash   for a particular resource in a namespace passed in the $storehash hash 
 reference  reference. If $tolog is true, the transaction is logged in the courselog
   with an action=PUTSTORE.
   
 =item *  =item *
   
Removed from v.1.1172.2.52  
changed lines
  Added in v.1.1172.2.60

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>