[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.81 and 1.1189

version 1.1172.2.81, 2016/09/18 14:37:57 version 1.1189, 2012/09/02 16:18:24
Line 75  use LWP::UserAgent(); Line 75  use LWP::UserAgent();
 use HTTP::Date;  use HTTP::Date;
 use Image::Magick;  use Image::Magick;
   
   
   use Encode;
   
 use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir  use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir
             $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease              $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease
             %managerstab);              %managerstab);
Line 89  use GDBM_File; Line 92  use GDBM_File;
 use HTML::LCParser;  use HTML::LCParser;
 use Fcntl qw(:flock);  use Fcntl qw(:flock);
 use Storable qw(thaw nfreeze);  use Storable qw(thaw nfreeze);
 use Time::HiRes qw( sleep gettimeofday tv_interval );  use Time::HiRes qw( gettimeofday tv_interval );
 use Cache::Memcached;  use Cache::Memcached;
 use Digest::MD5;  use Digest::MD5;
 use Math::Random;  use Math::Random;
Line 102  use LONCAPA::Lond; Line 105  use LONCAPA::Lond;
 use File::Copy;  use File::Copy;
   
 my $readit;  my $readit;
 my $max_connection_retries = 20;     # Or some such value.  my $max_connection_retries = 10;     # Or some such value.
   
 require Exporter;  require Exporter;
   
 our @ISA = qw (Exporter);  our @ISA = qw (Exporter);
 our @EXPORT = qw(%env);  our @EXPORT = qw(%env);
   
   
 # ------------------------------------ Logging (parameters, docs, slots, roles)  # ------------------------------------ Logging (parameters, docs, slots, roles)
 {  {
     my $logid;      my $logid;
Line 123  our @EXPORT = qw(%env); Line 127  our @EXPORT = qw(%env);
  $logid ++;   $logid ++;
         my $now = time();          my $now = time();
  my $id=$now.'00000'.$$.'00000'.$logid;   my $id=$now.'00000'.$$.'00000'.$logid;
         my $logentry = {          my $logentry = { 
                          $id => {                            $id => {
                                   'exe_uname' => $env{'user.name'},                                     'exe_uname' => $env{'user.name'},
                                   'exe_udom'  => $env{'user.domain'},                                     'exe_udom'  => $env{'user.domain'},
                                   'exe_time'  => $now,                                     'exe_time'  => $now,
                                   'exe_ip'    => $ENV{'REMOTE_ADDR'},                                     'exe_ip'    => $ENV{'REMOTE_ADDR'},
                                   'delflag'   => $delflag,                                     'delflag'   => $delflag,
                                   'logentry'  => $storehash,                                     'logentry'  => $storehash,
                                   'uname'     => $uname,                                     'uname'     => $uname,
                                   'udom'      => $udom,                                     'udom'      => $udom,
                                 }                                    }
                        };                         };
         return &put('nohist_'.$hash_name,$logentry,$cdom,$cnum);   return &put('nohist_'.$hash_name,$logentry,$cdom,$cnum);
     }      }
 }  }
   
Line 352  sub get_remote_globals { Line 356  sub get_remote_globals {
 }  }
   
 sub remote_devalidate_cache {  sub remote_devalidate_cache {
     my ($lonhost,$cachekeys) = @_;      my ($lonhost,$name,$id) = @_;
     my $items;      my $response = &reply('devalidatecache:'.&escape($name).':'.&escape($id),$lonhost);
     return unless (ref($cachekeys) eq 'ARRAY');      return $response;
     my $cachestr = join('&',@{$cachekeys});  
     return &reply('devalidatecache:'.&escape($cachestr),$lonhost);  
 }  }
   
 # -------------------------------------------------- Non-critical communication  # -------------------------------------------------- Non-critical communication
