[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.1056.4.11 and 1.1225

version 1.1056.4.11, 2010/10/01 14:26:07 version 1.1225, 2013/05/27 18:35:05
Line 75  use LWP::UserAgent(); Line 75  use LWP::UserAgent();
 use HTTP::Date;  use HTTP::Date;
 use Image::Magick;  use Image::Magick;
   
 use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir  
             $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease);  use Encode;
   
   use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir $apache
               $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease
               %managerstab);
   
 my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash,  my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash,
     %userrolehash, $processmarker, $dumpcount, %coursedombuf,      %userrolehash, $processmarker, $dumpcount, %coursedombuf,
Line 95  use Math::Random; Line 99  use Math::Random;
 use File::MMagic;  use File::MMagic;
 use LONCAPA qw(:DEFAULT :match);  use LONCAPA qw(:DEFAULT :match);
 use LONCAPA::Configuration;  use LONCAPA::Configuration;
   use LONCAPA::lonmetadata;
   use LONCAPA::Lond;
   
   use File::Copy;
   
 my $readit;  my $readit;
 my $max_connection_retries = 10;     # Or some such value.  my $max_connection_retries = 10;     # Or some such value.
Line 105  our @ISA = qw (Exporter); Line 113  our @ISA = qw (Exporter);
 our @EXPORT = qw(%env);  our @EXPORT = qw(%env);
   
   
 # --------------------------------------------------------------------- Logging  # ------------------------------------ Logging (parameters, docs, slots, roles)
 {  {
     my $logid;      my $logid;
     sub instructor_log {      sub write_log {
  my ($hash_name,$storehash,$delflag,$uname,$udom,$cnum,$cdom)=@_;   my ($context,$hash_name,$storehash,$delflag,$uname,$udom,$cnum,$cdom)=@_;
         if (($cnum eq '') || ($cdom eq '')) {          if ($context eq 'course') {
             $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};              if (($cnum eq '') || ($cdom eq '')) {
             $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};                  $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
                   $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
               }
         }          }
  $logid++;   $logid ++;
         my $now = time();          my $now = time();
  my $id=$now.'00000'.$$.'00000'.$logid;   my $id=$now.'00000'.$$.'00000'.$logid;
  return &Apache::lonnet::put('nohist_'.$hash_name,          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,
     }                                    }
   },$cdom,$cnum);                         };
    return &put('nohist_'.$hash_name,$logentry,$cdom,$cnum);
     }      }
 }  }
   