Line 370  sub subreply { Line 372  sub subreply {
   
     my $lockfile=$peerfile.".lock";      my $lockfile=$peerfile.".lock";
     while (-e $lockfile) { # Need to wait for the lockfile to disappear.      while (-e $lockfile) { # Need to wait for the lockfile to disappear.
  sleep(0.1);   sleep(1);
     }      }
     # At this point, either a loncnew parent is listening or an old lonc      # At this point, either a loncnew parent is listening or an old lonc
     # or loncnew child is listening so we can connect or everything's dead.      # or loncnew child is listening so we can connect or everything's dead.
Line 388  sub subreply { Line 390  sub subreply {
  } else {   } else {
     &create_connection(&hostname($server),$server);      &create_connection(&hostname($server),$server);
  }   }
         sleep(0.1); # Try again later if failed connection.          sleep(1); # Try again later if failed connection.
     }      }
     my $answer;      my $answer;
     if ($client) {      if ($client) {
Line 417  sub reply { Line 419  sub reply {
   
 sub reconlonc {  sub reconlonc {
     my ($lonid) = @_;      my ($lonid) = @_;
       my $hostname = &hostname($lonid);
     if ($lonid) {      if ($lonid) {
         my $hostname = &hostname($lonid);  
  my $peerfile="$perlvar{'lonSockDir'}/$hostname";   my $peerfile="$perlvar{'lonSockDir'}/$hostname";
  if ($hostname && -e $peerfile) {   if ($hostname && -e $peerfile) {
     &logthis("Trying to reconnect lonc for $lonid ($hostname)");      &logthis("Trying to reconnect lonc for $lonid ($hostname)");
Line 464  sub critical { Line 466  sub critical {
     }      }
     my $answer=reply($cmd,$server);      my $answer=reply($cmd,$server);
     if ($answer eq 'con_lost') {      if ($answer eq 'con_lost') {
  &reconlonc($server);   &reconlonc("$perlvar{'lonSockDir'}/$server");
  my $answer=reply($cmd,$server);   my $answer=reply($cmd,$server);
         if ($answer eq 'con_lost') {          if ($answer eq 'con_lost') {
             my $now=time;              my $now=time;
Line 481  sub critical { Line 483  sub critical {
     close($dfh);      close($dfh);
  }   }
             }              }
             sleep 1;              sleep 2;
             my $wcmd='';              my $wcmd='';
             {              {
  my $dfh;   my $dfh;
Line 601  sub transfer_profile_to_env { Line 603  sub transfer_profile_to_env {
   
 # ---------------------------------------------------- Check for valid session   # ---------------------------------------------------- Check for valid session 
 sub check_for_valid_session {  sub check_for_valid_session {
     my ($r,$name,$userhashref) = @_;      my ($r,$name) = @_;
     my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));      my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));
     if ($name eq '') {      if ($name eq '') {
         $name = 'lonID';          $name = 'lonID';
Line 632  sub check_for_valid_session { Line 634  sub check_for_valid_session {
  || !defined($disk_env{'user.domain'})) {   || !defined($disk_env{'user.domain'})) {
  return undef;   return undef;
     }      }
   
     if (ref($userhashref) eq 'HASH') {  
         $userhashref->{'name'} = $disk_env{'user.name'};  
         $userhashref->{'domain'} = $disk_env{'user.domain'};  
     }  
   
     return $handle;      return $handle;
 }  }
   
Line 671  sub appenv { Line 667  sub appenv {
     if (($key =~ /^user\.role/) || ($key =~ /^user\.priv/)) {      if (($key =~ /^user\.role/) || ($key =~ /^user\.priv/)) {
                 $refused = 1;                  $refused = 1;
                 if (ref($roles) eq 'ARRAY') {                  if (ref($roles) eq 'ARRAY') {
                     my ($type,$role) = ($key =~ m{^user\.(role|priv)\.(.+?)\./});                      my ($type,$role) = ($key =~ /^user\.(role|priv)\.([^.]+)\./);
                     if (grep(/^\Q$role\E$/,@{$roles})) {                      if (grep(/^\Q$role\E$/,@{$roles})) {
                         $refused = 0;                          $refused = 0;
                     }                      }
Line 844  sub spareserver { Line 840  sub spareserver {
     if (ref($spareshash) eq 'HASH') {      if (ref($spareshash) eq 'HASH') {
         if (ref($spareshash->{'primary'}) eq 'ARRAY') {          if (ref($spareshash->{'primary'}) eq 'ARRAY') {
             foreach my $try_server (@{ $spareshash->{'primary'} }) {              foreach my $try_server (@{ $spareshash->{'primary'} }) {
                 next unless (&spare_can_host($udom,$uint_dom,$remotesessions,                  if ($uint_dom) {
                                              $try_server));                      next unless (&spare_can_host($udom,$uint_dom,$remotesessions,
                                                    $try_server));
                   }
         ($spare_server, $lowest_load) =          ($spare_server, $lowest_load) =
             &compare_server_load($try_server, $spare_server, $lowest_load);              &compare_server_load($try_server, $spare_server, $lowest_load);
             }              }
Line 856  sub spareserver { Line 854  sub spareserver {
         if (!$found_server) {          if (!$found_server) {
             if (ref($spareshash->{'default'}) eq 'ARRAY') {               if (ref($spareshash->{'default'}) eq 'ARRAY') { 
         foreach my $try_server (@{ $spareshash->{'default'} }) {          foreach my $try_server (@{ $spareshash->{'default'} }) {
                     next unless (&spare_can_host($udom,$uint_dom,                      if ($uint_dom) {
                                                  $remotesessions,$try_server));                          next unless (&spare_can_host($udom,$uint_dom,
                                                        $remotesessions,$try_server));
                       }
             ($spare_server, $lowest_load) =              ($spare_server, $lowest_load) =
         &compare_server_load($try_server, $spare_server, $lowest_load);          &compare_server_load($try_server, $spare_server, $lowest_load);
                 }                  }
Line 881  sub spareserver { Line 881  sub spareserver {
 }  }
   
 sub compare_server_load {  sub compare_server_load {
     my ($try_server, $spare_server, $lowest_load, $required) = @_;      my ($try_server, $spare_server, $lowest_load) = @_;
   
     if ($required) {  
         my ($reqdmajor,$reqdminor) = ($required =~ /^(\d+)\.(\d+)$/);  
         my $remoterev = &get_server_loncaparev(undef,$try_server);  
         my ($major,$minor) = ($remoterev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/);  
         if (($major eq '' && $minor eq '') ||  
             (($reqdmajor > $major) || (($reqdmajor == $major) && ($reqdminor > $minor)))) {  
             return ($spare_server,$lowest_load);  
         }  
     }  
   
     my $loadans     = &reply('load',    $try_server);      my $loadans     = &reply('load',    $try_server);
     my $userloadans = &reply('userload',$try_server);      my $userloadans = &reply('userload',$try_server);
Line 952  sub has_user_session { Line 942  sub has_user_session {
 # --------- determine least loaded server in a user's domain which allows login  # --------- determine least loaded server in a user's domain which allows login
   
 sub choose_server {  sub choose_server {
     my ($udom,$checkloginvia,$required,$skiploadbal) = @_;      my ($udom,$checkloginvia) = @_;
     my %domconfhash = &Apache::loncommon::get_domainconf($udom);      my %domconfhash = &Apache::loncommon::get_domainconf($udom);
     my %servers = &get_servers($udom);      my %servers = &get_servers($udom);
     my $lowest_load = 30000;      my $lowest_load = 30000;
     my ($login_host,$hostname,$portal_path,$isredirect,$balancers);      my ($login_host,$hostname,$portal_path,$isredirect);
     if ($skiploadbal) {  
         ($balancers,my $cached)=&is_cached_new('loadbalancing',$udom);  
         unless (defined($cached)) {  
             my $cachetime = 60*60*24;  
             my %domconfig =  
                 &Apache::lonnet::get_dom('configuration',['loadbalancing'],$udom);  
             if (ref($domconfig{'loadbalancing'}) eq 'HASH') {  
                 $balancers = &do_cache_new('loadbalancing',$udom,$domconfig{'loadbalancing'},  
                                            $cachetime);  
             }  
         }  
     }  
     foreach my $lonhost (keys(%servers)) {      foreach my $lonhost (keys(%servers)) {
         my $loginvia;          my $loginvia;
         if ($skiploadbal) {  
             if (ref($balancers) eq 'HASH') {  
                 next if (exists($balancers->{$lonhost}));  
             }  
         }  
         if ($checkloginvia) {          if ($checkloginvia) {
             $loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost};              $loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost};
             if ($loginvia) {              if ($loginvia) {
                 my ($server,$path) = split(/:/,$loginvia);                  my ($server,$path) = split(/:/,$loginvia);
                 ($login_host, $lowest_load) =                  ($login_host, $lowest_load) =
                     &compare_server_load($server, $login_host, $lowest_load, $required);                      &compare_server_load($server, $login_host, $lowest_load);
                 if ($login_host eq $server) {                  if ($login_host eq $server) {
                     $portal_path = $path;                      $portal_path = $path;
                     $isredirect = 1;                      $isredirect = 1;
                 }                  }
             } else {              } else {
                 ($login_host, $lowest_load) =                  ($login_host, $lowest_load) =
                     &compare_server_load($lonhost, $login_host, $lowest_load, $required);                      &compare_server_load($lonhost, $login_host, $lowest_load);
                 if ($login_host eq $lonhost) {                  if ($login_host eq $lonhost) {
                     $portal_path = '';                      $portal_path = '';
                     $isredirect = '';                       $isredirect = ''; 
Line 996  sub choose_server { Line 969  sub choose_server {
             }              }
         } else {          } else {
             ($login_host, $lowest_load) =              ($login_host, $lowest_load) =
                 &compare_server_load($lonhost, $login_host, $lowest_load, $required);                  &compare_server_load($lonhost, $login_host, $lowest_load);
         }          }
     }      }
     if ($login_host ne '') {      if ($login_host ne '') {
Line 1169  sub can_host_session { Line 1142  sub can_host_session {
 sub spare_can_host {  sub spare_can_host {
     my ($udom,$uint_dom,$remotesessions,$try_server)=@_;      my ($udom,$uint_dom,$remotesessions,$try_server)=@_;
     my $canhost=1;      my $canhost=1;
     my $try_server_hostname = &hostname($try_server);      my @intdoms;
     my $serverhomeID = &get_server_homeID($try_server_hostname);      my $internet_names = &Apache::lonnet::get_internet_names($try_server);
     my $serverhomedom = &host_domain($serverhomeID);      if (ref($internet_names) eq 'ARRAY') {
     my %defdomdefaults = &get_domain_defaults($serverhomedom);          @intdoms = @{$internet_names};
     if (ref($defdomdefaults{'offloadnow'}) eq 'HASH') {      }
         if ($defdomdefaults{'offloadnow'}{$try_server}) {      unless (grep(/^\Q$uint_dom\E$/,@intdoms)) {
             $canhost = 0;          my $serverhomeID = &Apache::lonnet::get_server_homeID($try_server);
         }          my $serverhomedom = &Apache::lonnet::host_domain($serverhomeID);
     }          my %defdomdefaults = &Apache::lonnet::get_domain_defaults($serverhomedom);
     if (($canhost) && ($uint_dom)) {          my $remoterev = &Apache::lonnet::get_server_loncaparev(undef,$try_server);
         my @intdoms;          $canhost = &can_host_session($udom,$try_server,$remoterev,
         my $internet_names = &get_internet_names($try_server);                                       $remotesessions,
         if (ref($internet_names) eq 'ARRAY') {                                       $defdomdefaults{'hostedsessions'});
             @intdoms = @{$internet_names};  
         }  
         unless (grep(/^\Q$uint_dom\E$/,@intdoms)) {  
             my $remoterev = &get_server_loncaparev(undef,$try_server);  
             $canhost = &can_host_session($udom,$try_server,$remoterev,  
                                          $remotesessions,  
                                          $defdomdefaults{'hostedsessions'});  
         }  
     }      }
     return $canhost;      return $canhost;
 }  }
Line 1275  sub get_lonbalancer_config { Line 1240  sub get_lonbalancer_config {
   
 sub check_loadbalancing {  sub check_loadbalancing {
     my ($uname,$udom) = @_;      my ($uname,$udom) = @_;
     my ($is_balancer,$currtargets,$currrules,$dom_in_use,$homeintdom,      my ($is_balancer,$dom_in_use,$homeintdom,$rule_in_effect,
         $rule_in_effect,$offloadto,$otherserver);          $offloadto,$otherserver);
     my $lonhost = $perlvar{'lonHostID'};      my $lonhost = $perlvar{'lonHostID'};
     my @hosts = &current_machine_ids();      my @hosts = &current_machine_ids();
     my $uprimary_id = &Apache::lonnet::domain($udom,'primary');      my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
     my $uintdom = &Apache::lonnet::internet_dom($uprimary_id);      my $uintdom = &Apache::lonnet::internet_dom($uprimary_id);
     my $intdom = &Apache::lonnet::internet_dom($lonhost);      my $intdom = &Apache::lonnet::internet_dom($lonhost);
     my $serverhomedom = &host_domain($lonhost);      my $serverhomedom = &host_domain($lonhost);
     my $domneedscache;   
     my $cachetime = 60*60*24;      my $cachetime = 60*60*24;
   
     if (($uintdom ne '') && ($uintdom eq $intdom)) {      if (($uintdom ne '') && ($uintdom eq $intdom)) {
Line 1298  sub check_loadbalancing { Line 1263  sub check_loadbalancing {
             &Apache::lonnet::get_dom('configuration',['loadbalancing'],$dom_in_use);              &Apache::lonnet::get_dom('configuration',['loadbalancing'],$dom_in_use);
         if (ref($domconfig{'loadbalancing'}) eq 'HASH') {          if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
             $result = &do_cache_new('loadbalancing',$dom_in_use,$domconfig{'loadbalancing'},$cachetime);              $result = &do_cache_new('loadbalancing',$dom_in_use,$domconfig{'loadbalancing'},$cachetime);
         } else {  
             $domneedscache = $dom_in_use;  
         }          }
     }      }
     if (ref($result) eq 'HASH') {      if (ref($result) eq 'HASH') {
         ($is_balancer,$currtargets,$currrules) =          my $currbalancer = $result->{'lonhost'};
             &check_balancer_result($result,@hosts);          my $currtargets = $result->{'targets'};
           my $currrules = $result->{'rules'};
           if ($currbalancer ne '') {
               if (grep(/^\Q$currbalancer\E$/,@hosts)) {
                   $is_balancer = 1;
               }
           }
         if ($is_balancer) {          if ($is_balancer) {
             if (ref($currrules) eq 'HASH') {              if (ref($currrules) eq 'HASH') {
                 if ($homeintdom) {                  if ($homeintdom) {
Line 1353  sub check_loadbalancing { Line 1322  sub check_loadbalancing {
             }              }
         }          }
     } elsif (($homeintdom) && ($udom ne $serverhomedom)) {      } elsif (($homeintdom) && ($udom ne $serverhomedom)) {
         ($result,$cached)=&is_cached_new('loadbalancing',$serverhomedom);          my ($result,$cached)=&is_cached_new('loadbalancing',$serverhomedom);
         unless (defined($cached)) {          unless (defined($cached)) {
             my %domconfig =              my %domconfig =
                 &Apache::lonnet::get_dom('configuration',['loadbalancing'],$serverhomedom);                  &Apache::lonnet::get_dom('configuration',['loadbalancing'],$serverhomedom);
             if (ref($domconfig{'loadbalancing'}) eq 'HASH') {              if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
                 $result = &do_cache_new('loadbalancing',$serverhomedom,$domconfig{'loadbalancing'},$cachetime);                  $result = &do_cache_new('loadbalancing',$dom_in_use,$domconfig{'loadbalancing'},$cachetime);
             } else {  
                 $domneedscache = $serverhomedom;  
             }              }
         }          }
         if (ref($result) eq 'HASH') {          if (ref($result) eq 'HASH') {
             ($is_balancer,$currtargets,$currrules) =              my $currbalancer = $result->{'lonhost'};
                 &check_balancer_result($result,@hosts);              my $currtargets = $result->{'targets'};
             if ($is_balancer) {              my $currrules = $result->{'rules'};
   
               if ($currbalancer eq $lonhost) {
                   $is_balancer = 1;
                 if (ref($currrules) eq 'HASH') {                  if (ref($currrules) eq 'HASH') {
                     if ($currrules->{'_LC_internetdom'} ne '') {                      if ($currrules->{'_LC_internetdom'} ne '') {
                         $rule_in_effect = $currrules->{'_LC_internetdom'};                          $rule_in_effect = $currrules->{'_LC_internetdom'};
Line 1380  sub check_loadbalancing { Line 1350  sub check_loadbalancing {
                 $is_balancer = 1;                  $is_balancer = 1;
                 $offloadto = &this_host_spares($dom_in_use);                  $offloadto = &this_host_spares($dom_in_use);
             }              }
             unless (defined($cached)) {  
                 $domneedscache = $serverhomedom;  
             }  
         }          }
     } else {      } else {
         if ($perlvar{'lonBalancer'} eq 'yes') {          if ($perlvar{'lonBalancer'} eq 'yes') {
             $is_balancer = 1;              $is_balancer = 1;
             $offloadto = &this_host_spares($dom_in_use);              $offloadto = &this_host_spares($dom_in_use);
         }          }
         unless (defined($cached)) {  
             $domneedscache = $serverhomedom;  
         }  
     }  
     if ($domneedscache) {  
         &do_cache_new('loadbalancing',$domneedscache,$is_balancer,$cachetime);  
     }      }
     if ($is_balancer) {      if ($is_balancer) {
         my $lowest_load = 30000;          my $lowest_load = 30000;
Line 1429  sub check_loadbalancing { Line 1390  sub check_loadbalancing {
             $is_balancer = 0;              $is_balancer = 0;
             if ($uname ne '' && $udom ne '') {              if ($uname ne '' && $udom ne '') {
                 if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) {                  if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) {
                       
                     &appenv({'user.loadbalexempt'     => $lonhost,                      &appenv({'user.loadbalexempt'     => $lonhost,  
                              'user.loadbalcheck.time' => time});                               'user.loadbalcheck.time' => time});
                 }                  }
             }              }
Line 1439  sub check_loadbalancing { Line 1400  sub check_loadbalancing {
     return ($is_balancer,$otherserver);      return ($is_balancer,$otherserver);
 }  }
   
 sub check_balancer_result {  
     my ($result,@hosts) = @_;  
     my ($is_balancer,$currtargets,$currrules);  
     if (ref($result) eq 'HASH') {  
         if ($result->{'lonhost'} ne '') {  
             my $currbalancer = $result->{'lonhost'};  
             if (grep(/^\Q$currbalancer\E$/,@hosts)) {  
                 $is_balancer = 1;  
                 $currtargets = $result->{'targets'};  
                 $currrules = $result->{'rules'};  
             }  
         } else {  
             foreach my $key (keys(%{$result})) {  
                 if (($key ne '') && (grep(/^\Q$key\E$/,@hosts)) &&  
                     (ref($result->{$key}) eq 'HASH')) {  
                     $is_balancer = 1;  
                     $currrules = $result->{$key}{'rules'};  
                     $currtargets = $result->{$key}{'targets'};  
                     last;  
                 }  
             }  
         }  
     }  
     return ($is_balancer,$currtargets,$currrules);  
 }  
   
 sub get_loadbalancer_targets {  sub get_loadbalancer_targets {
     my ($rule_in_effect,$currtargets,$uname,$udom) = @_;      my ($rule_in_effect,$currtargets,$uname,$udom) = @_;
     my $offloadto;      my $offloadto;
Line 1567  sub idget { Line 1502  sub idget {
           
     my %servers = &get_servers($udom,'library');      my %servers = &get_servers($udom,'library');
     foreach my $tryserver (keys(%servers)) {      foreach my $tryserver (keys(%servers)) {
  my $idlist=join('&', map { &escape($_); } @ids);   my $idlist=join('&',@ids);
  $idlist=~tr/A-Z/a-z/;    $idlist=~tr/A-Z/a-z/; 
  my $reply=&reply("idget:$udom:".$idlist,$tryserver);   my $reply=&reply("idget:$udom:".$idlist,$tryserver);
  my @answer=();   my @answer=();
Line 1577  sub idget { Line 1512  sub idget {
  my $i;   my $i;
  for ($i=0;$i<=$#ids;$i++) {   for ($i=0;$i<=$#ids;$i++) {
     if ($answer[$i]) {      if ($answer[$i]) {
  $returnhash{$ids[$i]}=&unescape($answer[$i]);   $returnhash{$ids[$i]}=$answer[$i];
     }       } 
  }   }
     }       } 
Line 1619  sub idput { Line 1554  sub idput {
     }      }
 }  }
   
 # ---------------------------------------- Delete unwanted IDs from ids.db file  
   
 sub iddel {  
     my ($udom,$idshashref,$uhome)=@_;  
     my %result=();  
     unless (ref($idshashref) eq 'HASH') {  
         return %result;  
     }  
     my %servers=();  
     while (my ($id,$uname) = each(%{$idshashref})) {  
         my $uhom;  
         if ($uhome) {  
             $uhom = $uhome;  
         } else {  
             $uhom=&homeserver($uname,$udom);  
         }  
         if ($uhom ne 'no_host') {  
             if ($servers{$uhom}) {  
                 $servers{$uhom}.='&'.&escape($id);  
             } else {  
                 $servers{$uhom}=&escape($id);  
             }  
         }  
     }  
     foreach my $server (keys(%servers)) {  
         $result{$server} = &critical('iddel:'.$udom.':'.$servers{$server},$uhome);  
     }  
     return %result;  
 }  
   
 # ------------------------------dump from db file owned by domainconfig user  # ------------------------------dump from db file owned by domainconfig user
 sub dump_dom {  sub dump_dom {
     my ($namespace, $udom, $regexp) = @_;      my ($namespace, $udom, $regexp) = @_;
Line 1664  sub dump_dom { Line 1569  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 1672  sub get_dom { Line 1576  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 1776  sub retrieve_inst_usertypes { Line 1679  sub retrieve_inst_usertypes {
     my %domdefs = &Apache::lonnet::get_domain_defaults($udom);      my %domdefs = &Apache::lonnet::get_domain_defaults($udom);
     if ((ref($domdefs{'inststatustypes'}) eq 'HASH') &&       if ((ref($domdefs{'inststatustypes'}) eq 'HASH') && 
         (ref($domdefs{'inststatusorder'}) eq 'ARRAY')) {          (ref($domdefs{'inststatusorder'}) eq 'ARRAY')) {
         return ($domdefs{'inststatustypes'},$domdefs{'inststatusorder'});          %returnhash = %{$domdefs{'inststatustypes'}};
           @order = @{$domdefs{'inststatusorder'}};
     } else {      } else {
         if (defined(&domain($udom,'primary'))) {          if (defined(&domain($udom,'primary'))) {
             my $uhome=&domain($udom,'primary');              my $uhome=&domain($udom,'primary');
             my $rep=&reply("inst_usertypes:$udom",$uhome);              my $rep=&reply("inst_usertypes:$udom",$uhome);
             if ($rep =~ /^(con_lost|error|no_such_host|refused)/) {              if ($rep =~ /^(con_lost|error|no_such_host|refused)/) {
                 &logthis("retrieve_inst_usertypes failed - $rep returned from $uhome in domain: $udom");                  &logthis("get_dom failed - $rep returned from $uhome in domain: $udom");
                 return (\%returnhash,\@order);                  return (\%returnhash,\@order);
             }              }
             my ($hashitems,$orderitems) = split(/:/,$rep);               my ($hashitems,$orderitems) = split(/:/,$rep); 
Line 1798  sub retrieve_inst_usertypes { Line 1702  sub retrieve_inst_usertypes {
                 push(@order,&unescape($item));                  push(@order,&unescape($item));
             }              }
         } else {          } else {
             &logthis("retrieve_inst_usertypes failed - no primary domain server for $udom");              &logthis("get_dom failed - no primary domain server for $udom");
         }          }
         return (\%returnhash,\@order);  
     }      }
       return (\%returnhash,\@order);
 }  }
   
 sub is_domainimage {  sub is_domainimage {
     my ($url) = @_;      my ($url) = @_;
     if ($url=~m-^/+res/+($match_domain)/+\1\-domainconfig/+(img|logo|domlogo)/+[^/]-) {      if ($url=~m-^/+res/+($match_domain)/+\1\-domainconfig/+(img|logo|domlogo)/+-) {
         if (&domain($1) ne '') {          if (&domain($1) ne '') {
             return '1';              return '1';
         }          }
Line 1947  sub get_instuser { Line 1851  sub get_instuser {
     return ($outcome,%userinfo);      return ($outcome,%userinfo);
 }  }
   
 sub get_multiple_instusers {  
     my ($udom,$users,$caller) = @_;  
     my ($outcome,$results);  
     if (ref($users) eq 'HASH') {  
         my $count = keys(%{$users});  
         my $requested = &freeze_escape($users);  
         my $homeserver = &domain($udom,'primary');  
         if ($homeserver ne '') {  
             my $queryid=&reply('querysend:getmultinstusers:::'.$caller.'='.$requested,$homeserver);  
             my $host=&hostname($homeserver);  
             if ($queryid !~/^\Q$host\E\_/) {  
                 &logthis('get_multiple_instusers invalid queryid: '.$queryid.  
                          ' for host: '.$homeserver.'in domain '.$udom);  
                 return ($outcome,$results);  
             }  
             my $response = &get_query_reply($queryid);  
             my $maxtries = 5;  
             if ($count > 100) {  
                 $maxtries = 1+int($count/20);  
             }  
             my $tries = 1;  
             while (($response=~/^timeout/) && ($tries <= $maxtries)) {  
                 $response = &get_query_reply($queryid);  
                 $tries ++;  
             }  
             if ($response eq '') {  
                 $results = {};  
                 foreach my $key (keys(%{$users})) {  
                     my ($uname,$id);  
                     if ($caller eq 'id') {  
                         $id = $key;  
                     } else {  
                         $uname = $key;  
                     }  
                     my ($resp,%info) = &get_instuser($udom,$uname,$id);  
                     $outcome = $resp;  
                     if ($resp eq 'ok') {  
                         %{$results} = (%{$results}, %info);  
                     } else {  
                         last;  
                     }  
                 }  
             } elsif(!&error($response) && ($response ne 'refused')) {  
                 if (($response eq 'unavailable') || ($response eq 'invalid') || ($response eq 'timeout')) {  
                     $outcome = $response;  
                 } else {  
                     ($outcome,my $userdata) = split(/=/,$response,2);  
                     if ($outcome eq 'ok') {  
                         $results = &thaw_unescape($userdata);  
                     }  
                 }  
             }  
         }  
     }  
     return ($outcome,$results);  
 }  
   
 sub inst_rulecheck {  sub inst_rulecheck {
     my ($udom,$uname,$id,$item,$rules) = @_;      my ($udom,$uname,$id,$item,$rules) = @_;
     my %returnhash;      my %returnhash;
Line 2083  sub inst_userrules { Line 1930  sub inst_userrules {
 # ------------- Get Authentication, Language and User Tools Defaults for Domain  # ------------- Get Authentication, Language and User Tools Defaults for Domain
   
 sub get_domain_defaults {  sub get_domain_defaults {
     my ($domain,$ignore_cache) = @_;      my ($domain) = @_;
     return if (($domain eq '') || ($domain eq 'public'));  
     my $cachetime = 60*60*24;      my $cachetime = 60*60*24;
     unless ($ignore_cache) {      my ($result,$cached)=&is_cached_new('domdefaults',$domain);
         my ($result,$cached)=&is_cached_new('domdefaults',$domain);      if (defined($cached)) {
         if (defined($cached)) {          if (ref($result) eq 'HASH') {
             if (ref($result) eq 'HASH') {              return %{$result};
                 return %{$result};  
             }  
         }          }
     }      }
     my %domdefaults;      my %domdefaults;
Line 2099  sub get_domain_defaults { Line 1943  sub get_domain_defaults {
          &Apache::lonnet::get_dom('configuration',['defaults','quotas',           &Apache::lonnet::get_dom('configuration',['defaults','quotas',
                                   'requestcourses','inststatus',                                    'requestcourses','inststatus',
                                   'coursedefaults','usersessions',                                    'coursedefaults','usersessions',
                                   'requestauthor','selfenrollment',                                    'requestauthor'],$domain);
                                   'coursecategories','autoenroll'],$domain);  
     my @coursetypes = ('official','unofficial','community','textbook');  
     if (ref($domconfig{'defaults'}) eq 'HASH') {      if (ref($domconfig{'defaults'}) eq 'HASH') {
         $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'};           $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; 
         $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'};          $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'};
Line 2119  sub get_domain_defaults { Line 1961  sub get_domain_defaults {
             $domdefaults{'defaultquota'} = $domconfig{'quotas'}{'defaultquota'};              $domdefaults{'defaultquota'} = $domconfig{'quotas'}{'defaultquota'};
         } else {          } else {
             $domdefaults{'defaultquota'} = $domconfig{'quotas'};              $domdefaults{'defaultquota'} = $domconfig{'quotas'};
         }          } 
         my @usertools = ('aboutme','blog','webdav','portfolio');          my @usertools = ('aboutme','blog','webdav','portfolio');
         foreach my $item (@usertools) {          foreach my $item (@usertools) {
             if (ref($domconfig{'quotas'}{$item}) eq 'HASH') {              if (ref($domconfig{'quotas'}{$item}) eq 'HASH') {
                 $domdefaults{$item} = $domconfig{'quotas'}{$item};                  $domdefaults{$item} = $domconfig{'quotas'}{$item};
             }              }
         }          }
         if (ref($domconfig{'quotas'}{'authorquota'}) eq 'HASH') {  
             $domdefaults{'authorquota'} = $domconfig{'quotas'}{'authorquota'};  
         }  
     }      }
     if (ref($domconfig{'requestcourses'}) eq 'HASH') {      if (ref($domconfig{'requestcourses'}) eq 'HASH') {
         foreach my $item ('official','unofficial','community','textbook') {          foreach my $item ('official','unofficial','community') {
             $domdefaults{$item} = $domconfig{'requestcourses'}{$item};              $domdefaults{$item} = $domconfig{'requestcourses'}{$item};
         }          }
     }      }
Line 2139  sub get_domain_defaults { Line 1978  sub get_domain_defaults {
         $domdefaults{'requestauthor'} = $domconfig{'requestauthor'};          $domdefaults{'requestauthor'} = $domconfig{'requestauthor'};
     }      }
     if (ref($domconfig{'inststatus'}) eq 'HASH') {      if (ref($domconfig{'inststatus'}) eq 'HASH') {
         foreach my $item ('inststatustypes','inststatusorder','inststatusguest') {          foreach my $item ('inststatustypes','inststatusorder') {
             $domdefaults{$item} = $domconfig{'inststatus'}{$item};              $domdefaults{$item} = $domconfig{'inststatus'}{$item};
         }          }
     }      }
     if (ref($domconfig{'coursedefaults'}) eq 'HASH') {      if (ref($domconfig{'coursedefaults'}) eq 'HASH') {
         $domdefaults{'usejsme'} = $domconfig{'coursedefaults'}{'usejsme'};          foreach my $item ('canuse_pdfforms') {
         $domdefaults{'uselcmath'} = $domconfig{'coursedefaults'}{'uselcmath'};              $domdefaults{$item} = $domconfig{'coursedefaults'}{$item};
         if (ref($domconfig{'coursedefaults'}{'postsubmit'}) eq 'HASH') {  
             $domdefaults{'postsubmit'} = $domconfig{'coursedefaults'}{'postsubmit'}{'client'};  
         }  
         foreach my $type (@coursetypes) {  
             if (ref($domconfig{'coursedefaults'}{'coursecredits'}) eq 'HASH') {  
                 unless ($type eq 'community') {  
                     $domdefaults{$type.'credits'} = $domconfig{'coursedefaults'}{'coursecredits'}{$type};  
                 }  
             }  
             if (ref($domconfig{'coursedefaults'}{'uploadquota'}) eq 'HASH') {  
                 $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{'coursedefaults'}{'canclone'}) eq 'HASH') {  
             if (ref($domconfig{'coursedefaults'}{'canclone'}{'instcode'}) eq 'ARRAY') {  
                 my @clonecodes = @{$domconfig{'coursedefaults'}{'canclone'}{'instcode'}};  
                 if (@clonecodes) {  
                     $domdefaults{'canclone'} = join('+',@clonecodes);  
                 }  
             }  
         } elsif ($domconfig{'coursedefaults'}{'canclone'}) {  
             $domdefaults{'canclone'}=$domconfig{'coursedefaults'}{'canclone'};  
         }          }
     }      }
     if (ref($domconfig{'usersessions'}) eq 'HASH') {      if (ref($domconfig{'usersessions'}) eq 'HASH') {
Line 2183  sub get_domain_defaults { Line 1994  sub get_domain_defaults {
         if (ref($domconfig{'usersessions'}{'hosted'}) eq 'HASH') {          if (ref($domconfig{'usersessions'}{'hosted'}) eq 'HASH') {
             $domdefaults{'hostedsessions'} = $domconfig{'usersessions'}{'hosted'};              $domdefaults{'hostedsessions'} = $domconfig{'usersessions'}{'hosted'};
         }          }
         if (ref($domconfig{'usersessions'}{'offloadnow'}) eq 'HASH') {  
             $domdefaults{'offloadnow'} = $domconfig{'usersessions'}{'offloadnow'};  
         }  
     }      }
     if (ref($domconfig{'selfenrollment'}) eq 'HASH') {      &Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults,
         if (ref($domconfig{'selfenrollment'}{'admin'}) eq 'HASH') {                                    $cachetime);
             my @settings = ('types','registered','enroll_dates','access_dates','section',  
                             'approval','limit');  
             foreach my $type (@coursetypes) {  
                 if (ref($domconfig{'selfenrollment'}{'admin'}{$type}) eq 'HASH') {  
                     my @mgrdc = ();  
                     foreach my $item (@settings) {  
                         if ($domconfig{'selfenrollment'}{'admin'}{$type}{$item} eq '0') {  
                             push(@mgrdc,$item);  
                         }  
                     }  
                     if (@mgrdc) {  
                         $domdefaults{$type.'selfenrolladmdc'} = join(',',@mgrdc);  
                     }  
                 }  
             }  
         }  
         if (ref($domconfig{'selfenrollment'}{'default'}) eq 'HASH') {  
             foreach my $type (@coursetypes) {  
                 if (ref($domconfig{'selfenrollment'}{'default'}{$type}) eq 'HASH') {  
                     foreach my $item (keys(%{$domconfig{'selfenrollment'}{'default'}{$type}})) {  
                         $domdefaults{$type.'selfenroll'.$item} = $domconfig{'selfenrollment'}{'default'}{$type}{$item};  
                     }  
                 }  
             }  
         }  
     }  
     if (ref($domconfig{'coursecategories'}) eq 'HASH') {  
         $domdefaults{'catauth'} = 'std';  
         $domdefaults{'catunauth'} = 'std';  
         if ($domconfig{'coursecategories'}{'auth'}) {  
             $domdefaults{'catauth'} = $domconfig{'coursecategories'}{'auth'};  
         }  
         if ($domconfig{'coursecategories'}{'unauth'}) {  
             $domdefaults{'catunauth'} = $domconfig{'coursecategories'}{'unauth'};  
         }  
     }  
     if (ref($domconfig{'autoenroll'}) eq 'HASH') {  
         $domdefaults{'autofailsafe'} = $domconfig{'autoenroll'}{'autofailsafe'};  
     }  
     &do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);  
     return %domdefaults;      return %domdefaults;
 }  }
   
Line 2468  sub make_key { Line 2236  sub make_key {
 sub devalidate_cache_new {  sub devalidate_cache_new {
     my ($name,$id,$debug) = @_;      my ($name,$id,$debug) = @_;
     if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); }      if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); }
     my $remembered_id=$name.':'.$id;  
     $id=&make_key($name,$id);      $id=&make_key($name,$id);
     $memcache->delete($id);      $memcache->delete($id);
     delete($remembered{$remembered_id});      delete($remembered{$id});
     delete($accessed{$remembered_id});      delete($accessed{$id});
 }  }
   
 sub is_cached_new {  sub is_cached_new {
     my ($name,$id,$debug) = @_;      my ($name,$id,$debug) = @_;
     my $remembered_id=$name.':'.$id; # this is to avoid make_key (which is slow) for       $id=&make_key($name,$id);
                                      # keys in %remembered hash, which persists for      if (exists($remembered{$id})) {
                                      # duration of request (no restriction on key length).   if ($debug) { &Apache::lonnet::logthis("Early return $id of $remembered{$id} "); }
     if (exists($remembered{$remembered_id})) {   $accessed{$id}=[&gettimeofday()];
  if ($debug) { &Apache::lonnet::logthis("Early return $remembered_id of $remembered{$remembered_id} "); }  
  $accessed{$remembered_id}=[&gettimeofday()];  
  $hits++;   $hits++;
  return ($remembered{$remembered_id},1);   return ($remembered{$id},1);
     }      }
     $id=&make_key($name,$id);  
     my $value = $memcache->get($id);      my $value = $memcache->get($id);
     if (!(defined($value))) {      if (!(defined($value))) {
  if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); }   if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); }
Line 2496  sub is_cached_new { Line 2260  sub is_cached_new {
  if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); }   if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); }
  $value=undef;   $value=undef;
     }      }
     &make_room($remembered_id,$value,$debug);      &make_room($id,$value,$debug);
     if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); }      if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); }
     return ($value,1);      return ($value,1);
 }  }
   
 sub do_cache_new {  sub do_cache_new {
     my ($name,$id,$value,$time,$debug) = @_;      my ($name,$id,$value,$time,$debug) = @_;
     my $remembered_id=$name.':'.$id;  
     $id=&make_key($name,$id);      $id=&make_key($name,$id);
     my $setvalue=$value;      my $setvalue=$value;
     if (!defined($setvalue)) {      if (!defined($setvalue)) {
Line 2519  sub do_cache_new { Line 2282  sub do_cache_new {
  $memcache->disconnect_all();   $memcache->disconnect_all();
     }      }
     # need to make a copy of $value      # need to make a copy of $value
     &make_room($remembered_id,$value,$debug);      &make_room($id,$value,$debug);
     return $value;      return $value;
 }  }
   
 sub make_room {  sub make_room {
     my ($remembered_id,$value,$debug)=@_;      my ($id,$value,$debug)=@_;
   
     $remembered{$remembered_id}= (ref($value)) ? &Storable::dclone($value)      $remembered{$id}= (ref($value)) ? &Storable::dclone($value)
                                     : $value;                                      : $value;
     if ($to_remember<0) { return; }      if ($to_remember<0) { return; }
     $accessed{$remembered_id}=[&gettimeofday()];      $accessed{$id}=[&gettimeofday()];
     if (scalar(keys(%remembered)) <= $to_remember) { return; }      if (scalar(keys(%remembered)) <= $to_remember) { return; }
     my $to_kick;      my $to_kick;
     my $max_time=0;      my $max_time=0;
Line 2823  sub ssi { Line 2586  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 {        $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys(%form)));
             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);
     }      }
   
     $request->header(Cookie => $ENV{'HTTP_COOKIE'});      $request->header(Cookie => $ENV{'HTTP_COOKIE'});
     my $response= $ua->request($request);      my $response= $ua->request($request);
       my $content = $response->content;
   
   
     if (wantarray) {      if (wantarray) {
  return ($response->content, $response);   return ($content, $response);
     } else {      } else {
  return $response->content;   return $content;
     }      }
 }  }
   
Line 2867  sub allowuploaded { Line 2628  sub allowuploaded {
     &Apache::lonnet::appenv(\%httpref);      &Apache::lonnet::appenv(\%httpref);
 }  }
   
 #  
 # Determine if the current user should be able to edit a particular resource,  
 # when viewing in course context.  
 # (a) When viewing resource used to determine if "Edit" item is included in  
 #     Functions.  
 # (b) When displaying folder contents in course editor, used to determine if  
 #     "Edit" link will be displayed alongside resource.  
 #  
 #  input: six args -- filename (decluttered), course number, course domain,  
 #                   url, symb (if registered) and group (if this is a group  
 #                   item -- e.g., bulletin board, group page etc.).  
 #  output: array of five scalars --  
 #          $cfile -- url for file editing if editable on current server  
 #          $home -- homeserver of resource (i.e., for author if published,  
 #                                           or course if uploaded.).  
 #          $switchserver --  1 if server switch will be needed.  
 #          $forceedit -- 1 if icon/link should be to go to edit mode  
 #          $forceview -- 1 if icon/link should be to go to view mode  
 #  
   
 sub can_edit_resource {  
     my ($file,$cnum,$cdom,$resurl,$symb,$group) = @_;  
     my ($cfile,$home,$switchserver,$forceedit,$forceview,$uploaded,$incourse);  
 #  
 # For aboutme pages user can only edit his/her own.  
 #  
     if ($resurl =~ m{^/?adm/($match_domain)/($match_username)/aboutme$}) {  
         my ($sdom,$sname) = ($1,$2);  
         if (($sdom eq $env{'user.domain'}) && ($sname eq $env{'user.name'})) {  
             $home = $env{'user.home'};  
             $cfile = $resurl;  
             if ($env{'form.forceedit'}) {  
                 $forceview = 1;  
             } else {  
                 $forceedit = 1;  
             }  
             return ($cfile,$home,$switchserver,$forceedit,$forceview);  
         } else {  
             return;  
         }  
     }  
   
     if ($env{'request.course.id'}) {  
         my $crsedit = &Apache::lonnet::allowed('mdc',$env{'request.course.id'});  
         if ($group ne '') {  
 # if this is a group homepage or group bulletin board, check group privs  
             my $allowed = 0;  
             if ($resurl =~ m{^/?adm/$cdom/$cnum/$group/smppg$}) {  
                 if ((&allowed('mdg',$env{'request.course.id'}.  
                               ($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:''))) ||  
                         (&allowed('mgh',$env{'request.course.id'}.'/'.$group)) || $crsedit) {  
                     $allowed = 1;  
                 }  
             } elsif ($resurl =~ m{^/?adm/$cdom/$cnum/\d+/bulletinboard$}) {  
                 if ((&allowed('mdg',$env{'request.course.id'}.($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:''))) ||  
                         (&allowed('cgb',$env{'request.course.id'}.'/'.$group)) || $crsedit) {  
                     $allowed = 1;  
                 }  
             }  
             if ($allowed) {  
                 $home=&homeserver($cnum,$cdom);  
                 if ($env{'form.forceedit'}) {  
                     $forceview = 1;  
                 } else {  
                     $forceedit = 1;  
                 }  
                 $cfile = $resurl;  
             } else {  
                 return;  
             }  
         } else {  
             if ($resurl =~ m{^/?adm/viewclasslist$}) {  
                 unless (&Apache::lonnet::allowed('opa',$env{'request.course.id'})) {  
                     return;  
                 }  
             } elsif (!$crsedit) {  
 #  
 # No edit allowed where CC has switched to student role.  
 #  
                 return;  
             }  
         }  
     }  
   
     if ($file ne '') {  
         if (($cnum =~ /$match_courseid/) && ($cdom =~ /$match_domain/)) {  
             if (&is_course_upload($file,$cnum,$cdom)) {  
                 $uploaded = 1;  
                 $incourse = 1;  
                 if ($file =~/\.(htm|html|css|js|txt)$/) {  
                     $cfile = &hreflocation('',$file);  
                     if ($env{'form.forceedit'}) {  
                         $forceview = 1;  
                     } else {  
                         $forceedit = 1;  
                     }  
                 }  
             } elsif ($resurl =~ m{^/public/$cdom/$cnum/syllabus}) {  
                 $incourse = 1;  
                 if ($env{'form.forceedit'}) {  
                     $forceview = 1;  
                 } else {  
                     $forceedit = 1;  
                 }  
                 $cfile = $resurl;  
             } elsif (($resurl ne '') && (&is_on_map($resurl))) {  
                 if ($resurl =~ m{^/adm/$match_domain/$match_username/\d+/smppg|bulletinboard$}) {  
                     $incourse = 1;  
                     if ($env{'form.forceedit'}) {  
                         $forceview = 1;  
                     } else {  
                         $forceedit = 1;  
                     }  
                     $cfile = $resurl;  
                 } elsif ($resurl eq '/res/lib/templates/simpleproblem.problem') {  
                     $incourse = 1;  
                     $cfile = $resurl.'/smpedit';  
                 } elsif ($resurl =~ m{^/adm/wrapper/ext/}) {  
                     $incourse = 1;  
                     if ($env{'form.forceedit'}) {  
                         $forceview = 1;  
                     } else {  
                         $forceedit = 1;  
                     }  
                     $cfile = $resurl;  
                 } elsif ($resurl =~ m{^/?adm/viewclasslist$}) {  
                     $incourse = 1;  
                     if ($env{'form.forceedit'}) {  
                         $forceview = 1;  
                     } else {  
                         $forceedit = 1;  
                     }  
                     $cfile = ($resurl =~ m{^/} ? $resurl : "/$resurl");  
                 }  
             } elsif ($resurl eq '/res/lib/templates/simpleproblem.problem/smpedit') {  
                 my $template = '/res/lib/templates/simpleproblem.problem';  
                 if (&is_on_map($template)) {  
                     $incourse = 1;  
                     $forceview = 1;  
                     $cfile = $template;  
                 }  
             } elsif (($resurl =~ m{^/adm/wrapper/ext/}) && ($env{'form.folderpath'} =~ /^supplemental/)) {  
                     $incourse = 1;  
                     if ($env{'form.forceedit'}) {  
                         $forceview = 1;  
                     } else {  
                         $forceedit = 1;  
                     }  
                     $cfile = $resurl;  
             } elsif (($resurl eq '/adm/extresedit') && ($symb || $env{'form.folderpath'})) {  
                 $incourse = 1;  
                 $forceview = 1;  
                 if ($symb) {  
                     my ($map,$id,$res)=&decode_symb($symb);  
                     $env{'request.symb'} = $symb;  
                     $cfile = &clutter($res);  
                 } else {  
                     $cfile = $env{'form.suppurl'};  
                     $cfile =~ s{^http://}{};  
                     $cfile = '/adm/wrapper/ext/'.$cfile;  
                 }  
             } elsif ($resurl =~ m{^/?adm/viewclasslist$}) {  
                 if ($env{'form.forceedit'}) {  
                     $forceview = 1;  
                 } else {  
                     $forceedit = 1;  
                 }  
                 $cfile = ($resurl =~ m{^/} ? $resurl : "/$resurl");  
             }  
         }  
         if ($uploaded || $incourse) {  
             $home=&homeserver($cnum,$cdom);  
         } elsif ($file !~ m{/$}) {  
             $file=~s{^(priv/$match_domain/$match_username)}{/$1};  
             $file=~s{^($match_domain/$match_username)}{/priv/$1};  
             # Check that the user has permission to edit this resource  
             my $setpriv = 1;  
             my ($cfuname,$cfudom)=&constructaccess($file,$setpriv);  
             if (defined($cfudom)) {  
                 $home=&homeserver($cfuname,$cfudom);  
                 $cfile=$file;  
             }  
         }  
         if (($cfile ne '') && (!$incourse || $uploaded) &&  
             (($home ne '') && ($home ne 'no_host'))) {  
             my @ids=&current_machine_ids();  
             unless (grep(/^\Q$home\E$/,@ids)) {  
                 $switchserver=1;  
             }  
         }  
     }  
     return ($cfile,$home,$switchserver,$forceedit,$forceview);  
 }  
   
 sub is_course_upload {  
     my ($file,$cnum,$cdom) = @_;  
     my $uploadpath = &LONCAPA::propath($cdom,$cnum);  
     $uploadpath =~ s{^\/}{};  
     if (($file =~ m{^\Q$uploadpath\E/userfiles/(docs|supplemental)/}) ||  
         ($file =~ m{^userfiles/\Q$cdom\E/\Q$cnum\E/(docs|supplemental)/})) {  
         return 1;  
     }  
     return;  
 }  
   
 sub in_course {  
     my ($udom,$uname,$cdom,$cnum,$type,$hideprivileged) = @_;  
     if ($hideprivileged) {  
         my $skipuser;  
         my %coursehash = &coursedescription($cdom.'_'.$cnum);  
         my @possdoms = ($cdom);  
         if ($coursehash{'checkforpriv'}) {  
             push(@possdoms,split(/,/,$coursehash{'checkforpriv'}));  
         }  
         if (&privileged($uname,$udom,\@possdoms)) {  
             $skipuser = 1;  
             if ($coursehash{'nothideprivileged'}) {  
                 foreach my $item (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {  
                     my $user;  
                     if ($item =~ /:/) {  
                         $user = $item;  
                     } else {  
                         $user = join(':',split(/[\@]/,$item));  
                     }  
                     if ($user eq $uname.':'.$udom) {  
                         undef($skipuser);  
                         last;  
                     }  
                 }  
             }  
             if ($skipuser) {  
                 return 0;  
             }  
         }  
     }  
     $type ||= 'any';  
     if (!defined($cdom) || !defined($cnum)) {  
         my $cid  = $env{'request.course.id'};  
         $cdom = $env{'course.'.$cid.'.domain'};  
         $cnum = $env{'course.'.$cid.'.num'};  
     }  
     my $typesref;  
     if (($type eq 'any') || ($type eq 'all')) {  
         $typesref = ['active','previous','future'];  
     } elsif ($type eq 'previous' || $type eq 'future') {  
         $typesref = [$type];  
     }  
     my %roles = &get_my_roles($uname,$udom,'userroles',  
                               $typesref,undef,[$cdom]);  
     my ($tmp) = keys(%roles);  
     return 0 if ($tmp =~ /^(con_lost|error|no_such_host)/i);  
     my @course_roles = grep(/^\Q$cnum\E:\Q$cdom\E:/, keys(%roles));  
     if (@course_roles > 0) {  
         return 1;  
     }  
     return 0;  
 }  
   
 # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course  # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course
 # input: action, courseID, current domain, intended  # input: action, courseID, current domain, intended
 #        path to file, source of file, instruction to parse file for objects,  #        path to file, source of file, instruction to parse file for objects,
Line 3415  sub userfileupload { Line 2918  sub userfileupload {
  $codebase,$thumbwidth,$thumbheight,   $codebase,$thumbwidth,$thumbheight,
                                          $resizewidth,$resizeheight,$context,$mimetype);                                           $resizewidth,$resizeheight,$context,$mimetype);
         } else {          } else {
             if ($env{'form.folder'}) {              $fname=$env{'form.folder'}.'/'.$fname;
                 $fname=$env{'form.folder'}.'/'.$fname;  
             }  
             return &process_coursefile('uploaddoc',$docuname,$docudom,              return &process_coursefile('uploaddoc',$docuname,$docudom,
        $fname,$formname,$parser,         $fname,$formname,$parser,
        $allfiles,$codebase,$mimetype);         $allfiles,$codebase,$mimetype);
Line 3432  sub userfileupload { Line 2933  sub userfileupload {
     } else {      } else {
         my $docuname=$env{'user.name'};          my $docuname=$env{'user.name'};
         my $docudom=$env{'user.domain'};          my $docudom=$env{'user.domain'};
         if ((exists($env{'form.group'})) || ($context eq 'syllabus')) {          if (exists($env{'form.group'})) {
             $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};              $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
             $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};              $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
         }          }
Line 3582  sub extract_embedded_items { Line 3083  sub extract_embedded_items {
  &add_filetype($allfiles,$attr->{'src'},'src');   &add_filetype($allfiles,$attr->{'src'},'src');
     }      }
     if (lc($tagname) eq 'a') {      if (lc($tagname) eq 'a') {
                 unless (($attr->{'href'} =~ /^#/) || ($attr->{'href'} eq '')) {   &add_filetype($allfiles,$attr->{'href'},'href');
     &add_filetype($allfiles,$attr->{'href'},'href');  
                 }  
     }      }
             if (lc($tagname) eq 'script') {              if (lc($tagname) eq 'script') {
                 my $src;                  my $src;
Line 3672  sub extract_embedded_items { Line 3171  sub extract_embedded_items {
                     }                      }
                 }                  }
     }      }
             if (lc($tagname) eq 'iframe') {  
                 my $src = $attr->{'src'} ;  
                 if (($src ne '') && ($src !~ m{^(/|https?://)})) {  
                     &add_filetype($allfiles,$src,'src');  
                 } elsif ($src =~ m{^/}) {  
                     if ($env{'request.course.id'}) {  
                         my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};  
                         my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};  
                         my $url = &hreflocation('',$fullpath);  
                         if ($url =~ m{^/uploaded/$cdom/$cnum/docs/(\w+/\d+)/}) {  
                             my $relpath = $1;  
                             if ($src =~ m{^/uploaded/$cdom/$cnum/docs/\Q$relpath\E/(.+)$}) {  
                                 &add_filetype($allfiles,$1,'src');  
                             }  
                         }  
                     }  
                 }  
             }  
             if ($t->[4] =~ m{/>$}) {              if ($t->[4] =~ m{/>$}) {
                 pop(@state);                  pop(@state);  
             }              }
  } elsif ($t->[0] eq 'E') {   } elsif ($t->[0] eq 'E') {
     my ($tagname) = ($t->[1]);      my ($tagname) = ($t->[1]);
Line 4133  sub get_course_adv_roles { Line 3614  sub get_course_adv_roles {
             $nothide{$user}=1;              $nothide{$user}=1;
         }          }
     }      }
     my @possdoms = ($coursehash{'domain'});  
     if ($coursehash{'checkforpriv'}) {  
         push(@possdoms,split(/,/,$coursehash{'checkforpriv'}));  
     }  
     my %returnhash=();      my %returnhash=();
     my %dumphash=      my %dumphash=
             &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});              &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});
Line 4149  sub get_course_adv_roles { Line 3626  sub get_course_adv_roles {
         if (($tstart) && ($now<$tstart)) { next; }          if (($tstart) && ($now<$tstart)) { next; }
         my ($role,$username,$domain,$section)=split(/\:/,$entry);          my ($role,$username,$domain,$section)=split(/\:/,$entry);
  if ($username eq '' || $domain eq '') { next; }   if ($username eq '' || $domain eq '') { next; }
         if ((&privileged($username,$domain,\@possdoms)) &&          unless (ref($privileged{$domain}) eq 'HASH') {
               my %dompersonnel =
                   &Apache::lonnet::get_domain_roles($domain,['dc'],$now,$now);
               $privileged{$domain} = {};
               foreach my $server (keys(%dompersonnel)) {
                   if (ref($dompersonnel{$server}) eq 'HASH') {
                       foreach my $user (keys(%{$dompersonnel{$server}})) {
                           my ($trole,$uname,$udom) = split(/:/,$user);
                           $privileged{$udom}{$uname} = 1;
                       }
                   }
               }
           }
           if ((exists($privileged{$domain}{$username})) && 
             (!$nothide{$username.':'.$domain})) { next; }              (!$nothide{$username.':'.$domain})) { next; }
  if ($role eq 'cr') { next; }   if ($role eq 'cr') { next; }
         if ($codes) {          if ($codes) {
Line 4180  sub get_my_roles { Line 3670  sub get_my_roles {
     if ($context eq 'userroles') {      if ($context eq 'userroles') {
         %dumphash = &dump('roles',$udom,$uname);          %dumphash = &dump('roles',$udom,$uname);
     } else {      } else {
         %dumphash = &dump('nohist_userroles',$udom,$uname);          %dumphash=
               &dump('nohist_userroles',$udom,$uname);
         if ($hidepriv) {          if ($hidepriv) {
             my %coursehash=&coursedescription($udom.'_'.$uname);              my %coursehash=&coursedescription($udom.'_'.$uname);
             foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {              foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
Line 4248  sub get_my_roles { Line 3739  sub get_my_roles {
             }              }
         }          }
         if ($hidepriv) {          if ($hidepriv) {
             my @privroles = ('dc','su');  
             if ($context eq 'userroles') {              if ($context eq 'userroles') {
                 next if (grep(/^\Q$role\E$/,@privroles));                  if ((&privileged($username,$domain)) &&
                       (!$nothide{$username.':'.$domain})) {
                       next;
                   }
             } else {              } else {
                 my $possdoms = [$domain];                  unless (ref($privileged{$domain}) eq 'HASH') {
                 if (ref($roledoms) eq 'ARRAY') {                      my %dompersonnel =
                    push(@{$possdoms},@{$roledoms});                          &Apache::lonnet::get_domain_roles($domain,['dc'],$now,$now);
                       $privileged{$domain} = {};
                       if (keys(%dompersonnel)) {
                           foreach my $server (keys(%dompersonnel)) {
                               if (ref($dompersonnel{$server}) eq 'HASH') {
                                   foreach my $user (keys(%{$dompersonnel{$server}})) {
                                       my ($trole,$uname,$udom) = split(/:/,$user);
                                       $privileged{$udom}{$uname} = $trole;
                                   }
                               }
                           }
                       }
                 }                  }
                 if (&privileged($username,$domain,$possdoms,\@privroles)) {                  if (exists($privileged{$domain}{$username})) {
                     if (!$nothide{$username.':'.$domain}) {                      if (!$nothide{$username.':'.$domain}) {
                         next;                          next;
                     }                      }
Line 4348  sub courseiddump { Line 3852  sub courseiddump {
     my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,      my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,
         $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,          $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,
         $selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone,          $selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone,
         $cloneonly,$createdbefore,$createdafter,$creationcontext,$domcloner,          $cloneonly,$createdbefore,$createdafter,$creationcontext,$domcloner)=@_;
         $hasuniquecode,$reqcrsdom,$reqinstcode)=@_;  
     my $as_hash = 1;      my $as_hash = 1;
     my %returnhash;      my %returnhash;
     if (!$domfilter) { $domfilter=''; }      if (!$domfilter) { $domfilter=''; }
Line 4362  sub courseiddump { Line 3865  sub courseiddump {
     if (($domfilter eq '') ||      if (($domfilter eq '') ||
  (&host_domain($tryserver) eq $domfilter)) {   (&host_domain($tryserver) eq $domfilter)) {
                 my $rep;                  my $rep;
                 if (grep { $_ eq $tryserver } &current_machine_ids()) {                  if (grep { $_ eq $tryserver } current_machine_ids()) {
                     $rep = &LONCAPA::Lond::dump_course_id_handler(                      $rep = LONCAPA::Lond::dump_course_id_handler(
                         join(":", (&host_domain($tryserver), $sincefilter,                          join(":", (&host_domain($tryserver), $sincefilter, 
                                 &escape($descfilter), &escape($instcodefilter),                                  &escape($descfilter), &escape($instcodefilter), 
                                 &escape($ownerfilter), &escape($coursefilter),                                  &escape($ownerfilter), &escape($coursefilter),
                                 &escape($typefilter), &escape($regexp_ok),                                  &escape($typefilter), &escape($regexp_ok), 
                                 $as_hash, &escape($selfenrollonly),                                  $as_hash, &escape($selfenrollonly), 
                                 &escape($catfilter), $showhidden, $caller,                                  &escape($catfilter), $showhidden, $caller, 
                                 &escape($cloner), &escape($cc_clone), $cloneonly,                                  &escape($cloner), &escape($cc_clone), $cloneonly, 
                                 &escape($createdbefore), &escape($createdafter),                                  &escape($createdbefore), &escape($createdafter), 
                                 &escape($creationcontext),$domcloner,$hasuniquecode,                                  &escape($creationcontext), $domcloner)));
                                 $reqcrsdom,&escape($reqinstcode))));  
                 } else {                  } else {
                     $rep = &reply('courseiddump:'.&host_domain($tryserver).':'.                      $rep = &reply('courseiddump:'.&host_domain($tryserver).':'.
                              $sincefilter.':'.&escape($descfilter).':'.                               $sincefilter.':'.&escape($descfilter).':'.
Line 4384  sub courseiddump { Line 3886  sub courseiddump {
                              $showhidden.':'.$caller.':'.&escape($cloner).':'.                               $showhidden.':'.$caller.':'.&escape($cloner).':'.
                              &escape($cc_clone).':'.$cloneonly.':'.                               &escape($cc_clone).':'.$cloneonly.':'.
                              &escape($createdbefore).':'.&escape($createdafter).':'.                               &escape($createdbefore).':'.&escape($createdafter).':'.
                              &escape($creationcontext).':'.$domcloner.':'.$hasuniquecode.                               &escape($creationcontext).':'.$domcloner,
                              ':'.$reqcrsdom.':'.&escape($reqinstcode),$tryserver);                               $tryserver);
                 }                  }
                        
                 my @pairs=split(/\&/,$rep);                  my @pairs=split(/\&/,$rep);
                 foreach my $item (@pairs) {                  foreach my $item (@pairs) {
                     my ($key,$value)=split(/\=/,$item,2);                      my ($key,$value)=split(/\=/,$item,2);
Line 4493  sub get_domain_roles { Line 3995  sub get_domain_roles {
     }      }
     my $rolelist;      my $rolelist;
     if (ref($roles) eq 'ARRAY') {      if (ref($roles) eq 'ARRAY') {
         $rolelist = join('&',@{$roles});          $rolelist = join(':',@{$roles});
     }      }
     my %personnel = ();      my %personnel = ();
   
Line 4524  my $cachedkey=''; Line 4026  my $cachedkey='';
 # The cached times for this user  # The cached times for this user
 my %cachedtimes=();  my %cachedtimes=();
 # When this was last done  # When this was last done
 my $cachedtime='';  my $cachedtime=();
   
 sub load_all_first_access {  sub load_all_first_access {
     my ($uname,$udom)=@_;      my ($uname,$udom)=@_;
Line 4586  sub set_first_access { Line 4088  sub set_first_access {
     return 'already_set';      return 'already_set';
 }  }
 }  }
   
 sub checkout {  
     my ($symb,$tuname,$tudom,$tcrsid)=@_;  
     my $now=time;  
     my $lonhost=$perlvar{'lonHostID'};  
     my $infostr=&escape(  
                  'CHECKOUTTOKEN&'.  
                  $tuname.'&'.  
                  $tudom.'&'.  
                  $tcrsid.'&'.  
                  $symb.'&'.  
                  $now.'&'.$ENV{'REMOTE_ADDR'});  
     my $token=&reply('tmpput:'.$infostr,$lonhost);  
     if ($token=~/^error\:/) {  
         &logthis("<font color=\"blue\">WARNING: ".  
                 "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.  
                  "</font>");  
         return '';  
     }  
   
     $token=~s/^(\d+)\_.*\_(\d+)$/$1\*$2\*$lonhost/;  
     $token=~tr/a-z/A-Z/;  
   
     my %infohash=('resource.0.outtoken' => $token,  
                   'resource.0.checkouttime' => $now,  
                   'resource.0.outremote' => $ENV{'REMOTE_ADDR'});  
   
     unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {  
        return '';  
     } else {  
         &logthis("<font color=\"blue\">WARNING: ".  
                 "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.  
                  "</font>");  
     }  
   
     if (&log($tudom,$tuname,&homeserver($tuname,$tudom),  
                          &escape('Checkout '.$infostr.' - '.  
                                                  $token)) ne 'ok') {  
         return '';  
     } else {  
         &logthis("<font color=\"blue\">WARNING: ".  
                 "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.  
                  "</font>");  
     }  
     return $token;  
 }  
   
 # ------------------------------------------------------------ Check in an item  
   
 sub checkin {  
     my $token=shift;  
     my $now=time;  
     my ($ta,$tb,$lonhost)=split(/\*/,$token);  
     $lonhost=~tr/A-Z/a-z/;  
     my $dtoken=$ta.'_'.&hostname($lonhost).'_'.$tb;  
     $dtoken=~s/\W/\_/g;  
     my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=  
                  split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));  
   
     unless (($tuname) && ($tudom)) {  
         &logthis('Check in '.$token.' ('.$dtoken.') failed');  
         return '';  
     }  
   
     unless (&allowed('mgr',$tcrsid)) {  
         &logthis('Check in '.$token.' ('.$dtoken.') unauthorized: '.  
                  $env{'user.name'}.' - '.$env{'user.domain'});  
         return '';  
     }  
   
     my %infohash=('resource.0.intoken' => $token,  
                   'resource.0.checkintime' => $now,  
                   'resource.0.inremote' => $ENV{'REMOTE_ADDR'});  
   
     unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {  
        return '';  
     }  
   
     if (&log($tudom,$tuname,&homeserver($tuname,$tudom),  
                          &escape('Checkin - '.$token)) ne 'ok') {  
         return '';  
     }  
   
     return ($symb,$tuname,$tudom,$tcrsid);  
 }  
   
 # --------------------------------------------- Set Expire Date for Spreadsheet  # --------------------------------------------- Set Expire Date for Spreadsheet
   
 sub expirespread {  sub expirespread {
Line 5042  sub tmprestore { Line 4458  sub tmprestore {
 # ----------------------------------------------------------------------- Store  # ----------------------------------------------------------------------- Store
   
 sub store {  sub store {
     my ($storehash,$symb,$namespace,$domain,$stuname,$laststore) = @_;      my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
     my $home='';      my $home='';
   
     if ($stuname) { $home=&homeserver($stuname,$domain); }      if ($stuname) { $home=&homeserver($stuname,$domain); }
Line 5072  sub store { Line 4488  sub store {
     }      }
     $namevalue=~s/\&$//;      $namevalue=~s/\&$//;
     &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue);      &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue);
     return reply("store:$domain:$stuname:$namespace:$symb:$namevalue:$laststore","$home");      return reply("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");
 }  }
   
 # -------------------------------------------------------------- Critical Store  # -------------------------------------------------------------- Critical Store
   
 sub cstore {  sub cstore {
     my ($storehash,$symb,$namespace,$domain,$stuname,$laststore) = @_;      my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
     my $home='';      my $home='';
   
     if ($stuname) { $home=&homeserver($stuname,$domain); }      if ($stuname) { $home=&homeserver($stuname,$domain); }
Line 5109  sub cstore { Line 4525  sub cstore {
     $namevalue=~s/\&$//;      $namevalue=~s/\&$//;
     &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue);      &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue);
     return critical      return critical
                 ("store:$domain:$stuname:$namespace:$symb:$namevalue:$laststore","$home");                  ("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");
 }  }
   
 # --------------------------------------------------------------------- Restore  # --------------------------------------------------------------------- Restore
Line 5121  sub restore { Line 4537  sub restore {
     if ($stuname) { $home=&homeserver($stuname,$domain); }      if ($stuname) { $home=&homeserver($stuname,$domain); }
   
     if (!$symb) {      if (!$symb) {
         return if ($namespace eq 'courserequests');        unless ($symb=escape(&symbread())) { return ''; }
         unless ($symb=escape(&symbread())) { return ''; }  
     } else {      } else {
         unless ($namespace eq 'courserequests') {        $symb=&escape(&symbclean($symb));
             $symb=&escape(&symbclean($symb));  
         }  
     }      }
     if (!$namespace) {       if (!$namespace) { 
        unless ($namespace=$env{'request.course.id'}) {          unless ($namespace=$env{'request.course.id'}) { 
Line 5261  sub update_released_required { Line 4674  sub update_released_required {
 # -------------------------------------------------See if a user is privileged  # -------------------------------------------------See if a user is privileged
   
 sub privileged {  sub privileged {
     my ($username,$domain,$possdomains,$possroles)=@_;      my ($username,$domain)=@_;
   
       my %rolesdump = &dump("roles", $domain, $username) or return 0;
     my $now = time;      my $now = time;
     my $roles;  
     if (ref($possroles) eq 'ARRAY') {  
         $roles = $possroles;  
     } else {  
         $roles = ['dc','su'];  
     }  
     if (ref($possdomains) eq 'ARRAY') {  
         my %privileged = &privileged_by_domain($possdomains,$roles);  
         foreach my $dom (@{$possdomains}) {  
             if (($username =~ /^$match_username$/) && ($domain =~ /^$match_domain$/) &&  
                 (ref($privileged{$dom}) eq 'HASH')) {  
                 foreach my $role (@{$roles}) {  
                     if (ref($privileged{$dom}{$role}) eq 'HASH') {  
                         if (exists($privileged{$dom}{$role}{$username.':'.$domain})) {  
                             my ($end,$start) = split(/:/,$privileged{$dom}{$role}{$username.':'.$domain});  
                             return 1 unless (($end && $end < $now) ||  
                                              ($start && $start > $now));  
                         }  
                     }  
                 }  
             }  
         }  
     } else {  
         my %rolesdump = &dump("roles", $domain, $username) or return 0;  
         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 (($trole eq 'dc') || ($trole eq 'su')) {
                 return 1 unless ($tend && $tend < $now)                  return 1 unless ($tend && $tend < $now) 
                         or ($tstart && $tstart > $now);                      or ($tstart && $tstart > $now);
             }              }
         }   }
     }  
     return 0;  
 }  
   
 sub privileged_by_domain {      return 0;
     my ($domains,$roles) = @_;  
     my %privileged = ();  
     my $cachetime = 60*60*24;  
     my $now = time;  
     unless ((ref($domains) eq 'ARRAY') && (ref($roles) eq 'ARRAY')) {  
         return %privileged;  
     }  
     foreach my $dom (@{$domains}) {  
         next if (ref($privileged{$dom}) eq 'HASH');  
         my $needroles;  
         foreach my $role (@{$roles}) {  
             my ($result,$cached)=&is_cached_new('priv_'.$role,$dom);  
             if (defined($cached)) {  
                 if (ref($result) eq 'HASH') {  
                     $privileged{$dom}{$role} = $result;  
                 }  
             } else {  
                 $needroles = 1;  
             }  
         }  
         if ($needroles) {  
             my %dompersonnel = &get_domain_roles($dom,$roles);  
             $privileged{$dom} = {};  
             foreach my $server (keys(%dompersonnel)) {  
                 if (ref($dompersonnel{$server}) eq 'HASH') {  
                     foreach my $item (keys(%{$dompersonnel{$server}})) {  
                         my ($trole,$uname,$udom,$rest) = split(/:/,$item,4);  
                         my ($end,$start) = split(/:/,$dompersonnel{$server}{$item});  
                         next if ($end && $end < $now);  
                         $privileged{$dom}{$trole}{$uname.':'.$udom} =  
                             $dompersonnel{$server}{$item};  
                     }  
                 }  
             }  
             if (ref($privileged{$dom}) eq 'HASH') {  
                 foreach my $role (@{$roles}) {  
                     if (ref($privileged{$dom}{$role}) eq 'HASH') {  
                         &do_cache_new('priv_'.$role,$dom,$privileged{$dom}{$role},$cachetime);  
                     } else {  
                         my %hash = ();  
                         &do_cache_new('priv_'.$role,$dom,\%hash,$cachetime);  
                     }  
                 }  
             }  
         }  
     }  
     return %privileged;  
 }  }
   
 # -------------------------------------------------------- Get user privileges  # -------------------------------------------------------- Get user privileges
Line 5378  sub rolesinit { Line 4718  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 5459  sub rolesinit { Line 4799  sub rolesinit {
 }  }
   
 sub set_arearole {  sub set_arearole {
     my ($trole,$area,$tstart,$tend,$domain,$username,$nolog) = @_;      my ($trole,$area,$tstart,$tend,$domain,$username) = @_;
     unless ($nolog) {  
 # log the associated role with the area  # log the associated role with the area
         &userrolelog($trole,$username,$domain,$area,$tstart,$tend);      &userrolelog($trole,$username,$domain,$area,$tstart,$tend);
     }  
     return ('user.role.'.$trole.'.'.$area => $tstart.'.'.$tend);      return ('user.role.'.$trole.'.'.$area => $tstart.'.'.$tend);
 }  }
   
 sub custom_roleprivs {  sub custom_roleprivs {
     my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_;      my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_;
     my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);      my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
     my $homsvr = &homeserver($rauthor,$rdomain);      my $homsvr=homeserver($rauthor,$rdomain);
     if (&hostname($homsvr) ne '') {      if (&hostname($homsvr) ne '') {
         my ($rdummy,$roledef)=          my ($rdummy,$roledef)=
             &get('roles',["rolesdef_$rrole"],$rdomain,$rauthor);              &get('roles',["rolesdef_$rrole"],$rdomain,$rauthor);
Line 5591  sub set_userprivs { Line 4929  sub set_userprivs {
   
 sub role_status {  sub role_status {
     my ($rolekey,$update,$refresh,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_;      my ($rolekey,$update,$refresh,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_;
       my @pwhere = ();
     if (exists($env{$rolekey}) && $env{$rolekey} ne '') {      if (exists($env{$rolekey}) && $env{$rolekey} ne '') {
         my ($one,$two) = split(m{\./},$rolekey,2);          (undef,undef,$$role,@pwhere)=split(/\./,$rolekey);
         (undef,undef,$$role) = split(/\./,$one,3);  
         unless (!defined($$role) || $$role eq '') {          unless (!defined($$role) || $$role eq '') {
             $$where = '/'.$two;              $$where=join('.',@pwhere);
             $$trolecode=$$role.'.'.$$where;              $$trolecode=$$role.'.'.$$where;
             ($$tstart,$$tend)=split(/\./,$env{$rolekey});              ($$tstart,$$tend)=split(/\./,$env{$rolekey});
             $$tstatus='is';              $$tstatus='is';
Line 5732  sub set_adhoc_privileges { Line 5070  sub set_adhoc_privileges {
     my $area = '/'.$dcdom.'/'.$pickedcourse;      my $area = '/'.$dcdom.'/'.$pickedcourse;
     my $spec = $role.'.'.$area;      my $spec = $role.'.'.$area;
     my %userroles = &set_arearole($role,$area,'','',$env{'user.domain'},      my %userroles = &set_arearole($role,$area,'','',$env{'user.domain'},
                                   $env{'user.name'},1);                                    $env{'user.name'});
     my %ccrole = ();      my %ccrole = ();
     &standard_roleprivs(\%ccrole,$role,$dcdom,$spec,$pickedcourse,$area);      &standard_roleprivs(\%ccrole,$role,$dcdom,$spec,$pickedcourse,$area);
     my ($author,$adv)= &set_userprivs(\%userroles,\%ccrole);      my ($author,$adv)= &set_userprivs(\%userroles,\%ccrole);
Line 5801  sub unserialize { Line 5139  sub unserialize {
     return {} if $rep =~ /^error/;      return {} if $rep =~ /^error/;
   
     my %returnhash=();      my %returnhash=();
     foreach my $item (split(/\&/,$rep)) {   foreach my $item (split /\&/, $rep) {
         my ($key, $value) = split(/=/, $item, 2);      my ($key, $value) = split(/=/, $item, 2);
         $key = unescape($key) unless $escapedkeys;      $key = unescape($key) unless $escapedkeys;
         next if $key =~ /^error: 2 /;      next if $key =~ /^error: 2 /;
         $returnhash{$key} = &thaw_unescape($value);      $returnhash{$key} = Apache::lonnet::thaw_unescape($value);
     }   }
       #return %returnhash;
     return \%returnhash;      return \%returnhash;
 }  }        
   
 # see Lond::dump_with_regexp  # see Lond::dump_with_regexp
 # if $escapedkeys hash keys won't get unescaped.  # if $escapedkeys hash keys won't get unescaped.
Line 5818  sub dump { Line 5157  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 (grep { $_ eq $uhome } current_machine_ids()) {
           # user is hosted on this machine
           $reply = LONCAPA::Lond::dump_with_regexp(join(":", ($udomain,
                       $uname, $namespace, $regexp, $range)), $loncaparevs{$uhome});
           return %{unserialize($reply, $escapedkeys)};
       }
     if ($regexp) {      if ($regexp) {
         $regexp=&escape($regexp);   $regexp=&escape($regexp);
     } else {      } else {
         $regexp='.';   $regexp='.';
     }  
     if (grep { $_ eq $uhome } &current_machine_ids()) {  
         # user is hosted on this machine  
         my $reply = LONCAPA::Lond::dump_with_regexp(join(':', ($udomain,  
                     $uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'});  
         return %{&unserialize($reply, $escapedkeys)};  
     }      }
     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);
Line 5835  sub dump { Line 5175  sub dump {
     if (!($rep =~ /^error/ )) {      if (!($rep =~ /^error/ )) {
  foreach my $item (@pairs) {   foreach my $item (@pairs) {
     my ($key,$value)=split(/=/,$item,2);      my ($key,$value)=split(/=/,$item,2);
             $key = &unescape($key) unless ($escapedkeys);          $key = unescape($key) unless $escapedkeys;
           #$key = &unescape($key);
     next if ($key =~ /^error: 2 /);      next if ($key =~ /^error: 2 /);
     $returnhash{$key}=&thaw_unescape($value);      $returnhash{$key}=&thaw_unescape($value);
  }   }
Line 5879  sub currentdump { Line 5220  sub currentdump {
    my $rep;     my $rep;
   
    if (grep { $_ eq $uhome } current_machine_ids()) {     if (grep { $_ eq $uhome } current_machine_ids()) {
        $rep = LONCAPA::Lond::dump_profile_database(join(":", ($sdom, $sname,         $rep = LONCAPA::Lond::dump_profile_database(join(":", ($sdom, $sname, 
                    $courseid)));                     $courseid)));
    } else {     } else {
        $rep = reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome);         $rep = reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome);
Line 6005  sub newput { Line 5346  sub newput {
 # ---------------------------------------------------------  putstore interface  # ---------------------------------------------------------  putstore interface
   
 sub putstore {  sub putstore {
    my ($namespace,$symb,$version,$storehash,$udomain,$uname,$tolog)=@_;     my ($namespace,$symb,$version,$storehash,$udomain,$uname)=@_;
    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 6019  sub putstore { Line 5360  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 6138  sub tmpdel { Line 5468  sub tmpdel {
     return &reply("tmpdel:$token",$server);      return &reply("tmpdel:$token",$server);
 }  }
   
 # ------------------------------------------------------------ get_timebased_id  
   
 sub get_timebased_id {  
     my ($prefix,$keyid,$namespace,$cdom,$cnum,$idtype,$who,$locktries,  
         $maxtries) = @_;  
     my ($newid,$error,$dellock);  
     unless (($prefix =~ /^\w+$/) && ($keyid =~ /^\w+$/) && ($namespace ne '')) {  
         return ('','ok','invalid call to get suffix');  
     }  
   
 # set defaults for any optional args for which values were not supplied  
     if ($who eq '') {  
         $who = $env{'user.name'}.':'.$env{'user.domain'};  
     }  
     if (!$locktries) {  
         $locktries = 3;  
     }  
     if (!$maxtries) {  
         $maxtries = 10;  
     }  
   
     if (($cdom eq '') || ($cnum eq '')) {  
         if ($env{'request.course.id'}) {  
             $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};  
             $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};  
         }  
         if (($cdom eq '') || ($cnum eq '')) {  
             return ('','ok','call to get suffix not in course context');  
         }  
     }  
   
 # construct locking item  
     my $lockhash = {  
                       $prefix."\0".'locked_'.$keyid => $who,  
                    };  
     my $tries = 0;  
   
 # attempt to get lock on nohist_$namespace file  
     my $gotlock = &Apache::lonnet::newput('nohist_'.$namespace,$lockhash,$cdom,$cnum);  
     while (($gotlock ne 'ok') && $tries <$locktries) {  
         $tries ++;  
         sleep 1;  
         $gotlock = &Apache::lonnet::newput('nohist_'.$namespace,$lockhash,$cdom,$cnum);  
     }  
   
 # attempt to get unique identifier, based on current timestamp  
     if ($gotlock eq 'ok') {  
         my %inuse = &Apache::lonnet::dump('nohist_'.$namespace,$cdom,$cnum,$prefix);  
         my $id = time;  
         $newid = $id;  
         if ($idtype eq 'addcode') {  
             $newid .= &sixnum_code();  
         }  
         my $idtries = 0;  
         while (exists($inuse{$prefix."\0".$newid}) && $idtries < $maxtries) {  
             if ($idtype eq 'concat') {  
                 $newid = $id.$idtries;  
             } elsif ($idtype eq 'addcode') {  
                 $newid = $newid.&sixnum_code();  
             } else {  
                 $newid ++;  
             }  
             $idtries ++;  
         }  
         if (!exists($inuse{$prefix."\0".$newid})) {  
             my %new_item =  (  
                               $prefix."\0".$newid => $who,  
                             );  
             my $putresult = &Apache::lonnet::put('nohist_'.$namespace,\%new_item,  
                                                  $cdom,$cnum);  
             if ($putresult ne 'ok') {  
                 undef($newid);  
                 $error = 'error saving new item: '.$putresult;  
             }  
         } else {  
              undef($newid);  
              $error = ('error: no unique suffix available for the new item ');  
         }  
 #  remove lock  
         my @del_lock = ($prefix."\0".'locked_'.$keyid);  
         $dellock = &Apache::lonnet::del('nohist_'.$namespace,\@del_lock,$cdom,$cnum);  
     } else {  
         $error = "error: could not obtain lockfile\n";  
         $dellock = 'ok';  
         if (($prefix eq 'paste') && ($namespace eq 'courseeditor') && ($keyid eq 'num')) {  
             $dellock = 'nolock';  
         }  
     }  
     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 {
     my ($requrl,$clientip) = @_;      my ($requrl) = @_;
     my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl);      my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl);
     my $result = &get_portfolio_access($udom,$unum,$file_name,$group,$clientip);      my $result = &get_portfolio_access($udom,$unum,$file_name,$group);
     if ($result) {      if ($result) {
         my %setters;          my %setters;
         if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {          if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
Line 6268  sub portfolio_access { Line 5499  sub portfolio_access {
 }  }
   
 sub get_portfolio_access {  sub get_portfolio_access {
     my ($udom,$unum,$file_name,$group,$clientip,$access_hash) = @_;      my ($udom,$unum,$file_name,$group,$access_hash) = @_;
   
     if (!ref($access_hash)) {      if (!ref($access_hash)) {
  my $current_perms = &get_portfile_permissions($udom,$unum);   my $current_perms = &get_portfile_permissions($udom,$unum);
Line 6277  sub get_portfolio_access { Line 5508  sub get_portfolio_access {
  $access_hash = $access_controls{$file_name};   $access_hash = $access_controls{$file_name};
     }      }
   
     my ($public,$guest,@domains,@users,@courses,@groups,@ips);      my ($public,$guest,@domains,@users,@courses,@groups);
     my $now = time;      my $now = time;
     if (ref($access_hash) eq 'HASH') {      if (ref($access_hash) eq 'HASH') {
         foreach my $key (keys(%{$access_hash})) {          foreach my $key (keys(%{$access_hash})) {
Line 6301  sub get_portfolio_access { Line 5532  sub get_portfolio_access {
                 push(@courses,$key);                  push(@courses,$key);
             } elsif ($scope eq 'group') {              } elsif ($scope eq 'group') {
                 push(@groups,$key);                  push(@groups,$key);
             } elsif ($scope eq 'ip') {  
                 push(@ips,$key);  
             }              }
         }          }
         if ($public) {          if ($public) {
             return 'ok';              return 'ok';
         } elsif (@ips > 0) {  
             my $allowed;  
             foreach my $ipkey (@ips) {  
                 if (ref($access_hash->{$ipkey}{'ip'}) eq 'ARRAY') {  
                     if (&Apache::loncommon::check_ip_acc(join(',',@{$access_hash->{$ipkey}{'ip'}}),$clientip)) {  
                         $allowed = 1;  
                         last;  
                     }  
                 }  
             }  
             if ($allowed) {  
                 return 'ok';  
             }  
         }          }
         if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {          if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
             if ($guest) {              if ($guest) {
Line 6506  sub usertools_access { Line 5722  sub usertools_access {
                       official   => 1,                        official   => 1,
                       unofficial => 1,                        unofficial => 1,
                       community  => 1,                        community  => 1,
                       textbook   => 1,  
                  );                   );
     } elsif ($context eq 'requestauthor') {      } elsif ($context eq 'requestauthor') {
         %tools = (          %tools = (
Line 6522  sub usertools_access { Line 5737  sub usertools_access {
     }      }
     return if (!defined($tools{$tool}));      return if (!defined($tools{$tool}));
   
     if (($udom eq '') || ($uname eq '')) {      if ((!defined($udom)) || (!defined($uname))) {
         $udom = $env{'user.domain'};          $udom = $env{'user.domain'};
         $uname = $env{'user.name'};          $uname = $env{'user.name'};
     }      }
Line 6541  sub usertools_access { Line 5756  sub usertools_access {
   
     my ($toolstatus,$inststatus,$envkey);      my ($toolstatus,$inststatus,$envkey);
     if ($context eq 'requestauthor') {      if ($context eq 'requestauthor') {
         $envkey = $context;          $envkey = $context; 
     } else {      } else {
         $envkey = $context.'.'.$tool;          $envkey = $context.'.'.$tool;
     }      }
Line 6803  sub customaccess { Line 6018  sub customaccess {
 # ------------------------------------------------- Check for a user privilege  # ------------------------------------------------- Check for a user privilege
   
 sub allowed {  sub allowed {
     my ($priv,$uri,$symb,$role,$clientip,$noblockcheck)=@_;      my ($priv,$uri,$symb,$role)=@_;
     my $ver_orguri=$uri;      my $ver_orguri=$uri;
     $uri=&deversion($uri);      $uri=&deversion($uri);
     my $orguri=$uri;      my $orguri=$uri;
Line 6998  sub allowed { Line 6213  sub allowed {
         if ($match) {          if ($match) {
             if ($env{'user.priv.'.$env{'request.role'}.'./'}              if ($env{'user.priv.'.$env{'request.role'}.'./'}
                   =~/\Q$priv\E\&([^\:]*)/) {                    =~/\Q$priv\E\&([^\:]*)/) {
                 my $value = $1;                  my @blockers = &has_comm_blocking($priv,$symb,$uri);
                 if ($noblockcheck) {                  if (@blockers > 0) {
                     $thisallowed.=$value;                      $thisallowed = 'B';
                 } else {                  } else {
                     my @blockers = &has_comm_blocking($priv,$symb,$uri);                      $thisallowed.=$1;
                     if (@blockers > 0) {  
                         $thisallowed = 'B';  
                     } else {  
                         $thisallowed.=$value;  
                     }  
                 }                  }
             }              }
         } else {          } else {
Line 7019  sub allowed { Line 6229  sub allowed {
                     $refuri=&declutter($refuri);                      $refuri=&declutter($refuri);
                     my ($match) = &is_on_map($refuri);                      my ($match) = &is_on_map($refuri);
                     if ($match) {                      if ($match) {
                         if ($noblockcheck) {                          my @blockers = &has_comm_blocking($priv,$symb,$refuri);
                             $thisallowed='F';                          if (@blockers > 0) {
                               $thisallowed = 'B';
                         } else {                          } else {
                             my @blockers = &has_comm_blocking($priv,$symb,$refuri);                              $thisallowed='F';
                             if (@blockers > 0) {  
                                 $thisallowed = 'B';  
                             } else {  
                                 $thisallowed='F';  
                             }  
                         }                          }
                     }                      }
                 }                  }
Line 7039  sub allowed { Line 6245  sub allowed {
  && $thisallowed ne 'F'    && $thisallowed ne 'F' 
  && $thisallowed ne '2'   && $thisallowed ne '2'
  && &is_portfolio_url($uri)) {   && &is_portfolio_url($uri)) {
  $thisallowed = &portfolio_access($uri,$clientip);   $thisallowed = &portfolio_access($uri);
     }      }
           
 # Full access at system, domain or course-wide level? Exit.  # Full access at system, domain or course-wide level? Exit.
Line 7082  sub allowed { Line 6288  sub allowed {
                =~/\Q$priv\E\&([^\:]*)/) {                 =~/\Q$priv\E\&([^\:]*)/) {
                my $value = $1;                 my $value = $1;
                if ($priv eq 'bre') {                 if ($priv eq 'bre') {
                    if ($noblockcheck) {                     my @blockers = &has_comm_blocking($priv,$symb,$uri);
                        $thisallowed.=$value;                     if (@blockers > 0) {
                          $thisallowed = 'B';
                    } else {                     } else {
                        my @blockers = &has_comm_blocking($priv,$symb,$uri);                         $thisallowed.=$value;
                        if (@blockers > 0) {  
                            $thisallowed = 'B';  
                        } else {  
                            $thisallowed.=$value;  
                        }  
                    }                     }
                } else {                 } else {
                    $thisallowed.=$value;                     $thisallowed.=$value;
Line 7124  sub allowed { Line 6326  sub allowed {
                   =~/\Q$priv\E\&([^\:]*)/) {                    =~/\Q$priv\E\&([^\:]*)/) {
                   my $value = $1;                    my $value = $1;
                   if ($priv eq 'bre') {                    if ($priv eq 'bre') {
                       if ($noblockcheck) {                        my @blockers = &has_comm_blocking($priv,$symb,$refuri);
                           $thisallowed.=$value;                        if (@blockers > 0) {
                             $thisallowed = 'B';
                       } else {                        } else {
                           my @blockers = &has_comm_blocking($priv,$symb,$refuri);                            $thisallowed.=$value;
                           if (@blockers > 0) {  
                               $thisallowed = 'B';  
                           } else {  
                               $thisallowed.=$value;  
                           }  
                       }                        }
                   } else {                    } else {
                       $thisallowed.=$value;                        $thisallowed.=$value;
Line 7296  sub allowed { Line 6494  sub allowed {
    return 'F';     return 'F';
 }  }
   
 # ------------------------------------------- Check construction space access  
   
 sub constructaccess {  
     my ($url,$setpriv)=@_;  
   
 # We do not allow editing of previous versions of files  
     if ($url=~/\.(\d+)\.(\w+)$/) { return ''; }  
   
 # Get username and domain from URL  
     my ($ownername,$ownerdomain,$ownerhome);  
   
     ($ownerdomain,$ownername) =  
         ($url=~ m{^(?:\Q$perlvar{'lonDocRoot'}\E|)/priv/($match_domain)/($match_username)/});  
   
 # The URL does not really point to any authorspace, forget it  
     unless (($ownername) && ($ownerdomain)) { return ''; }  
   
 # Now we need to see if the user has access to the authorspace of  
 # $ownername at $ownerdomain  
   
     if (($ownername eq $env{'user.name'}) && ($ownerdomain eq $env{'user.domain'})) {  
 # Real author for this?  
        $ownerhome = $env{'user.home'};  
        if (exists($env{'user.priv.au./'.$ownerdomain.'/./'})) {  
           return ($ownername,$ownerdomain,$ownerhome);  
        }  
     } else {  
 # Co-author for this?  
         if (exists($env{'user.priv.ca./'.$ownerdomain.'/'.$ownername.'./'}) ||  
             exists($env{'user.priv.aa./'.$ownerdomain.'/'.$ownername.'./'}) ) {  
             $ownerhome = &homeserver($ownername,$ownerdomain);  
             return ($ownername,$ownerdomain,$ownerhome);  
         }  
     }  
   
 # We don't have any access right now. If we are not possibly going to do anything about this,  
 # we might as well leave  
    unless ($setpriv) { return ''; }  
   
 # Backdoor access?  
     my $allowed=&allowed('eco',$ownerdomain);  
 # Nope  
     unless ($allowed) { return ''; }  
 # Looks like we may have access, but could be locked by the owner of the construction space  
     if ($allowed eq 'U') {  
         my %blocked=&get('environment',['domcoord.author'],  
                          $ownerdomain,$ownername);  
 # Is blocked by owner  
         if ($blocked{'domcoord.author'} eq 'blocked') { return ''; }  
     }  
     if (($allowed eq 'F') || ($allowed eq 'U')) {  
 # Grant temporary access  
         my $then=$env{'user.login.time'};  
         my $update=$env{'user.update.time'};  
         if (!$update) { $update = $then; }  
         my $refresh=$env{'user.refresh.time'};  
         if (!$refresh) { $refresh = $update; }  
         my $now = time;  
         &check_adhoc_privs($ownerdomain,$ownername,$update,$refresh,  
                            $now,'ca','constructaccess');  
         $ownerhome = &homeserver($ownername,$ownerdomain);  
         return($ownername,$ownerdomain,$ownerhome);  
     }  
 # No business here  
     return '';  
 }  
   
 # ----------------------------------------------------------- Content Blocking  
   
 {  
 # Caches for faster Course Contents display where content blocking  
 # is in operation (i.e., interval param set) for timed quiz.  
 #  
 # User for whom data are being temporarily cached.  
 my $cacheduser='';  
 # Cached blockers for this user (a hash of blocking items).  
 my %cachedblockers=();  
 # When the data were last cached.  
 my $cachedlast='';  
   
 sub load_all_blockers {  
     my ($uname,$udom,$blocks)=@_;  
     if (($uname ne '') && ($udom ne '')) {  
         if (($cacheduser eq $uname.':'.$udom) &&  
             (abs($cachedlast-time)<5)) {  
             return;  
         }  
     }  
     $cachedlast=time;  
     $cacheduser=$uname.':'.$udom;  
     %cachedblockers = &get_commblock_resources($blocks);  
 }  
   
 sub get_comm_blocks {  sub get_comm_blocks {
     my ($cdom,$cnum) = @_;      my ($cdom,$cnum) = @_;
     if ($cdom eq '' || $cnum eq '') {      if ($cdom eq '' || $cnum eq '') {
Line 7409  sub get_comm_blocks { Line 6514  sub get_comm_blocks {
     return %commblocks;      return %commblocks;
 }  }
   
 sub get_commblock_resources {  sub has_comm_blocking {
     my ($blocks) = @_;      my ($priv,$symb,$uri,$blocks) = @_;
     my %blockers = ();      return unless ($env{'request.course.id'});
     return %blockers unless ($env{'request.course.id'});      return unless ($priv eq 'bre');
     return %blockers if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/);      return if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/);
     my %commblocks;      my %commblocks;
     if (ref($blocks) eq 'HASH') {      if (ref($blocks) eq 'HASH') {
         %commblocks = %{$blocks};          %commblocks = %{$blocks};
     } else {      } else {
         %commblocks = &get_comm_blocks();          %commblocks = &get_comm_blocks();
     }      }
     return %blockers unless (keys(%commblocks) > 0);      return unless (keys(%commblocks) > 0);
     my $navmap = Apache::lonnavmaps::navmap->new();      if (!$symb) { $symb=&symbread($uri,1); }
     return %blockers unless (ref($navmap));      my ($map,$resid,undef)=&decode_symb($symb);
       my %tocheck = (
                       maps      => $map,
                       resources => $symb,
                     );
       my @blockers;
     my $now = time;      my $now = time;
       my $navmap = Apache::lonnavmaps::navmap->new();
     foreach my $block (keys(%commblocks)) {      foreach my $block (keys(%commblocks)) {
         if ($block =~ /^(\d+)____(\d+)$/) {          if ($block =~ /^(\d+)____(\d+)$/) {
             my ($start,$end) = ($1,$2);              my ($start,$end) = ($1,$2);
Line 7431  sub get_commblock_resources { Line 6542  sub get_commblock_resources {
                 if (ref($commblocks{$block}{'blocks'}) eq 'HASH') {                  if (ref($commblocks{$block}{'blocks'}) eq 'HASH') {
                     if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') {                      if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') {
                         if (ref($commblocks{$block}{'blocks'}{'docs'}{'maps'}) eq 'HASH') {                          if (ref($commblocks{$block}{'blocks'}{'docs'}{'maps'}) eq 'HASH') {
                             if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'maps'}})) {                              if ($commblocks{$block}{'blocks'}{'docs'}{'maps'}{$map}) {
                                 $blockers{$block}{maps} = $commblocks{$block}{'blocks'}{'docs'}{'maps'};                                  unless (grep(/^\Q$block\E$/,@blockers)) {
                                       push(@blockers,$block);
                                   }
                             }                              }
                         }                          }
                         if (ref($commblocks{$block}{'blocks'}{'docs'}{'resources'}) eq 'HASH') {                          if (ref($commblocks{$block}{'blocks'}{'docs'}{'resources'}) eq 'HASH') {
                             if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'resources'}})) {                              if ($commblocks{$block}{'blocks'}{'docs'}{'resources'}{$symb}) {
                                 $blockers{$block}{'resources'} = $commblocks{$block}{'blocks'}{'docs'}{'resources'};                                  unless (grep(/^\Q$block\E$/,@blockers)) {  
                                       push(@blockers,$block);
                                   }
                             }                              }
                         }                          }
                     }                      }
Line 7448  sub get_commblock_resources { Line 6563  sub get_commblock_resources {
             my @to_test;              my @to_test;
             if (ref($commblocks{$block}{'blocks'}) eq 'HASH') {              if (ref($commblocks{$block}{'blocks'}) eq 'HASH') {
                 if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') {                  if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') {
                     my @interval;                      my $check_interval;
                     my $type = 'map';                      if (&check_docs_block($commblocks{$block}{'blocks'}{'docs'},\%tocheck)) {
                     if ($item eq 'course') {                          my @interval;
                         $type = 'course';                          my $type = 'map';
                         @interval=&EXT("resource.0.interval");                          if ($item eq 'course') {
                     } else {                              $type = 'course';
                         if ($item =~ /___\d+___/) {                              @interval=&EXT("resource.0.interval");
                             $type = 'resource';  
                             @interval=&EXT("resource.0.interval",$item);  
                             if (ref($navmap)) {  
                                 my $res = $navmap->getBySymb($item);  
                                 push(@to_test,$res);  
                             }  
                         } else {                          } else {
                             my $mapsymb = &symbread($item,1);                              if ($item =~ /___\d+___/) {
                             if ($mapsymb) {                                  $type = 'resource';
                                 if (ref($navmap)) {                                  @interval=&EXT("resource.0.interval",$item);
                                     my $mapres = $navmap->getBySymb($mapsymb);                                  if (ref($navmap)) {                        
                                     @to_test = $mapres->retrieveResources($mapres,undef,0,0,0,1);                                      my $res = $navmap->getBySymb($item); 
                                     foreach my $res (@to_test) {                                      push(@to_test,$res);
                                         my $symb = $res->symb();                                  }
                                         next if ($symb eq $mapsymb);                              } else {
                                         if ($symb ne '') {                                  my $mapsymb = &symbread($item,1);
                                             @interval=&EXT("resource.0.interval",$symb);                                  if ($mapsymb) {
                                             if ($interval[1] eq 'map') {                                      if (ref($navmap)) {
                                           my $mapres = $navmap->getBySymb($mapsymb);
                                           @to_test = $mapres->retrieveResources($mapres,undef,0,1);
                                           foreach my $res (@to_test) {
                                               my $symb = $res->symb();
                                               next if ($symb eq $mapsymb);
                                               if ($symb ne '') {
                                                   @interval=&EXT("resource.0.interval",$symb);
                                                 last;                                                  last;
                                             }                                              }
                                         }                                          }
Line 7480  sub get_commblock_resources { Line 6596  sub get_commblock_resources {
                                 }                                  }
                             }                              }
                         }                          }
                     }                          if ($interval[0] =~ /\d+/) {
                     if ($interval[0] =~ /^\d+$/) {                              my $first_access;
                         my $first_access;                              if ($type eq 'resource') {
                         if ($type eq 'resource') {                                  $first_access=&get_first_access($interval[1],$item);
                             $first_access=&get_first_access($interval[1],$item);                              } elsif ($type eq 'map') {
                         } elsif ($type eq 'map') {                                  $first_access=&get_first_access($interval[1],undef,$item);
                             $first_access=&get_first_access($interval[1],undef,$item);                              } else {
                         } else {                                  $first_access=&get_first_access($interval[1]);
                             $first_access=&get_first_access($interval[1]);                              }
                         }                              if ($first_access) {
                         if ($first_access) {                                  my $timesup = $first_access+$interval[0];
                             my $timesup = $first_access+$interval[0];                                  if ($timesup > $now) {
                             if ($timesup > $now) {                                      foreach my $res (@to_test) {
                                 my $activeblock;                                          if ($res->is_problem()) {
                                 foreach my $res (@to_test) {                                              if ($res->completable()) {
                                     if ($res->answerable()) {                                                  unless (grep(/^\Q$block\E$/,@blockers)) {
                                         $activeblock = 1;                                                      push(@blockers,$block);
                                         last;                                                  }
                                     }                                                  last;
                                 }                                              }
                                 if ($activeblock) {  
                                     if (ref($commblocks{$block}{'blocks'}{'docs'}{'maps'}) eq 'HASH') {  
                                          if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'maps'}})) {  
                                              $blockers{$block}{'maps'} = $commblocks{$block}{'blocks'}{'docs'}{'maps'};  
                                          }  
                                     }  
                                     if (ref($commblocks{$block}{'blocks'}{'docs'}{'resources'}) eq 'HASH') {  
                                         if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'resources'}})) {  
                                             $blockers{$block}{'resources'} = $commblocks{$block}{'blocks'}{'docs'}{'resources'};  
                                         }                                          }
                                     }                                      }
                                 }                                  }
Line 7519  sub get_commblock_resources { Line 6626  sub get_commblock_resources {
             }              }
         }          }
     }      }
     return %blockers;      return @blockers;
 }  }
   
 sub has_comm_blocking {  sub check_docs_block {
     my ($priv,$symb,$uri,$blocks) = @_;      my ($docsblock,$tocheck) =@_;
     my @blockers;      if ((ref($docsblock) ne 'HASH') || (ref($tocheck) ne 'HASH')) {
     return unless ($env{'request.course.id'});          return;
     return unless ($priv eq 'bre');  
     return if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/);  
     return if ($env{'request.state'} eq 'construct');  
     &load_all_blockers($env{'user.name'},$env{'user.domain'},$blocks);  
     return unless (keys(%cachedblockers) > 0);  
     my (%possibles,@symbs);  
     if (!$symb) {  
         $symb = &symbread($uri,1,1,1,\%possibles);  
     }      }
     if ($symb) {      if (ref($docsblock->{'maps'}) eq 'HASH') {
         @symbs = ($symb);          if ($tocheck->{'maps'}) {
     } elsif (keys(%possibles)) {              if ($docsblock->{'maps'}{$tocheck->{'maps'}}) {
         @symbs = keys(%possibles);                  return 1;
     }  
     my $noblock;  
     foreach my $symb (@symbs) {  
         last if ($noblock);  
         my ($map,$resid,$resurl)=&decode_symb($symb);  
         foreach my $block (keys(%cachedblockers)) {  
             if ($block =~ /^firstaccess____(.+)$/) {  
                 my $item = $1;  
                 if (($item eq $map) || ($item eq $symb)) {  
                     $noblock = 1;  
                     last;  
                 }  
             }  
             if (ref($cachedblockers{$block}) eq 'HASH') {  
                 if (ref($cachedblockers{$block}{'resources'}) eq 'HASH') {  
                     if ($cachedblockers{$block}{'resources'}{$symb}) {  
                         unless (grep(/^\Q$block\E$/,@blockers)) {  
                             push(@blockers,$block);  
                         }  
                     }  
                 }  
             }              }
             if (ref($cachedblockers{$block}{'maps'}) eq 'HASH') {          }
                 if ($cachedblockers{$block}{'maps'}{$map}) {      }
                     unless (grep(/^\Q$block\E$/,@blockers)) {      if (ref($docsblock->{'resources'}) eq 'HASH') {
                         push(@blockers,$block);          if ($tocheck->{'resources'}) {
                     }              if ($docsblock->{'resources'}{$tocheck->{'resources'}}) {
                 }                  return 1;
             }              }
         }          }
     }      }
     return if ($noblock);      return;
     return @blockers;  
 }  
 }  }
   
 # -------------------------------- Deversion and split uri into path an filename  
   
 #  #
 #   Removes the version from a URI and  #   Removes the versino from a URI and
 #   splits it in to its filename and path to the filename.  #   splits it in to its filename and path to the filename.
 #   Seems like File::Basename could have done this more clearly.  #   Seems like File::Basename could have done this more clearly.
 #   Parameters:  #   Parameters:
Line 7687  sub definerole { Line 6761  sub definerole {
 # ---------------- Make a metadata query against the network of library servers  # ---------------- Make a metadata query against the network of library servers
   
 sub metadata_query {  sub metadata_query {
     my ($query,$custom,$customshow,$server_array,$domains_hash)=@_;      my ($query,$custom,$customshow,$server_array)=@_;
     my %rhash;      my %rhash;
     my %libserv = &all_library();      my %libserv = &all_library();
     my @server_list = (defined($server_array) ? @$server_array      my @server_list = (defined($server_array) ? @$server_array
                                               : keys(%libserv) );                                                : keys(%libserv) );
     for my $server (@server_list) {      for my $server (@server_list) {
         my $domains = '';  
         if (ref($domains_hash) eq 'HASH') {  
             $domains = $domains_hash->{$server};      
         }  
  unless ($custom or $customshow) {   unless ($custom or $customshow) {
     my $reply=&reply("querysend:".&escape($query).':::'.&escape($domains),$server);      my $reply=&reply("querysend:".&escape($query),$server);
     $rhash{$server}=$reply;      $rhash{$server}=$reply;
  }   }
  else {   else {
     my $reply=&reply("querysend:".&escape($query).':'.      my $reply=&reply("querysend:".&escape($query).':'.
      &escape($custom).':'.&escape($customshow).':'.&escape($domains),       &escape($custom).':'.&escape($customshow),
      $server);       $server);
     $rhash{$server}=$reply;      $rhash{$server}=$reply;
  }   }
Line 7760  sub update_allusers_table { Line 6830  sub update_allusers_table {
   
 sub fetch_enrollment_query {  sub fetch_enrollment_query {
     my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_;      my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_;
     my ($homeserver,$sleep,$loopmax);      my $homeserver;
     my $maxtries = 1;      my $maxtries = 1;
     if ($context eq 'automated') {      if ($context eq 'automated') {
         $homeserver = $perlvar{'lonHostID'};          $homeserver = $perlvar{'lonHostID'};
         $sleep = 2;  
         $loopmax = 100;  
         $maxtries = 10; # will wait for up to 2000s for retrieval of classlist data before timeout          $maxtries = 10; # will wait for up to 2000s for retrieval of classlist data before timeout
     } else {      } else {
         $homeserver = &homeserver($cnum,$dom);          $homeserver = &homeserver($cnum,$dom);
Line 7783  sub fetch_enrollment_query { Line 6851  sub fetch_enrollment_query {
         &logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum);           &logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum); 
         return 'error: '.$queryid;          return 'error: '.$queryid;
     }      }
     my $reply = &get_query_reply($queryid,$sleep.$loopmax);      my $reply = &get_query_reply($queryid);
     my $tries = 1;      my $tries = 1;
     while (($reply=~/^timeout/) && ($tries < $maxtries)) {      while (($reply=~/^timeout/) && ($tries < $maxtries)) {
         $reply = &get_query_reply($queryid,$sleep,$loopmax);          $reply = &get_query_reply($queryid);
         $tries ++;          $tries ++;
     }      }
     if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {      if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
Line 7828  sub fetch_enrollment_query { Line 6896  sub fetch_enrollment_query {
 }  }
   
 sub get_query_reply {  sub get_query_reply {
     my ($queryid,$sleep,$loopmax) = @_;      my $queryid=shift;
     if (($sleep eq '') || ($sleep !~ /^\d+\.?\d*$/)) {  
         $sleep = 0.2;  
     }  
     if (($loopmax eq '') || ($loopmax =~ /\D/)) {  
         $loopmax = 100;  
     }  
     my $replyfile=LONCAPA::tempdir().$queryid;      my $replyfile=LONCAPA::tempdir().$queryid;
     my $reply='';      my $reply='';
     for (1..$loopmax) {      for (1..100) {
  sleep($sleep);   sleep 2;
         if (-e $replyfile.'.end') {          if (-e $replyfile.'.end') {
     if (open(my $fh,$replyfile)) {      if (open(my $fh,$replyfile)) {
  $reply = join('',<$fh>);   $reply = join('',<$fh>);
Line 7957  sub auto_validate_instcode { Line 7019  sub auto_validate_instcode {
     }      }
     $response=&unescape(&reply('autovalidateinstcode:'.$cdom.':'.      $response=&unescape(&reply('autovalidateinstcode:'.$cdom.':'.
                         &escape($instcode).':'.&escape($owner),$homeserver));                          &escape($instcode).':'.&escape($owner),$homeserver));
     my ($outcome,$description,$defaultcredits) = map { &unescape($_); } split('&',$response,3);      my ($outcome,$description) = map { &unescape($_); } split('&',$response,2);
     return ($outcome,$description,$defaultcredits);      return ($outcome,$description);
 }  }
   
 sub auto_create_password {  sub auto_create_password {
Line 8200  sub auto_courserequest_checks { Line 7262  sub auto_courserequest_checks {
 }  }
   
 sub auto_courserequest_validation {  sub auto_courserequest_validation {
     my ($dom,$owner,$crstype,$inststatuslist,$instcode,$instseclist,$custominfo) = @_;      my ($dom,$owner,$crstype,$inststatuslist,$instcode,$instseclist) = @_;
     my ($homeserver,$response);      my ($homeserver,$response);
     if ($dom =~ /^$match_domain$/) {      if ($dom =~ /^$match_domain$/) {
         $homeserver = &domain($dom,'primary');          $homeserver = &domain($dom,'primary');
     }      }
     unless ($homeserver eq 'no_host') {      unless ($homeserver eq 'no_host') {  
         my $customdata;            
         if (ref($custominfo) eq 'HASH') {  
             $customdata = &freeze_escape($custominfo);  
         }  
         $response=&unescape(&reply('autocrsreqvalidation:'.$dom.':'.&escape($owner).          $response=&unescape(&reply('autocrsreqvalidation:'.$dom.':'.&escape($owner).
                                     ':'.&escape($crstype).':'.&escape($inststatuslist).                                      ':'.&escape($crstype).':'.&escape($inststatuslist).
                                     ':'.&escape($instcode).':'.&escape($instseclist).':'.                                      ':'.&escape($instcode).':'.&escape($instseclist),
                                     $customdata,$homeserver));                                      $homeserver));
     }      }
     return $response;      return $response;
 }  }
Line 8232  sub auto_validate_class_sec { Line 7291  sub auto_validate_class_sec {
     return $response;      return $response;
 }  }
   
 sub auto_crsreq_update {  
     my ($cdom,$cnum,$crstype,$action,$ownername,$ownerdomain,$fullname,$title,  
         $code,$accessstart,$accessend,$inbound) = @_;  
     my ($homeserver,%crsreqresponse);  
     if ($cdom =~ /^$match_domain$/) {  
         $homeserver = &domain($cdom,'primary');  
     }  
     unless (($homeserver eq 'no_host') || ($homeserver eq '')) {  
         my $info;  
         if (ref($inbound) eq 'HASH') {  
             $info = &freeze_escape($inbound);  
         }  
         my $response=&reply('autocrsrequpdate:'.$cdom.':'.$cnum.':'.&escape($crstype).  
                             ':'.&escape($action).':'.&escape($ownername).':'.  
                             &escape($ownerdomain).':'.&escape($fullname).':'.  
                             &escape($title).':'.&escape($code).':'.  
                             &escape($accessstart).':'.&escape($accessend).':'.$info,$homeserver);  
         unless ($response =~ /(con_lost|error|no_such_host|refused)/) {  
             my @items = split(/&/,$response);  
             foreach my $item (@items) {  
                 my ($key,$value) = split('=',$item);  
                 $crsreqresponse{&unescape($key)} = &thaw_unescape($value);  
             }  
         }  
     }  
     return \%crsreqresponse;  
 }  
   
 sub auto_export_grades {  
     my ($cdom,$cnum,$inforef,$gradesref) = @_;  
     my ($homeserver,%exportresponse);  
     if ($cdom =~ /^$match_domain$/) {  
         $homeserver = &domain($cdom,'primary');  
     }  
     unless (($homeserver eq 'no_host') || ($homeserver eq '')) {  
         my $info;  
         if (ref($inforef) eq 'HASH') {  
             $info = &freeze_escape($inforef);  
         }  
         if (ref($gradesref) eq 'HASH') {  
             my $grades = &freeze_escape($gradesref);  
             my $response=&reply('encrypt:autoexportgrades:'.$cdom.':'.$cnum.':'.  
                                 $info.':'.$grades,$homeserver);  
             unless ($response =~ /(con_lost|error|no_such_host|refused|unknown_command)/) {  
                 my @items = split(/&/,$response);  
                 foreach my $item (@items) {  
                     my ($key,$value) = split('=',$item);  
                     $exportresponse{&unescape($key)} = &thaw_unescape($value);  
                 }  
             }  
         }  
     }  
     return \%exportresponse;  
 }  
   
 sub check_instcode_cloning {  
     my ($codedefaults,$code_order,$cloner,$clonefromcode,$clonetocode) = @_;  
     unless ((ref($codedefaults) eq 'HASH') && (ref($code_order) eq 'ARRAY')) {  
         return;  
     }  
     my $canclone;  
     if (@{$code_order} > 0) {  
         my $instcoderegexp ='^';  
         my @clonecodes = split(/\&/,$cloner);  
         foreach my $item (@{$code_order}) {  
             if (grep(/^\Q$item\E=/,@clonecodes)) {  
                 foreach my $pair (@clonecodes) {  
                     my ($key,$val) = split(/\=/,$pair,2);  
                     $val = &unescape($val);  
                     if ($key eq $item) {  
                         $instcoderegexp .= '('.$val.')';  
                         last;  
                     }  
                 }  
             } else {  
                 $instcoderegexp .= $codedefaults->{$item};  
             }  
         }  
         $instcoderegexp .= '$';  
         my (@from,@to);  
         eval {  
                (@from) = ($clonefromcode =~ /$instcoderegexp/);  
                (@to) = ($clonetocode =~ /$instcoderegexp/);  
         };  
         if ((@from > 0) && (@to > 0)) {  
             my @diffs = &Apache::loncommon::compare_arrays(\@from,\@to);  
             if (!@diffs) {  
                 $canclone = 1;  
             }  
         }  
     }  
     return $canclone;  
 }  
   
 sub default_instcode_cloning {  
     my ($clonedom,$domdefclone,$clonefromcode,$clonetocode,$codedefaultsref,$codeorderref) = @_;  
     my (%codedefaults,@code_order,$canclone);  
     if ((ref($codedefaultsref) eq 'HASH') && (ref($codeorderref) eq 'ARRAY')) {  
         %codedefaults = %{$codedefaultsref};  
         @code_order = @{$codeorderref};  
     } elsif ($clonedom) {  
         &auto_instcode_defaults($clonedom,\%codedefaults,\@code_order);  
     }  
     if (($domdefclone) && (@code_order)) {  
         my @clonecodes = split(/\+/,$domdefclone);  
         my $instcoderegexp ='^';  
         foreach my $item (@code_order) {  
             if (grep(/^\Q$item\E$/,@clonecodes)) {  
                 $instcoderegexp .= '('.$codedefaults{$item}.')';  
             } else {  
                 $instcoderegexp .= $codedefaults{$item};  
             }  
         }  
         $instcoderegexp .= '$';  
         my (@from,@to);  
         eval {  
             (@from) = ($clonefromcode =~ /$instcoderegexp/);  
             (@to) = ($clonetocode =~ /$instcoderegexp/);  
         };  
         if ((@from > 0) && (@to > 0)) {  
             my @diffs = &Apache::loncommon::compare_arrays(\@from,\@to);  
             if (!@diffs) {  
                 $canclone = 1;  
             }  
         }  
     }  
     return $canclone;  
 }  
   
 # ------------------------------------------------------- Course Group routines  # ------------------------------------------------------- Course Group routines
   
 sub get_coursegroups {  sub get_coursegroups {
Line 8629  sub assignrole { Line 7559  sub assignrole {
                         }                          }
                     }                      }
                 } elsif ($context eq 'requestauthor') {                  } elsif ($context eq 'requestauthor') {
                     if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) &&                      if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) && 
                         ($url eq '/'.$udom.'/') && ($role eq 'au')) {                          ($url eq '/'.$udom.'/') && ($role eq 'au')) {
                         if ($env{'environment.requestauthor'} eq 'automatic') {                          if ($env{'environment.requestauthor'} eq 'automatic') {
                             $refused = '';                              $refused = '';
Line 8637  sub assignrole { Line 7567  sub assignrole {
                             my %domdefaults = &get_domain_defaults($udom);                              my %domdefaults = &get_domain_defaults($udom);
                             if (ref($domdefaults{'requestauthor'}) eq 'HASH') {                              if (ref($domdefaults{'requestauthor'}) eq 'HASH') {
                                 my $checkbystatus;                                  my $checkbystatus;
                                 if ($env{'user.adv'}) {                                  if ($env{'user.adv'}) { 
                                     my $disposition = $domdefaults{'requestauthor'}{'_LC_adv'};                                      my $disposition = $domdefaults{'requestauthor'}{'_LC_adv'};
                                     if ($disposition eq 'automatic') {                                      if ($disposition eq 'automatic') {
                                         $refused = '';                                          $refused = '';
                                     } elsif ($disposition eq '') {                                      } elsif ($disposition eq '') {
                                         $checkbystatus = 1;                                          $checkbystatus = 1;
                                     }                                      } 
                                 } else {                                  } else {
                                     $checkbystatus = 1;                                      $checkbystatus = 1;
                                 }                                  }
Line 8712  sub assignrole { Line 7642  sub assignrole {
 # log new user role if status is ok  # log new user role if status is ok
     if ($answer eq 'ok') {      if ($answer eq 'ok') {
  &userrolelog($role,$uname,$udom,$url,$start,$end);   &userrolelog($role,$uname,$udom,$url,$start,$end);
   # for course roles, perform group memberships changes triggered by role change.
           unless ($role =~ /^gr/) {
               &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend,
                                                $origstart,$selfenroll,$context);
           }
         if (($role eq 'cc') || ($role eq 'in') ||          if (($role eq 'cc') || ($role eq 'in') ||
             ($role eq 'ep') || ($role eq 'ad') ||              ($role eq 'ep') || ($role eq 'ad') ||
             ($role eq 'ta') || ($role eq 'st') ||              ($role eq 'ta') || ($role eq 'st') ||
             ($role=~/^cr/) || ($role eq 'gr') ||              ($role=~/^cr/) || ($role eq 'gr') ||
             ($role eq 'co')) {              ($role eq 'co')) {
 # for course roles, perform group memberships changes triggered by role change.  
             unless ($role =~ /^gr/) {  
                 &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend,  
                                                  $origstart,$selfenroll,$context);  
             }  
             &courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,              &courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
                            $selfenroll,$context);                             $selfenroll,$context);
         } elsif (($role eq 'li') || ($role eq 'dg') || ($role eq 'sc') ||          } elsif (($role eq 'li') || ($role eq 'dg') || ($role eq 'sc') ||
Line 8730  sub assignrole { Line 7660  sub assignrole {
                            $context);                             $context);
         } elsif (($role eq 'ca') || ($role eq 'aa')) {          } elsif (($role eq 'ca') || ($role eq 'aa')) {
             &coauthorrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,              &coauthorrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
                              $context);                               $context); 
         }          }
         if ($role eq 'cc') {          if ($role eq 'cc') {
             &autoupdate_coowners($url,$end,$start,$uname,$udom);              &autoupdate_coowners($url,$end,$start,$uname,$udom);
Line 9030  sub modifyuser { Line 7960  sub modifyuser {
 sub modifystudent {  sub modifystudent {
     my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,      my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
         $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid,          $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid,
         $selfenroll,$context,$inststatus,$credits,$instsec)=@_;          $selfenroll,$context,$inststatus)=@_;
     if (!$cid) {      if (!$cid) {
  unless ($cid=$env{'request.course.id'}) {   unless ($cid=$env{'request.course.id'}) {
     return 'not_in_class';      return 'not_in_class';
Line 9042  sub modifystudent { Line 7972  sub modifystudent {
          $desiredhome,$email,$inststatus);           $desiredhome,$email,$inststatus);
     unless ($reply eq 'ok') { return $reply; }      unless ($reply eq 'ok') { return $reply; }
     # This will cause &modify_student_enrollment to get the uid from the      # This will cause &modify_student_enrollment to get the uid from the
     # student's environment      # students environment
     $uid = undef if (!$forceid);      $uid = undef if (!$forceid);
     $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,      $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,
  $gene,$usec,$end,$start,$type,$locktype,   $gene,$usec,$end,$start,$type,$locktype,$cid,$selfenroll,$context);
                                         $cid,$selfenroll,$context,$credits,$instsec);  
     return $reply;      return $reply;
 }  }
   
 sub modify_student_enrollment {  sub modify_student_enrollment {
     my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,      my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid,$selfenroll,$context) = @_;
         $locktype,$cid,$selfenroll,$context,$credits,$instsec) = @_;  
     my ($cdom,$cnum,$chome);      my ($cdom,$cnum,$chome);
     if (!$cid) {      if (!$cid) {
  unless ($cid=$env{'request.course.id'}) {   unless ($cid=$env{'request.course.id'}) {
Line 9099  sub modify_student_enrollment { Line 8027  sub modify_student_enrollment {
     my %old_entry = &Apache::lonnet::get('classlist',[$user],$cdom,$cnum);      my %old_entry = &Apache::lonnet::get('classlist',[$user],$cdom,$cnum);
     my $reply=cput('classlist',      my $reply=cput('classlist',
    {$user =>      {$user => 
  join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype,$credits,$instsec) },   join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) },
    $cdom,$cnum);     $cdom,$cnum);
     if (($reply eq 'ok') || ($reply eq 'delayed')) {      if (($reply eq 'ok') || ($reply eq 'delayed')) {
         &devalidate_getsection_cache($udom,$uname,$cid);          &devalidate_getsection_cache($udom,$uname,$cid);
Line 9328  sub is_course { Line 8256  sub is_course {
     my %courses = &courseiddump($cdom, '.', 1, '.', '.', $cnum, undef, undef,      my %courses = &courseiddump($cdom, '.', 1, '.', '.', $cnum, undef, undef,
         '.');          '.');
   
     return unless(exists($courses{$cdom.'_'.$cnum}));      return unless exists($courses{$cdom.'_'.$cnum});
     return wantarray ? ($cdom, $cnum) : $cdom.'_'.$cnum;      return wantarray ? ($cdom, $cnum) : $cdom.'_'.$cnum;
 }  }
   
Line 9353  sub store_userdata { Line 8281  sub store_userdata {
                     $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';                      $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
                 }                  }
                 $namevalue=~s/\&$//;                  $namevalue=~s/\&$//;
                 unless ($namespace eq 'courserequests') {  
                     $datakey = &escape($datakey);  
                 }  
                 $result =  &reply("store:$udom:$uname:$namespace:$datakey:".                  $result =  &reply("store:$udom:$uname:$namespace:$datakey:".
                                   $namevalue,$uhome);                                    $namevalue,$uhome);
             }              }
Line 9623  sub modify_access_controls { Line 8548  sub modify_access_controls {
     my $tries = 0;      my $tries = 0;
     my $gotlock = &newput('file_permissions',$lockhash,$domain,$user);      my $gotlock = &newput('file_permissions',$lockhash,$domain,$user);
         
     while (($gotlock ne 'ok') && $tries < 10) {      while (($gotlock ne 'ok') && $tries <3) {
         $tries ++;          $tries ++;
         sleep(0.1);          sleep 1;
         $gotlock = &newput('file_permissions',$lockhash,$domain,$user);          $gotlock = &newput('file_permissions',$lockhash,$domain,$user);
     }      }
     if ($gotlock eq 'ok') {      if ($gotlock eq 'ok') {
Line 9918  sub dirlist { Line 8843  sub dirlist {
             foreach my $user (sort(keys(%allusers))) {              foreach my $user (sort(keys(%allusers))) {
                 push(@alluserslist,$user.'&user');                  push(@alluserslist,$user.'&user');
             }              }
             if (!%listerror) {              return (\@alluserslist);
                 # no errors  
                 return (\@alluserslist);  
             } elsif (scalar(keys(%servers)) == 1) {  
                 # one library server, one error  
                 my ($key) = keys(%listerror);  
                 return (\@alluserslist, $listerror{$key});  
             } elsif ( grep { $_ eq 'con_lost' } values(%listerror) ) {  
                 # con_lost indicates that we might miss data from at least one  
                 # library server  
                 return (\@alluserslist, 'con_lost');  
             } else {  
                 # multiple library servers and no con_lost -> data should be  
                 # complete.  
                 return (\@alluserslist);  
             }  
   
         } else {          } else {
             return ([],'missing username');              return ([],'missing username');
         }          }
Line 10151  sub get_userresdata { Line 9060  sub get_userresdata {
     }      }
     #error 2 occurs when the .db doesn't exist      #error 2 occurs when the .db doesn't exist
     if ($tmp!~/error: 2 /) {      if ($tmp!~/error: 2 /) {
         if ((!defined($cached)) || ($tmp ne 'con_lost')) {   &logthis("<font color=\"blue\">WARNING:".
     &logthis("<font color=\"blue\">WARNING:".   " Trying to get resource data for ".
      " Trying to get resource data for ".   $uname." at ".$udom.": ".
      $uname." at ".$udom.": ".   $tmp."</font>");
      $tmp."</font>");  
         }  
     } elsif ($tmp=~/error: 2 /) {      } elsif ($tmp=~/error: 2 /) {
  #&EXT_cache_set($udom,$uname);   #&EXT_cache_set($udom,$uname);
  &do_cache_new('userres',$hashid,undef,600);   &do_cache_new('userres',$hashid,undef,600);
Line 10196  sub resdata { Line 9103  sub resdata {
     return undef;      return undef;
 }  }
   
 sub get_numsuppfiles {  
     my ($cnum,$cdom,$ignorecache)=@_;  
     my $hashid=$cnum.':'.$cdom;  
     my ($suppcount,$cached);  
     unless ($ignorecache) {  
         ($suppcount,$cached) = &is_cached_new('suppcount',$hashid);  
     }  
     unless (defined($cached)) {  
         my $chome=&homeserver($cnum,$cdom);  
         unless ($chome eq 'no_host') {  
             ($suppcount,my $errors) = (0,0);  
             my $suppmap = 'supplemental.sequence';  
             ($suppcount,$errors) =  
                 &Apache::loncommon::recurse_supplemental($cnum,$cdom,$suppmap,$suppcount,$errors);  
         }  
         &do_cache_new('suppcount',$hashid,$suppcount,600);  
     }  
     return $suppcount;  
 }  
   
 #  #
 # EXT resource caching routines  # EXT resource caching routines
 #  #
Line 10244  sub EXT_cache_set { Line 9131  sub EXT_cache_set {
 # --------------------------------------------------------- Value of a Variable  # --------------------------------------------------------- Value of a Variable
 sub EXT {  sub EXT {
   
     my ($varname,$symbparm,$udom,$uname,$usection,$recurse,$cid)=@_;      my ($varname,$symbparm,$udom,$uname,$usection,$recurse)=@_;
     unless ($varname) { return ''; }      unless ($varname) { return ''; }
     #get real user name/domain, courseid and symb      #get real user name/domain, courseid and symb
     my $courseid;      my $courseid;
Line 10359  sub EXT { Line 9246  sub EXT {
     if (!$symbparm) { $symbparm=&symbread(); }      if (!$symbparm) { $symbparm=&symbread(); }
  }   }
   
         if ($qualifier eq '') {   if ($space eq 'title') {
     if ($space eq 'title') {      if (!$symbparm) { $symbparm = $env{'request.filename'}; }
         if (!$symbparm) { $symbparm = $env{'request.filename'}; }      return &gettitle($symbparm);
         return &gettitle($symbparm);   }
     }  
   
     if ($space eq 'map') {   if ($space eq 'map') {
         my ($map) = &decode_symb($symbparm);      my ($map) = &decode_symb($symbparm);
         return &symbread($map);      return &symbread($map);
     }   }
             if ($space eq 'maptitle') {   if ($space eq 'filename') {
                 my ($map) = &decode_symb($symbparm);      if ($symbparm) {
                 return &gettitle($map);   return &clutter((&decode_symb($symbparm))[2]);
             }  
     if ($space eq 'filename') {  
         if ($symbparm) {  
     return &clutter((&decode_symb($symbparm))[2]);  
         }  
         return &hreflocation('',$env{'request.filename'});  
     }      }
       return &hreflocation('',$env{'request.filename'});
             if ((defined($courseid)) && ($courseid eq $env{'request.course.id'}) && $symbparm) {   }
                 if ($space eq 'visibleparts') {  
                     my $navmap = Apache::lonnavmaps::navmap->new();  
                     my $item;  
                     if (ref($navmap)) {  
                         my $res = $navmap->getBySymb($symbparm);  
                         my $parts = $res->parts();  
                         if (ref($parts) eq 'ARRAY') {  
                             $item = join(',',@{$parts});  
                         }  
                         undef($navmap);  
                     }  
                     return $item;  
                 }  
             }  
         }  
   
  my ($section, $group, @groups);   my ($section, $group, @groups);
  my ($courselevelm,$courselevel);   my ($courselevelm,$courselevel);
         if (($courseid eq '') && ($cid)) {   if ($symbparm && defined($courseid) && 
             $courseid = $cid;      $courseid eq $env{'request.course.id'}) {
         }  
  if (($symbparm && $courseid) &&   
     (($courseid eq $env{'request.course.id'}) || ($courseid eq $cid))) {  
   
     #print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;      #print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;
   
Line 10650  sub metadata { Line 9512  sub metadata {
     # if it is a non metadata possible uri return quickly      # if it is a non metadata possible uri return quickly
     if (($uri eq '') ||       if (($uri eq '') || 
  (($uri =~ m|^/*adm/|) &&    (($uri =~ m|^/*adm/|) && 
      ($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard)$})) ||       ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) ||
         ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) {          ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) {
  return undef;   return undef;
     }      }
     if (($uri =~ /^priv/ || $uri=~m{^home/httpd/html/priv})       if (($uri =~ /^priv/ || $uri=~/home\/httpd\/html\/priv/) 
  && &Apache::lonxml::get_state('target') =~ /^(|meta)$/) {   && &Apache::lonxml::get_state('target') =~ /^(|meta)$/) {
  return undef;   return undef;
     }      }
Line 10915  sub metadata { Line 9777  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 11081  sub get_course_slots { Line 9943  sub get_course_slots {
         my %slots=&Apache::lonnet::dump('slots',$cdom,$cnum);          my %slots=&Apache::lonnet::dump('slots',$cdom,$cnum);
         my ($tmp) = keys(%slots);          my ($tmp) = keys(%slots);
         if ($tmp !~ /^(con_lost|error|no_such_host)/i) {          if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
             &do_cache_new('allslots',$hashid,\%slots,600);              &Apache::lonnet::do_cache_new('allslots',$hashid,\%slots,600);
             return %slots;              return %slots;
         }          }
     }      }
Line 11156  sub symblist { Line 10018  sub symblist {
 # --------------------------------------------------------------- Verify a symb  # --------------------------------------------------------------- Verify a symb
   
 sub symbverify {  sub symbverify {
     my ($symb,$thisurl,$encstate)=@_;      my ($symb,$thisurl)=@_;
     my $thisfn=$thisurl;      my $thisfn=$thisurl;
     $thisfn=&declutter($thisfn);      $thisfn=&declutter($thisfn);
 # direct jump to resource in page or to a sequence - will construct own symbs  # direct jump to resource in page or to a sequence - will construct own symbs
Line 11175  sub symbverify { Line 10037  sub symbverify {
   
     if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',      if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
                             &GDBM_READER(),0640)) {                              &GDBM_READER(),0640)) {
         my $noclutter;  
         if (($thisurl =~ m{^/adm/wrapper/ext/}) || ($thisurl =~ m{^ext/})) {          if (($thisurl =~ m{^/adm/wrapper/ext/}) || ($thisurl =~ m{^ext/})) {
             $thisurl =~ s/\?.+$//;              $thisurl =~ s/\?.+$//;
             if ($map =~ m{^uploaded/.+\.page$}) {  
                 $thisurl =~ s{^(/adm/wrapper|)/ext/}{http://};  
                 $thisurl =~ s{^\Qhttp://https://\E}{https://};  
                 $noclutter = 1;  
             }  
         }  
         my $ids;  
         if ($noclutter) {  
             $ids=$bighash{'ids_'.$thisurl};  
         } else {  
             $ids=$bighash{'ids_'.&clutter($thisurl)};  
         }          }
           my $ids=$bighash{'ids_'.&clutter($thisurl)};
         unless ($ids) {          unless ($ids) {
             my $idkey = 'ids_'.($thisurl =~ m{^/}? '' : '/').$thisurl;              my $idkey = 'ids_'.($thisurl =~ m{^/}? '' : '/').$thisurl;  
             $ids=$bighash{$idkey};              $ids=$bighash{$idkey};
         }          }
         if ($ids) {          if ($ids) {
 # ------------------------------------------------------------------- Has ID(s)  # ------------------------------------------------------------------- Has ID(s)
             if ($thisfn =~ m{^/adm/wrapper/ext/}) {  
                 $symb =~ s/\?.+$//;  
             }  
     foreach my $id (split(/\,/,$ids)) {      foreach my $id (split(/\,/,$ids)) {
        my ($mapid,$resid)=split(/\./,$id);         my ($mapid,$resid)=split(/\./,$id);
                  if ($thisfn =~ m{^/adm/wrapper/ext/}) {
                      $symb =~ s/\?.+$//;
                  }
                if (                 if (
   &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)    &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)
    eq $symb) {     eq $symb) { 
                    if (ref($encstate)) {     if (($env{'request.role.adv'}) ||
                        $$encstate = $bighash{'encrypted_'.$id};         ($bighash{'encrypted_'.$id} eq $env{'request.enc'}) ||
                    }  
                    if (($env{'request.role.adv'}) ||  
                        ($bighash{'encrypted_'.$id} eq $env{'request.enc'}) ||  
                        ($thisurl eq '/adm/navmaps')) {                         ($thisurl eq '/adm/navmaps')) {
                        $okay=1;         $okay=1; 
                        last;     }
                    }         }
                }     }
            }  
         }          }
  untie(%bighash);   untie(%bighash);
     }      }
Line 11286  sub deversion { Line 10133  sub deversion {
 # ------------------------------------------------------ Return symb list entry  # ------------------------------------------------------ Return symb list entry
   
 sub symbread {  sub symbread {
     my ($thisfn,$donotrecurse,$ignorecachednull,$checkforblock,$possibles)=@_;      my ($thisfn,$donotrecurse)=@_;
     my $cache_str='request.symbread.cached.'.$thisfn;      my $cache_str='request.symbread.cached.'.$thisfn;
     if (defined($env{$cache_str})) {      if (defined($env{$cache_str})) {
         if ($ignorecachednull) {          if (($thisfn) || ($env{$cache_str} ne '')) {
             return $env{$cache_str} unless ($env{$cache_str} eq '');  
         } else {  
             return $env{$cache_str};              return $env{$cache_str};
         }          }
     }      }
 # no filename provided? try from environment  # no filename provided? try from environment
     unless ($thisfn) {      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'});
         }   }
         $thisfn=$env{'request.filename'};   $thisfn=$env{'request.filename'};
     }      }
     if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }      if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }
 # is that filename actually a symb? Verify, clean, and return  # is that filename actually a symb? Verify, clean, and return
Line 11356  sub symbread { Line 10201  sub symbread {
      my ($mapid,$resid)=split(/\./,$ids);       my ($mapid,$resid)=split(/\./,$ids);
      $syval=&encode_symb($bighash{'map_id_'.$mapid},       $syval=&encode_symb($bighash{'map_id_'.$mapid},
     $resid,$thisfn);      $resid,$thisfn);
                      if (ref($possibles) eq 'HASH') {                   } elsif (!$donotrecurse) {
                          $possibles->{$syval} = 1;  
                      }  
                      if ($checkforblock) {  
                          my @blockers = &has_comm_blocking('bre',$syval,$bighash{'src_'.$ids});  
                          if (@blockers) {  
                              $syval = '';  
                              return;  
                          }  
                      }  
                  } elsif ((!$donotrecurse) || ($checkforblock) || (ref($possibles) eq 'HASH')) {  
 # ------------------------------------------ There is more than one possibility  # ------------------------------------------ There is more than one possibility
                      my $realpossible=0;                       my $realpossible=0;
                      foreach my $id (@possibilities) {                       foreach my $id (@possibilities) {
  my $file=$bighash{'src_'.$id};   my $file=$bighash{'src_'.$id};
                          my $canaccess;                           if (&allowed('bre',$file)) {
                          if (($donotrecurse) || ($checkforblock) || (ref($possibles) eq 'HASH')) {               my ($mapid,$resid)=split(/\./,$id);
                              $canaccess = 1;                              if ($bighash{'map_type_'.$mapid} ne 'page') {
                          } else {   $realpossible++;
                              $canaccess = &allowed('bre',$file);                                  $syval=&encode_symb($bighash{'map_id_'.$mapid},
                          }      $resid,$thisfn);
                          if ($canaccess) {                              }
               my ($mapid,$resid)=split(/\./,$id);  
                              if ($bighash{'map_type_'.$mapid} ne 'page') {  
                                  my $poss_syval=&encode_symb($bighash{'map_id_'.$mapid},  
                                                              $resid,$thisfn);  
                                  if (ref($possibles) eq 'HASH') {  
                                      $possibles->{$syval} = 1;  
                                  }  
                                  if ($checkforblock) {  
                                      my @blockers = &has_comm_blocking('bre',$poss_syval,$file);  
                                      unless (@blockers > 0) {  
                                          $syval = $poss_syval;  
                                          $realpossible++;  
                                      }  
                                  } else {  
                                      $syval = $poss_syval;  
                                      $realpossible++;  
                                  }  
                              }  
  }   }
                      }                       }
      if ($realpossible!=1) { $syval=''; }       if ($realpossible!=1) { $syval=''; }
Line 11403  sub symbread { Line 10220  sub symbread {
                      $syval='';                       $syval='';
                  }                   }
       }        }
               untie(%bighash);                untie(%bighash)
            }             }
         }          }
         if ($syval) {          if ($syval) {
Line 11556  sub rndseed { Line 10373  sub rndseed {
  $which =&get_rand_alg($courseid);   $which =&get_rand_alg($courseid);
     }      }
     if (defined(&getCODE())) {      if (defined(&getCODE())) {
   
  if ($which eq '64bit5') {   if ($which eq '64bit5') {
     return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username);      return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username);
  } elsif ($which eq '64bit4') {   } elsif ($which eq '64bit4') {
Line 11741  sub rndseed_CODE_64bit5 { Line 10559  sub rndseed_CODE_64bit5 {
 sub setup_random_from_rndseed {  sub setup_random_from_rndseed {
     my ($rndseed)=@_;      my ($rndseed)=@_;
     if ($rndseed =~/([,:])/) {      if ($rndseed =~/([,:])/) {
  my ($num1,$num2) = map { abs($_); } (split(/[,:]/,$rndseed));   my ($num1,$num2)=split(/[,:]/,$rndseed);
         if ((!$num1) || (!$num2) || ($num1 > 2147483562) || ($num2 > 2147483398)) {   &Math::Random::random_set_seed(abs($num1),abs($num2));
             &Math::Random::random_set_seed_from_phrase($rndseed);  
         } else {  
             &Math::Random::random_set_seed($num1,$num2);  
         }  
     } else {      } else {
  &Math::Random::random_set_seed_from_phrase($rndseed);   &Math::Random::random_set_seed_from_phrase($rndseed);
     }      }
Line 12137  sub default_login_domain { Line 10951  sub default_login_domain {
 sub declutter {  sub declutter {
     my $thisfn=shift;      my $thisfn=shift;
     if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }      if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }
     unless ($thisfn=~m{^/home/httpd/html/priv/}) {      $thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//;
         $thisfn=~s{^/home/httpd/html}{};  
     }  
     $thisfn=~s/^\///;      $thisfn=~s/^\///;
     $thisfn=~s|^adm/wrapper/||;      $thisfn=~s|^adm/wrapper/||;
     $thisfn=~s|^adm/coursedocs/showdoc/||;      $thisfn=~s|^adm/coursedocs/showdoc/||;
Line 12244  sub goodbye { Line 11056  sub goodbye {
 }  }
   
 sub get_dns {  sub get_dns {
     my ($url,$func,$ignore_cache,$nocache,$hashref) = @_;      my ($url,$func,$ignore_cache) = @_;
     if (!$ignore_cache) {      if (!$ignore_cache) {
  my ($content,$cached)=   my ($content,$cached)=
     &Apache::lonnet::is_cached_new('dns',$url);      &Apache::lonnet::is_cached_new('dns',$url);
  if ($cached) {   if ($cached) {
     &$func($content,$hashref);      &$func($content);
     return;      return;
  }   }
     }      }
Line 12266  sub get_dns { Line 11078  sub get_dns {
  $alldns{$host} = $protocol;   $alldns{$host} = $protocol;
     }      }
     while (%alldns) {      while (%alldns) {
  my ($dns) = sort { $b cmp $a } keys(%alldns);   my ($dns) = keys(%alldns);
  my $ua=new LWP::UserAgent;   my $ua=new LWP::UserAgent;
         $ua->timeout(30);          $ua->timeout(30);
  my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");   my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");
Line 12274  sub get_dns { Line 11086  sub get_dns {
         delete($alldns{$dns});          delete($alldns{$dns});
  next if ($response->is_error());   next if ($response->is_error());
  my @content = split("\n",$response->content);   my @content = split("\n",$response->content);
         unless ($nocache) {   &Apache::lonnet::do_cache_new('dns',$url,\@content,30*24*60*60);
     &do_cache_new('dns',$url,\@content,30*24*60*60);   &$func(\@content);
         }  
  &$func(\@content,$hashref);  
  return;   return;
     }      }
     close($config);      close($config);
Line 12285  sub get_dns { Line 11095  sub get_dns {
     &logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n");      &logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n");
     open($config,"<$perlvar{'lonTabDir'}/dns_$which.tab");      open($config,"<$perlvar{'lonTabDir'}/dns_$which.tab");
     my @content = <$config>;      my @content = <$config>;
     &$func(\@content,$hashref);      &$func(\@content);
     return;      return;
 }  }
   
 # ------------------------------------------------------Get DNS checksums file  
 sub parse_dns_checksums_tab {  
     my ($lines,$hashref) = @_;  
     my $lonhost = $perlvar{'lonHostID'};  
     my $machine_dom = &Apache::lonnet::host_domain($lonhost);  
     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 (%chksum,%revnum);  
     if (ref($lines) eq 'ARRAY') {  
         chomp(@{$lines});  
         my $version = shift(@{$lines});  
         if ($version eq $release) {  
             foreach my $line (@{$lines}) {  
                 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;  
                 $revnum{$file} = $version;  
             }  
             if (ref($hashref) eq 'HASH') {  
                 %{$hashref} = (  
                                 sums     => \%chksum,  
                                 versions => \%revnum,  
                               );  
             }  
         }  
     }  
     return;  
 }  
   
 sub fetch_dns_checksums {  
     my %checksums;  
     my $machine_dom = &Apache::lonnet::host_domain($perlvar{'lonHostID'});  
     my $loncaparev = &get_server_loncaparev($machine_dom,$perlvar{'lonHostID'});  
     my ($release,$timestamp) = split(/\-/,$loncaparev);  
     &get_dns("/adm/dns/checksums/$release",\&parse_dns_checksums_tab,1,1,  
              \%checksums);  
     return \%checksums;  
 }  
   
 # ------------------------------------------------------------ Read domain file  # ------------------------------------------------------------ Read domain file
 {  {
     my $loaded;      my $loaded;
Line 12373  sub fetch_dns_checksums { Line 11126  sub fetch_dns_checksums {
     }      }
   
     sub load_domain_tab {      sub load_domain_tab {
  my ($ignore_cache,$nocache) = @_;   my ($ignore_cache) = @_;
  &get_dns('/adm/dns/domain',\&parse_domain_tab,$ignore_cache,$nocache);   &get_dns('/adm/dns/domain',\&parse_domain_tab,$ignore_cache);
  my $fh;   my $fh;
  if (open($fh,"<".$perlvar{'lonTabDir'}.'/domain.tab')) {   if (open($fh,"<".$perlvar{'lonTabDir'}.'/domain.tab')) {
     my @lines = <$fh>;      my @lines = <$fh>;
Line 12460  sub fetch_dns_checksums { Line 11213  sub fetch_dns_checksums {
     }      }
   
     sub load_hosts_tab {      sub load_hosts_tab {
  my ($ignore_cache,$nocache) = @_;   my ($ignore_cache) = @_;
  &get_dns('/adm/dns/hosts',\&parse_hosts_tab,$ignore_cache,$nocache);   &get_dns('/adm/dns/hosts',\&parse_hosts_tab,$ignore_cache);
  open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");   open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
  my @config = <$config>;   my @config = <$config>;
  &parse_hosts_tab(\@config);   &parse_hosts_tab(\@config);
Line 12483  sub fetch_dns_checksums { Line 11236  sub fetch_dns_checksums {
     }      }
   
     sub all_names {      sub all_names {
         my ($ignore_cache,$nocache) = @_;   &load_hosts_tab() if (!$loaded);
  &load_hosts_tab($ignore_cache,$nocache) if (!$loaded);  
   
  return %name_to_host;   return %name_to_host;
     }      }
Line 12606  sub fetch_dns_checksums { Line 11358  sub fetch_dns_checksums {
     }      }
           
     sub get_iphost {      sub get_iphost {
  my ($ignore_cache,$nocache) = @_;   my ($ignore_cache) = @_;
   
  if (!$ignore_cache) {   if (!$ignore_cache) {
     if (%iphost) {      if (%iphost) {
Line 12630  sub fetch_dns_checksums { Line 11382  sub fetch_dns_checksums {
     %old_name_to_ip = %{$ip_info->[1]};      %old_name_to_ip = %{$ip_info->[1]};
  }   }
   
  my %name_to_host = &all_names($ignore_cache,$nocache);   my %name_to_host = &all_names();
  foreach my $name (keys(%name_to_host)) {   foreach my $name (keys(%name_to_host)) {
     my $ip;      my $ip;
     if (!exists($name_to_ip{$name})) {      if (!exists($name_to_ip{$name})) {
Line 12655  sub fetch_dns_checksums { Line 11407  sub fetch_dns_checksums {
     }      }
     push(@{$iphost{$ip}},@{$name_to_host{$name}});      push(@{$iphost{$ip}},@{$name_to_host{$name}});
  }   }
         unless ($nocache) {   &Apache::lonnet::do_cache_new('iphost','iphost',
     &do_cache_new('iphost','iphost',        [\%iphost,\%name_to_ip,\%lonid_to_ip],
           [\%iphost,\%name_to_ip,\%lonid_to_ip],        48*60*60);
           48*60*60);  
         }  
   
  return %iphost;   return %iphost;
     }      }
Line 12715  sub fetch_dns_checksums { Line 11465  sub fetch_dns_checksums {
             }              }
             $seen{$prim_ip} = 1;              $seen{$prim_ip} = 1;
         }          }
         return &do_cache_new('internetnames',$lonid,\@idns,12*60*60);          return &Apache::lonnet::do_cache_new('internetnames',$lonid,\@idns,12*60*60);
     }      }
   
 }  }
   
 sub all_loncaparevs {  sub all_loncaparevs {
     return qw(1.1 1.2 1.3 2.0 2.1 2.2 2.3 2.4 2.5 2.6 2.7 2.8 2.9 2.10 2.11);      return qw(1.1 1.2 1.3 2.0 2.1 2.2 2.3 2.4 2.5 2.6 2.7 2.8 2.9 2.10);
 }  
   
 # ------------------------------------------------------- Read loncaparev table  
 {  
     sub load_loncaparevs {  
         if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") {  
             if (open(my $config,"<$perlvar{'lonTabDir'}/loncaparevs.tab")) {  
                 while (my $configline=<$config>) {  
                     chomp($configline);  
                     my ($hostid,$loncaparev)=split(/:/,$configline);  
                     $loncaparevs{$hostid}=$loncaparev;  
                 }  
                 close($config);  
             }  
         }  
     }  
 }  }
   
 # ----------------------------------------------------- Read serverhostID table  
 {  
     sub load_serverhomeIDs {  
         if (-e "$perlvar{'lonTabDir'}/serverhomeIDs.tab") {  
             if (open(my $config,"<$perlvar{'lonTabDir'}/serverhomeIDs.tab")) {  
                 while (my $configline=<$config>) {  
                     chomp($configline);  
                     my ($name,$id)=split(/:/,$configline);  
                     $serverhomeIDs{$name}=$id;  
                 }  
                 close($config);  
             }  
         }  
     }  
 }  
   
   
 BEGIN {  BEGIN {
   
 # ----------------------------------- Read loncapa.conf and loncapa_apache.conf  # ----------------------------------- Read loncapa.conf and loncapa_apache.conf
Line 12832  BEGIN { Line 11549  BEGIN {
     close($config);      close($config);
 }  }
   
 # --------------------------------------------------------- Read loncaparev table  # ---------------------------------------------------------- Read loncaparev table
   {
 &load_loncaparevs();      if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") {
           if (open(my $config,"<$perlvar{'lonTabDir'}/loncaparevs.tab")) {
 # ------------------------------------------------------- Read serverhostID table              while (my $configline=<$config>) {
                   chomp($configline);
                   my ($hostid,$loncaparev)=split(/:/,$configline);
                   $loncaparevs{$hostid}=$loncaparev;
               }
               close($config);
           }
       }
   }
   
 &load_serverhomeIDs();  # ---------------------------------------------------------- Read serverhostID table
   {
       if (-e "$perlvar{'lonTabDir'}/serverhomeIDs.tab") {
           if (open(my $config,"<$perlvar{'lonTabDir'}/serverhomeIDs.tab")) {
               while (my $configline=<$config>) {
                   chomp($configline);
                   my ($name,$id)=split(/:/,$configline);
                   $serverhomeIDs{$name}=$id;
               }
               close($config);
           }
       }
   }
   
 # ---------------------------------------------------------- Read releaseslist XML  
 {  {
     my $file = $Apache::lonnet::perlvar{'lonTabDir'}.'/releaseslist.xml';      my $file = $Apache::lonnet::perlvar{'lonTabDir'}.'/releaseslist.xml';
     if (-e $file) {      if (-e $file) {
Line 13039  were new keys. I.E. 1:foo will become 1: Line 11775  were new keys. I.E. 1:foo will become 1:
   
 Calling convention:  Calling convention:
   
  my %record=&Apache::lonnet::restore($symb,$courseid,$domain,$uname);   my %record=&Apache::lonnet::restore($symb,$courseid,$domain,$uname,$home);
  &Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname,$laststore);   &Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname,$home);
   
 For more detailed information, see lonnet specific documentation.  For more detailed information, see lonnet specific documentation.
   
Line 13176  escaped strings of the action recorded i Line 11912  escaped strings of the action recorded i
   
 =item *  =item *
   
 allowed($priv,$uri,$symb,$role,$clientip,$noblockcheck) : check for a user privilege;   allowed($priv,$uri,$symb,$role) : check for a user privilege; returns codes for allowed actions
 returns codes for allowed actions.  
   
 The first argument is required, all others are optional.  
   
 $priv is the privilege being checked.  
 $uri contains additional information about what is being checked for access (e.g.,  
 URL, course ID etc.).  
 $symb is the unique resource instance identifier in a course; if needed,  
 but not provided, it will be retrieved via a call to &symbread().  
 $role is the role for which a priv is being checked (only used if priv is evb).  
 $clientip is the user's IP address (only used when checking for access to portfolio  
 files).  
 $noblockcheck, if true, skips calls to &has_comm_blocking() for the bre priv. This  
 prevents recursive calls to &allowed.  
   
  F: full access   F: full access
  U,I,K: authentication modes (cxx only)   U,I,K: authentication modes (cxx only)
  '': forbidden   '': forbidden
  1: user needs to choose course   1: user needs to choose course
  2: browse allowed   2: browse allowed
  A: passphrase authentication needed   A: passphrase authentication needed
  B: access temporarily blocked because of a blocking event in a course.  
   
 =item *  
   
 constructaccess($url,$setpriv) : check for access to construction space URL  
   
 See if the owner domain and name in the URL match those in the  
 expected environment.  If so, return three element list  
 ($ownername,$ownerdomain,$ownerhome).  
   
 Otherwise return the null string.  
   
 If second argument 'setpriv' is true, it assigns the privileges,  
 and returns the same three element list, unless the owner has  
 blocked "ad hoc" Domain Coordinator access to the Author Space,  
 in which case the null string is returned.  
   
 =item *  =item *
   
Line 13233  environment).  If no custom name is defi Line 11938  environment).  If no custom name is defi
         
 =item *  =item *
   
 get_my_roles($uname,$udom,$context,$types,$roles,$roledoms,$withsec,$hidepriv) :  get_my_roles($uname,$udom,$context,$types,$roles,$roledoms,$withsec) :
 All arguments are optional. Returns a hash of a roles, either for  All arguments are optional. Returns a hash of a roles, either for
 co-author/assistant author roles for a user's Construction Space  co-author/assistant author roles for a user's Construction Space
 (default), or if $context is 'userroles', roles for the user himself,  (default), or if $context is 'userroles', roles for the user himself,
Line 13247  of role statuses (active, future or prev Line 11952  of role statuses (active, future or prev
 to restrict the list of roles reported. If no array ref is   to restrict the list of roles reported. If no array ref is 
 provided for types, will default to return only active roles.  provided for types, will default to return only active roles.
   
 =item *  
   
 in_course($udom,$uname,$cdom,$cnum,$type,$hideprivileged) : determine if  
 user: $uname:$udom has a role in the course: $cdom_$cnum.  
   
 Additional optional arguments are: $type (if role checking is to be restricted  
 to certain user status types -- previous (expired roles), active (currently  
 available roles) or future (roles available in the future), and  
 $hideprivileged -- if true will not report course roles for users who  
 have active Domain Coordinator role in course's domain or in additional  
 domains (specified in 'Domains to check for privileged users' in course  
 environment -- set via:  Course Settings -> Classlists and staff listing).  
   
 =item *  
   
 privileged($username,$domain,$possdomains,$possroles) : returns 1 if user  
 $username:$domain is a privileged user (e.g., Domain Coordinator or Super User)  
 $possdomains and $possroles are optional array refs -- to domains to check and  
 roles to check.  If $possdomains is not specified, a dump will be done of the  
 users' roles.db to check for a dc or su role in any domain. This can be  
 time consuming if &privileged is called repeatedly (e.g., when displaying a  
 classlist), so in such cases, supplying a $possdomains array is preferred, as  
 this then allows &privileged_by_domain() to be used, which caches the identity  
 of privileged users, eliminating the need for repeated calls to &dump().  
   
 =item *  
   
 privileged_by_domain($possdomains,$roles) : returns a hash of a hash of a hash,  
 where the outer hash keys are domains specified in the $possdomains array ref,  
 next inner hash keys are privileged roles specified in the $roles array ref,  
 and the innermost hash contains key = value pairs for username:domain = end:start  
 for active or future "privileged" users with that role in that domain. To avoid  
 repeated dumps of domain roles -- via &get_domain_roles() -- contents of the  
 innerhash are cached using priv_$role and $dom as the identifiers.  
   
 =back  =back
   
 =head2 User Modification  =head2 User Modification
Line 13323  or when Autoupdate.pl is run by cron in Line 11993  or when Autoupdate.pl is run by cron in
 modifystudent  modifystudent
   
 modify a student's enrollment and identification information.  modify a student's enrollment and identification information.
 The course id is resolved based on the current user's environment.    The course id is resolved based on the current users environment.  
 This means the invoking user must be a course coordinator or otherwise  This means the envoking user must be a course coordinator or otherwise
 associated with a course.  associated with a course.
   
 This call is essentially a wrapper for lonnet::modifyuser and  This call is essentially a wrapper for lonnet::modifyuser and
Line 13374  Inputs: Line 12044  Inputs:
   
 =item B<$context> role change context (shown in User Management Logs display in a course)  =item B<$context> role change context (shown in User Management Logs display in a course)
   
 =item B<$inststatus> institutional status of user - : separated string of escaped status types  =item B<$inststatus> institutional status of user - : separated string of escaped status types  
   
 =item B<$credits> Number of credits student will earn from this class - only needs to be supplied if value needs to be different from default credits for class.  
   
 =back  =back
   
Line 13384  Inputs: Line 12052  Inputs:
   
 modify_student_enrollment  modify_student_enrollment
   
 Change a student's enrollment status in a class.  The environment variable  Change a students enrollment status in a class.  The environment variable
 'role.request.course' must be defined for this function to proceed.  'role.request.course' must be defined for this function to proceed.
   
 Inputs:  Inputs:
   
 =over 4  =over 4
   
 =item $udom, student's domain  =item $udom, students domain
   
 =item $uname, student's name  =item $uname, students name
   
 =item $uid, student's user id  =item $uid, students user id
   
 =item $first, student's first name  =item $first, students first name
   
 =item $middle  =item $middle
   
Line 13421  Inputs: Line 12089  Inputs:
   
 =item $context  =item $context
   
 =item $credits, number of credits student will earn from this class  
   
 =item $instsec, institutional course section code for student  
   
 =back  =back
   
   
Line 13481  If defined, the supplied username is use Line 12145  If defined, the supplied username is use
 resdata($name,$domain,$type,@which) : request for current parameter  resdata($name,$domain,$type,@which) : request for current parameter
 setting for a specific $type, where $type is either 'course' or 'user',  setting for a specific $type, where $type is either 'course' or 'user',
 @what should be a list of parameters to ask about. This routine caches  @what should be a list of parameters to ask about. This routine caches
 answers for 10 minutes.  answers for 5 minutes.
   
 =item *  =item *
   
Line 13490  data base, returning a hash that is keye Line 12154  data base, returning a hash that is keye
 values that are the resource value.  I believe that the timestamps and  values that are the resource value.  I believe that the timestamps and
 versions are also returned.  versions are also returned.
   
 get_numsuppfiles($cnum,$cdom) : retrieve number of files in a course's  
 supplemental content area. This routine caches the number of files for  
 10 minutes.  
   
 =back  =back
   
Line 13553  resource. Expects the local filesystem p Line 12214  resource. Expects the local filesystem p
   
 =item *  =item *
   
 EXT($varname,$symb,$udom,$uname,$usection,$recurse,$cid) : evaluates   EXT($varname,$symb,$udom,$uname) : evaluates and returns the value of
 and returns the value of a variety of different possible values,  a vairety of different possible values, $varname should be a request
 $varname should be a request string, and the other parameters can be  string, and the other parameters can be used to specify who and what
 used to specify who and what one is asking about. Ordinarily, $cid   one is asking about.
 does not need to be specified, as it is retrived from   
 $env{'request.course.id'}, but &Apache::lonnet::EXT() is called  
 within lonuserstate::loadmap() when initializing a course, before  
 $env{'request.course.id'} has been set, so it needs to be provided  
 in that one case.  
   
 Possible values for $varname are environment.lastname (or other item  Possible values for $varname are environment.lastname (or other item
 from the envirnment hash), user.name (or someother aspect about the  from the envirnment hash), user.name (or someother aspect about the
Line 13594  will be stored for query Line 12250  will be stored for query
   
 =item *  =item *
   
 symbread($filename,$donotrecurse,$ignorecachednull,$checkforblock,$possibles) :  symbread($filename) : return symbolic list entry (filename argument optional);
 return symbolic list entry (all arguments optional).  
   
 Args: filename is the filename (including path) for the file for which a symb  
 is required; donotrecurse, if true will prevent calls to allowed() being made  
 to check access status if more than one resource was found in the bighash  
 (see rev. 1.249) to avoid an infinite loop if an ambiguous resource is part of  
 a randompick); ignorecachednull, if true will prevent a symb of '' being  
 returned if $env{$cache_str} is defined as ''; checkforblock if true will  
 cause possible symbs to be checked to determine if they are subject to content  
 blocking, if so they will not be included as possible symbs; possibles is a  
 ref to a hash, which, as a side effect, will be populated with all possible  
 symbs (content blocking not tested).  
   
 returns the data handle  returns the data handle
   
 =item *  =item *
   
 symbverify($symb,$thisfn,$encstate) : verifies that $symb actually exists  symbverify($symb,$thisfn) : verifies that $symb actually exists and is
 and is a possible symb for the URL in $thisfn, and if is an encrypted  a possible symb for the URL in $thisfn, and if is an encryypted
 resource that the user accessed using /enc/ returns a 1 on success, 0  resource that the user accessed using /enc/ returns a 1 on success, 0
 on failure, user must be in a course, as it assumes the existence of  on failure, user must be in a course, as it assumes the existance of
 the course initial hash, and uses $env('request.course.id'}.  The third  the course initial hash, and uses $env('request.course.id'}
 arg is an optional reference to a scalar.  If this arg is passed in the  
 call to symbverify, it will be set to 1 if the symb has been set to be   
 encrypted; otherwise it will be null.  
   
 =item *  =item *
   
Line 13672  expirespread($uname,$udom,$stype,$usymb) Line 12313  expirespread($uname,$udom,$stype,$usymb)
 devalidate($symb) : devalidate temporary spreadsheet calculations,  devalidate($symb) : devalidate temporary spreadsheet calculations,
 forcing spreadsheet to reevaluate the resource scores next time.  forcing spreadsheet to reevaluate the resource scores next time.
   
 =item *  
   
 can_edit_resource($file,$cnum,$cdom,$resurl,$symb,$group) : determine if current user can edit a particular resource,  
 when viewing in course context.  
   
  input: six args -- filename (decluttered), course number, course domain,  
                     url, symb (if registered) and group (if this is a  
                     group item -- e.g., bulletin board, group page etc.).  
   
  output: array of five scalars --  
          $cfile -- url for file editing if editable on current server  
          $home -- homeserver of resource (i.e., for author if published,  
                                           or course if uploaded.).  
          $switchserver --  1 if server switch will be needed.  
          $forceedit -- 1 if icon/link should be to go to edit mode  
          $forceview -- 1 if icon/link should be to go to view mode  
   
 =item *  
   
 is_course_upload($file,$cnum,$cdom)  
   
 Used in course context to determine if current file was uploaded to  
 the course (i.e., would be found in /userfiles/docs on the course's  
 homeserver.  
   
   input: 3 args -- filename (decluttered), course number and course domain.  
   output: boolean -- 1 if file was uploaded.  
   
 =back  =back
   
 =head2 Storing/Retreiving Data  =head2 Storing/Retreiving Data
Line 13708  homeserver. Line 12321  homeserver.
   
 =item *  =item *
   
 store($storehash,$symb,$namespace,$udom,$uname,$laststore) : stores hash   store($storehash,$symb,$namespace,$udom,$uname) : stores hash permanently
 permanently for this url; hashref needs to be given and should be a \%hashname;  for this url; hashref needs to be given and should be a \%hashname; the
 the remaining args aren't required and if they aren't passed or are '' they will  remaining args aren't required and if they aren't passed or are '' they will
 be derived from the env (with the exception of $laststore, which is an  be derived from the env
 optional arg used when a user's submission is stored in grading).  
 $laststore is $version=$timestamp, where $version is the most recent version  
 number retrieved for the corresponding $symb in the $namespace db file, and  
 $timestamp is the timestamp for that transaction (UNIX time).  
 $laststore is currently only passed when cstore() is called by  
 structuretags::finalize_storage().  
   
 =item *  =item *
   
 cstore($storehash,$symb,$namespace,$udom,$uname,$laststore) : same as store   cstore($storehash,$symb,$namespace,$udom,$uname) : same as store but
 but uses critical subroutine  uses critical subroutine
   
 =item *  =item *
   
Line 13745  $range should be either an integer '100' Line 12352  $range should be either an integer '100'
   
 =item *  =item *
   
 putstore($namespace,$symb,$version,$storehash,$udomain,$uname,$tolog) :  putstore($namespace,$symb,$version,$storehash,$udomain,$uname) :
 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. If $tolog is true, the transaction is logged in the courselog  reference
 with an action=PUTSTORE.  
   
 =item *  =item *
   
Line 13859  server ($udom and $uhome are optional) Line 12465  server ($udom and $uhome are optional)
   
 =item *   =item * 
   
 get_domain_defaults($target_domain,$ignore_cache) : returns hash with defaults  get_domain_defaults($target_domain) : returns hash with defaults for
 for: authentication, language, quotas, timezone, date locale, and portal URL in  authentication and language in the domain. Keys are: auth_def, auth_arg_def,
 the target domain.  lang_def; corresponsing values are authentication type (internal, krb4, krb5,
   or localauth), initial password or a kerberos realm, language (e.g., en-us).
 May also include additional key => value pairs for the following groups:  Values are retrieved from cache (if current), or from domain's configuration.db
   (if available), or lastly from values in lonTabs/dns_domain,tab, 
 =over  or lonTabs/domain.tab. 
   
 =item  
 disk quotas (MB allocated by default to portfolios and authoring spaces).  
   
 =over  %domdefaults = &get_auth_defaults($target_domain);
   
 =item defaultquota, authorquota  
   
 =back  
   
 =item  
 tools (availability of aboutme page, blog, webDAV access for authoring spaces,  
 portfolio for users).  
   
 =over  
   
 =item  
 aboutme, blog, webdav, portfolio  
   
 =back  
   
 =item  
 requestcourses: ability to request courses, and how requests are processed.  
   
 =over  
   
 =item  
 official, unofficial, community, textbook  
   
 =back  
   
 =item  
 inststatus: types of institutional affiliation, and order in which they are displayed.  
   
 =over  
   
 =item  
 inststatustypes, inststatusorder, inststatusguest  
   
 =back  
   
 =item  
 coursedefaults: can PDF forms can be created, default credits for courses, default quotas (MB)  
 for course's uploaded content.  
   
 =over  
   
 =item  
 canuse_pdfforms, officialcredits, unofficialcredits, textbookcredits, officialquota, unofficialquota,  
 communityquota, textbookquota  
   
 =back  
   
 =item  
 usersessions: set options for hosting of your users in other domains, and hosting of users from other domains  
 on your servers.  
   
 =over  
   
 =item  
 remotesessions, hostedsessions  
   
 =back  
   
 =back  
   
 In cases where a domain coordinator has never used the "Set Domain Configuration"  
 utility to create a configuration.db file on a domain's primary library server  
 only the following domain defaults: auth_def, auth_arg_def, lang_def  
 -- corresponding values are authentication type (internal, krb4, krb5,  
 or localauth), initial password or a kerberos realm, language (e.g., en-us) --  
 will be available. Values are retrieved from cache (if current), unless the  
 optional $ignore_cache arg is true, or from domain's configuration.db (if available),  
 or lastly from values in lonTabs/dns_domain,tab, or lonTabs/domain.tab.  
   
 Typical usage:  
   
 %domdefaults = &get_domain_defaults($target_domain);  
   
 =back  =back
   
Line 14168  filelocation except for hrefs Line 12698  filelocation except for hrefs
   
 =item *  =item *
   
 declutter() : declutters URLs -- remove beginning slashes, 'res' etc.  declutter() : declutters URLs (remove docroot, beginning slashes, 'res' etc)
 also removes beginning /home/httpd/html unless /priv/ follows it.  
   
 =back  =back
   
Line 14339  Internal notes: Line 12868  Internal notes:
     
  Locks on files (resulting from submission of portfolio file to a homework problem stored in array of arrays.   Locks on files (resulting from submission of portfolio file to a homework problem stored in array of arrays.
   
 =item *  
   
 modify_access_controls():  modify_access_controls():
   
 Modifies access controls for a portfolio file  Modifies access controls for a portfolio file
Line 14358  Returns: Line 12885  Returns:
 3. reference to hash of any new or updated access controls.  3. reference to hash of any new or updated access controls.
 4. reference to hash used to map incoming IDs to uniqueIDs assigned to control.  4. reference to hash used to map incoming IDs to uniqueIDs assigned to control.
    key = integer (inbound ID)     key = integer (inbound ID)
    value = uniqueID     value = uniqueID  
   
 =item *  
   
 get_timebased_id():  
   
 Attempts to get a unique timestamp-based suffix for use with items added to a  
 course via the Course Editor (e.g., folders, composite pages,  
 group bulletin boards).  
   
 Args: (first three required; six others optional)  
   
 1. prefix (alphanumeric): of keys in hash, e.g., suppsequence, docspage,  
    docssequence, or name of group  
   
 2. keyid (alphanumeric): name of temporary locking key in hash,  
    e.g., num, boardids  
   
 3. namespace: name of gdbm file used to store suffixes already assigned;  
    file will be named nohist_namespace.db  
   
 4. cdom: domain of course; default is current course domain from %env  
   
 5. cnum: course number; default is current course number from %env  
   
 6. idtype: set to concat if an additional digit is to be appended to the  
    unix timestamp to form the suffix, if the plain timestamp is already  
    in use.  Default is to not do this, but simply increment the unix  
    timestamp by 1 until a unique key is obtained.  
   
 7. who: holder of locking key; defaults to user:domain for user.  
   
 8. locktries: number of attempts to obtain a lock (sleep of 1s before  
    retrying); default is 3.  
   
 9. maxtries: number of attempts to obtain a unique suffix; default is 20.  
   
 Returns:  
   
 1. suffix obtained (numeric)  
   
 2. result of deleting locking key (ok if deleted, or lock never obtained)  
   
 3. error: contains (localized) error message if an error occurred.  
   
   
 =back  =back
   
Removed from v.1.1172.2.81  
changed lines
  Added in v.1.1189

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