Line 195  sub get_server_timezone { Line 206  sub get_server_timezone {
     }      }
 }  }
   
   sub get_server_distarch {
       my ($lonhost,$ignore_cache) = @_;
       if (defined($lonhost)) {
           if (!defined(&hostname($lonhost))) {
               return;
           }
           my $cachetime = 12*3600;
           if (!$ignore_cache) {
               my ($distarch,$cached)=&is_cached_new('serverdistarch',$lonhost);
               if (defined($cached)) {
                   return $distarch;
               }
           }
           my $rep = &reply('serverdistarch',$lonhost);
           unless ($rep eq 'unknown_command' || $rep eq 'no_such_host' ||
                   $rep eq 'con_lost' || $rep eq 'rejected' || $rep eq 'refused' ||
                   $rep eq '') {
               return &do_cache_new('serverdistarch',$lonhost,$rep,$cachetime);
           }
       }
       return;
   }
   
 sub get_server_loncaparev {  sub get_server_loncaparev {
     my ($dom,$lonhost,$ignore_cache,$caller) = @_;      my ($dom,$lonhost,$ignore_cache,$caller) = @_;
     if (defined($lonhost)) {      if (defined($lonhost)) {
Line 263  sub get_server_homeID { Line 297  sub get_server_homeID {
     }      }
     my $cachetime = 12*3600;      my $cachetime = 12*3600;
     my $serverhomeID;      my $serverhomeID;
     if ($caller eq 'loncron') {      if ($caller eq 'loncron') { 
         my @machine_ids = &machine_ids($hostname);          my @machine_ids = &machine_ids($hostname);
         foreach my $id (@machine_ids) {          foreach my $id (@machine_ids) {
             my $response = &reply('serverhomeID',$id);              my $response = &reply('serverhomeID',$id);
Line 281  sub get_server_homeID { Line 315  sub get_server_homeID {
     return &do_cache_new('serverhomeID',$hostname,$serverhomeID,$cachetime);      return &do_cache_new('serverhomeID',$hostname,$serverhomeID,$cachetime);
 }  }
   
   sub get_remote_globals {
       my ($lonhost,$whathash,$ignore_cache) = @_;
       my ($result,%returnhash,%whatneeded);
       if (ref($whathash) eq 'HASH') {
           foreach my $what (sort(keys(%{$whathash}))) {
               my $hashid = $lonhost.'-'.$what;
               my ($response,$cached);
               unless ($ignore_cache) {
                   ($response,$cached)=&is_cached_new('lonnetglobal',$hashid);
               }
               if (defined($cached)) {
                   $returnhash{$what} = $response;
               } else {
                   $whatneeded{$what} = 1;
               }
           }
           if (keys(%whatneeded) == 0) {
               $result = 'ok';
           } else {
               my $requested = &freeze_escape(\%whatneeded);
               my $rep=&reply('readlonnetglobal:'.$requested,$lonhost);
               if (($rep=~/^(refused|rejected|error)/) || ($rep eq 'con_lost') ||
                   ($rep eq 'unknown_cmd')) {
                   $result = $rep;
               } else {
                   $result = 'ok';
                   my @pairs=split(/\&/,$rep);
                   foreach my $item (@pairs) {
                       my ($key,$value)=split(/=/,$item,2);
                       my $what = &unescape($key);
                       my $hashid = $lonhost.'-'.$what;
                       $returnhash{$what}=&thaw_unescape($value);
                       &do_cache_new('lonnetglobal',$hashid,$returnhash{$what},600);
                   }
               }
           }
       }
       return ($result,\%returnhash);
   }
   
   sub remote_devalidate_cache {
       my ($lonhost,$name,$id) = @_;
       my $response = &reply('devalidatecache:'.&escape($name).':'.&escape($id),$lonhost);
       return $response;
   }
   
 # -------------------------------------------------- Non-critical communication  # -------------------------------------------------- Non-critical communication
 sub subreply {  sub subreply {
     my ($cmd,$server)=@_;      my ($cmd,$server)=@_;
Line 523  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) = @_;      my ($r,$name) = @_;
     my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));      my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));
     my $lonid=$cookies{'lonID'};      if ($name eq '') {
           $name = 'lonID';
       }
       my $lonid=$cookies{$name};
     return undef if (!$lonid);      return undef if (!$lonid);
   
     my $handle=&LONCAPA::clean_handle($lonid->value);      my $handle=&LONCAPA::clean_handle($lonid->value);
     my $lonidsdir=$r->dir_config('lonIDsDir');      my $lonidsdir;
       if ($name eq 'lonDAV') {
           $lonidsdir=$r->dir_config('lonDAVsessDir');
       } else {
           $lonidsdir=$r->dir_config('lonIDsDir');
       }
     return undef if (!-e "$lonidsdir/$handle.id");      return undef if (!-e "$lonidsdir/$handle.id");
   
     my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");      my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");
Line 546  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 (($r->user() eq '') && ($apache >= 2.4)) {
           if ($disk_env{'user.domain'} eq $r->dir_config('lonDefDomain')) {
               $r->user($disk_env{'user.name'});
           } else {
               $r->user($disk_env{'user.name'}.':'.$disk_env{'user.domain'});
           }
       }
     return $handle;      return $handle;
 }  }
   
Line 611  sub appenv { Line 706  sub appenv {
 # ----------------------------------------------------- Delete from Environment  # ----------------------------------------------------- Delete from Environment
   
 sub delenv {  sub delenv {
     my ($delthis,$regexp) = @_;      my ($delthis,$regexp,$roles) = @_;
     if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {      if (($delthis=~/^user\.role/) || ($delthis=~/^user\.priv/)) {
         &logthis("<font color=\"blue\">WARNING: ".          my $refused = 1;
                 "Attempt to delete from environment ".$delthis);          if (ref($roles) eq 'ARRAY') {
         return 'error';              my ($type,$role) = ($delthis =~ /^user\.(role|priv)\.([^.]+)\./);
               if (grep(/^\Q$role\E$/,@{$roles})) {
                   $refused = 0;
               }
           }
           if ($refused) {
               &logthis("<font color=\"blue\">WARNING: ".
                        "Attempt to delete from environment ".$delthis);
               return 'error';
           }
     }      }
     my $opened = open(my $env_file,'+<',$env{'user.environment'});      my $opened = open(my $env_file,'+<',$env{'user.environment'});
     if ($opened      if ($opened
Line 724  sub userload { Line 828  sub userload {
     return $userloadpercent;      return $userloadpercent;
 }  }
   
 # ------------------------------------------ Fight off request when overloaded  
   
 sub overloaderror {  
     my ($r,$checkserver)=@_;  
     unless ($checkserver) { $checkserver=$perlvar{'lonHostID'}; }  
     my $loadavg;  
     if ($checkserver eq $perlvar{'lonHostID'}) {  
        open(my $loadfile,'/proc/loadavg');  
        $loadavg=<$loadfile>;  
        $loadavg =~ s/\s.*//g;  
        $loadavg = 100*$loadavg/$perlvar{'lonLoadLim'};  
        close($loadfile);  
     } else {  
        $loadavg=&reply('load',$checkserver);  
     }  
     my $overload=$loadavg-100;  
     if ($overload>0) {  
  $r->err_headers_out->{'Retry-After'}=$overload;  
         $r->log_error('Overload of '.$overload.' on '.$checkserver);  
         return 413;  
     }      
     return '';  
 }  
   
 # ------------------------------ Find server with least workload from spare.tab  # ------------------------------ Find server with least workload from spare.tab
   
 sub spareserver {  sub spareserver {
     my ($loadpercent,$userloadpercent,$want_server_name) = @_;      my ($loadpercent,$userloadpercent,$want_server_name,$udom) = @_;
     my $spare_server;      my $spare_server;
     if ($userloadpercent !~ /\d/) { $userloadpercent=0; }      if ($userloadpercent !~ /\d/) { $userloadpercent=0; }
     my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent       my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent 
                                                      :  $userloadpercent;                                                       :  $userloadpercent;
     my ($uint_dom,$remotesessions);      my ($uint_dom,$remotesessions);
     if ($env{'user.domain'}) {      if (($udom ne '') && (&domain($udom) ne '')) {
         my $uprimary_id = &Apache::lonnet::domain($env{'user.domain'},'primary');          my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
         $uint_dom = &Apache::lonnet::internet_dom($uprimary_id);          $uint_dom = &Apache::lonnet::internet_dom($uprimary_id);
         my %udomdefaults = &Apache::lonnet::get_domain_defaults($env{'user.domain'});          my %udomdefaults = &Apache::lonnet::get_domain_defaults($udom);
         $remotesessions = $udomdefaults{'remotesessions'};          $remotesessions = $udomdefaults{'remotesessions'};
     }      }
     foreach my $try_server (@{ $spareid{'primary'} }) {      my $spareshash = &this_host_spares($udom);
         if ($uint_dom) {      if (ref($spareshash) eq 'HASH') {
             next unless (&spare_can_host($env{'user.domain'},$uint_dom,          if (ref($spareshash->{'primary'}) eq 'ARRAY') {
                                          $remotesessions,$try_server));              foreach my $try_server (@{ $spareshash->{'primary'} }) {
                   if ($uint_dom) {
                       next unless (&spare_can_host($udom,$uint_dom,$remotesessions,
                                                    $try_server));
                   }
           ($spare_server, $lowest_load) =
               &compare_server_load($try_server, $spare_server, $lowest_load);
               }
         }          }
  ($spare_server, $lowest_load) =  
     &compare_server_load($try_server, $spare_server, $lowest_load);  
     }  
   
     my $found_server = ($spare_server ne '' && $lowest_load < 100);          my $found_server = ($spare_server ne '' && $lowest_load < 100);
   
     if (!$found_server) {          if (!$found_server) {
  foreach my $try_server (@{ $spareid{'default'} }) {              if (ref($spareshash->{'default'}) eq 'ARRAY') { 
             if ($uint_dom) {          foreach my $try_server (@{ $spareshash->{'default'} }) {
                 next unless (&spare_can_host($env{'user.domain'},$uint_dom,                      if ($uint_dom) {
                                              $remotesessions,$try_server));                          next unless (&spare_can_host($udom,$uint_dom,
             }                                                       $remotesessions,$try_server));
     ($spare_server, $lowest_load) =                      }
  &compare_server_load($try_server, $spare_server, $lowest_load);              ($spare_server, $lowest_load) =
  }          &compare_server_load($try_server, $spare_server, $lowest_load);
                   }
       }
           }
     }      }
   
     if (!$want_server_name) {      if (!$want_server_name) {
Line 807  sub compare_server_load { Line 894  sub compare_server_load {
     my $userloadans = &reply('userload',$try_server);      my $userloadans = &reply('userload',$try_server);
   
     if ($loadans !~ /\d/ && $userloadans !~ /\d/) {      if ($loadans !~ /\d/ && $userloadans !~ /\d/) {
         return; #didn't get a number from the server   return ($spare_server, $lowest_load); #didn't get a number from the server
     }      }
   
     my $load;      my $load;
Line 833  sub compare_server_load { Line 920  sub compare_server_load {
 # --------------------------- ask offload servers if user already has a session  # --------------------------- ask offload servers if user already has a session
 sub find_existing_session {  sub find_existing_session {
     my ($udom,$uname) = @_;      my ($udom,$uname) = @_;
     foreach my $try_server (@{ $spareid{'primary'} },      my $spareshash = &this_host_spares($udom);
     @{ $spareid{'default'} }) {      if (ref($spareshash) eq 'HASH') {
  return $try_server if (&has_user_session($try_server, $udom, $uname));          if (ref($spareshash->{'primary'}) eq 'ARRAY') {
               foreach my $try_server (@{ $spareshash->{'primary'} }) {
                   return $try_server if (&has_user_session($try_server, $udom, $uname));
               }
           }
           if (ref($spareshash->{'default'}) eq 'ARRAY') {
               foreach my $try_server (@{ $spareshash->{'default'} }) {
                   return $try_server if (&has_user_session($try_server, $udom, $uname));
               }
           }
     }      }
     return;      return;
 }  }
Line 853  sub has_user_session { Line 949  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) = @_;      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);      my ($login_host,$hostname,$portal_path,$isredirect);
     foreach my $lonhost (keys(%servers)) {      foreach my $lonhost (keys(%servers)) {
         my $loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost};          my $loginvia;
         if ($loginvia eq '') {          if ($checkloginvia) {
               $loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost};
               if ($loginvia) {
                   my ($server,$path) = split(/:/,$loginvia);
                   ($login_host, $lowest_load) =
                       &compare_server_load($server, $login_host, $lowest_load);
                   if ($login_host eq $server) {
                       $portal_path = $path;
                       $isredirect = 1;
                   }
               } else {
                   ($login_host, $lowest_load) =
                       &compare_server_load($lonhost, $login_host, $lowest_load);
                   if ($login_host eq $lonhost) {
                       $portal_path = '';
                       $isredirect = ''; 
                   }
               }
           } else {
             ($login_host, $lowest_load) =              ($login_host, $lowest_load) =
             &compare_server_load($lonhost, $login_host, $lowest_load);                  &compare_server_load($lonhost, $login_host, $lowest_load);
         }          }
     }      }
     if ($login_host ne '') {      if ($login_host ne '') {
         $hostname = $servers{$login_host};          $hostname = &hostname($login_host);
     }      }
     return ($login_host,$hostname);      return ($login_host,$hostname,$portal_path,$isredirect);
 }  }
   
 # --------------------------------------------- Try to change a user's password  # --------------------------------------------- Try to change a user's password
Line 1009  sub can_host_session { Line 1123  sub can_host_session {
     }      }
     if ($canhost) {      if ($canhost) {
         if (ref($hostedsessions) eq 'HASH') {          if (ref($hostedsessions) eq 'HASH') {
               my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
               my $uint_dom = &Apache::lonnet::internet_dom($uprimary_id);
             if (ref($hostedsessions->{'excludedomain'}) eq 'ARRAY') {              if (ref($hostedsessions->{'excludedomain'}) eq 'ARRAY') {
                 if (grep(/^\Q$udom\E$/,@{$hostedsessions->{'excludedomain'}})) {                  if (($uint_dom ne '') && 
                       (grep(/^\Q$uint_dom\E$/,@{$hostedsessions->{'excludedomain'}}))) {
                     $canhost = 0;                      $canhost = 0;
                 } else {                  } else {
                     $canhost = 1;                      $canhost = 1;
                 }                  }
             }              }
             if (ref($hostedsessions->{'includedomain'}) eq 'ARRAY') {              if (ref($hostedsessions->{'includedomain'}) eq 'ARRAY') {
                 if (grep(/^\Q$udom\E$/,@{$hostedsessions->{'includedomain'}})) {                  if (($uint_dom ne '') && 
                       (grep(/^\Q$uint_dom\E$/,@{$hostedsessions->{'includedomain'}}))) {
                     $canhost = 1;                      $canhost = 1;
                 } else {                  } else {
                     $canhost = 0;                      $canhost = 0;
Line 1048  sub spare_can_host { Line 1166  sub spare_can_host {
     return $canhost;      return $canhost;
 }  }
   
   sub this_host_spares {
       my ($dom) = @_;
       my ($dom_in_use,$lonhost_in_use,$result);
       my @hosts = &current_machine_ids();
       foreach my $lonhost (@hosts) {
           if (&host_domain($lonhost) eq $dom) {
               $dom_in_use = $dom;
               $lonhost_in_use = $lonhost;
               last;
           }
       }
       if ($dom_in_use ne '') {
           $result = &spares_for_offload($dom_in_use,$lonhost_in_use);
       }
       if (ref($result) ne 'HASH') {
           $lonhost_in_use = $perlvar{'lonHostID'};
           $dom_in_use = &host_domain($lonhost_in_use);
           $result = &spares_for_offload($dom_in_use,$lonhost_in_use);
           if (ref($result) ne 'HASH') {
               $result = \%spareid;
           }
       }
       return $result;
   }
   
   sub spares_for_offload  {
       my ($dom_in_use,$lonhost_in_use) = @_;
       my ($result,$cached)=&is_cached_new('spares',$dom_in_use);
       if (defined($cached)) {
           return $result;
       } else {
           my $cachetime = 60*60*24;
           my %domconfig =
               &Apache::lonnet::get_dom('configuration',['usersessions'],$dom_in_use);
           if (ref($domconfig{'usersessions'}) eq 'HASH') {
               if (ref($domconfig{'usersessions'}{'spares'}) eq 'HASH') {
                   if (ref($domconfig{'usersessions'}{'spares'}{$lonhost_in_use}) eq 'HASH') {
                       return &do_cache_new('spares',$dom_in_use,$domconfig{'usersessions'}{'spares'}{$lonhost_in_use},$cachetime);
                   }
               }
           }
       }
       return;
   }
   
   sub get_lonbalancer_config {
       my ($servers) = @_;
       my ($currbalancer,$currtargets);
       if (ref($servers) eq 'HASH') {
           foreach my $server (keys(%{$servers})) {
               my %what = (
                            spareid => 1,
                            perlvar => 1,
                          );
               my ($result,$returnhash) = &get_remote_globals($server,\%what);
               if ($result eq 'ok') {
                   if (ref($returnhash) eq 'HASH') {
                       if (ref($returnhash->{'perlvar'}) eq 'HASH') {
                           if ($returnhash->{'perlvar'}->{'lonBalancer'} eq 'yes') {
                               $currbalancer = $server;
                               $currtargets = {};
                               if (ref($returnhash->{'spareid'}) eq 'HASH') {
                                   if (ref($returnhash->{'spareid'}->{'primary'}) eq 'ARRAY') {
                                       $currtargets->{'primary'} = $returnhash->{'spareid'}->{'primary'};
                                   }
                                   if (ref($returnhash->{'spareid'}->{'default'}) eq 'ARRAY') {
                                       $currtargets->{'default'} = $returnhash->{'spareid'}->{'default'};
                                   }
                               }
                               last;
                           }
                       }
                   }
               }
           }
       }
       return ($currbalancer,$currtargets);
   }
   
   sub check_loadbalancing {
       my ($uname,$udom) = @_;
       my ($is_balancer,$currtargets,$currrules,$dom_in_use,$homeintdom,
           $rule_in_effect,$offloadto,$otherserver);
       my $lonhost = $perlvar{'lonHostID'};
       my @hosts = &current_machine_ids();
       my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
       my $uintdom = &Apache::lonnet::internet_dom($uprimary_id);
       my $intdom = &Apache::lonnet::internet_dom($lonhost);
       my $serverhomedom = &host_domain($lonhost);
   
       my $cachetime = 60*60*24;
   
       if (($uintdom ne '') && ($uintdom eq $intdom)) {
           $dom_in_use = $udom;
           $homeintdom = 1;
       } else {
           $dom_in_use = $serverhomedom;
       }
       my ($result,$cached)=&is_cached_new('loadbalancing',$dom_in_use);
       unless (defined($cached)) {
           my %domconfig =
               &Apache::lonnet::get_dom('configuration',['loadbalancing'],$dom_in_use);
           if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
               $result = &do_cache_new('loadbalancing',$dom_in_use,$domconfig{'loadbalancing'},$cachetime);
           }
       }
       if (ref($result) eq 'HASH') {
           ($is_balancer,$currtargets,$currrules) = 
               &check_balancer_result($result,@hosts);
           if ($is_balancer) {
               if (ref($currrules) eq 'HASH') {
                   if ($homeintdom) {
                       if ($uname ne '') {
                           if (($currrules->{'_LC_adv'} ne '') || ($currrules->{'_LC_author'} ne '')) {
                               my ($is_adv,$is_author) = &is_advanced_user($udom,$uname);
                               if (($currrules->{'_LC_author'} ne '') && ($is_author)) {
                                   $rule_in_effect = $currrules->{'_LC_author'};
                               } elsif (($currrules->{'_LC_adv'} ne '') && ($is_adv)) {
                                   $rule_in_effect = $currrules->{'_LC_adv'}
                               }
                           }
                           if ($rule_in_effect eq '') {
                               my %userenv = &userenvironment($udom,$uname,'inststatus');
                               if ($userenv{'inststatus'} ne '') {
                                   my @statuses = map { &unescape($_); } split(/:/,$userenv{'inststatus'});
                                   my ($othertitle,$usertypes,$types) =
                                       &Apache::loncommon::sorted_inst_types($udom);
                                   if (ref($types) eq 'ARRAY') {
                                       foreach my $type (@{$types}) {
                                           if (grep(/^\Q$type\E$/,@statuses)) {
                                               if (exists($currrules->{$type})) {
                                                   $rule_in_effect = $currrules->{$type};
                                               }
                                           }
                                       }
                                   }
                               } else {
                                   if (exists($currrules->{'default'})) {
                                       $rule_in_effect = $currrules->{'default'};
                                   }
                               }
                           }
                       } else {
                           if (exists($currrules->{'default'})) {
                               $rule_in_effect = $currrules->{'default'};
                           }
                       }
                   } else {
                       if ($currrules->{'_LC_external'} ne '') {
                           $rule_in_effect = $currrules->{'_LC_external'};
                       }
                   }
                   $offloadto = &get_loadbalancer_targets($rule_in_effect,$currtargets,
                                                          $uname,$udom);
               }
           }
       } elsif (($homeintdom) && ($udom ne $serverhomedom)) {
           my ($result,$cached)=&is_cached_new('loadbalancing',$serverhomedom);
           unless (defined($cached)) {
               my %domconfig =
                   &Apache::lonnet::get_dom('configuration',['loadbalancing'],$serverhomedom);
               if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
                   $result = &do_cache_new('loadbalancing',$dom_in_use,$domconfig{'loadbalancing'},$cachetime);
               }
           }
           if (ref($result) eq 'HASH') {
               ($is_balancer,$currtargets,$currrules) = 
                   &check_balancer_result($result,@hosts);
               if ($is_balancer) {
                   if (ref($currrules) eq 'HASH') {
                       if ($currrules->{'_LC_internetdom'} ne '') {
                           $rule_in_effect = $currrules->{'_LC_internetdom'};
                       }
                   }
                   $offloadto = &get_loadbalancer_targets($rule_in_effect,$currtargets,
                                                          $uname,$udom);
               }
           } else {
               if ($perlvar{'lonBalancer'} eq 'yes') {
                   $is_balancer = 1;
                   $offloadto = &this_host_spares($dom_in_use);
               }
           }
       } else {
           if ($perlvar{'lonBalancer'} eq 'yes') {
               $is_balancer = 1;
               $offloadto = &this_host_spares($dom_in_use);
           }
       }
       if ($is_balancer) {
           my $lowest_load = 30000;
           if (ref($offloadto) eq 'HASH') {
               if (ref($offloadto->{'primary'}) eq 'ARRAY') {
                   foreach my $try_server (@{$offloadto->{'primary'}}) {
                       ($otherserver,$lowest_load) =
                           &compare_server_load($try_server,$otherserver,$lowest_load);
                   }
               }
               my $found_server = ($otherserver ne '' && $lowest_load < 100);
   
               if (!$found_server) {
                   if (ref($offloadto->{'default'}) eq 'ARRAY') {
                       foreach my $try_server (@{$offloadto->{'default'}}) {
                           ($otherserver,$lowest_load) =
                               &compare_server_load($try_server,$otherserver,$lowest_load);
                       }
                   }
               }
           } elsif (ref($offloadto) eq 'ARRAY') {
               if (@{$offloadto} == 1) {
                   $otherserver = $offloadto->[0];
               } elsif (@{$offloadto} > 1) {
                   foreach my $try_server (@{$offloadto}) {
                       ($otherserver,$lowest_load) =
                           &compare_server_load($try_server,$otherserver,$lowest_load);
                   }
               }
           }
           if (($otherserver ne '') && (grep(/^\Q$otherserver\E$/,@hosts))) {
               $is_balancer = 0;
               if ($uname ne '' && $udom ne '') {
                   if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) {
                       
                       &appenv({'user.loadbalexempt'     => $lonhost,  
                                'user.loadbalcheck.time' => time});
                   }
               }
           }
       }
       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 {
       my ($rule_in_effect,$currtargets,$uname,$udom) = @_;
       my $offloadto;
       if ($rule_in_effect eq 'none') {
           return [$perlvar{'lonHostID'}];
       } elsif ($rule_in_effect eq '') {
           $offloadto = $currtargets;
       } else {
           if ($rule_in_effect eq 'homeserver') {
               my $homeserver = &homeserver($uname,$udom);
               if ($homeserver ne 'no_host') {
                   $offloadto = [$homeserver];
               }
           } elsif ($rule_in_effect eq 'externalbalancer') {
               my %domconfig =
                   &Apache::lonnet::get_dom('configuration',['loadbalancing'],$udom);
               if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
                   if ($domconfig{'loadbalancing'}{'lonhost'} ne '') {
                       if (&hostname($domconfig{'loadbalancing'}{'lonhost'}) ne '') {
                           $offloadto = [$domconfig{'loadbalancing'}{'lonhost'}];
                       }
                   }
               } else {
                   my %servers = &internet_dom_servers($udom);
                   my ($remotebalancer,$remotetargets) = &get_lonbalancer_config(\%servers);
                   if (&hostname($remotebalancer) ne '') {
                       $offloadto = [$remotebalancer];
                   }
               }
           } elsif (&hostname($rule_in_effect) ne '') {
               $offloadto = [$rule_in_effect];
           }
       }
       return $offloadto;
   }
   
   sub internet_dom_servers {
       my ($dom) = @_;
       my (%uniqservers,%servers);
       my $primaryserver = &hostname(&domain($dom,'primary'));
       my @machinedoms = &machine_domains($primaryserver);
       foreach my $mdom (@machinedoms) {
           my %currservers = %servers;
           my %server = &get_servers($mdom);
           %servers = (%currservers,%server);
       }
       my %by_hostname;
       foreach my $id (keys(%servers)) {
           push(@{$by_hostname{$servers{$id}}},$id);
       }
       foreach my $hostname (sort(keys(%by_hostname))) {
           if (@{$by_hostname{$hostname}} > 1) {
               my $match = 0;
               foreach my $id (@{$by_hostname{$hostname}}) {
                   if (&host_domain($id) eq $dom) {
                       $uniqservers{$id} = $hostname;
                       $match = 1;
                   }
               }
               unless ($match) {
                   $uniqservers{$by_hostname{$hostname}[0]} = $hostname;
               }
           } else {
               $uniqservers{$by_hostname{$hostname}[0]} = $hostname;
           }
       }
       return %uniqservers;
   }
   
 # ---------------------- Find the homebase for a user from domain's lib servers  # ---------------------- Find the homebase for a user from domain's lib servers
   
 my %homecache;  my %homecache;
Line 1135  sub idput { Line 1580  sub idput {
   
 # ------------------------------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,$range)=@_;      my ($namespace, $udom, $regexp) = @_;
     if (!$udom) {  
         $udom=$env{'user.domain'};      $udom ||= $env{'user.domain'};
     }  
     my %returnhash;      return () unless $udom;
     if ($udom) {  
         my $uname = &get_domainconfiguser($udom);      return &dump($namespace, $udom, &get_domainconfiguser($udom), $regexp);
         %returnhash = &dump($namespace,$udom,$uname,$regexp,$range);  
     }  
     return %returnhash;  
 }  }
   
 # ------------------------------------------ get items from domain db files     # ------------------------------------------ get items from domain db files   
Line 1524  sub get_domain_defaults { Line 1966  sub get_domain_defaults {
     my %domconfig =      my %domconfig =
          &Apache::lonnet::get_dom('configuration',['defaults','quotas',           &Apache::lonnet::get_dom('configuration',['defaults','quotas',
                                   'requestcourses','inststatus',                                    'requestcourses','inststatus',
                                   'coursedefaults','usersessions'],$domain);                                    'coursedefaults','usersessions',
                                     'requestauthor'],$domain);
     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'};
         $domdefaults{'auth_arg_def'} = $domconfig{'defaults'}{'auth_arg_def'};          $domdefaults{'auth_arg_def'} = $domconfig{'defaults'}{'auth_arg_def'};
         $domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'};          $domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'};
         $domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'};          $domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'};
           $domdefaults{'portal_def'} = $domconfig{'defaults'}{'portal_def'};
     } else {      } else {
         $domdefaults{'lang_def'} = &domain($domain,'lang_def');          $domdefaults{'lang_def'} = &domain($domain,'lang_def');
         $domdefaults{'auth_def'} = &domain($domain,'auth_def');          $domdefaults{'auth_def'} = &domain($domain,'auth_def');
Line 1542  sub get_domain_defaults { Line 1986  sub get_domain_defaults {
         } else {          } else {
             $domdefaults{'defaultquota'} = $domconfig{'quotas'};              $domdefaults{'defaultquota'} = $domconfig{'quotas'};
         }           } 
         my @usertools = ('aboutme','blog','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};
Line 1554  sub get_domain_defaults { Line 1998  sub get_domain_defaults {
             $domdefaults{$item} = $domconfig{'requestcourses'}{$item};              $domdefaults{$item} = $domconfig{'requestcourses'}{$item};
         }          }
     }      }
       if (ref($domconfig{'requestauthor'}) eq 'HASH') {
           $domdefaults{'requestauthor'} = $domconfig{'requestauthor'};
       }
     if (ref($domconfig{'inststatus'}) eq 'HASH') {      if (ref($domconfig{'inststatus'}) eq 'HASH') {
         foreach my $item ('inststatustypes','inststatusorder') {          foreach my $item ('inststatustypes','inststatusorder') {
             $domdefaults{$item} = $domconfig{'inststatus'}{$item};              $domdefaults{$item} = $domconfig{'inststatus'}{$item};
Line 1563  sub get_domain_defaults { Line 2010  sub get_domain_defaults {
         foreach my $item ('canuse_pdfforms') {          foreach my $item ('canuse_pdfforms') {
             $domdefaults{$item} = $domconfig{'coursedefaults'}{$item};              $domdefaults{$item} = $domconfig{'coursedefaults'}{$item};
         }          }
           if (ref($domconfig{'coursedefaults'}{'coursecredits'}) eq 'HASH') {
               $domdefaults{'officialcredits'} = $domconfig{'coursedefaults'}{'coursecredits'}{'official'};
               $domdefaults{'unofficialcredits'} = $domconfig{'coursedefaults'}{'coursecredits'}{'unofficial'};
           }
     }      }
     if (ref($domconfig{'usersessions'}) eq 'HASH') {      if (ref($domconfig{'usersessions'}) eq 'HASH') {
         if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') {          if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') {
Line 1572  sub get_domain_defaults { Line 2023  sub get_domain_defaults {
             $domdefaults{'hostedsessions'} = $domconfig{'usersessions'}{'hosted'};              $domdefaults{'hostedsessions'} = $domconfig{'usersessions'}{'hosted'};
         }          }
     }      }
     &Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults,      &do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);
                                   $cachetime);  
     return %domdefaults;      return %domdefaults;
 }  }
   
Line 1757  sub getsection { Line 2207  sub getsection {
     # If there is a role which has expired, return it.      # If there is a role which has expired, return it.
     #      #
     $courseid = &courseid_to_courseurl($courseid);      $courseid = &courseid_to_courseurl($courseid);
     my $extra = &freeze_escape({'skipcheck' => 1});      my %roleshash = &dump('roles',$udom,$unam,$courseid);
     my %roleshash = &dump('roles',$udom,$unam,$courseid,undef,$extra);  
     foreach my $key (keys(%roleshash)) {      foreach my $key (keys(%roleshash)) {
         next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/);          next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/);
         my $section=$1;          my $section=$1;
Line 1824  sub is_cached_new { Line 2273  sub is_cached_new {
     my ($name,$id,$debug) = @_;      my ($name,$id,$debug) = @_;
     $id=&make_key($name,$id);      $id=&make_key($name,$id);
     if (exists($remembered{$id})) {      if (exists($remembered{$id})) {
  if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); }   if ($debug) { &Apache::lonnet::logthis("Early return $id of $remembered{$id} "); }
  $accessed{$id}=[&gettimeofday()];   $accessed{$id}=[&gettimeofday()];
  $hits++;   $hits++;
  return ($remembered{$id},1);   return ($remembered{$id},1);
Line 1984  sub chatsend { Line 2433  sub chatsend {
   
 sub getversion {  sub getversion {
     my $fname=&clutter(shift);      my $fname=&clutter(shift);
     unless ($fname=~/^\/res\//) { return -1; }      unless ($fname=~m{^(/adm/wrapper|)/res/}) { return -1; }
     return &currentversion(&filelocation('',$fname));      return &currentversion(&filelocation('',$fname));
 }  }
   
 sub currentversion {  sub currentversion {
     my $fname=shift;      my $fname=shift;
     my ($result,$cached)=&is_cached_new('resversion',$fname);  
     if (defined($cached)) { return $result; }  
     my $author=$fname;      my $author=$fname;
     $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;      $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
     my ($udom,$uname)=split(/\//,$author);      my ($udom,$uname)=split(/\//,$author);
     my $home=homeserver($uname,$udom);      my $home=&homeserver($uname,$udom);
     if ($home eq 'no_host') {       if ($home eq 'no_host') { 
         return -1;           return -1; 
     }      }
     my $answer=reply("currentversion:$fname",$home);      my $answer=&reply("currentversion:$fname",$home);
     if (($answer eq 'con_lost') || ($answer eq 'rejected')) {      if (($answer eq 'con_lost') || ($answer eq 'rejected')) {
  return -1;   return -1;
     }      }
     return &do_cache_new('resversion',$fname,$answer,600);      return $answer;
   }
   
   #
   # Return special version number of resource if set by override, empty otherwise
   #
   sub usedversion {
       my $fname=shift;
       unless ($fname) { $fname=$env{'request.uri'}; }
       my ($urlversion)=($fname=~/\.(\d+)\.\w+$/);
       if ($urlversion) { return $urlversion; }
       return '';
 }  }
   
 # ----------------------------- Subscribe to a resource, return URL if possible  # ----------------------------- Subscribe to a resource, return URL if possible
Line 2031  sub subscribe { Line 2489  sub subscribe {
 sub repcopy {  sub repcopy {
     my $filename=shift;      my $filename=shift;
     $filename=~s/\/+/\//g;      $filename=~s/\/+/\//g;
     if ($filename=~m|^/home/httpd/html/adm/|) { return 'ok'; }      my $londocroot = $perlvar{'lonDocRoot'};
     if ($filename=~m|^/home/httpd/html/lonUsers/|) { return 'ok'; }      if ($filename=~m{^\Q$londocroot/adm/\E}) { return 'ok'; }
     if ($filename=~m|^/home/httpd/html/userfiles/| or      if ($filename=~m{^\Q/home/httpd/lonUsers/\E}) { return 'ok'; }
  $filename=~m -^/*(uploaded|editupload)/-) {       if ($filename=~m{^\Q$londocroot/userfiles/\E} or
    $filename=~m{^/*(uploaded|editupload)/}) {
  return &repcopy_userfile($filename);   return &repcopy_userfile($filename);
     }      }
     $filename=~s/[\n\r]//g;      $filename=~s/[\n\r]//g;
Line 2061  sub repcopy { Line 2520  sub repcopy {
         unless ($home eq $perlvar{'lonHostID'}) {          unless ($home eq $perlvar{'lonHostID'}) {
            my @parts=split(/\//,$filename);             my @parts=split(/\//,$filename);
            my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";             my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";
            if ($path ne "$perlvar{'lonDocRoot'}/res") {             if ($path ne "$londocroot/res") {
                &logthis("Malconfiguration for replication: $filename");                 &logthis("Malconfiguration for replication: $filename");
        return 'bad_request';         return 'bad_request';
            }             }
Line 2160  sub ssi { Line 2619  sub ssi {
     }      }
   
     $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 2194  sub allowuploaded { Line 2655  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;
                   }
               }
           }
           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,
 #        ref to hash for embedded objects,  #        ref to hash for embedded objects,
 #        ref to hash for codebase of java objects.  #        ref to hash for codebase of java objects.
   #        reference to scalar to accommodate mime type determined
   #          from File::MMagic if $parser = parse.
 #  #
 # output: url to file (if action was uploaddoc),   # output: url to file (if action was uploaddoc), 
 #         ok if successful, or diagnostic message otherwise (if action was propagate or copy)  #         ok if successful, or diagnostic message otherwise (if action was propagate or copy)
Line 2225  sub allowuploaded { Line 2939  sub allowuploaded {
 #  #
   
 sub process_coursefile {  sub process_coursefile {
     my ($action,$docuname,$docudom,$file,$source,$parser,$allfiles,$codebase)=@_;      my ($action,$docuname,$docudom,$file,$source,$parser,$allfiles,$codebase,
           $mimetype)=@_;
     my $fetchresult;      my $fetchresult;
     my $home=&homeserver($docuname,$docudom);      my $home=&homeserver($docuname,$docudom);
     if ($action eq 'propagate') {      if ($action eq 'propagate') {
Line 2253  sub process_coursefile { Line 2968  sub process_coursefile {
             close($fh);              close($fh);
             if ($parser eq 'parse') {              if ($parser eq 'parse') {
                 my $mm = new File::MMagic;                  my $mm = new File::MMagic;
                 my $mime_type = $mm->checktype_filename($filepath.'/'.$fname);                  my $type = $mm->checktype_filename($filepath.'/'.$fname);
                 if ($mime_type eq 'text/html') {                  if ($type eq 'text/html') {
                     my $parse_result = &extract_embedded_items($filepath.'/'.$fname,$allfiles,$codebase);                      my $parse_result = &extract_embedded_items($filepath.'/'.$fname,$allfiles,$codebase);
                     unless ($parse_result eq 'ok') {                      unless ($parse_result eq 'ok') {
                         &logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result);                          &logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result);
                     }                      }
                 }                  }
                   if (ref($mimetype)) {
                       $$mimetype = $type;
                   } 
             }              }
             $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,              $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
                                  $home);                                   $home);
Line 2375  sub resizeImage { Line 3093  sub resizeImage {
   
 # --------------- Take an uploaded file and put it into the userfiles directory  # --------------- Take an uploaded file and put it into the userfiles directory
 # input: $formname - the contents of the file are in $env{"form.$formname"}  # input: $formname - the contents of the file are in $env{"form.$formname"}
 #                    the desired filenam is in $env{"form.$formname.filename"}  #                    the desired filename is in $env{"form.$formname.filename"}
 #        $coursedoc - if true up to the current course  #        $context - possible values: coursedoc, existingfile, overwrite, 
 #                     if false  #                                    canceloverwrite, or ''. 
   #                   if 'coursedoc': upload to the current course
   #                   if 'existingfile': write file to tmp/overwrites directory 
   #                   if 'canceloverwrite': delete file written to tmp/overwrites directory
   #                   $context is passed as argument to &finishuserfileupload
 #        $subdir - directory in userfile to store the file into  #        $subdir - directory in userfile to store the file into
 #        $parser - instruction to parse file for objects ($parser = parse)      #        $parser - instruction to parse file for objects ($parser = parse)    
 #        $allfiles - reference to hash for embedded objects  #        $allfiles - reference to hash for embedded objects
Line 2388  sub resizeImage { Line 3110  sub resizeImage {
 #        $thumbheight - height (pixels) of thumbnail to make for uploaded image  #        $thumbheight - height (pixels) of thumbnail to make for uploaded image
 #        $resizewidth - width (pixels) to which to resize uploaded image  #        $resizewidth - width (pixels) to which to resize uploaded image
 #        $resizeheight - height (pixels) to which to resize uploaded image  #        $resizeheight - height (pixels) to which to resize uploaded image
   #        $mimetype - reference to scalar to accommodate mime type determined
   #                    from File::MMagic.
 #   # 
 # output: url of file in userspace, or error: <message>   # output: url of file in userspace, or error: <message> 
 #             or /adm/notfound.html if failure to upload occurse  #             or /adm/notfound.html if failure to upload occurse
   
 sub userfileupload {  sub userfileupload {
     my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname,      my ($formname,$context,$subdir,$parser,$allfiles,$codebase,$destuname,
         $destudom,$thumbwidth,$thumbheight,$resizewidth,$resizeheight)=@_;          $destudom,$thumbwidth,$thumbheight,$resizewidth,$resizeheight,$mimetype)=@_;
     if (!defined($subdir)) { $subdir='unknown'; }      if (!defined($subdir)) { $subdir='unknown'; }
     my $fname=$env{'form.'.$formname.'.filename'};      my $fname=$env{'form.'.$formname.'.filename'};
     $fname=&clean_filename($fname);      $fname=&clean_filename($fname);
 # See if there is anything left      # See if there is anything left
     unless ($fname) { return 'error: no uploaded file'; }      unless ($fname) { return 'error: no uploaded file'; }
     chop($env{'form.'.$formname});      # Files uploaded to help request form, or uploaded to "create course" page are handled differently
     if (($formname eq 'screenshot') && ($subdir eq 'helprequests')) { #files uploaded to help request form are handled differently      if ((($formname eq 'screenshot') && ($subdir eq 'helprequests')) ||
           (($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) ||
            ($context eq 'existingfile') || ($context eq 'canceloverwrite')) {
         my $now = time;          my $now = time;
         my $filepath = 'tmp/helprequests/'.$now;          my $filepath;
         my @parts=split(/\//,$filepath);          if (($formname eq 'screenshot') && ($subdir eq 'helprequests')) {
         my $fullpath = $perlvar{'lonDaemons'};               $filepath = 'tmp/helprequests/'.$now;
         for (my $i=0;$i<@parts;$i++) {          } elsif (($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) {
             $fullpath .= '/'.$parts[$i];               $filepath = 'tmp/addcourse/'.$destudom.'/web/'.$env{'user.name'}.
             if ((-e $fullpath)!=1) {                           '_'.$env{'user.domain'}.'/pending';
                 mkdir($fullpath,0777);          } elsif (($context eq 'existingfile') || ($context eq 'canceloverwrite')) {
               my ($docuname,$docudom);
               if ($destudom) {
                   $docudom = $destudom;
               } else {
                   $docudom = $env{'user.domain'};
               }
               if ($destuname) {
                   $docuname = $destuname;
               } else {
                   $docuname = $env{'user.name'};
               }
               if (exists($env{'form.group'})) {
                   $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
                   $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
               }
               $filepath = 'tmp/overwrites/'.$docudom.'/'.$docuname.'/'.$subdir;
               if ($context eq 'canceloverwrite') {
                   my $tempfile =  $perlvar{'lonDaemons'}.'/'.$filepath.'/'.$fname;
                   if (-e  $tempfile) {
                       my @info = stat($tempfile);
                       if ($info[9] eq $env{'form.timestamp'}) {
                           unlink($tempfile);
                       }
                   }
                   return;
             }              }
         }          }
         open(my $fh,'>'.$fullpath.'/'.$fname);          # Create the directory if not present
         print $fh $env{'form.'.$formname};  
         close($fh);  
         return $fullpath.'/'.$fname;  
     } elsif (($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) { #files uploaded to create course page are handled differently  
         my $filepath = 'tmp/addcourse/'.$destudom.'/web/'.$env{'user.name'}.  
                        '_'.$env{'user.domain'}.'/pending';  
         my @parts=split(/\//,$filepath);          my @parts=split(/\//,$filepath);
         my $fullpath = $perlvar{'lonDaemons'};          my $fullpath = $perlvar{'lonDaemons'};
         for (my $i=0;$i<@parts;$i++) {          for (my $i=0;$i<@parts;$i++) {
Line 2430  sub userfileupload { Line 3175  sub userfileupload {
         open(my $fh,'>'.$fullpath.'/'.$fname);          open(my $fh,'>'.$fullpath.'/'.$fname);
         print $fh $env{'form.'.$formname};          print $fh $env{'form.'.$formname};
         close($fh);          close($fh);
         return $fullpath.'/'.$fname;          if ($context eq 'existingfile') {
               my @info = stat($fullpath.'/'.$fname);
               return ($fullpath.'/'.$fname,$info[9]);
           } else {
               return $fullpath.'/'.$fname;
           }
     }      }
     if ($subdir eq 'scantron') {      if ($subdir eq 'scantron') {
         $fname = 'scantron_orig_'.$fname;          $fname = 'scantron_orig_'.$fname;
     } else {         } else {
 # Create the directory if not present  
         $fname="$subdir/$fname";          $fname="$subdir/$fname";
     }      }
     if ($coursedoc) {      if ($context eq 'coursedoc') {
  my $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};   my $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
  my $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};   my $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
         if ($env{'form.folder'} =~ m/^(default|supplemental)/) {          if ($env{'form.folder'} =~ m/^(default|supplemental)/) {
             return &finishuserfileupload($docuname,$docudom,              return &finishuserfileupload($docuname,$docudom,
  $formname,$fname,$parser,$allfiles,   $formname,$fname,$parser,$allfiles,
  $codebase,$thumbwidth,$thumbheight,   $codebase,$thumbwidth,$thumbheight,
                                          $resizewidth,$resizeheight);                                           $resizewidth,$resizeheight,$context,$mimetype);
         } else {          } else {
             $fname=$env{'form.folder'}.'/'.$fname;              if ($env{'form.folder'}) {
                   $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);         $allfiles,$codebase,$mimetype);
         }          }
     } elsif (defined($destuname)) {      } elsif (defined($destuname)) {
         my $docuname=$destuname;          my $docuname=$destuname;
Line 2458  sub userfileupload { Line 3209  sub userfileupload {
  return &finishuserfileupload($docuname,$docudom,$formname,$fname,   return &finishuserfileupload($docuname,$docudom,$formname,$fname,
      $parser,$allfiles,$codebase,       $parser,$allfiles,$codebase,
                                      $thumbwidth,$thumbheight,                                       $thumbwidth,$thumbheight,
                                      $resizewidth,$resizeheight);                                       $resizewidth,$resizeheight,$context,$mimetype);
           
     } 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'})) {          if ((exists($env{'form.group'})) || ($context eq 'syllabus')) {
             $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'};
         }          }
  return &finishuserfileupload($docuname,$docudom,$formname,$fname,   return &finishuserfileupload($docuname,$docudom,$formname,$fname,
      $parser,$allfiles,$codebase,       $parser,$allfiles,$codebase,
                                      $thumbwidth,$thumbheight,                                       $thumbwidth,$thumbheight,
                                      $resizewidth,$resizeheight);                                       $resizewidth,$resizeheight,$context,$mimetype);
     }      }
 }  }
   
 sub finishuserfileupload {  sub finishuserfileupload {
     my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase,      my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase,
         $thumbwidth,$thumbheight,$resizewidth,$resizeheight) = @_;          $thumbwidth,$thumbheight,$resizewidth,$resizeheight,$context,$mimetype) = @_;
     my $path=$docudom.'/'.$docuname.'/';      my $path=$docudom.'/'.$docuname.'/';
     my $filepath=$perlvar{'lonDocRoot'};      my $filepath=$perlvar{'lonDocRoot'};
       
Line 2502  sub finishuserfileupload { Line 3252  sub finishuserfileupload {
     print STDERR ('Failed to create '.$filepath.'/'.$file."\n");      print STDERR ('Failed to create '.$filepath.'/'.$file."\n");
     return '/adm/notfound.html';      return '/adm/notfound.html';
  }   }
  if (!print FH ($env{'form.'.$formname})) {          if ($context eq 'overwrite') {
               my $source =  LONCAPA::tempdir().'/overwrites/'.$docudom.'/'.$docuname.'/'.$fname;
               my $target = $filepath.'/'.$file;
               if (-e $source) {
                   my @info = stat($source);
                   if ($info[9] eq $env{'form.timestamp'}) {   
                       unless (&File::Copy::move($source,$target)) {
                           &logthis('Failed to overwrite '.$filepath.'/'.$file);
                           return "Moving from $source failed";
                       }
                   } else {
                       return "Temporary file: $source had unexpected date/time for last modification";
                   }
               } else {
                   return "Temporary file: $source missing";
               }
           } elsif (!print FH ($env{'form.'.$formname})) {
     &logthis('Failed to write to '.$filepath.'/'.$file);      &logthis('Failed to write to '.$filepath.'/'.$file);
     print STDERR ('Failed to write to '.$filepath.'/'.$file."\n");      print STDERR ('Failed to write to '.$filepath.'/'.$file."\n");
     return '/adm/notfound.html';      return '/adm/notfound.html';
Line 2516  sub finishuserfileupload { Line 3282  sub finishuserfileupload {
             }                }  
  }   }
     }      }
       if (($context eq 'coursedoc') || ($parser eq 'parse')) {
           if (ref($mimetype)) {
               if ($$mimetype eq '') {
                   my $mm = new File::MMagic;
                   my $type = $mm->checktype_filename($filepath.'/'.$file);
                   $$mimetype = $type;
               }
           }
       }
     if ($parser eq 'parse') {      if ($parser eq 'parse') {
         my $mm = new File::MMagic;          if ((ref($mimetype)) && ($$mimetype eq 'text/html')) {
         my $mime_type = $mm->checktype_filename($filepath.'/'.$file);  
         if ($mime_type eq 'text/html') {  
             my $parse_result = &extract_embedded_items($filepath.'/'.$file,              my $parse_result = &extract_embedded_items($filepath.'/'.$file,
                                                        $allfiles,$codebase);                                                         $allfiles,$codebase);
             unless ($parse_result eq 'ok') {              unless ($parse_result eq 'ok') {
Line 2563  sub finishuserfileupload { Line 3336  sub finishuserfileupload {
 sub extract_embedded_items {  sub extract_embedded_items {
     my ($fullpath,$allfiles,$codebase,$content) = @_;      my ($fullpath,$allfiles,$codebase,$content) = @_;
     my @state = ();      my @state = ();
       my (%lastids,%related,%shockwave,%flashvars);
     my %javafiles = (      my %javafiles = (
                       codebase => '',                        codebase => '',
                       code => '',                        code => '',
Line 2589  sub extract_embedded_items { Line 3363  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') {
  &add_filetype($allfiles,$attr->{'href'},'href');                  unless (($attr->{'href'} =~ /^#/) || ($attr->{'href'} eq '')) {
                       &add_filetype($allfiles,$attr->{'href'},'href');
                   }
     }      }
             if (lc($tagname) eq 'script') {              if (lc($tagname) eq 'script') {
                   my $src;
                 if ($attr->{'archive'} =~ /\.jar$/i) {                  if ($attr->{'archive'} =~ /\.jar$/i) {
                     &add_filetype($allfiles,$attr->{'archive'},'archive');                      &add_filetype($allfiles,$attr->{'archive'},'archive');
                 } else {                  } else {
                     &add_filetype($allfiles,$attr->{'src'},'src');                      if ($attr->{'src'} ne '') {
                           $src = $attr->{'src'};
                           &add_filetype($allfiles,$src,'src');
                       }
                   }
                   my $text = $p->get_trimmed_text();
                   if ($text =~ /\Qswfobject.registerObject(\E([^\)]+)\)/) {
                       my @swfargs = split(/,/,$1);
                       foreach my $item (@swfargs) {
                           $item =~ s/["']//g;
                           $item =~ s/^\s+//;
                           $item =~ s/\s+$//;
                       }
                       if (($swfargs[0] ne'') && ($swfargs[2] ne '')) {
                           if (ref($related{$swfargs[0]}) eq 'ARRAY') {
                               push(@{$related{$swfargs[0]}},$swfargs[2]);
                           } else {
                               $related{$swfargs[0]} = [$swfargs[2]];
                           }
                       }
                 }                  }
             }              }
             if (lc($tagname) eq 'link') {              if (lc($tagname) eq 'link') {
Line 2608  sub extract_embedded_items { Line 3404  sub extract_embedded_items {
  foreach my $item (keys(%javafiles)) {   foreach my $item (keys(%javafiles)) {
     $javafiles{$item} = '';      $javafiles{$item} = '';
  }   }
                   if ((lc($tagname) eq 'object') && (lc($state[-2]) ne 'object')) {
                       $lastids{lc($tagname)} = $attr->{'id'};
                   }
     }      }
     if (lc($state[-2]) eq 'object' && lc($tagname) eq 'param') {      if (lc($state[-2]) eq 'object' && lc($tagname) eq 'param') {
  my $name = lc($attr->{'name'});   my $name = lc($attr->{'name'});
Line 2617  sub extract_embedded_items { Line 3416  sub extract_embedded_items {
  last;   last;
     }      }
  }   }
                   my $pathfrom;
  foreach my $item (keys(%mediafiles)) {   foreach my $item (keys(%mediafiles)) {
     if ($name eq $item) {      if ($name eq $item) {
  &add_filetype($allfiles, $attr->{'value'}, 'value');                          $pathfrom = $attr->{'value'};
                           $shockwave{$lastids{lc($state[-2])}} = $pathfrom;
    &add_filetype($allfiles,$pathfrom,$name);
  last;   last;
     }      }
  }   }
                   if ($name eq 'flashvars') {
                       $flashvars{$lastids{lc($state[-2])}} = $attr->{'value'};
                   }
                   if ($pathfrom ne '') {
                       &embedded_dependency($allfiles,\%related,$lastids{lc($state[-2])},
                                            $pathfrom);
                   }
     }      }
     if (lc($tagname) eq 'embed' || lc($tagname) eq 'applet') {      if (lc($tagname) eq 'embed' || lc($tagname) eq 'applet') {
  foreach my $item (keys(%javafiles)) {   foreach my $item (keys(%javafiles)) {
Line 2637  sub extract_embedded_items { Line 3446  sub extract_embedded_items {
  last;   last;
     }      }
  }   }
                   if (lc($tagname) eq 'embed') {
                       if (($attr->{'name'} ne '') && ($attr->{'src'} ne '')) {
                           &embedded_dependency($allfiles,\%related,$attr->{'name'},
                                                $attr->{'src'});
                       }
                   }
     }      }
               if ($t->[4] =~ m{/>$}) {
                   pop(@state);  
               }
  } elsif ($t->[0] eq 'E') {   } elsif ($t->[0] eq 'E') {
     my ($tagname) = ($t->[1]);      my ($tagname) = ($t->[1]);
     if ($javafiles{'codebase'} ne '') {      if ($javafiles{'codebase'} ne '') {
Line 2657  sub extract_embedded_items { Line 3475  sub extract_embedded_items {
     pop @state;      pop @state;
  }   }
     }      }
       foreach my $id (sort(keys(%flashvars))) {
           if ($shockwave{$id} ne '') {
               my @pairs = split(/\&/,$flashvars{$id});
               foreach my $pair (@pairs) {
                   my ($key,$value) = split(/\=/,$pair);
                   if ($key eq 'thumb') {
                       &add_filetype($allfiles,$value,$key);
                   } elsif ($key eq 'content') {
                       my ($path) = ($shockwave{$id} =~ m{^(.+/)[^/]+$});
                       my ($ext) = ($value =~ /\.([^.]+)$/);
                       if ($ext ne '') {
                           &add_filetype($allfiles,$path.$value,$ext);
                       }
                   }
               }
           }
       }
     return 'ok';      return 'ok';
 }  }
   
Line 2671  sub add_filetype { Line 3506  sub add_filetype {
     }      }
 }  }
   
   sub embedded_dependency {
       my ($allfiles,$related,$identifier,$pathfrom) = @_;
       if ((ref($allfiles) eq 'HASH') && (ref($related) eq 'HASH')) {
           if (($identifier ne '') &&
               (ref($related->{$identifier}) eq 'ARRAY') &&
               ($pathfrom ne '')) {
               my ($path) = ($pathfrom =~ m{^(.+/)[^/]+$});
               foreach my $dep (@{$related->{$identifier}}) {
                   &add_filetype($allfiles,$path.$dep,'object');
               }
           }
       }
       return;
   }
   
 sub removeuploadedurl {  sub removeuploadedurl {
     my ($url)=@_;      my ($url)=@_;
     my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);          my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);    
Line 2797  sub flushcourselogs { Line 3647  sub flushcourselogs {
             my $result = &inc('nohist_accesscount',\%temphash,$dom,$name);              my $result = &inc('nohist_accesscount',\%temphash,$dom,$name);
             if ($result eq 'ok') {              if ($result eq 'ok') {
                 delete $accesshash{$entry};                  delete $accesshash{$entry};
             } elsif ($result eq 'unknown_cmd') {  
                 # Target server has old code running on it.  
                 my %temphash=($entry => $value);  
                 if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {  
                     delete $accesshash{$entry};  
                 }  
             }              }
         } else {          } else {
             my ($dom,$name) = ($entry=~m{___($match_domain)/($match_name)/(.*)___(\w+)$});              my ($dom,$name) = ($entry=~m{___($match_domain)/($match_name)/(.*)___(\w+)$});
               if (($dom eq 'uploaded') || ($dom eq 'adm')) { next; }
             my %temphash=($entry => $accesshash{$entry});              my %temphash=($entry => $accesshash{$entry});
             if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {              if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {
                 delete $accesshash{$entry};                  delete $accesshash{$entry};
Line 2884  sub courseacclog { Line 3729  sub courseacclog {
     my $fnsymb=shift;      my $fnsymb=shift;
     unless ($env{'request.course.id'}) { return ''; }      unless ($env{'request.course.id'}) { return ''; }
     my $what=$fnsymb.':'.$env{'user.name'}.':'.$env{'user.domain'};      my $what=$fnsymb.':'.$env{'user.name'}.':'.$env{'user.domain'};
     if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|task|page)$/) {      if ($fnsymb=~/$LONCAPA::assess_re/) {
         $what.=':POST';          $what.=':POST';
         # FIXME: Probably ought to escape things....          # FIXME: Probably ought to escape things....
  foreach my $key (keys(%env)) {   foreach my $key (keys(%env)) {
Line 2916  sub countacc { Line 3761  sub countacc {
     my $url=&declutter(shift);      my $url=&declutter(shift);
     return if (! defined($url) || $url eq '');      return if (! defined($url) || $url eq '');
     unless ($env{'request.course.id'}) { return ''; }      unless ($env{'request.course.id'}) { return ''; }
   #
   # Mark that this url was used in this course
   #
     $accesshash{$env{'request.course.id'}.'___'.$url.'___course'}=1;      $accesshash{$env{'request.course.id'}.'___'.$url.'___course'}=1;
   #
   # Increase the access count for this resource in this child process
   #
     my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count';      my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count';
     $accesshash{$key}++;      $accesshash{$key}++;
 }  }
Line 2928  sub linklog { Line 3779  sub linklog {
     $accesshash{$from.'___'.$to.'___comefrom'}=1;      $accesshash{$from.'___'.$to.'___comefrom'}=1;
     $accesshash{$to.'___'.$from.'___goto'}=1;      $accesshash{$to.'___'.$from.'___goto'}=1;
 }  }
   
   sub statslog {
       my ($symb,$part,$users,$av_attempts,$degdiff)=@_;
       if ($users<2) { return; }
       my %dynstore=&LONCAPA::lonmetadata::dynamic_metadata_storage({
               'course'       => $env{'request.course.id'},
               'sections'     => '"all"',
               'num_students' => $users,
               'part'         => $part,
               'symb'         => $symb,
               'mean_tries'   => $av_attempts,
               'deg_of_diff'  => $degdiff});
       foreach my $key (keys(%dynstore)) {
           $accesshash{$key}=$dynstore{$key};
       }
   }
       
 sub userrolelog {  sub userrolelog {
     my ($trole,$username,$domain,$area,$tstart,$tend)=@_;      my ($trole,$username,$domain,$area,$tstart,$tend)=@_;
     if (($trole=~/^ca/) || ($trole=~/^aa/) ||      if ( $trole =~ /^(ca|aa|in|cc|ep|cr|ta|co)/ ) {
         ($trole=~/^in/) || ($trole=~/^cc/) ||  
         ($trole=~/^ep/) || ($trole=~/^cr/) ||  
         ($trole=~/^ta/) || ($trole=~/^co/)) {  
        my (undef,$rudom,$runame,$rsec)=split(/\//,$area);         my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
        $userrolehash         $userrolehash
          {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}           {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
                     =$tend.':'.$tstart;                      =$tend.':'.$tstart;
     }      }
     if (($env{'request.role'} =~ /dc\./) &&      if ($env{'request.role'} =~ /dc\./ && $trole =~ /^(au|in|cc|ep|cr|ta|co)/) {
  (($trole=~/^au/) || ($trole=~/^in/) ||  
  ($trole=~/^cc/) || ($trole=~/^ep/) ||  
  ($trole=~/^cr/) || ($trole=~/^ta/) ||  
          ($trole=~/^co/))) {  
        $userrolehash         $userrolehash
          {$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'}           {$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'}
                     =$tend.':'.$tstart;                      =$tend.':'.$tstart;
     }      }
     if (($trole=~/^dc/) || ($trole=~/^ad/) ||      if ($trole =~ /^(dc|ad|li|au|dg|sc)/ ) {
         ($trole=~/^li/) || ($trole=~/^li/) ||  
         ($trole=~/^au/) || ($trole=~/^dg/) ||  
         ($trole=~/^sc/)) {  
        my (undef,$rudom,$runame,$rsec)=split(/\//,$area);         my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
        $domainrolehash         $domainrolehash
          {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}           {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
Line 2962  sub userrolelog { Line 3819  sub userrolelog {
   
 sub courserolelog {  sub courserolelog {
     my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$selfenroll,$context)=@_;      my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$selfenroll,$context)=@_;
     if (($trole eq 'cc') || ($trole eq 'in') ||      if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) {
         ($trole eq 'ep') || ($trole eq 'ad') ||          my $cdom = $1;
         ($trole eq 'ta') || ($trole eq 'st') ||          my $cnum = $2;
         ($trole=~/^cr/) || ($trole eq 'gr') ||          my $sec = $3;
         ($trole eq 'co')) {          my $namespace = 'rolelog';
         if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) {          my %storehash = (
             my $cdom = $1;                             role    => $trole,
             my $cnum = $2;                             start   => $tstart,
             my $sec = $3;                             end     => $tend,
             my $namespace = 'rolelog';                             selfenroll => $selfenroll,
             my %storehash = (                             context    => $context,
                                role    => $trole,                          );
                                start   => $tstart,          if ($trole eq 'gr') {
                                end     => $tend,              $namespace = 'groupslog';
                                selfenroll => $selfenroll,              $storehash{'group'} = $sec;
                                context    => $context,          } else {
                             );              $storehash{'section'} = $sec;
             if ($trole eq 'gr') {          }
                 $namespace = 'groupslog';          &write_log('course',$namespace,\%storehash,$delflag,$username,
                 $storehash{'group'} = $sec;                     $domain,$cnum,$cdom);
             } else {          if (($trole ne 'st') || ($sec ne '')) {
                 $storehash{'section'} = $sec;              &devalidate_cache_new('getcourseroles',$cdom.'_'.$cnum);
             }  
             &instructor_log($namespace,\%storehash,$delflag,$username,$domain,$cnum,$cdom);  
             if (($trole ne 'st') || ($sec ne '')) {  
                 &devalidate_cache_new('getcourseroles',$cdom.'_'.$cnum);  
             }  
         }          }
     }      }
     return;      return;
 }  }
   
   sub domainrolelog {
       my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$context)=@_;
       if ($area =~ m{^/($match_domain)/$}) {
           my $cdom = $1;
           my $domconfiguser = &Apache::lonnet::get_domainconfiguser($cdom);
           my $namespace = 'rolelog';
           my %storehash = (
                              role    => $trole,
                              start   => $tstart,
                              end     => $tend,
                              context => $context,
                           );
           &write_log('domain',$namespace,\%storehash,$delflag,$username,
                      $domain,$domconfiguser,$cdom);
       }
       return;
   
   }
   
   sub coauthorrolelog {
       my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$context)=@_;
       if ($area =~ m{^/($match_domain)/($match_username)$}) {
           my $audom = $1;
           my $auname = $2;
           my $namespace = 'rolelog';
           my %storehash = (
                              role    => $trole,
                              start   => $tstart,
                              end     => $tend,
                              context => $context,
                           );
           &write_log('author',$namespace,\%storehash,$delflag,$username,
                      $domain,$auname,$audom);
       }
       return;
   }
   
 sub get_course_adv_roles {  sub get_course_adv_roles {
     my ($cid,$codes) = @_;      my ($cid,$codes) = @_;
     $cid=$env{'request.course.id'} unless (defined($cid));      $cid=$env{'request.course.id'} unless (defined($cid));
Line 3007  sub get_course_adv_roles { Line 3896  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 3019  sub get_course_adv_roles { Line 3912  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; }
         unless (ref($privileged{$domain}) eq 'HASH') {          if ((&privileged($username,$domain,\@possdoms)) &&
             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 3060  sub get_my_roles { Line 3940  sub get_my_roles {
     unless (defined($uname)) { $uname=$env{'user.name'}; }      unless (defined($uname)) { $uname=$env{'user.name'}; }
     unless (defined($udom)) { $udom=$env{'user.domain'}; }      unless (defined($udom)) { $udom=$env{'user.domain'}; }
     my (%dumphash,%nothide);      my (%dumphash,%nothide);
     if ($context eq 'userroles') {       if ($context eq 'userroles') {
         my $extra = &freeze_escape({'skipcheck' => 1});          %dumphash = &dump('roles',$udom,$uname);
         %dumphash = &dump('roles',$udom,$uname,'.',undef,$extra);  
     } else {      } else {
         %dumphash=          %dumphash = &dump('nohist_userroles',$udom,$uname);
             &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 3083  sub get_my_roles { Line 3961  sub get_my_roles {
     foreach my $entry (keys(%dumphash)) {      foreach my $entry (keys(%dumphash)) {
         my ($role,$tend,$tstart);          my ($role,$tend,$tstart);
         if ($context eq 'userroles') {          if ($context eq 'userroles') {
               next if ($entry =~ /^rolesdef/);
     ($role,$tend,$tstart)=split(/_/,$dumphash{$entry});      ($role,$tend,$tstart)=split(/_/,$dumphash{$entry});
         } else {          } else {
             ($tend,$tstart)=split(/\:/,$dumphash{$entry});              ($tend,$tstart)=split(/\:/,$dumphash{$entry});
Line 3106  sub get_my_roles { Line 3985  sub get_my_roles {
         }          }
         my ($rolecode,$username,$domain,$section,$area);          my ($rolecode,$username,$domain,$section,$area);
         if ($context eq 'userroles') {          if ($context eq 'userroles') {
             ($area,$rolecode) = split(/_/,$entry);              ($area,$rolecode) = ($entry =~ /^(.+)_([^_]+)$/);
             (undef,$domain,$username,$section) = split(/\//,$area);              (undef,$domain,$username,$section) = split(/\//,$area);
         } else {          } else {
             ($role,$username,$domain,$section) = split(/\:/,$entry);              ($role,$username,$domain,$section) = split(/\:/,$entry);
Line 3122  sub get_my_roles { Line 4001  sub get_my_roles {
                     if (!grep(/^cr$/,@{$roles})) {                      if (!grep(/^cr$/,@{$roles})) {
                         next;                          next;
                     }                      }
                   } elsif ($role =~ /^gr\//) {
                       if (!grep(/^gr$/,@{$roles})) {
                           next;
                       }
                 } else {                  } else {
                     next;                      next;
                 }                  }
             }              }
         }          }
         if ($hidepriv) {          if ($hidepriv) {
               my @privroles = ('dc','su');
             if ($context eq 'userroles') {              if ($context eq 'userroles') {
                 if ((&privileged($username,$domain)) &&                  next if (grep(/^\Q$role\E$/,@privroles));
                     (!$nothide{$username.':'.$domain})) {  
                     next;  
                 }  
             } else {              } else {
                 unless (ref($privileged{$domain}) eq 'HASH') {                  my $possdoms = [$domain];
                     my %dompersonnel =                  if (ref($roledoms) eq 'ARRAY') {
                         &Apache::lonnet::get_domain_roles($domain,['dc'],$now,$now);                     push(@{$possdoms},@{$roledoms}); 
                     $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 (exists($privileged{$domain}{$username})) {                  if (&privileged($username,$domain,$possdoms,\@privroles)) {
                     if (!$nothide{$username.':'.$domain}) {                      if (!$nothide{$username.':'.$domain}) {
                         next;                          next;
                     }                      }
Line 3253  sub courseiddump { Line 4123  sub courseiddump {
   
     if (($domfilter eq '') ||      if (($domfilter eq '') ||
  (&host_domain($tryserver) eq $domfilter)) {   (&host_domain($tryserver) eq $domfilter)) {
                 my $rep =                   my $rep;
                   &reply('courseiddump:'.&host_domain($tryserver).':'.                  if (grep { $_ eq $tryserver } current_machine_ids()) {
                          $sincefilter.':'.&escape($descfilter).':'.                      $rep = LONCAPA::Lond::dump_course_id_handler(
                          &escape($instcodefilter).':'.&escape($ownerfilter).                          join(":", (&host_domain($tryserver), $sincefilter, 
                          ':'.&escape($coursefilter).':'.&escape($typefilter).                                  &escape($descfilter), &escape($instcodefilter), 
                          ':'.&escape($regexp_ok).':'.$as_hash.':'.                                  &escape($ownerfilter), &escape($coursefilter),
                          &escape($selfenrollonly).':'.&escape($catfilter).':'.                                  &escape($typefilter), &escape($regexp_ok), 
                          $showhidden.':'.$caller.':'.&escape($cloner).':'.                                  $as_hash, &escape($selfenrollonly), 
                          &escape($cc_clone).':'.$cloneonly.':'.                                  &escape($catfilter), $showhidden, $caller, 
                          &escape($createdbefore).':'.&escape($createdafter).':'.                                  &escape($cloner), &escape($cc_clone), $cloneonly, 
                          &escape($creationcontext).':'.$domcloner,                                  &escape($createdbefore), &escape($createdafter), 
                          $tryserver);                                  &escape($creationcontext), $domcloner)));
                   } else {
                       $rep = &reply('courseiddump:'.&host_domain($tryserver).':'.
                                $sincefilter.':'.&escape($descfilter).':'.
                                &escape($instcodefilter).':'.&escape($ownerfilter).
                                ':'.&escape($coursefilter).':'.&escape($typefilter).
                                ':'.&escape($regexp_ok).':'.$as_hash.':'.
                                &escape($selfenrollonly).':'.&escape($catfilter).':'.
                                $showhidden.':'.$caller.':'.&escape($cloner).':'.
                                &escape($cc_clone).':'.$cloneonly.':'.
                                &escape($createdbefore).':'.&escape($createdafter).':'.
                                &escape($creationcontext).':'.$domcloner,
                                $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 3370  sub get_domain_roles { Line 4254  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 3390  sub get_domain_roles { Line 4274  sub get_domain_roles {
     return %personnel;      return %personnel;
 }  }
   
 # ----------------------------------------------------------- Check out an item  # ----------------------------------------------------------- Interval timing 
   
   {
   # Caches needed for speedup of navmaps
   # We don't want to cache this for very long at all (5 seconds at most)
   # 
   # The user for whom we cache
   my $cachedkey='';
   # The cached times for this user
   my %cachedtimes=();
   # When this was last done
   my $cachedtime=();
   
   sub load_all_first_access {
       my ($uname,$udom)=@_;
       if (($cachedkey eq $uname.':'.$udom) &&
           (abs($cachedtime-time)<5) && (!$env{'form.markaccess'})) {
           return;
       }
       $cachedtime=time;
       $cachedkey=$uname.':'.$udom;
       %cachedtimes=&dump('firstaccesstimes',$udom,$uname);
   }
   
 sub get_first_access {  sub get_first_access {
     my ($type,$argsymb)=@_;      my ($type,$argsymb,$argmap)=@_;
     my ($symb,$courseid,$udom,$uname)=&whichuser();      my ($symb,$courseid,$udom,$uname)=&whichuser();
     if ($argsymb) { $symb=$argsymb; }      if ($argsymb) { $symb=$argsymb; }
     my ($map,$id,$res)=&decode_symb($symb);      my ($map,$id,$res)=&decode_symb($symb);
       if ($argmap) { $map = $argmap; }
     if ($type eq 'course') {      if ($type eq 'course') {
  $res='course';   $res='course';
     } elsif ($type eq 'map') {      } elsif ($type eq 'map') {
Line 3404  sub get_first_access { Line 4311  sub get_first_access {
     } else {      } else {
  $res=$symb;   $res=$symb;
     }      }
     my %times=&get('firstaccesstimes',["$courseid\0$res"],$udom,$uname);      &load_all_first_access($uname,$udom);
     return $times{"$courseid\0$res"};      return $cachedtimes{"$courseid\0$res"};
 }  }
   
 sub set_first_access {  sub set_first_access {
     my ($type)=@_;      my ($type,$interval)=@_;
     my ($symb,$courseid,$udom,$uname)=&whichuser();      my ($symb,$courseid,$udom,$uname)=&whichuser();
     my ($map,$id,$res)=&decode_symb($symb);      my ($map,$id,$res)=&decode_symb($symb);
     if ($type eq 'course') {      if ($type eq 'course') {
Line 3419  sub set_first_access { Line 4326  sub set_first_access {
     } else {      } else {
  $res=$symb;   $res=$symb;
     }      }
     my $firstaccess=&get_first_access($type,$symb);      $cachedkey='';
       my $firstaccess=&get_first_access($type,$symb,$map);
     if (!$firstaccess) {      if (!$firstaccess) {
  return &put('firstaccesstimes',{"$courseid\0$res"=>time},$udom,$uname);          my $start = time;
    my $putres = &put('firstaccesstimes',{"$courseid\0$res"=>$start},
                             $udom,$uname);
           if ($putres eq 'ok') {
               &put('timerinterval',{"$courseid\0$res"=>$interval},
                    $udom,$uname); 
               &appenv(
                        {
                           'course.'.$courseid.'.firstaccess.'.$res   => $start,
                           'course.'.$courseid.'.timerinterval.'.$res => $interval,
                        }
                     );
           }
           return $putres;
     }      }
     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 3615  sub hashref2str { Line 4451  sub hashref2str {
       $result.='=';        $result.='=';
       #print("Got a ref of ".(ref($key))." skipping.");        #print("Got a ref of ".(ref($key))." skipping.");
     } else {      } else {
  if ($key) {$result.=&escape($key).'=';} else { last; }   if (defined($key)) {$result.=&escape($key).'=';} else { last; }
     }      }
   
     if(ref($hashref->{$key}) eq 'ARRAY') {      if(ref($hashref->{$key}) eq 'ARRAY') {
Line 3767  sub tmpreset { Line 4603  sub tmpreset {
   if ($domain eq 'public' && $stuname eq 'public') {    if ($domain eq 'public' && $stuname eq 'public') {
       $stuname=$ENV{'REMOTE_ADDR'};        $stuname=$ENV{'REMOTE_ADDR'};
   }    }
   my $path=$perlvar{'lonDaemons'}.'/tmp';    my $path=LONCAPA::tempdir();
   my %hash;    my %hash;
   if (tie(%hash,'GDBM_File',    if (tie(%hash,'GDBM_File',
   $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',    $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
Line 3806  sub tmpstore { Line 4642  sub tmpstore {
   }    }
   my $now=time;    my $now=time;
   my %hash;    my %hash;
   my $path=$perlvar{'lonDaemons'}.'/tmp';    my $path=LONCAPA::tempdir();
   if (tie(%hash,'GDBM_File',    if (tie(%hash,'GDBM_File',
   $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',    $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
   &GDBM_WRCREAT(),0640)) {    &GDBM_WRCREAT(),0640)) {
Line 3852  sub tmprestore { Line 4688  sub tmprestore {
   $namespace=~s/\//\_/g;    $namespace=~s/\//\_/g;
   $namespace=~s/\W//g;    $namespace=~s/\W//g;
   my %hash;    my %hash;
   my $path=$perlvar{'lonDaemons'}.'/tmp';    my $path=LONCAPA::tempdir();
   if (tie(%hash,'GDBM_File',    if (tie(%hash,'GDBM_File',
   $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',    $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
   &GDBM_READER(),0640)) {    &GDBM_READER(),0640)) {
Line 3960  sub restore { Line 4796  sub restore {
     if ($stuname) { $home=&homeserver($stuname,$domain); }      if ($stuname) { $home=&homeserver($stuname,$domain); }
   
     if (!$symb) {      if (!$symb) {
       unless ($symb=escape(&symbread())) { return ''; }          return if ($namespace eq 'courserequests');
           unless ($symb=escape(&symbread())) { return ''; }
     } else {      } else {
       $symb=&escape(&symbclean($symb));          unless ($namespace eq 'courserequests') {
               $symb=&escape(&symbclean($symb));
           }
     }      }
     if (!$namespace) {       if (!$namespace) { 
        unless ($namespace=$env{'request.course.id'}) {          unless ($namespace=$env{'request.course.id'}) { 
Line 3989  sub restore { Line 4828  sub restore {
 }  }
   
 # ---------------------------------------------------------- Course Description  # ---------------------------------------------------------- Course Description
   #
   #  
   
 sub coursedescription {  sub coursedescription {
     my ($courseid,$args)=@_;      my ($courseid,$args)=@_;
Line 4018  sub coursedescription { Line 4859  sub coursedescription {
  return %returnhash;   return %returnhash;
     }      }
   
     # get the data agin      # get the data again
   
     if (!$args->{'one_time'}) {      if (!$args->{'one_time'}) {
  $envhash{'course.'.$normalid.'.last_cache'}=time;   $envhash{'course.'.$normalid.'.last_cache'}=time;
     }      }
Line 4026  sub coursedescription { Line 4868  sub coursedescription {
     if ($chome ne 'no_host') {      if ($chome ne 'no_host') {
        %returnhash=&dump('environment',$cdomain,$cnum);         %returnhash=&dump('environment',$cdomain,$cnum);
        if (!exists($returnhash{'con_lost'})) {         if (!exists($returnhash{'con_lost'})) {
      my $username = $env{'user.name'}; # Defult username
      if(defined $args->{'user'}) {
          $username = $args->{'user'};
      }
            $returnhash{'home'}= $chome;             $returnhash{'home'}= $chome;
    $returnhash{'domain'} = $cdomain;     $returnhash{'domain'} = $cdomain;
    $returnhash{'num'} = $cnum;     $returnhash{'num'} = $cnum;
Line 4036  sub coursedescription { Line 4882  sub coursedescription {
                $envhash{'course.'.$normalid.'.'.$name}=$value;                 $envhash{'course.'.$normalid.'.'.$name}=$value;
            }             }
            $returnhash{'url'}=&clutter($returnhash{'url'});             $returnhash{'url'}=&clutter($returnhash{'url'});
            $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'.             $returnhash{'fn'}=LONCAPA::tempdir() .
        $env{'user.name'}.'_'.$cdomain.'_'.$cnum;         $username.'_'.$cdomain.'_'.$cnum;
            $envhash{'course.'.$normalid.'.home'}=$chome;             $envhash{'course.'.$normalid.'.home'}=$chome;
            $envhash{'course.'.$normalid.'.domain'}=$cdomain;             $envhash{'course.'.$normalid.'.domain'}=$cdomain;
            $envhash{'course.'.$normalid.'.num'}=$cnum;             $envhash{'course.'.$normalid.'.num'}=$cnum;
Line 4090  sub update_released_required { Line 4936  sub update_released_required {
 # -------------------------------------------------See if a user is privileged  # -------------------------------------------------See if a user is privileged
   
 sub privileged {  sub privileged {
     my ($username,$domain)=@_;      my ($username,$domain,$possdomains,$possroles)=@_;
     my $rolesdump=&reply("dump:$domain:$username:roles",      my $now = time;
  &homeserver($username,$domain));      my $roles;
     if (($rolesdump eq 'con_lost') || ($rolesdump eq '') ||       if (ref($possroles) eq 'ARRAY') {
         ($rolesdump =~ /^error:/)) {          $roles = $possroles; 
         return 0;      } else {
     }          $roles = ['dc','su'];
     my $now=time;      }
     if ($rolesdump ne '') {      if (ref($possdomains) eq 'ARRAY') {
         foreach my $entry (split(/&/,$rolesdump)) {          my %privileged = &privileged_by_domain($possdomains,$roles);
     if ($entry!~/^rolesdef_/) {          foreach my $dom (@{$possdomains}) {
  my ($area,$role)=split(/=/,$entry);              if (($username =~ /^$match_username$/) && ($domain =~ /^$match_domain$/) &&
  $area=~s/\_\w\w$//;                  (ref($privileged{$dom}) eq 'HASH')) {
  my ($trole,$tend,$tstart)=split(/_/,$role);                  foreach my $role (@{$roles}) {
  if (($trole eq 'dc') || ($trole eq 'su')) {                      if (ref($privileged{$dom}{$role}) eq 'HASH') {
     my $active=1;                          if (exists($privileged{$dom}{$role}{$username.':'.$domain})) {
     if ($tend) {                              my ($end,$start) = split(/:/,$privileged{$dom}{$role}{$username.':'.$domain});
  if ($tend<$now) { $active=0; }                              return 1 unless (($end && $end < $now) ||
     }                                               ($start && $start > $now));
     if ($tstart) {                          }
  if ($tstart>$now) { $active=0; }                      }
     }                  }
     if ($active) { return 1; }              }
  }          }
     }      } else {
  }          my %rolesdump = &dump("roles", $domain, $username) or return 0;
           my $now = time;
   
           for my $role (@rolesdump{grep { ! /^rolesdef_/ } keys %rolesdump}) {
               my ($trole, $tend, $tstart) = split(/_/, $role);
               if (grep(/^\Q$trole\E$/,@{$roles})) {
                   return 1 unless ($tend && $tend < $now) 
                           or ($tstart && $tstart > $now);
               }
           }
     }      }
     return 0;      return 0;
 }  }
   
   sub privileged_by_domain {
       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
   
 sub rolesinit {  sub rolesinit {
     my ($domain,$username,$authhost)=@_;      my ($domain, $username) = @_;
     my $now=time;      my %userroles = ('user.login.time' => time);
     my %userroles = ('user.login.time' => $now);      my %rolesdump = &dump("roles", $domain, $username) or return \%userroles;
     my $extra = &freeze_escape({'skipcheck' => 1});  
     my $rolesdump=reply("dump:$domain:$username:roles:.::$extra",$authhost);      # firstaccess and timerinterval are related to timed maps/resources. 
     if (($rolesdump eq 'con_lost') || ($rolesdump eq '') ||       # also, blocking can be triggered by an activating timer
         ($rolesdump =~ /^error:/)) {      # it's saved in the user's %env.
         return \%userroles;      my %firstaccess = &dump('firstaccesstimes', $domain, $username);
       my %timerinterval = &dump('timerinterval', $domain, $username);
       my (%coursetimerstarts, %firstaccchk, %firstaccenv, %coursetimerintervals,
           %timerintchk, %timerintenv);
   
       foreach my $key (keys(%firstaccess)) {
           my ($cid, $rest) = split(/\0/, $key);
           $coursetimerstarts{$cid}{$rest} = $firstaccess{$key};
       }
   
       foreach my $key (keys(%timerinterval)) {
           my ($cid,$rest) = split(/\0/,$key);
           $coursetimerintervals{$cid}{$rest} = $timerinterval{$key};
     }      }
   
     my %allroles=();      my %allroles=();
     my %allgroups=();         my %allgroups=();
     my $group_privs;  
   
     if ($rolesdump ne '') {      for my $area (grep { ! /^rolesdef_/ } keys %rolesdump) {
         foreach my $entry (split(/&/,$rolesdump)) {          my $role = $rolesdump{$area};
   if ($entry!~/^rolesdef_/) {          $area =~ s/\_\w\w$//;
             my ($area,$role)=split(/=/,$entry);  
     $area=~s/\_\w\w$//;          my ($trole, $tend, $tstart, $group_privs);
             my ($trole,$tend,$tstart,$group_privs);  
     if ($role=~/^cr/) {           if ($role =~ /^cr/) {
  if ($role=~m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|) {          # Custom role, defined by a user 
     ($trole,my $trest)=($role=~m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|);          # e.g., user.role.cr/msu/smith/mynewrole
     ($tend,$tstart)=split('_',$trest);              if ($role =~ m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|) {
  } else {                  $trole = $1;
     $trole=$role;                  ($tend, $tstart) = split('_', $2);
  }              } else {
             } elsif ($role =~ m|^gr/|) {                  $trole = $role;
                 ($trole,$tend,$tstart) = split(/_/,$role);  
                 ($trole,$group_privs) = split(/\//,$trole);  
                 $group_privs = &unescape($group_privs);  
     } else {  
  ($trole,$tend,$tstart)=split(/_/,$role);  
     }  
     my %new_role = &set_arearole($trole,$area,$tstart,$tend,$domain,  
  $username);  
     @userroles{keys(%new_role)} = @new_role{keys(%new_role)};  
             if (($tend!=0) && ($tend<$now)) { $trole=''; }  
             if (($tstart!=0) && ($tstart>$now)) { $trole=''; }  
             if (($area ne '') && ($trole ne '')) {  
  my $spec=$trole.'.'.$area;  
  my ($tdummy,$tdomain,$trest)=split(/\//,$area);  
  if ($trole =~ /^cr\//) {  
                     &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);  
                 } elsif ($trole eq 'gr') {  
                     &group_roleprivs(\%allgroups,$area,$group_privs,$tend,$tstart);  
  } else {  
                     &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);  
  }  
             }              }
           }          } elsif ($role =~ m|^gr/|) {
           # Role of member in a group, defined within a course/community
           # e.g., user.role.gr/msu/04935610a19ee4a5fmsul1/leopards
               ($trole, $tend, $tstart) = split(/_/, $role);
               next if $tstart eq '-1';
               ($trole, $group_privs) = split(/\//, $trole);
               $group_privs = &unescape($group_privs);
           } else {
           # Just a normal role, defined in roles.tab
               ($trole, $tend, $tstart) = split(/_/,$role);
           }
   
           my %new_role = &set_arearole($trole,$area,$tstart,$tend,$domain,
                    $username);
           @userroles{keys(%new_role)} = @new_role{keys(%new_role)};
   
           # role expired or not available yet?
           $trole = '' if ($tend != 0 && $tend < $userroles{'user.login.time'}) or 
               ($tstart != 0 && $tstart > $userroles{'user.login.time'});
   
           next if $area eq '' or $trole eq '';
   
           my $spec = "$trole.$area";
           my ($tdummy, $tdomain, $trest) = split(/\//, $area);
   
           if ($trole =~ /^cr\//) {
           # Custom role, defined by a user
               &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);
           } elsif ($trole eq 'gr') {
           # Role of a member in a group, defined within a course/community
               &group_roleprivs(\%allgroups,$area,$group_privs,$tend,$tstart);
               next;
           } else {
           # Normal role, defined in roles.tab
               &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
           }
   
           my $cid = $tdomain.'_'.$trest;
           unless ($firstaccchk{$cid}) {
               if (ref($coursetimerstarts{$cid}) eq 'HASH') {
                   foreach my $item (keys(%{$coursetimerstarts{$cid}})) {
                       $firstaccenv{'course.'.$cid.'.firstaccess.'.$item} = 
                           $coursetimerstarts{$cid}{$item}; 
                   }
               }
               $firstaccchk{$cid} = 1;
           }
           unless ($timerintchk{$cid}) {
               if (ref($coursetimerintervals{$cid}) eq 'HASH') {
                   foreach my $item (keys(%{$coursetimerintervals{$cid}})) {
                       $timerintenv{'course.'.$cid.'.timerinterval.'.$item} =
                          $coursetimerintervals{$cid}{$item};
                   }
               }
               $timerintchk{$cid} = 1;
         }          }
         my ($author,$adv) = &set_userprivs(\%userroles,\%allroles,\%allgroups);  
         $userroles{'user.adv'}    = $adv;  
  $userroles{'user.author'} = $author;  
         $env{'user.adv'}=$adv;  
     }      }
     return \%userroles;    
       @userroles{'user.author', 'user.adv'} = &set_userprivs(\%userroles,
           \%allroles, \%allgroups);
       $env{'user.adv'} = $userroles{'user.adv'};
   
       return (\%userroles,\%firstaccenv,\%timerintenv);
 }  }
   
 sub set_arearole {  sub set_arearole {
     my ($trole,$area,$tstart,$tend,$domain,$username) = @_;      my ($trole,$area,$tstart,$tend,$domain,$username,$nolog) = @_;
       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);
 }  }
   
Line 4255  sub set_userprivs { Line 5208  sub set_userprivs {
     my $adv=0;      my $adv=0;
     my %grouproles = ();      my %grouproles = ();
     if (keys(%{$allgroups}) > 0) {      if (keys(%{$allgroups}) > 0) {
         my @groupkeys;          my @groupkeys; 
         foreach my $role (keys(%{$allroles})) {          foreach my $role (keys(%{$allroles})) {
             push(@groupkeys,$role);              push(@groupkeys,$role);
         }          }
Line 4303  sub set_userprivs { Line 5256  sub set_userprivs {
             }              }
         }          }
         my $thesestr='';          my $thesestr='';
         foreach my $priv (keys(%thesepriv)) {          foreach my $priv (sort(keys(%thesepriv))) {
     $thesestr.=':'.$priv.'&'.$thesepriv{$priv};      $thesestr.=':'.$priv.'&'.$thesepriv{$priv};
  }   }
         $userroles->{'user.priv.'.$role} = $thesestr;          $userroles->{'user.priv.'.$role} = $thesestr;
Line 4312  sub set_userprivs { Line 5265  sub set_userprivs {
 }  }
   
 sub role_status {  sub role_status {
     my ($rolekey,$then,$refresh,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_;      my ($rolekey,$update,$refresh,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_;
     my @pwhere = ();      my @pwhere = ();
     if (exists($env{$rolekey}) && $env{$rolekey} ne '') {      if (exists($env{$rolekey}) && $env{$rolekey} ne '') {
         (undef,undef,$$role,@pwhere)=split(/\./,$rolekey);          (undef,undef,$$role,@pwhere)=split(/\./,$rolekey);
Line 4321  sub role_status { Line 5274  sub role_status {
             $$trolecode=$$role.'.'.$$where;              $$trolecode=$$role.'.'.$$where;
             ($$tstart,$$tend)=split(/\./,$env{$rolekey});              ($$tstart,$$tend)=split(/\./,$env{$rolekey});
             $$tstatus='is';              $$tstatus='is';
             if ($$tstart && $$tstart>$then) {              if ($$tstart && $$tstart>$update) {
                 $$tstatus='future';                  $$tstatus='future';
                 if ($$tstart<$now) {                  if ($$tstart<$now) {
                     if ($$tstart && $$tstart>$refresh) {                      if ($$tstart && $$tstart>$refresh) {
Line 4331  sub role_status { Line 5284  sub role_status {
                             my %userroles = (                              my %userroles = (
                                 'user.role.'.$$role.'.'.$$where => $$tstart.'.'.$$tend                                  'user.role.'.$$role.'.'.$$where => $$tstart.'.'.$$tend
                             );                              );
                             @rolecodes = ('cm');                              @rolecodes = ('cm'); 
                             my $spec=$$role.'.'.$$where;                              my $spec=$$role.'.'.$$where;
                             my ($tdummy,$tdomain,$trest)=split(/\//,$$where);                              my ($tdummy,$tdomain,$trest)=split(/\//,$$where);
                             if ($$role =~ /^cr\//) {                              if ($$role =~ /^cr\//) {
Line 4346  sub role_status { Line 5299  sub role_status {
                                 $group_privs = &unescape($group_privs);                                  $group_privs = &unescape($group_privs);
                                 &group_roleprivs(\%allgroups,$$where,$group_privs,$$tend,$$tstart);                                  &group_roleprivs(\%allgroups,$$where,$group_privs,$$tend,$$tstart);
                                 my %course_roles = &get_my_roles($env{'user.name'},$env{'user.domain'},'userroles',['active'],['cc','co','in','ta','ep','ad','st','cr'],[$tdomain],1);                                  my %course_roles = &get_my_roles($env{'user.name'},$env{'user.domain'},'userroles',['active'],['cc','co','in','ta','ep','ad','st','cr'],[$tdomain],1);
                                 if (keys(%course_roles) > 0) {                                  &get_groups_roles($tdomain,$trest,
                                     my ($tnum) = ($trest =~ /^($match_courseid)/);                                                    \%course_roles,\@rolecodes,
                                     if ($tdomain ne '' && $tnum ne '') {                                                    \%groups_roles);
                                         foreach my $key (keys(%course_roles)) {  
                                             if ($key =~ /^\Q$tnum\E:\Q$tdomain\E:([^:]+):?([^:]*)/) {  
                                                 my $crsrole = $1;  
                                                 my $crssec = $2;  
                                                 if ($crsrole =~ /^cr/) {  
                                                     unless (grep(/^cr$/,@rolecodes)) {  
                                                         push(@rolecodes,'cr');  
                                                     }  
                                                 } else {  
                                                     unless(grep(/^\Q$crsrole\E$/,@rolecodes)) {  
                                                         push(@rolecodes,$crsrole);  
                                                     }  
                                                 }  
                                                 my $rolekey = $crsrole.'./'.$tdomain.'/'.$tnum;  
                                                 if ($crssec ne '') {  
                                                     $rolekey .= '/'.$crssec;  
                                                 }  
                                                 $rolekey .= './';  
                                                 $groups_roles{$rolekey} = \@rolecodes;  
                                             }  
                                         }  
                                     }  
                                 }  
                             } else {                              } else {
                                 push(@rolecodes,$$role);                                  push(@rolecodes,$$role);
                                 &standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where);                                  &standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where);
Line 4385  sub role_status { Line 5315  sub role_status {
                 }                  }
             }              }
             if ($$tend) {              if ($$tend) {
                 if ($$tend<$then) {                  if ($$tend<$update) {
                     $$tstatus='expired';                      $$tstatus='expired';
                 } elsif ($$tend<$now) {                  } elsif ($$tend<$now) {
                     $$tstatus='will_not';                      $$tstatus='will_not';
Line 4395  sub role_status { Line 5325  sub role_status {
     }      }
 }  }
   
   sub get_groups_roles {
       my ($cdom,$rest,$cdom_courseroles,$rolecodes,$groups_roles) = @_;
       return unless((ref($cdom_courseroles) eq 'HASH') && 
                     (ref($rolecodes) eq 'ARRAY') && 
                     (ref($groups_roles) eq 'HASH')); 
       if (keys(%{$cdom_courseroles}) > 0) {
           my ($cnum) = ($rest =~ /^($match_courseid)/);
           if ($cdom ne '' && $cnum ne '') {
               foreach my $key (keys(%{$cdom_courseroles})) {
                   if ($key =~ /^\Q$cnum\E:\Q$cdom\E:([^:]+):?([^:]*)/) {
                       my $crsrole = $1;
                       my $crssec = $2;
                       if ($crsrole =~ /^cr/) {
                           unless (grep(/^cr$/,@{$rolecodes})) {
                               push(@{$rolecodes},'cr');
                           }
                       } else {
                           unless(grep(/^\Q$crsrole\E$/,@{$rolecodes})) {
                               push(@{$rolecodes},$crsrole);
                           }
                       }
                       my $rolekey = "$crsrole./$cdom/$cnum";
                       if ($crssec ne '') {
                           $rolekey .= "/$crssec";
                       }
                       $rolekey .= './';
                       $groups_roles->{$rolekey} = $rolecodes;
                   }
               }
           }
       }
       return;
   }
   
   sub delete_env_groupprivs {
       my ($where,$courseroles,$possroles) = @_;
       return unless((ref($courseroles) eq 'HASH') && (ref($possroles) eq 'ARRAY'));
       my ($dummy,$udom,$uname,$group) = split(/\//,$where);
       unless (ref($courseroles->{$udom}) eq 'HASH') {
           %{$courseroles->{$udom}} =
               &get_my_roles('','','userroles',['active'],
                             $possroles,[$udom],1);
       }
       if (ref($courseroles->{$udom}) eq 'HASH') {
           foreach my $item (keys(%{$courseroles->{$udom}})) {
               my ($cnum,$cdom,$crsrole,$crssec) = split(/:/,$item);
               my $area = '/'.$cdom.'/'.$cnum;
               my $privkey = "user.priv.$crsrole.$area";
               if ($crssec ne '') {
                   $privkey .= '/'.$crssec;
               }
               $privkey .= ".$area/$group";
               &Apache::lonnet::delenv($privkey,undef,[$crsrole]);
           }
       }
       return;
   }
   
 sub check_adhoc_privs {  sub check_adhoc_privs {
     my ($cdom,$cnum,$then,$refresh,$now,$checkrole) = @_;      my ($cdom,$cnum,$update,$refresh,$now,$checkrole,$caller) = @_;
     my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum;      my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum;
       my $setprivs;
     if ($env{$cckey}) {      if ($env{$cckey}) {
         my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend);          my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend);
         &role_status($cckey,$then,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend);          &role_status($cckey,$update,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend);
         unless (($tstatus eq 'is') || ($tstatus eq 'will_not')) {          unless (($tstatus eq 'is') || ($tstatus eq 'will_not')) {
             &set_adhoc_privileges($cdom,$cnum,$checkrole);              &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller);
               $setprivs = 1;
         }          }
     } else {      } else {
         &set_adhoc_privileges($cdom,$cnum,$checkrole);          &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller);
           $setprivs = 1;
     }      }
       return $setprivs;
 }  }
   
 sub set_adhoc_privileges {  sub set_adhoc_privileges {
 # role can be cc or ca  # role can be cc or ca
     my ($dcdom,$pickedcourse,$role) = @_;      my ($dcdom,$pickedcourse,$role,$caller) = @_;
     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'});                                    $env{'user.name'},1);
     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);
     &appenv(\%userroles,[$role,'cm']);      &appenv(\%userroles,[$role,'cm']);
     &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role);      &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role);
     &appenv( {'request.role'        => $spec,      unless ($caller eq 'constructaccess' && $env{'request.course.id'}) {
               'request.role.domain' => $dcdom,          &appenv( {'request.role'        => $spec,
               'request.course.sec'  => ''                    'request.role.domain' => $dcdom,
              }                    'request.course.sec'  => ''
            );                   }
     my $tadv=0;                 );
     if (&allowed('adv') eq 'F') { $tadv=1; }          my $tadv=0;
     &appenv({'request.role.adv'    => $tadv});          if (&allowed('adv') eq 'F') { $tadv=1; }
           &appenv({'request.role.adv'    => $tadv});
       }
 }  }
   
 # --------------------------------------------------------------- get interface  # --------------------------------------------------------------- get interface
Line 4476  sub del { Line 5470  sub del {
   
 # -------------------------------------------------------------- dump interface  # -------------------------------------------------------------- dump interface
   
   sub unserialize {
       my ($rep, $escapedkeys) = @_;
   
       return {} if $rep =~ /^error/;
   
       my %returnhash=();
    foreach my $item (split /\&/, $rep) {
       my ($key, $value) = split(/=/, $item, 2);
       $key = unescape($key) unless $escapedkeys;
       next if $key =~ /^error: 2 /;
       $returnhash{$key} = Apache::lonnet::thaw_unescape($value);
    }
       #return %returnhash;
       return \%returnhash;
   }        
   
   # see Lond::dump_with_regexp
   # if $escapedkeys hash keys won't get unescaped.
 sub dump {  sub dump {
     my ($namespace,$udomain,$uname,$regexp,$range,$extra)=@_;      my ($namespace,$udomain,$uname,$regexp,$range,$escapedkeys)=@_;
     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);
   
       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='.';
     }      }
     my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range:$extra",$uhome);      my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
     my @pairs=split(/\&/,$rep);      my @pairs=split(/\&/,$rep);
     my %returnhash=();      my %returnhash=();
     foreach my $item (@pairs) {      if (!($rep =~ /^error/ )) {
  my ($key,$value)=split(/=/,$item,2);   foreach my $item (@pairs) {
  $key = &unescape($key);      my ($key,$value)=split(/=/,$item,2);
  next if ($key =~ /^error: 2 /);          $key = unescape($key) unless $escapedkeys;
  $returnhash{$key}=&thaw_unescape($value);          #$key = &unescape($key);
       next if ($key =~ /^error: 2 /);
       $returnhash{$key}=&thaw_unescape($value);
    }
     }      }
     return %returnhash;      return %returnhash;
 }  }
   
   
 # --------------------------------------------------------- dumpstore interface  # --------------------------------------------------------- dumpstore interface
   
 sub dumpstore {  sub dumpstore {
    my ($namespace,$udomain,$uname,$regexp,$range)=@_;     my ($namespace,$udomain,$uname,$regexp,$range)=@_;
    if (!$udomain) { $udomain=$env{'user.domain'}; }     # same as dump but keys must be escaped. They may contain colon separated
    if (!$uname) { $uname=$env{'user.name'}; }     # lists of values that may themself contain colons (e.g. symbs).
    my $uhome=&homeserver($uname,$udomain);     return &dump($namespace, $udomain, $uname, $regexp, $range, 1);
    if ($regexp) {  
        $regexp=&escape($regexp);  
    } else {  
        $regexp='.';  
    }  
    my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);  
    my @pairs=split(/\&/,$rep);  
    my %returnhash=();  
    foreach my $item (@pairs) {  
        my ($key,$value)=split(/=/,$item,2);  
        next if ($key =~ /^error: 2 /);  
        $returnhash{$key}=&thaw_unescape($value);  
    }  
    return %returnhash;  
 }  }
   
 # -------------------------------------------------------------- keys interface  # -------------------------------------------------------------- keys interface
Line 4544  sub currentdump { Line 5554  sub currentdump {
    $sdom     = $env{'user.domain'}       if (! defined($sdom));     $sdom     = $env{'user.domain'}       if (! defined($sdom));
    $sname    = $env{'user.name'}         if (! defined($sname));     $sname    = $env{'user.name'}         if (! defined($sname));
    my $uhome = &homeserver($sname,$sdom);     my $uhome = &homeserver($sname,$sdom);
    my $rep=reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome);     my $rep;
   
      if (grep { $_ eq $uhome } current_machine_ids()) {
          $rep = LONCAPA::Lond::dump_profile_database(join(":", ($sdom, $sname, 
                      $courseid)));
      } else {
          $rep = reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome);
      }
   
    return if ($rep =~ /^(error:|no_such_host)/);     return if ($rep =~ /^(error:|no_such_host)/);
    #     #
    my %returnhash=();     my %returnhash=();
Line 4780  sub tmpget { Line 5798  sub tmpget {
     return %returnhash;      return %returnhash;
 }  }
   
 # ------------------------------------------------------------ tmpget interface  # ------------------------------------------------------------ tmpdel interface
 sub tmpdel {  sub tmpdel {
     my ($token,$server)=@_;      my ($token,$server)=@_;
     if (!defined($server)) { $server = $perlvar{'lonHostID'}; }      if (!defined($server)) { $server = $perlvar{'lonHostID'}; }
     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;
           my $idtries = 0;
           while (exists($inuse{$prefix."\0".$newid}) && $idtries < $maxtries) {
               if ($idtype eq 'concat') {
                   $newid = $id.$idtries;
               } 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 {
                $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';
       }
       return ($newid,$dellock,$error);
   }
   
 # -------------------------------------------------- portfolio access checking  # -------------------------------------------------- portfolio access checking
   
 sub portfolio_access {  sub portfolio_access {
Line 5031  sub is_portfolio_file { Line 6131  sub is_portfolio_file {
 }  }
   
 sub usertools_access {  sub usertools_access {
     my ($uname,$udom,$tool,$action,$context,$userenvref,$domdefref,$is_advref) = @_;      my ($uname,$udom,$tool,$action,$context,$userenvref,$domdefref,$is_advref)=@_;
     my ($access,%tools);      my ($access,%tools);
     if ($context eq '') {      if ($context eq '') {
         $context = 'tools';          $context = 'tools';
Line 5042  sub usertools_access { Line 6142  sub usertools_access {
                       unofficial => 1,                        unofficial => 1,
                       community  => 1,                        community  => 1,
                  );                   );
       } elsif ($context eq 'requestauthor') {
           %tools = (
                         requestauthor => 1,
                    );
     } else {      } else {
         %tools = (          %tools = (
                       aboutme   => 1,                        aboutme   => 1,
                       blog      => 1,                        blog      => 1,
                         webdav    => 1,
                       portfolio => 1,                        portfolio => 1,
                  );                   );
     }      }
Line 5060  sub usertools_access { Line 6165  sub usertools_access {
         if ($action ne 'reload') {          if ($action ne 'reload') {
             if ($context eq 'requestcourses') {              if ($context eq 'requestcourses') {
                 return $env{'environment.canrequest.'.$tool};                  return $env{'environment.canrequest.'.$tool};
               } elsif ($context eq 'requestauthor') {
                   return $env{'environment.canrequest.author'};
             } else {              } else {
                 return $env{'environment.availabletools.'.$tool};                  return $env{'environment.availabletools.'.$tool};
             }              }
         }          }
     }      }
   
     my ($toolstatus,$inststatus);      my ($toolstatus,$inststatus,$envkey);
       if ($context eq 'requestauthor') {
           $envkey = $context; 
       } else {
           $envkey = $context.'.'.$tool;
       }
   
     if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) &&      if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) &&
          ($action ne 'reload')) {           ($action ne 'reload')) {
         $toolstatus = $env{'environment.'.$context.'.'.$tool};          $toolstatus = $env{'environment.'.$envkey};
         $inststatus = $env{'environment.inststatus'};          $inststatus = $env{'environment.inststatus'};
     } else {      } else {
         if (ref($userenvref) eq 'HASH') {          if (ref($userenvref) eq 'HASH') {
             $toolstatus = $userenvref->{$context.'.'.$tool};              $toolstatus = $userenvref->{$envkey};
             $inststatus = $userenvref->{'inststatus'};              $inststatus = $userenvref->{'inststatus'};
         } else {          } else {
             my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool,'inststatus');              my %userenv = &userenvironment($udom,$uname,$envkey,'inststatus');
             $toolstatus = $userenv{$context.'.'.$tool};              $toolstatus = $userenv{$envkey};
             $inststatus = $userenv{'inststatus'};              $inststatus = $userenv{'inststatus'};
         }          }
     }      }
Line 5144  sub usertools_access { Line 6256  sub usertools_access {
             }              }
         }          }
     } else {      } else {
         if ($context eq 'tools') {          if (($context eq 'tools') && ($tool ne 'webdav')) {
             $access = 1;              $access = 1;
         } else {          } else {
             $access = 0;              $access = 0;
Line 5178  sub is_advanced_user { Line 6290  sub is_advanced_user {
     my ($udom,$uname) = @_;      my ($udom,$uname) = @_;
     if ($udom ne '' && $uname ne '') {      if ($udom ne '' && $uname ne '') {
         if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {          if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
             return $env{'user.adv'};              if (wantarray) {
                   return ($env{'user.adv'},$env{'user.author'});
               } else {
                   return $env{'user.adv'};
               }
         }          }
     }      }
     my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1);      my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1);
     my %allroles;      my %allroles;
     my $is_adv;      my ($is_adv,$is_author);
     foreach my $role (keys(%roleshash)) {      foreach my $role (keys(%roleshash)) {
         my ($trest,$tdomain,$trole,$sec) = split(/:/,$role);          my ($trest,$tdomain,$trole,$sec) = split(/:/,$role);
         my $area = '/'.$tdomain.'/'.$trest;          my $area = '/'.$tdomain.'/'.$trest;
Line 5197  sub is_advanced_user { Line 6313  sub is_advanced_user {
             } elsif ($trole ne 'gr') {              } elsif ($trole ne 'gr') {
                 &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);                  &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
             }              }
               if ($trole eq 'au') {
                   $is_author = 1;
               }
         }          }
     }      }
     foreach my $role (keys(%allroles)) {      foreach my $role (keys(%allroles)) {
Line 5211  sub is_advanced_user { Line 6330  sub is_advanced_user {
             }              }
         }          }
     }      }
       if (wantarray) {
           return ($is_adv,$is_author);
       }
     return $is_adv;      return $is_adv;
 }  }
   
Line 5481  sub allowed { Line 6603  sub allowed {
         }          }
     }      }
   
   # User who is not author or co-author might still be able to edit
   # resource of an author in the domain (e.g., if Domain Coordinator).
       if (($priv eq 'eco') && ($thisallowed eq '') && ($env{'request.course.id'}) &&
           (&allowed('mdc',$env{'request.course.id'}))) {
           if ($env{"user.priv.cm./$uri/"}=~/\Q$priv\E\&([^\:]*)/) {
               $thisallowed.=$1;
           }
       }
   
 # Course: uri itself is a course  # Course: uri itself is a course
     my $courseuri=$uri;      my $courseuri=$uri;
     $courseuri=~s/\_(\d)/\/$1/;      $courseuri=~s/\_(\d)/\/$1/;
Line 5501  sub allowed { Line 6632  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\&([^\:]*)/) {
                 $thisallowed.=$1;                  my @blockers = &has_comm_blocking($priv,$symb,$uri);
                   if (@blockers > 0) {
                       $thisallowed = 'B';
                   } else {
                       $thisallowed.=$1;
                   }
             }              }
         } else {          } else {
             my $refuri = $env{'httpref.'.$orguri} || $env{'httpref.'.$ver_orguri};              my $refuri = $env{'httpref.'.$orguri} || $env{'httpref.'.$ver_orguri};
Line 5512  sub allowed { Line 6648  sub allowed {
                     $refuri=&declutter($refuri);                      $refuri=&declutter($refuri);
                     my ($match) = &is_on_map($refuri);                      my ($match) = &is_on_map($refuri);
                     if ($match) {                      if ($match) {
                         $thisallowed='F';                          my @blockers = &has_comm_blocking($priv,$symb,$refuri);
                           if (@blockers > 0) {
                               $thisallowed = 'B';
                           } else {
                               $thisallowed='F';
                           }
                     }                      }
                 }                  }
             }              }
Line 5564  sub allowed { Line 6705  sub allowed {
            $statecond=$cond;             $statecond=$cond;
            if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid}             if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid}
                =~/\Q$priv\E\&([^\:]*)/) {                 =~/\Q$priv\E\&([^\:]*)/) {
                $thisallowed.=$1;                 my $value = $1;
                  if ($priv eq 'bre') {
                      my @blockers = &has_comm_blocking($priv,$symb,$uri);
                      if (@blockers > 0) {
                          $thisallowed = 'B';
                      } else {
                          $thisallowed.=$value;
                      }
                  } else {
                      $thisallowed.=$value;
                  }
                $checkreferer=0;                 $checkreferer=0;
            }             }
        }         }
Line 5592  sub allowed { Line 6743  sub allowed {
               my $refstatecond=$cond;                my $refstatecond=$cond;
               if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid}                if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid}
                   =~/\Q$priv\E\&([^\:]*)/) {                    =~/\Q$priv\E\&([^\:]*)/) {
                   $thisallowed.=$1;                    my $value = $1;
                     if ($priv eq 'bre') {
                         my @blockers = &has_comm_blocking($priv,$symb,$refuri);
                         if (@blockers > 0) {
                             $thisallowed = 'B';
                         } else {
                             $thisallowed.=$value;
                         }
                     } else {
                         $thisallowed.=$value;
                     }
                   $uri=$refuri;                    $uri=$refuri;
                   $statecond=$refstatecond;                    $statecond=$refstatecond;
               }                }
Line 5696  sub allowed { Line 6857  sub allowed {
        my $unamedom=$env{'user.name'}.':'.$env{'user.domain'};         my $unamedom=$env{'user.name'}.':'.$env{'user.domain'};
        if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'}         if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'}
    =~/\Q$rolecode\E/) {     =~/\Q$rolecode\E/) {
    if ($priv ne 'pch') {      if (($priv ne 'pch') && ($priv ne 'plc')) { 
        &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.         &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
  'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.   'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
  $env{'request.course.id'});   $env{'request.course.id'});
Line 5706  sub allowed { Line 6867  sub allowed {
   
        if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'}         if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'}
    =~/\Q$unamedom\E/) {     =~/\Q$unamedom\E/) {
    if ($priv ne 'pch') {      if (($priv ne 'pch') && ($priv ne 'plc')) { 
        &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.         &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.
  'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.   'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.
  $env{'request.course.id'});   $env{'request.course.id'});
Line 5720  sub allowed { Line 6881  sub allowed {
    if ($thisallowed=~/R/) {     if ($thisallowed=~/R/) {
        my $rolecode=(split(/\./,$env{'request.role'}))[0];         my $rolecode=(split(/\./,$env{'request.role'}))[0];
        if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) {         if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) {
    if ($priv ne 'pch') {      if (($priv ne 'pch') && ($priv ne 'plc')) { 
        &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.         &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
  'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);   'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
    }     }
Line 5752  sub allowed { Line 6913  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 '';
   }
   
   sub get_comm_blocks {
       my ($cdom,$cnum) = @_;
       if ($cdom eq '' || $cnum eq '') {
           return unless ($env{'request.course.id'});
           $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
           $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
       }
       my %commblocks;
       my $hashid=$cdom.'_'.$cnum;
       my ($blocksref,$cached)=&is_cached_new('comm_block',$hashid);
       if ((defined($cached)) && (ref($blocksref) eq 'HASH')) {
           %commblocks = %{$blocksref};
       } else {
           %commblocks = &Apache::lonnet::dump('comm_block',$cdom,$cnum);
           my $cachetime = 600;
           &do_cache_new('comm_block',$hashid,\%commblocks,$cachetime);
       }
       return %commblocks;
   }
   
   sub has_comm_blocking {
       my ($priv,$symb,$uri,$blocks) = @_;
       return unless ($env{'request.course.id'});
       return unless ($priv eq 'bre');
       return if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/);
       my %commblocks;
       if (ref($blocks) eq 'HASH') {
           %commblocks = %{$blocks};
       } else {
           %commblocks = &get_comm_blocks();
       }
       return unless (keys(%commblocks) > 0);
       if (!$symb) { $symb=&symbread($uri,1); }
       my ($map,$resid,undef)=&decode_symb($symb);
       my %tocheck = (
                       maps      => $map,
                       resources => $symb,
                     );
       my @blockers;
       my $now = time;
       my $navmap = Apache::lonnavmaps::navmap->new();
       foreach my $block (keys(%commblocks)) {
           if ($block =~ /^(\d+)____(\d+)$/) {
               my ($start,$end) = ($1,$2);
               if ($start <= $now && $end >= $now) {
                   if (ref($commblocks{$block}{'blocks'}) eq 'HASH') {
                       if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') {
                           if (ref($commblocks{$block}{'blocks'}{'docs'}{'maps'}) eq 'HASH') {
                               if ($commblocks{$block}{'blocks'}{'docs'}{'maps'}{$map}) {
                                   unless (grep(/^\Q$block\E$/,@blockers)) {
                                       push(@blockers,$block);
                                   }
                               }
                           }
                           if (ref($commblocks{$block}{'blocks'}{'docs'}{'resources'}) eq 'HASH') {
                               if ($commblocks{$block}{'blocks'}{'docs'}{'resources'}{$symb}) {
                                   unless (grep(/^\Q$block\E$/,@blockers)) {  
                                       push(@blockers,$block);
                                   }
                               }
                           }
                       }
                   }
               }
           } elsif ($block =~ /^firstaccess____(.+)$/) {
               my $item = $1;
               my @to_test;
               if (ref($commblocks{$block}{'blocks'}) eq 'HASH') {
                   if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') {
                       my $check_interval;
                       if (&check_docs_block($commblocks{$block}{'blocks'}{'docs'},\%tocheck)) {
                           my @interval;
                           my $type = 'map';
                           if ($item eq 'course') {
                               $type = 'course';
                               @interval=&EXT("resource.0.interval");
                           } else {
                               if ($item =~ /___\d+___/) {
                                   $type = 'resource';
                                   @interval=&EXT("resource.0.interval",$item);
                                   if (ref($navmap)) {                        
                                       my $res = $navmap->getBySymb($item); 
                                       push(@to_test,$res);
                                   }
                               } else {
                                   my $mapsymb = &symbread($item,1);
                                   if ($mapsymb) {
                                       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;
                                               }
                                           }
                                       }
                                   }
                               }
                           }
                           if ($interval[0] =~ /\d+/) {
                               my $first_access;
                               if ($type eq 'resource') {
                                   $first_access=&get_first_access($interval[1],$item);
                               } elsif ($type eq 'map') {
                                   $first_access=&get_first_access($interval[1],undef,$item);
                               } else {
                                   $first_access=&get_first_access($interval[1]);
                               }
                               if ($first_access) {
                                   my $timesup = $first_access+$interval[0];
                                   if ($timesup > $now) {
                                       foreach my $res (@to_test) {
                                           if ($res->is_problem()) {
                                               if ($res->completable()) {
                                                   unless (grep(/^\Q$block\E$/,@blockers)) {
                                                       push(@blockers,$block);
                                                   }
                                                   last;
                                               }
                                           }
                                       }
                                   }
                               }
                           }
                       }
                   }
               }
           }
       }
       return @blockers;
   }
   
   sub check_docs_block {
       my ($docsblock,$tocheck) =@_;
       if ((ref($docsblock) ne 'HASH') || (ref($tocheck) ne 'HASH')) {
           return;
       }
       if (ref($docsblock->{'maps'}) eq 'HASH') {
           if ($tocheck->{'maps'}) {
               if ($docsblock->{'maps'}{$tocheck->{'maps'}}) {
                   return 1;
               }
           }
       }
       if (ref($docsblock->{'resources'}) eq 'HASH') {
           if ($tocheck->{'resources'}) {
               if ($docsblock->{'resources'}{$tocheck->{'resources'}}) {
                   return 1;
               }
           }
       }
       return;
   }
   
   #
   #   Removes the versino from a URI and
   #   splits it in to its filename and path to the filename.
   #   Seems like File::Basename could have done this more clearly.
   #   Parameters:
   #      $uri   - input URI
   #   Returns:
   #     Two element list consisting of 
   #     $pathname  - the URI up to and excluding the trailing /
   #     $filename  - The part of the URI following the last /
   #  NOTE:
   #    Another realization of this is simply:
   #    use File::Basename;
   #    ...
   #    $uri = shift;
   #    $filename = basename($uri);
   #    $path     = dirname($uri);
   #    return ($filename, $path);
   #
   #     The implementation below is probably faster however.
   #
 sub split_uri_for_cond {  sub split_uri_for_cond {
     my $uri=&deversion(&declutter(shift));      my $uri=&deversion(&declutter(shift));
     my @uriparts=split(/\//,$uri);      my @uriparts=split(/\//,$uri);
Line 5947  sub fetch_enrollment_query { Line 7353  sub fetch_enrollment_query {
                 $$replyref{$key} = $value;                  $$replyref{$key} = $value;
             }              }
         } else {          } else {
             my $pathname = $perlvar{'lonDaemons'}.'/tmp';              my $pathname = LONCAPA::tempdir();
             foreach my $line (@responses) {              foreach my $line (@responses) {
                 my ($key,$value) = split(/=/,$line);                  my ($key,$value) = split(/=/,$line);
                 $$replyref{$key} = $value;                  $$replyref{$key} = $value;
Line 5977  sub fetch_enrollment_query { Line 7383  sub fetch_enrollment_query {
   
 sub get_query_reply {  sub get_query_reply {
     my $queryid=shift;      my $queryid=shift;
     my $replyfile=$perlvar{'lonDaemons'}.'/tmp/'.$queryid;      my $replyfile=LONCAPA::tempdir().$queryid;
     my $reply='';      my $reply='';
     for (1..100) {      for (1..100) {
  sleep 2;   sleep 2;
Line 6073  sub auto_get_sections { Line 7479  sub auto_get_sections {
 }  }
   
 sub auto_new_course {  sub auto_new_course {
     my ($cnum,$cdom,$inst_course_id,$owner) = @_;      my ($cnum,$cdom,$inst_course_id,$owner,$coowners) = @_;
     my $homeserver = &homeserver($cnum,$cdom);      my $homeserver = &homeserver($cnum,$cdom);
     my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.$owner.':'.$cdom,$homeserver));      my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.&escape($owner).':'.$cdom.':'.&escape($coowners),$homeserver));
     return $response;      return $response;
 }  }
   
Line 6099  sub auto_validate_instcode { Line 7505  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) = map { &unescape($_); } split('&',$response,2);      my ($outcome,$description,$defaultcredits) = map { &unescape($_); } split('&',$response,3);
     return ($outcome,$description);      return ($outcome,$description,$defaultcredits);
 }  }
   
 sub auto_create_password {  sub auto_create_password {
Line 6466  sub get_users_groups { Line 7872  sub get_users_groups {
     } else {        } else {  
         $grouplist = '';          $grouplist = '';
         my $courseurl = &courseid_to_courseurl($courseid);          my $courseurl = &courseid_to_courseurl($courseid);
         my $extra = &freeze_escape({'skipcheck' => 1});          my %roleshash = &dump('roles',$udom,$uname,$courseurl);
         my %roleshash = &dump('roles',$udom,$uname,$courseurl,undef,$extra);  
         my $access_end = $env{'course.'.$courseid.          my $access_end = $env{'course.'.$courseid.
                               '.default_enrollment_end_date'};                                '.default_enrollment_end_date'};
         my $now = time;          my $now = time;
Line 6639  sub assignrole { Line 8044  sub assignrole {
                             }                              }
                         }                          }
                     }                      }
                   } elsif ($context eq 'requestauthor') {
                       if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) && 
                           ($url eq '/'.$udom.'/') && ($role eq 'au')) {
                           if ($env{'environment.requestauthor'} eq 'automatic') {
                               $refused = '';
                           } else {
                               my %domdefaults = &get_domain_defaults($udom);
                               if (ref($domdefaults{'requestauthor'}) eq 'HASH') {
                                   my $checkbystatus;
                                   if ($env{'user.adv'}) { 
                                       my $disposition = $domdefaults{'requestauthor'}{'_LC_adv'};
                                       if ($disposition eq 'automatic') {
                                           $refused = '';
                                       } elsif ($disposition eq '') {
                                           $checkbystatus = 1;
                                       } 
                                   } else {
                                       $checkbystatus = 1;
                                   }
                                   if ($checkbystatus) {
                                       if ($env{'environment.inststatus'}) {
                                           my @inststatuses = split(/,/,$env{'environment.inststatus'});
                                           foreach my $type (@inststatuses) {
                                               if (($type ne '') &&
                                                   ($domdefaults{'requestauthor'}{$type} eq 'automatic')) {
                                                   $refused = '';
                                               }
                                           }
                                       } elsif ($domdefaults{'requestauthor'}{'default'} eq 'automatic') {
                                           $refused = '';
                                       }
                                   }
                               }
                           }
                       }
                 }                  }
                 if ($refused) {                  if ($refused) {
                     &logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.                      &logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.
Line 6647  sub assignrole { Line 8087  sub assignrole {
                     return 'refused';                      return 'refused';
                 }                  }
             }              }
           } elsif ($role eq 'au') {
               if ($url ne '/'.$udom.'/') {
                   &logthis('Attempt by '.$env{'user.name'}.':'.$env{'user.domain'}.
                            ' to assign author role for '.$uname.':'.$udom.
                            ' in domain: '.$url.' refused (wrong domain).');
                   return 'refused';
               }
         }          }
         $mrole=$role;          $mrole=$role;
     }      }
Line 6681  sub assignrole { Line 8128  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);
           if (($role eq 'cc') || ($role eq 'in') ||
               ($role eq 'ep') || ($role eq 'ad') ||
               ($role eq 'ta') || ($role eq 'st') ||
               ($role=~/^cr/) || ($role eq 'gr') ||
               ($role eq 'co')) {
 # for course roles, perform group memberships changes triggered by role change.  # for course roles, perform group memberships changes triggered by role change.
         &courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,$selfenroll,$context);              unless ($role =~ /^gr/) {
         unless ($role =~ /^gr/) {                  &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend,
             &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend,                                                   $origstart,$selfenroll,$context);
                                              $origstart,$selfenroll,$context);              }
               &courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
                              $selfenroll,$context);
           } elsif (($role eq 'li') || ($role eq 'dg') || ($role eq 'sc') ||
                    ($role eq 'au') || ($role eq 'dc')) {
               &domainrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
                              $context);
           } elsif (($role eq 'ca') || ($role eq 'aa')) {
               &coauthorrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
                                $context); 
         }          }
         if ($role eq 'cc') {          if ($role eq 'cc') {
             &autoupdate_coowners($url,$end,$start,$uname,$udom);              &autoupdate_coowners($url,$end,$start,$uname,$udom);
Line 6821  sub modifyuser { Line 8282  sub modifyuser {
     }      }
     &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.      &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
              $umode.', '.$first.', '.$middle.', '.               $umode.', '.$first.', '.$middle.', '.
              $last.', '.$gene.'(forceid: '.$forceid.'; candelete: '.$showcandelete.')'.       $last.', '.$gene.'(forceid: '.$forceid.'; candelete: '.$showcandelete.')'.
              (defined($desiredhome) ? ' desiredhome = '.$desiredhome :               (defined($desiredhome) ? ' desiredhome = '.$desiredhome :
                                      ' desiredhome not specified').                                        ' desiredhome not specified'). 
              ' by '.$env{'user.name'}.' at '.$env{'user.domain'}.               ' by '.$env{'user.name'}.' at '.$env{'user.domain'}.
Line 6967  sub modifyuser { Line 8428  sub modifyuser {
         return 'ok';          return 'ok';
     }      }
     my $reply = &put('environment', \%names, $udom,$uname);      my $reply = &put('environment', \%names, $udom,$uname);
     if ($reply ne 'ok') {      if ($reply ne 'ok') { 
         return 'error: '.$reply;          return 'error: '.$reply;
     }      }
     if ($names{'permanentemail'} ne $oldnames{'permanentemail'}) {      if ($names{'permanentemail'} ne $oldnames{'permanentemail'}) {
Line 6985  sub modifyuser { Line 8446  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)=@_;          $selfenroll,$context,$inststatus,$credits)=@_;
     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 7000  sub modifystudent { Line 8461  sub modifystudent {
     # students 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,$cid,$selfenroll,$context);                                          $gene,$usec,$end,$start,$type,$locktype,
                                           $cid,$selfenroll,$context,$credits);
     return $reply;      return $reply;
 }  }
   
 sub modify_student_enrollment {  sub modify_student_enrollment {
     my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid,$selfenroll,$context) = @_;      my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,
           $locktype,$cid,$selfenroll,$context,$credits) = @_;
     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 7048  sub modify_student_enrollment { Line 8511  sub modify_student_enrollment {
         $uid    = $tmp{'id'}         if (!defined($uid)    || $uid  eq '');          $uid    = $tmp{'id'}         if (!defined($uid)    || $uid  eq '');
     }      }
     my $fullname = &format_name($first,$middle,$last,$gene,'lastname');      my $fullname = &format_name($first,$middle,$last,$gene,'lastname');
       my $user = "$uname:$udom";
       my %old_entry = &Apache::lonnet::get('classlist',[$user],$cdom,$cnum);
     my $reply=cput('classlist',      my $reply=cput('classlist',
    {"$uname:$udom" =>      {$user => 
  join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) },   join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype,$credits) },
    $cdom,$cnum);     $cdom,$cnum);
     unless (($reply eq 'ok') || ($reply eq 'delayed')) {      if (($reply eq 'ok') || ($reply eq 'delayed')) {
           &devalidate_getsection_cache($udom,$uname,$cid);
       } else { 
  return 'error: '.$reply;   return 'error: '.$reply;
     } else {  
  &devalidate_getsection_cache($udom,$uname,$cid);  
     }      }
     # Add student role to user      # Add student role to user
     my $uurl='/'.$cid;      my $uurl='/'.$cid;
Line 7063  sub modify_student_enrollment { Line 8528  sub modify_student_enrollment {
     if ($usec) {      if ($usec) {
  $uurl.='/'.$usec;   $uurl.='/'.$usec;
     }      }
     return &assignrole($udom,$uname,$uurl,'st',$end,$start,undef,$selfenroll,$context);      my $result = &assignrole($udom,$uname,$uurl,'st',$end,$start,undef,
                                $selfenroll,$context);
       if ($result ne 'ok') {
           if ($old_entry{$user} ne '') {
               $reply = &cput('classlist',\%old_entry,$cdom,$cnum);
           } else {
               $reply = &del('classlist',[$user],$cdom,$cnum);
           }
       }
       return $result; 
 }  }
   
 sub format_name {  sub format_name {
Line 7262  sub generate_coursenum { Line 8736  sub generate_coursenum {
 }  }
   
 sub is_course {  sub is_course {
     my ($cdom,$cnum) = @_;      my ($cdom, $cnum) = scalar(@_) == 1 ? 
     my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,           ($_[0] =~ /^($match_domain)_($match_courseid)$/)  :  @_;
  undef,'.');  
     if (exists($courses{$cdom.'_'.$cnum})) {      return unless $cdom and $cnum;
         return 1;  
     }      my %courses = &courseiddump($cdom, '.', 1, '.', '.', $cnum, undef, undef,
     return 0;          '.');
   
       return unless(exists($courses{$cdom.'_'.$cnum}));
       return wantarray ? ($cdom, $cnum) : $cdom.'_'.$cnum;
 }  }
   
 sub store_userdata {  sub store_userdata {
Line 7292  sub store_userdata { Line 8769  sub store_userdata {
                     $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';                      $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
                 }                  }
                 $namevalue=~s/\&$//;                  $namevalue=~s/\&$//;
                 $result =  &reply("store:$env{'user.domain'}:$env{'user.name'}:".                  unless ($namespace eq 'courserequests') {
                                   "$namespace:$datakey:$namevalue",$uhome);                      $datakey = &escape($datakey);
                   }
                   $result =  &reply("store:$udom:$uname:$namespace:$datakey:".
                                     $namevalue,$uhome);
             }              }
         } else {          } else {
             $result = 'error: data to store was not a hash reference';               $result = 'error: data to store was not a hash reference'; 
Line 7346  sub diskusage { Line 8826  sub diskusage {
 }  }
   
 sub is_locked {  sub is_locked {
     my ($file_name, $domain, $user) = @_;      my ($file_name, $domain, $user, $which) = @_;
     my @check;      my @check;
     my $is_locked;      my $is_locked;
     push @check, $file_name;      push (@check,$file_name);
     my %locked = &get('file_permissions',\@check,      my %locked = &get('file_permissions',\@check,
       $env{'user.domain'},$env{'user.name'});        $env{'user.domain'},$env{'user.name'});
     my ($tmp)=keys(%locked);      my ($tmp)=keys(%locked);
Line 7358  sub is_locked { Line 8838  sub is_locked {
     if (ref($locked{$file_name}) eq 'ARRAY') {      if (ref($locked{$file_name}) eq 'ARRAY') {
         $is_locked = 'false';          $is_locked = 'false';
         foreach my $entry (@{$locked{$file_name}}) {          foreach my $entry (@{$locked{$file_name}}) {
            if (ref($entry) eq 'ARRAY') {              if (ref($entry) eq 'ARRAY') {
                $is_locked = 'true';                 $is_locked = 'true';
                last;                 if (ref($which) eq 'ARRAY') {
                      push(@{$which},$entry);
                  } else {
                      last;
                  }
            }             }
        }         }
     } else {      } else {
         $is_locked = 'false';          $is_locked = 'false';
     }      }
       return $is_locked;
 }  }
   
 sub declutter_portfile {  sub declutter_portfile {
Line 7409  sub save_selected_files { Line 8894  sub save_selected_files {
 sub clear_selected_files {  sub clear_selected_files {
     my ($user) = @_;      my ($user) = @_;
     my $filename = $user."savedfiles";      my $filename = $user."savedfiles";
     open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);      open (OUT, '>'.LONCAPA::tempdir().$filename);
     print (OUT undef);      print (OUT undef);
     close (OUT);      close (OUT);
     return ("ok");          return ("ok");    
Line 7419  sub files_in_path { Line 8904  sub files_in_path {
     my ($user, $path) = @_;      my ($user, $path) = @_;
     my $filename = $user."savedfiles";      my $filename = $user."savedfiles";
     my %return_files;      my %return_files;
     open (IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);      open (IN, '<'.LONCAPA::tempdir().$filename);
     while (my $line_in = <IN>) {      while (my $line_in = <IN>) {
         chomp ($line_in);          chomp ($line_in);
         my @paths_and_file = split (m!/!, $line_in);          my @paths_and_file = split (m!/!, $line_in);
Line 7441  sub files_not_in_path { Line 8926  sub files_not_in_path {
     my $filename = $user."savedfiles";      my $filename = $user."savedfiles";
     my @return_files;      my @return_files;
     my $path_part;      my $path_part;
     open(IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);      open(IN, '<'.LONCAPA::.$filename);
     while (my $line = <IN>) {      while (my $line = <IN>) {
         #ok, I know it's clunky, but I want it to work          #ok, I know it's clunky, but I want it to work
         my @paths_and_file = split(m|/|, $line);          my @paths_and_file = split(m|/|, $line);
Line 7789  sub dirlist { Line 9274  sub dirlist {
   
     if($udom) {      if($udom) {
         if($uname) {          if($uname) {
               my $uhome = &homeserver($uname,$udom);
               if ($uhome eq 'no_host') {
                   return ([],'no_host');
               }
             $listing = &reply('ls3:'.&escape('/'.$uri).':'.$getpropath.':'              $listing = &reply('ls3:'.&escape('/'.$uri).':'.$getpropath.':'
                               .$getuserdir.':'.&escape($dirRoot)                                .$getuserdir.':'.&escape($dirRoot)
                               .':'.&escape($uname).':'.&escape($udom),                                .':'.&escape($uname).':'.&escape($udom),$uhome);
                               &homeserver($uname,$udom));  
             if ($listing eq 'unknown_cmd') {              if ($listing eq 'unknown_cmd') {
                 $listing = &reply('ls2:'.$dirRoot.'/'.$uri,                  $listing = &reply('ls2:'.$dirRoot.'/'.$uri,$uhome);
                                   &homeserver($uname,$udom));  
             } else {              } else {
                 @listing_results = map { &unescape($_); } split(/:/,$listing);                  @listing_results = map { &unescape($_); } split(/:/,$listing);
             }              }
             if ($listing eq 'unknown_cmd') {              if ($listing eq 'unknown_cmd') {
                 $listing = &reply('ls:'.$dirRoot.'/'.$uri,                  $listing = &reply('ls:'.$dirRoot.'/'.$uri,$uhome);
   &homeserver($uname,$udom));  
                 @listing_results = split(/:/,$listing);                  @listing_results = split(/:/,$listing);
             } else {              } else {
                 @listing_results = map { &unescape($_); } split(/:/,$listing);                  @listing_results = map { &unescape($_); } split(/:/,$listing);
             }              }
             return @listing_results;              if (($listing eq 'no_such_host') || ($listing eq 'con_lost') || 
                   ($listing eq 'rejected') || ($listing eq 'refused') ||
                   ($listing eq 'no_such_dir') || ($listing eq 'empty')) {
                   return ([],$listing);
               } else {
                   return (\@listing_results);
               }
         } elsif(!$alternateRoot) {          } elsif(!$alternateRoot) {
             my %allusers;              my (%allusers,%listerror);
     my %servers = &get_servers($udom,'library');      my %servers = &get_servers($udom,'library');
      foreach my $tryserver (keys(%servers)) {       foreach my $tryserver (keys(%servers)) {
                 $listing = &reply('ls3:'.&escape("/res/$udom").':::::'.                  $listing = &reply('ls3:'.&escape("/res/$udom").':::::'.
Line 7827  sub dirlist { Line 9319  sub dirlist {
     @listing_results =      @listing_results =
  map { &unescape($_); } split(/:/,$listing);   map { &unescape($_); } split(/:/,$listing);
  }   }
  if ($listing_results[0] ne 'no_such_dir' &&                   if (($listing eq 'no_such_host') || ($listing eq 'con_lost') ||
     $listing_results[0] ne 'empty'       &&                      ($listing eq 'rejected') || ($listing eq 'refused') ||
     $listing_results[0] ne 'con_lost') {                      ($listing eq 'no_such_dir') || ($listing eq 'empty')) {
                       $listerror{$tryserver} = $listing;
                   } else {
     foreach my $line (@listing_results) {      foreach my $line (@listing_results) {
  my ($entry) = split(/&/,$line,2);   my ($entry) = split(/&/,$line,2);
  $allusers{$entry} = 1;   $allusers{$entry} = 1;
     }      }
  }   }
             }              }
             my $alluserstr='';              my @alluserslist=();
             foreach my $user (sort(keys(%allusers))) {              foreach my $user (sort(keys(%allusers))) {
                 $alluserstr.=$user.'&user:';                  push(@alluserslist,$user.'&user');
             }              }
             $alluserstr=~s/:$//;              return (\@alluserslist);
             return split(/:/,$alluserstr);  
         } else {          } else {
             return ('missing user name');              return ([],'missing username');
         }          }
     } elsif(!defined($getpropath)) {      } elsif(!defined($getpropath)) {
         my @all_domains = sort(&all_domains());          my $path = $perlvar{'lonDocRoot'}.'/res/'; 
         foreach my $domain (@all_domains) {          my @all_domains = map { $path.$_.'/&domain'; } (sort(&all_domains()));
             $domain = $perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain';          return (\@all_domains);
         }  
         return @all_domains;  
     } else {      } else {
         return ('missing domain');          return ([],'missing domain');
     }      }
 }  }
   
Line 7865  sub GetFileTimestamp { Line 9356  sub GetFileTimestamp {
     my ($studentDomain,$studentName,$filename,$getuserdir)=@_;      my ($studentDomain,$studentName,$filename,$getuserdir)=@_;
     $studentDomain = &LONCAPA::clean_domain($studentDomain);      $studentDomain = &LONCAPA::clean_domain($studentDomain);
     $studentName   = &LONCAPA::clean_username($studentName);      $studentName   = &LONCAPA::clean_username($studentName);
     my ($fileStat) =       my ($fileref,$error) = &dirlist($filename,$studentDomain,$studentName,
         &Apache::lonnet::dirlist($filename,$studentDomain,$studentName,                                       undef,$getuserdir);
                                  undef,$getuserdir);      if (($error eq 'empty') || ($error eq 'no_such_dir')) {
     my @stats = split('&', $fileStat);          return -1;
     if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {      }
       if (ref($fileref) eq 'ARRAY') {
           my @stats = split('&',$fileref->[0]);
         # @stats contains first the filename, then the stat output          # @stats contains first the filename, then the stat output
         return $stats[10]; # so this is 10 instead of 9.          return $stats[10]; # so this is 10 instead of 9.
     } else {      } else {
Line 7901  sub stat_file { Line 9394  sub stat_file {
     if ($file =~ /^userfiles\//) {      if ($file =~ /^userfiles\//) {
         $getpropath = 1;          $getpropath = 1;
     }      }
     my ($result) = &dirlist($file,$udom,$uname,$getpropath);      my ($listref,$error) = &dirlist($file,$udom,$uname,$getpropath);
     my @stats = split('&', $result);      if (($error eq 'empty') || ($error eq 'no_such_dir')) {
               return ();
     if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {      } else {
  shift(@stats); #filename is first          if (ref($listref) eq 'ARRAY') {
  return @stats;              my @stats = split('&',$listref->[0]);
       shift(@stats); #filename is first
       return @stats;
           }
     }      }
     return ();      return ();
 }  }
Line 8227  sub EXT { Line 9723  sub EXT {
    } elsif ($realm eq 'request') {     } elsif ($realm eq 'request') {
 # ------------------------------------------------------------- request.browser  # ------------------------------------------------------------- request.browser
         if ($space eq 'browser') {          if ($space eq 'browser') {
     if ($qualifier eq 'textremote') {              return $env{'browser.'.$qualifier};
  if (&Apache::lonlocal::mt('textual_remote_display') eq 'on') {  
     return 1;  
  } else {  
     return 0;  
  }  
     } else {  
  return $env{'browser.'.$qualifier};  
     }  
 # ------------------------------------------------------------ request.filename  # ------------------------------------------------------------ request.filename
         } else {          } else {
             return $env{'request.'.$spacequalifierrest};              return $env{'request.'.$spacequalifierrest};
Line 8508  sub add_prefix_and_part { Line 9996  sub add_prefix_and_part {
 # ---------------------------------------------------------------- Get metadata  # ---------------------------------------------------------------- Get metadata
   
 my %metaentry;  my %metaentry;
   my %importedpartids;
 sub metadata {  sub metadata {
     my ($uri,$what,$liburi,$prefix,$depthcount)=@_;      my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
     $uri=&declutter($uri);      $uri=&declutter($uri);
     # 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|/bulletinboard$|)) ||       ($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard)$})) ||
         ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) ) {          ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) {
  return undef;   return undef;
     }      }
     if (($uri =~ /^~/ || $uri =~ m{home/$match_username/public_html/})       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 8534  sub metadata { Line 10023  sub metadata {
  if (defined($cached)) { return $result->{':'.$what}; }   if (defined($cached)) { return $result->{':'.$what}; }
     }      }
     {      {
   # Imported parts would go here
           my %importedids=();
           my @origfileimportpartids=();
           my $importedparts=0;
 #  #
 # Is this a recursive call for a library?  # Is this a recursive call for a library?
 #  #
Line 8551  sub metadata { Line 10044  sub metadata {
         my %metathesekeys=();          my %metathesekeys=();
         unless ($filename=~/\.meta$/) { $filename.='.meta'; }          unless ($filename=~/\.meta$/) { $filename.='.meta'; }
  my $metastring;   my $metastring;
  if ($uri =~ /^~/ || $uri =~ m{home/$match_username/public_html/}) {   if ($uri =~ /^priv/ || $uri=~/home\/httpd\/html\/priv/) {
     my $which = &hreflocation('','/'.($liburi || $uri));      my $which = &hreflocation('','/'.($liburi || $uri));
     $metastring =       $metastring = 
  &Apache::lonnet::ssi_body($which,   &Apache::lonnet::ssi_body($which,
   ('grade_target' => 'meta'));    ('grade_target' => 'meta'));
     $cachetime = 1; # only want this cached in the child not long term      $cachetime = 1; # only want this cached in the child not long term
  } elsif ($uri !~ m -^(editupload)/-) {   } elsif (($uri !~ m -^(editupload)/-) && 
                    ($uri !~ m{^/*uploaded/$match_domain/$match_courseid/docs/})) {
     my $file=&filelocation('',&clutter($filename));      my $file=&filelocation('',&clutter($filename));
     #push(@{$metaentry{$uri.'.file'}},$file);      #push(@{$metaentry{$uri.'.file'}},$file);
     $metastring=&getfile($file);      $metastring=&getfile($file);
Line 8617  sub metadata { Line 10111  sub metadata {
 # This is not a package - some other kind of start tag  # This is not a package - some other kind of start tag
 #  #
     my $entry=$token->[1];      my $entry=$token->[1];
     my $unikey;      my $unikey='';
     if ($entry eq 'import') {  
  $unikey='';  
     } else {  
  $unikey=$entry;  
     }  
     $unikey.=&add_prefix_and_part($prefix,$token->[2]->{'part'});  
   
     if (defined($token->[2]->{'id'})) {   
  $unikey.='_'.$token->[2]->{'id'};   
     }  
   
     if ($entry eq 'import') {      if ($entry eq 'import') {
 #  #
 # Importing a library here  # Importing a library here
 #  #
                           my $location=$parser->get_text('/import');
                           my $dir=$filename;
                           $dir=~s|[^/]*$||;
                           $location=&filelocation($dir,$location);
                          
                           my $importmode=$token->[2]->{'importmode'};
                           if ($importmode eq 'problem') {
   # Import as problem/response
                              $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});
                           } elsif ($importmode eq 'part') {
   # Import as part(s)
                              $importedparts=1;
   # We need to get the original file and the imported file to get the part order correct
   # Good news: we do not need to worry about nested libraries, since parts cannot be nested
   # Load and inspect original file
                              if ($#origfileimportpartids<0) {
                                 undef(%importedpartids);
                                 my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri);
                                 my $origfile=&getfile($origfilelocation);
                                 @origfileimportpartids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
                              }
   
   # Load and inspect imported file
                              my $impfile=&getfile($location);
                              my @impfilepartids=($impfile=~/<part[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
                              if ($#impfilepartids>=0) {
   # This problem had parts
                                  $importedpartids{$token->[2]->{'id'}}=join(',',@impfilepartids);
                              } else {
   # Importing by turning a single problem into a problem part
   # It gets the import-tags ID as part-ID
                                  $unikey=&add_prefix_and_part($prefix,$token->[2]->{'id'});
                                  $importedpartids{$token->[2]->{'id'}}=$token->[2]->{'id'};
                              }
                           } else {
   # Normal import
                              $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});
                              if (defined($token->[2]->{'id'})) {
                                 $unikey.='_'.$token->[2]->{'id'};
                              }
                           }
   
  if ($depthcount<20) {   if ($depthcount<20) {
     my $location=$parser->get_text('/import');  
     my $dir=$filename;  
     $dir=~s|[^/]*$||;  
     $location=&filelocation($dir,$location);  
     my $metadata =       my $metadata = 
  &metadata($uri,'keys', $location,$unikey,   &metadata($uri,'keys', $location,$unikey,
   $depthcount+1);    $depthcount+1);
Line 8645  sub metadata { Line 10167  sub metadata {
  $metaentry{':'.$meta}=$metaentry{':'.$meta};   $metaentry{':'.$meta}=$metaentry{':'.$meta};
  $metathesekeys{$meta}=1;   $metathesekeys{$meta}=1;
     }      }
  }  
     } else {                           }
       } else {
   #
   # Not importing, some other kind of non-package, non-library start tag
   # 
                           $unikey=$entry.&add_prefix_and_part($prefix,$token->[2]->{'part'});
                           if (defined($token->[2]->{'id'})) {
                               $unikey.='_'.$token->[2]->{'id'};
                           }
  if (defined($token->[2]->{'name'})) {    if (defined($token->[2]->{'name'})) { 
     $unikey.='_'.$token->[2]->{'name'};       $unikey.='_'.$token->[2]->{'name'}; 
  }   }
Line 8720  sub metadata { Line 10250  sub metadata {
     grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'}));      grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'}));
  $metaentry{':packages'} = join(',',@uniq_packages);   $metaentry{':packages'} = join(',',@uniq_packages);
   
           if ($importedparts) {
   # We had imported parts and need to rebuild partorder
              $metaentry{':partorder'}='';
              $metathesekeys{'partorder'}=1;
              for (my $index=0;$index<$#origfileimportpartids;$index+=2) {
                  if ($origfileimportpartids[$index] eq 'part') {
   # original part, part of the problem
                     $metaentry{':partorder'}.=','.$origfileimportpartids[$index+1];
                  } else {
   # we have imported parts at this position
                     $metaentry{':partorder'}.=','.$importedpartids{$origfileimportpartids[$index+1]};
                  }
              }
              $metaentry{':partorder'}=~s/^\,//;
           }
   
  $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);
Line 8822  sub gettitle { Line 10368  sub gettitle {
  }   }
  $title=~s/\&colon\;/\:/gs;   $title=~s/\&colon\;/\:/gs;
  if ($title) {   if ($title) {
   # Remember both $symb and $title for dynamic metadata
               $accesshash{$symb.'___crstitle'}=$title;
               $accesshash{&declutter($map).'___'.&declutter($url).'___usage'}=time;
   # Cache this title and then return it
     return &do_cache_new('title',$key,$title,600);      return &do_cache_new('title',$key,$title,600);
  }   }
  $urlsymb=$url;   $urlsymb=$url;
Line 8854  sub get_slot { Line 10404  sub get_slot {
     }      }
     return $slotinfo{$which};      return $slotinfo{$which};
 }  }
   
   sub get_reservable_slots {
       my ($cnum,$cdom,$uname,$udom) = @_;
       my $now = time;
       my $reservable_info;
       my $key=join("\0",'reservableslots',$cdom,$cnum,$uname,$udom);
       if (exists($remembered{$key})) {
           $reservable_info = $remembered{$key};
       } else {
           my %resv;
           ($resv{'now_order'},$resv{'now'},$resv{'future_order'},$resv{'future'}) =
           &Apache::loncommon::get_future_slots($cnum,$cdom,$now);
           $reservable_info = \%resv;
           $remembered{$key} = $reservable_info;
       }
       return $reservable_info;
   }
   
   sub get_course_slots {
       my ($cnum,$cdom) = @_;
       my $hashid=$cnum.':'.$cdom;
       my ($result,$cached) = &Apache::lonnet::is_cached_new('allslots',$hashid);
       if (defined($cached)) {
           if (ref($result) eq 'HASH') {
               return %{$result};
           }
       } else {
           my %slots=&Apache::lonnet::dump('slots',$cdom,$cnum);
           my ($tmp) = keys(%slots);
           if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
               &do_cache_new('allslots',$hashid,\%slots,600);
               return %slots;
           }
       }
       return;
   }
   
   sub devalidate_slots_cache {
       my ($cnum,$cdom)=@_;
       my $hashid=$cnum.':'.$cdom;
       &devalidate_cache_new('allslots',$hashid);
   }
   
   sub get_coursechange {
       my ($cdom,$cnum) = @_;
       if ($cdom eq '' || $cnum eq '') {
           return unless ($env{'request.course.id'});
           $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
           $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
       }
       my $hashid=$cdom.'_'.$cnum;
       my ($change,$cached)=&is_cached_new('crschange',$hashid);
       if ((defined($cached)) && ($change ne '')) {
           return $change;
       } else {
           my %crshash;
           %crshash = &get('environment',['internal.contentchange'],$cdom,$cnum);
           if ($crshash{'internal.contentchange'} eq '') {
               $change = $env{'course.'.$cdom.'_'.$cnum.'.internal.created'};
               if ($change eq '') {
                   %crshash = &get('environment',['internal.created'],$cdom,$cnum);
                   $change = $crshash{'internal.created'};
               }
           } else {
               $change = $crshash{'internal.contentchange'};
           }
           my $cachetime = 600;
           &do_cache_new('crschange',$hashid,$change,$cachetime);
       }
       return $change;
   }
   
   sub devalidate_coursechange_cache {
       my ($cnum,$cdom)=@_;
       my $hashid=$cnum.':'.$cdom;
       &devalidate_cache_new('crschange',$hashid);
   }
   
 # ------------------------------------------------- Update symbolic store links  # ------------------------------------------------- Update symbolic store links
   
 sub symblist {  sub symblist {
Line 8881  sub symblist { Line 10509  sub symblist {
 # --------------------------------------------------------------- Verify a symb  # --------------------------------------------------------------- Verify a symb
   
 sub symbverify {  sub symbverify {
     my ($symb,$thisurl)=@_;      my ($symb,$thisurl,$encstate)=@_;
     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 8900  sub symbverify { Line 10528  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;  
            $ids=$bighash{'ids_/'.$thisurl};              $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)) {
                          $$encstate = $bighash{'encrypted_'.$id};
                      }
    if (($env{'request.role.adv'}) ||     if (($env{'request.role.adv'}) ||
        $bighash{'encrypted_'.$id} eq $env{'request.enc'}) {         ($bighash{'encrypted_'.$id} eq $env{'request.enc'}) ||
        $okay=1;                          ($thisurl eq '/adm/navmaps')) {
          $okay=1;
                          last;
    }     }
        }         }
    }     }
Line 8995  sub deversion { Line 10640  sub deversion {
   
 sub symbread {  sub symbread {
     my ($thisfn,$donotrecurse)=@_;      my ($thisfn,$donotrecurse)=@_;
     my $cache_str='request.symbread.cached.'.$thisfn;      my $cache_str;
     if (defined($env{$cache_str})) { return $env{$cache_str}; }      if ($thisfn ne '') {
           $cache_str='request.symbread.cached.'.$thisfn;
           if ($env{$cache_str} ne '') {
               return $env{$cache_str};
           }
       } else {
 # no filename provided? try from environment  # no filename provided? try from environment
     unless ($thisfn) {  
         if ($env{'request.symb'}) {          if ($env{'request.symb'}) {
     return $env{$cache_str}=&symbclean($env{'request.symb'});      return $env{$cache_str}=&symbclean($env{'request.symb'});
  }   }
Line 9193  sub getCODE { Line 10842  sub getCODE {
     }      }
     return undef;      return undef;
 }  }
   #
   #  Determines the random seed for a specific context:
   #
   # parameters:
   #   symb      - in course context the symb for the seed.
   #   course_id - The course id of the form domain_coursenum.
   #   domain    - Domain for the user.
   #   course    - Course for the user.
   #   cenv      - environment of the course.
   #
   # NOTE:
   #   All parameters are picked out of the environment if missing
   #   or not defined.
   #   If a symb cannot be determined the current time is used instead.
   #
   #  For a given well defined symb, courside, domain, username,
   #  and course environment, the seed is reproducible.
   #
 sub rndseed {  sub rndseed {
     my ($symb,$courseid,$domain,$username)=@_;      my ($symb,$courseid,$domain,$username, $cenv)=@_;
     my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser();      my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser();
     if (!defined($symb)) {      if (!defined($symb)) {
  unless ($symb=$wsymb) { return time; }   unless ($symb=$wsymb) { return time; }
     }      }
     if (!$courseid) { $courseid=$wcourseid; }      if (!defined $courseid) { 
     if (!$domain) { $domain=$wdomain; }   $courseid=$wcourseid; 
     if (!$username) { $username=$wusername }      }
     my $which=&get_rand_alg();      if (!defined $domain) { $domain=$wdomain; }
       if (!defined $username) { $username=$wusername }
   
       my $which;
       if (defined($cenv->{'rndseed'})) {
    $which = $cenv->{'rndseed'};
       } else {
    $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 9529  sub getfile { Line 11203  sub getfile {
   
 sub repcopy_userfile {  sub repcopy_userfile {
     my ($file)=@_;      my ($file)=@_;
     if ($file =~ m -^/*(uploaded|editupload)/-) { $file=&filelocation("",$file); }      my $londocroot = $perlvar{'lonDocRoot'};
     if ($file =~ m|^/home/httpd/html/lonUsers/|) { return 'ok'; }      if ($file =~ m{^/*(uploaded|editupload)/}) { $file=&filelocation("",$file); }
       if ($file =~ m{^\Q/home/httpd/lonUsers/\E}) { return 'ok'; }
     my ($cdom,$cnum,$filename) =       my ($cdom,$cnum,$filename) = 
  ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_name)/+(.*)|);   ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_name)/+(.*)|);
     my $uri="/uploaded/$cdom/$cnum/$filename";      my $uri="/uploaded/$cdom/$cnum/$filename";
Line 9659  sub filelocation { Line 11334  sub filelocation {
  $file=~s-^/adm/coursedocs/showdoc/-/-;   $file=~s-^/adm/coursedocs/showdoc/-/-;
     }      }
   
     if ($file=~m:^/~:) { # is a contruction space reference      if ($file =~ m-^\Q$Apache::lonnet::perlvar{'lonTabDir'}\E/-) {
         $location = $file;  
         $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;  
     } elsif ($file=~m{^/home/$match_username/public_html/}) {  
  # is a correct contruction space reference  
         $location = $file;  
     } elsif ($file =~ m-^\Q$Apache::lonnet::perlvar{'lonTabDir'}\E/-) {  
         $location = $file;          $location = $file;
     } elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file      } elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file
         my ($udom,$uname,$filename)=          my ($udom,$uname,$filename)=
Line 9675  sub filelocation { Line 11344  sub filelocation {
         my @ids=&current_machine_ids();          my @ids=&current_machine_ids();
         foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }          foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }
         if ($is_me) {          if ($is_me) {
      $location=&propath($udom,$uname).'/userfiles/'.$filename;       $location=propath($udom,$uname).'/userfiles/'.$filename;
         } else {          } else {
    $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.     $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.
        $udom.'/'.$uname.'/'.$filename;         $udom.'/'.$uname.'/'.$filename;
Line 9684  sub filelocation { Line 11353  sub filelocation {
  $location = $perlvar{'lonDocRoot'}.'/'.$file;   $location = $perlvar{'lonDocRoot'}.'/'.$file;
     } else {      } else {
         $file=~s/^\Q$perlvar{'lonDocRoot'}\E//;          $file=~s/^\Q$perlvar{'lonDocRoot'}\E//;
         $file=~s:^/res/:/:;          $file=~s:^/(res|priv)/:/:;
           my $space=$1;
         if ( !( $file =~ m:^/:) ) {          if ( !( $file =~ m:^/:) ) {
             $location = $dir. '/'.$file;              $location = $dir. '/'.$file;
         } else {          } else {
             $location = '/home/httpd/html/res'.$file;              $location = $perlvar{'lonDocRoot'}.'/'.$space.$file;
         }          }
     }      }
     $location=~s://+:/:g; # remove duplicate /      $location=~s://+:/:g; # remove duplicate /
Line 9713  sub hreflocation { Line 11383  sub hreflocation {
     }      }
     if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) {      if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) {
  $file=~s-^\Q$perlvar{'lonDocRoot'}\E--;   $file=~s-^\Q$perlvar{'lonDocRoot'}\E--;
     } elsif ($file=~m-/home/($match_username)/public_html/-) {  
  $file=~s-^/home/($match_username)/public_html/-/~$1/-;  
     } elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) {      } elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) {
  $file=~s-^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/   $file=~s{^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/}
     -/uploaded/$1/$2/-x;          {/uploaded/$1/$2/}x;
     }      }
     if ($file=~ m{^/userfiles/}) {      if ($file=~ m{^/userfiles/}) {
  $file =~ s{^/userfiles/}{/uploaded/};   $file =~ s{^/userfiles/}{/uploaded/};
Line 9725  sub hreflocation { Line 11393  sub hreflocation {
     return $file;      return $file;
 }  }
   
   
   
   
   
 sub current_machine_domains {  sub current_machine_domains {
     return &machine_domains(&hostname($perlvar{'lonHostID'}));      return &machine_domains(&hostname($perlvar{'lonHostID'}));
 }  }
Line 9790  sub declutter { Line 11462  sub declutter {
     $thisfn=~s|^adm/wrapper/||;      $thisfn=~s|^adm/wrapper/||;
     $thisfn=~s|^adm/coursedocs/showdoc/||;      $thisfn=~s|^adm/coursedocs/showdoc/||;
     $thisfn=~s/^res\///;      $thisfn=~s/^res\///;
       $thisfn=~s/^priv\///;
     unless (($thisfn =~ /^ext/) || ($thisfn =~ /\.(page|sequence)___\d+___ext/)) {      unless (($thisfn =~ /^ext/) || ($thisfn =~ /\.(page|sequence)___\d+___ext/)) {
         $thisfn=~s/\?.+$//;          $thisfn=~s/\?.+$//;
     }      }
Line 9889  sub goodbye { Line 11562  sub goodbye {
 }  }
   
 sub get_dns {  sub get_dns {
     my ($url,$func,$ignore_cache) = @_;      my ($url,$func,$ignore_cache,$nocache,$hashref) = @_;
     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);      &$func($content,$hashref);
     return;      return;
  }   }
     }      }
Line 9913  sub get_dns { Line 11586  sub get_dns {
     while (%alldns) {      while (%alldns) {
  my ($dns) = keys(%alldns);   my ($dns) = keys(%alldns);
  my $ua=new LWP::UserAgent;   my $ua=new LWP::UserAgent;
           $ua->timeout(30);
  my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");   my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");
  my $response=$ua->request($request);   my $response=$ua->request($request);
         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);
  &Apache::lonnet::do_cache_new('dns',$url,\@content,30*24*60*60);   unless ($nocache) {
  &$func(\@content);      &do_cache_new('dns',$url,\@content,30*24*60*60);
    }
    &$func(\@content,$hashref);
  return;   return;
     }      }
     close($config);      close($config);
Line 9927  sub get_dns { Line 11603  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);      &$func(\@content,$hashref);
       return;
   }
   
   # ------------------------------------------------------Get DNS checksums file
   sub parse_dns_checksums_tab {
       my ($lines,$hashref) = @_;
       my $machine_dom = &Apache::lonnet::host_domain($perlvar{'lonHostID'});
       my $loncaparev = &get_server_loncaparev($machine_dom);
       my ($release,$timestamp) = split(/\-/,$loncaparev);
       my (%chksum,%revnum);
       if (ref($lines) eq 'ARRAY') {
           chomp(@{$lines});
           my $versions = shift(@{$lines});
           my %supported;
           if ($versions =~ /^VERSIONS\:([\w\.\,]+)$/) {
               my $releaseslist = $1;
               if ($releaseslist =~ /,/) {
                   map { $supported{$_} = 1; } split(/,/,$releaseslist);
               } elsif ($releaseslist) {
                   $supported{$releaseslist} = 1;
               }
           }
           if ($supported{$release}) {  
               my $matchthis = 0;
               foreach my $line (@{$lines}) {
                   if ($line =~ /^(\d[\w\.]+)$/) {
                       if ($matchthis) {
                           last;
                       } elsif ($1 eq $release) {
                           $matchthis = 1;
                       }
                   } elsif ($matchthis) {
                       my ($file,$version,$shasum) = split(/,/,$line);
                       $chksum{$file} = $shasum;
                       $revnum{$file} = $version;
                   }
               }
               if (ref($hashref) eq 'HASH') {
                   %{$hashref} = (
                                   sums     => \%chksum,
                                   versions => \%revnum,
                                 );
               }
           }
       }
     return;      return;
 }  }
   
   sub fetch_dns_checksums {
       my %checksums; 
       &get_dns('/adm/dns/checksums',\&parse_dns_checksums_tab,1,1,
                \%checksums);
       return \%checksums;
   }
   
 # ------------------------------------------------------------ Read domain file  # ------------------------------------------------------------ Read domain file
 {  {
     my $loaded;      my $loaded;
Line 9997  sub get_dns { Line 11726  sub get_dns {
     my $loaded;      my $loaded;
     my %name_to_host;      my %name_to_host;
     my %internetdom;      my %internetdom;
       my %LC_dns_serv;
   
     sub parse_hosts_tab {      sub parse_hosts_tab {
  my ($file) = @_;   my ($file) = @_;
  foreach my $configline (@$file) {   foreach my $configline (@$file) {
     next if ($configline =~ /^(\#|\s*$ )/x);      next if ($configline =~ /^(\#|\s*$ )/x);
     next if ($configline =~ /^\^/);              chomp($configline);
     chomp($configline);      if ($configline =~ /^\^/) {
                   if ($configline =~ /^\^([\w.\-]+)/) {
                       $LC_dns_serv{$1} = 1;
                   }
                   next;
               }
     my ($id,$domain,$role,$name,$protocol,$intdom)=split(/:/,$configline);      my ($id,$domain,$role,$name,$protocol,$intdom)=split(/:/,$configline);
     $name=~s/\s//g;      $name=~s/\s//g;
     if ($id && $domain && $role && $name) {      if ($id && $domain && $role && $name) {
Line 10085  sub get_dns { Line 11820  sub get_dns {
     }      }
   
     sub unique_library {      sub unique_library {
         #2x reverse removes all hostnames that appear more than once   #2x reverse removes all hostnames that appear more than once
         my %unique = reverse &all_library();          my %unique = reverse &all_library();
         return reverse %unique;          return reverse %unique;
     }      }
Line 10115  sub get_dns { Line 11850  sub get_dns {
   
     sub get_unique_servers {      sub get_unique_servers {
         my %unique = reverse &get_servers(@_);          my %unique = reverse &get_servers(@_);
         return reverse %unique;   return reverse %unique;
     }      }
   
     sub host_domain {      sub host_domain {
Line 10139  sub get_dns { Line 11874  sub get_dns {
         my ($lonid) = @_;          my ($lonid) = @_;
         return $internetdom{$lonid};          return $internetdom{$lonid};
     }      }
   
       sub is_LC_dns {
           &load_hosts_tab() if (!$loaded);
   
           my ($hostname) = @_;
           return exists($LC_dns_serv{$hostname});
       }
   
 }  }
   
 {   { 
Line 10225  sub get_dns { Line 11968  sub get_dns {
     }      }
     push(@{$iphost{$ip}},@{$name_to_host{$name}});      push(@{$iphost{$ip}},@{$name_to_host{$name}});
  }   }
  &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 10283  sub get_dns { Line 12026  sub get_dns {
             }              }
             $seen{$prim_ip} = 1;              $seen{$prim_ip} = 1;
         }          }
         return &Apache::lonnet::do_cache_new('internetnames',$lonid,\@idns,12*60*60);          return &do_cache_new('internetnames',$lonid,\@idns,12*60*60);
     }      }
   
 }  }
Line 10414  BEGIN { Line 12157  BEGIN {
     }      }
 }  }
   
   # ---------------------------------------------------------- Read managers table
   {
       if (-e "$perlvar{'lonTabDir'}/managers.tab") {
           if (open(my $config,"<$perlvar{'lonTabDir'}/managers.tab")) {
               while (my $configline=<$config>) {
                   chomp($configline);
                   next if ($configline =~ /^\#/);
                   if (($configline =~ /^[\w\-]+$/) || ($configline =~ /^[\w\-]+\:[\w\-]+$/)) {
                       $managerstab{$configline} = 1;
                   }
               }
               close($config);
           }
       }
   }
   
 # ------------- set up temporary directory  # ------------- set up temporary directory
 {  {
     $tmpdir = $perlvar{'lonDaemons'}.'/tmp/';      $tmpdir = LONCAPA::tempdir();
   
 }  }
   
Line 10437  $readit=1; Line 12196  $readit=1;
  if ($test != 0) { $_64bit=1; } else { $_64bit=0; }   if ($test != 0) { $_64bit=1; } else { $_64bit=0; }
  &logthis(" Detected 64bit platform ($_64bit)");   &logthis(" Detected 64bit platform ($_64bit)");
     }      }
   
       {
           eval {
               ($apache) =
                   (Apache2::ServerUtil::get_server_version() =~ m{Apache/(\d+\.\d+)});
           };
           if ($@) {
              $apache = 1.3;
           }
       }
   
 }  }
 }  }
   
Line 10577  were new keys. I.E. 1:foo will become 1: Line 12347  were new keys. I.E. 1:foo will become 1:
   
 Calling convention:  Calling convention:
   
  my %record=&Apache::lonnet::restore($symb,$courseid,$domain,$uname,$home);   my %record=&Apache::lonnet::restore($symb,$courseid,$domain,$uname);
  &Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname,$home);   &Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname);
   
 For more detailed information, see lonnet specific documentation.  For more detailed information, see lonnet specific documentation.
   
Line 10651  $checkdefauth is optional (value is 1 if Line 12421  $checkdefauth is optional (value is 1 if
    authenticate user using default authentication method, and allow     authenticate user using default authentication method, and allow
    account creation if username does not have account in the domain).     account creation if username does not have account in the domain).
 $clientcancheckhost is optional (value is 1 if checking whether the  $clientcancheckhost is optional (value is 1 if checking whether the
    server can host will occur on the client side in lonauth.pm).     server can host will occur on the client side in lonauth.pm).   
   
 =item *  =item *
 X<homeserver()>  X<homeserver()>
Line 10677  B<idput($udom,%ids)>: store away a list Line 12447  B<idput($udom,%ids)>: store away a list
   
 =item *  =item *
 X<rolesinit()>  X<rolesinit()>
 B<rolesinit($udom,$username,$authhost)>: get user privileges  B<rolesinit($udom,$username)>: get user privileges.
   returns user role, first access and timer interval hashes
   
   =item *
   X<privileged()>
   B<privileged($username,$domain)>: returns a true if user has a
   privileged and active role (i.e. su or dc), false otherwise.
   
 =item *  =item *
 X<getsection()>  X<getsection()>
Line 10718  allowed($priv,$uri,$symb,$role) : check Line 12494  allowed($priv,$uri,$symb,$role) : check
   
 =item *  =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 *
   
 definerole($rolename,$sysrole,$domrole,$courole) : define role; define a custom  definerole($rolename,$sysrole,$domrole,$courole) : define role; define a custom
 role rolename set privileges in format of lonTabs/roles.tab for system, domain,  role rolename set privileges in format of lonTabs/roles.tab for system, domain,
 and course level  and course level
Line 10734  environment).  If no custom name is defi Line 12525  environment).  If no custom name is defi
         
 =item *  =item *
   
 get_my_roles($uname,$udom,$context,$types,$roles,$roledoms,$withsec) :  get_my_roles($uname,$udom,$context,$types,$roles,$roledoms,$withsec,$hidepriv) :
 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 10748  of role statuses (active, future or prev Line 12539  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 10840  Inputs: Line 12666  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 10885  Inputs: Line 12713  Inputs:
   
 =item $context  =item $context
   
   =item $credits, number of credits student will earn from this class
   
 =back  =back
   
   
Line 10910  revokecustomrole($udom,$uname,$url,$role Line 12740  revokecustomrole($udom,$uname,$url,$role
   
 =item *  =item *
   
 coursedescription($courseid) : returns a hash of information about the  coursedescription($courseid,$options) : returns a hash of information about the
 specified course id, including all environment settings for the  specified course id, including all environment settings for the
 course, the description of the course will be in the hash under the  course, the description of the course will be in the hash under the
 key 'description'  key 'description'
   
   $options is an optional parameter that if supplied is a hash reference that controls
   what how this function works.  It has the following key/values:
   
   =over 4
   
   =item freshen_cache
   
   If defined, and the environment cache for the course is valid, it is 
   returned in the returned hash.
   
   =item one_time
   
   If defined, the last cache time is set to _now_
   
   =item user
   
   If defined, the supplied username is used instead of the current user.
   
   
   =back
   
 =item *  =item *
   
 resdata($name,$domain,$type,@which) : request for current parameter  resdata($name,$domain,$type,@which) : request for current parameter
Line 10929  data base, returning a hash that is keye Line 12780  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.
   
   
 =back  =back
   
 =head2 Course Modification  =head2 Course Modification
Line 10949  createcourse($udom,$description,$url,$co Line 12799  createcourse($udom,$description,$url,$co
   
 generate_coursenum($udom,$crstype) : get a unique (unused) course number in domain $udom for course type $crstype (Course or Community).  generate_coursenum($udom,$crstype) : get a unique (unused) course number in domain $udom for course type $crstype (Course or Community).
   
   =item *
   
   is_course($courseid), is_course($cdom, $cnum)
   
   Accepts either a combined $courseid (in the form of domain_courseid) or the
   two component version $cdom, $cnum. It checks if the specified course exists.
   
   Returns:
       undef if the course doesn't exist, otherwise
       in scalar context the combined courseid.
       in list context the two components of the course identifier, domain and 
       courseid.    
   
 =back  =back
   
 =head2 Resource Subroutines  =head2 Resource Subroutines
Line 11017  returns the data handle Line 12880  returns the data handle
   
 =item *  =item *
   
 symbverify($symb,$thisfn) : verifies that $symb actually exists and is  symbverify($symb,$thisfn,$encstate) : verifies that $symb actually exists
 a possible symb for the URL in $thisfn, and if is an encryypted  and is a possible symb for the URL in $thisfn, and if is an encrypted
 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 existance of  on failure, user must be in a course, as it assumes the existence of
 the course initial hash, and uses $env('request.course.id'}  the course initial hash, and uses $env('request.course.id'}.  The third
   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 11075  expirespread($uname,$udom,$stype,$usymb) Line 12940  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 11245  or lonTabs/domain.tab. Line 13138  or lonTabs/domain.tab.
   
 =item *  =item *
   
 dirlist($uri) : return directory list based on URI  dirlist() : return directory list based on URI (first arg).
   
   Inputs: 1 required, 5 optional.
   
   =over
   
   =item 
   $uri - path to file in filesystem (starts: /res or /userfiles/). Required.
   
   =item
   $userdomain - domain of user/course to be listed. Extracted from $uri if absent. 
   
   =item
   $username -  username of user/course to be listed. Extracted from $uri if absent. 
   
   =item
   $getpropath - boolean: 1 if prepend path using &propath(). 
   
   =item
   $getuserdir - boolean: 1 if prepend path for "userfiles".
   
   =item 
   $alternateRoot - path to prepend in place of path from $uri.
   
   =back
   
   Returns: Array of up to two items.
   
   =over
   
   a reference to an array of files/subdirectories
   
   =over
   
   Each element in the array of files/subdirectories is a & separated list of
   item name and the result of running stat on the item.  If dirlist was requested
   for a file instead of a directory, the item name will be ''. For a directory 
   listing, if the item is a metadata file, the element will end &N&M 
   (where N amd M are either 0 or 1, corresponding to obsolete set (1), or
   default copyright set (1).  
   
   =back
   
   a scalar containing error condition (if encountered).
   
   =over
   
   =item 
   no_host (no homeserver identified for $username:$domain).
   
   =item 
   no_such_host (server contacted for listing not identified as valid host).
   
   =item 
   con_lost (connection to remote server failed).
   
   =item 
   refused (invalid $username:$domain received on lond side).
   
   =item 
   no_such_dir (directory at specified path on lond side does not exist). 
   
   =item 
   empty (directory at specified path on lond side is empty).
   
   =over
   
   This is currently not encountered because the &ls3, &ls2, 
   &ls (_handler) routines on the lond side do not filter out
   . and .. from a directory listing. 
   
   =back
   
   =back
   
   =back
   
 =item *  =item *
   
Line 11307  splitting on '&', supports elements that Line 13275  splitting on '&', supports elements that
   
 =head2 Logging Routines  =head2 Logging Routines
   
 =over 4  
   
 These routines allow one to make log messages in the lonnet.log and  These routines allow one to make log messages in the lonnet.log and
 lonnet.perm logfiles.  lonnet.perm logfiles.
   
   =over 4
   
 =item *  =item *
   
 logtouch() : make sure the logfile, lonnet.log, exists  logtouch() : make sure the logfile, lonnet.log, exists
Line 11327  logperm() : append a permanent message t Line 13296  logperm() : append a permanent message t
 file never gets deleted by any automated portion of the system, only  file never gets deleted by any automated portion of the system, only
 messages of critical importance should go in here.  messages of critical importance should go in here.
   
   
 =back  =back
   
 =head2 General File Helper Routines  =head2 General File Helper Routines
Line 11400  userfileupload(): main rotine for puttin Line 13370  userfileupload(): main rotine for puttin
            filename, and the contents of the file to create/modifed exist             filename, and the contents of the file to create/modifed exist
            the filename is in $env{'form.'.$formname.'.filename'} and the             the filename is in $env{'form.'.$formname.'.filename'} and the
            contents of the file is located in $env{'form.'.$formname}             contents of the file is located in $env{'form.'.$formname}
  coursedoc - if true, store the file in the course of the active role   context - if coursedoc, store the file in the course of the active role
              of the current user               of the current user; 
              if 'existingfile': store in 'overwrites' in /home/httpd/perl/tmp
              if 'canceloverwrite': delete file in tmp/overwrites directory
  subdir - required - subdirectory to put the file in under ../userfiles/   subdir - required - subdirectory to put the file in under ../userfiles/
          if undefined, it will be placed in "unknown"           if undefined, it will be placed in "unknown"
   
Line 11423  returns: the new clean filename Line 13395  returns: the new clean filename
   
 =item *  =item *
   
 finishuserfileupload(): routine that creaes and sends the file to  finishuserfileupload(): routine that creates and sends the file to
 userspace, probably shouldn't be called directly  userspace, probably shouldn't be called directly
   
   docuname: username or courseid of destination for the file    docuname: username or courseid of destination for the file
   docudom: domain of user/course of destination for the file    docudom: domain of user/course of destination for the file
   formname: same as for userfileupload()    formname: same as for userfileupload()
   fname: filename (inculding subdirectories) for the file    fname: filename (including subdirectories) for the file
     parser: if 'parse', will parse (html) file to extract references to objects, links etc.
     allfiles: reference to hash used to store objects found by parser
     codebase: reference to hash used for codebases of java objects found by parser
     thumbwidth: width (pixels) of thumbnail to be created for uploaded image
     thumbheight: height (pixels) of thumbnail to be created for uploaded image
     resizewidth: width to be used to resize image using resizeImage from ImageMagick
     resizeheight: height to be used to resize image using resizeImage from ImageMagick
     context: if 'overwrite', will move the uploaded file from its temporary location to
               userfiles to facilitate overwriting a previously uploaded file with same name.
     mimetype: reference to scalar to accommodate mime type determined
               from File::MMagic if $parser = parse.
   
  returns either the url of the uploaded file (/uploaded/....) if successful   returns either the url of the uploaded file (/uploaded/....) if successful
  and /adm/notfound.html if unsuccessful   and /adm/notfound.html if unsuccessful (or an error message if context 
    was 'overwrite').
    
   
 =item *  =item *
   
Line 11538  Internal notes: Line 13523  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 11555  Returns: Line 13542  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.1056.4.11  
changed lines
  Added in v.1.1225

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