[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.1070 and 1.1138

version 1.1070, 2010/06/04 00:14:15 version 1.1138, 2011/10/17 17:23:29
Line 76  use HTTP::Date; Line 76  use HTTP::Date;
 use Image::Magick;  use Image::Magick;
   
 use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir  use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir
             $_64bit %env %protocol);              $_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 96  use File::MMagic; Line 97  use File::MMagic;
 use LONCAPA qw(:DEFAULT :match);  use LONCAPA qw(:DEFAULT :match);
 use LONCAPA::Configuration;  use LONCAPA::Configuration;
   
   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 195  sub get_server_timezone { Line 198  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) = @_;      my ($dom,$lonhost,$ignore_cache,$caller) = @_;
     if (defined($lonhost)) {      if (defined($lonhost)) {
         if (!defined(&hostname($lonhost))) {          if (!defined(&hostname($lonhost))) {
             undef($lonhost);              undef($lonhost);
Line 211  sub get_server_loncaparev { Line 237  sub get_server_loncaparev {
         }          }
     }      }
     if (defined($lonhost)) {      if (defined($lonhost)) {
         my $cachetime = 24*3600;          my $cachetime = 12*3600;
         my ($loncaparev,$cached)=&is_cached_new('serverloncaparev',$lonhost);          if (!$ignore_cache) {
               my ($loncaparev,$cached)=&is_cached_new('serverloncaparev',$lonhost);
               if (defined($cached)) {
                   return $loncaparev;
               }
           }
           my ($answer,$loncaparev);
           my @ids=&current_machine_ids();
           if (grep(/^\Q$lonhost\E$/,@ids)) {
               $answer = $perlvar{'lonVersion'};
               if ($answer =~ /^[\'\"]?([\w.\-]+)[\'\"]?$/) {
                   $loncaparev = $1;
               }
           } else {
               $answer = &reply('serverloncaparev',$lonhost);
               if (($answer eq 'unknown_cmd') || ($answer eq 'con_lost')) {
                   if ($caller eq 'loncron') {
                       my $ua=new LWP::UserAgent;
                       $ua->timeout(4);
                       my $protocol = $protocol{$lonhost};
                       $protocol = 'http' if ($protocol ne 'https');
                       my $url = $protocol.'://'.&hostname($lonhost).'/adm/about.html';
                       my $request=new HTTP::Request('GET',$url);
                       my $response=$ua->request($request);
                       unless ($response->is_error()) {
                           my $content = $response->content;
                           if ($content =~ /<p>VERSION\:\s*([\w.\-]+)<\/p>/) {
                               $loncaparev = $1;
                           }
                       }
                   } else {
                       $loncaparev = $loncaparevs{$lonhost};
                   }
               } elsif ($answer =~ /^[\'\"]?([\w.\-]+)[\'\"]?$/) {
                   $loncaparev = $1;
               }
           }
           return &do_cache_new('serverloncaparev',$lonhost,$loncaparev,$cachetime);
       }
   }
   
   sub get_server_homeID {
       my ($hostname,$ignore_cache,$caller) = @_;
       unless ($ignore_cache) {
           my ($serverhomeID,$cached)=&is_cached_new('serverhomeID',$hostname);
         if (defined($cached)) {          if (defined($cached)) {
             return $loncaparev;              return $serverhomeID;
           }
       }
       my $cachetime = 12*3600;
       my $serverhomeID;
       if ($caller eq 'loncron') { 
           my @machine_ids = &machine_ids($hostname);
           foreach my $id (@machine_ids) {
               my $response = &reply('serverhomeID',$id);
               unless (($response eq 'unknown_cmd') || ($response eq 'con_lost')) {
                   $serverhomeID = $response;
                   last;
               }
           }
           if ($serverhomeID eq '') {
               $serverhomeID = $machine_ids[-1];
           }
       } else {
           $serverhomeID = $serverhomeIDs{$hostname};
       }
       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 {          } else {
             my $loncaparev = &reply('serverloncaparev',$lonhost);              my $requested = &freeze_escape(\%whatneeded);
             return &do_cache_new('serverloncaparev',$lonhost,$loncaparev,$cachetime);              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
Line 552  sub appenv { Line 683  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 668  sub userload { Line 808  sub userload {
 # ------------------------------ 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);
     foreach my $try_server (@{ $spareid{'primary'} }) {      if (($udom ne '') && (&domain($udom) ne '')) {
  ($spare_server, $lowest_load) =          my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
     &compare_server_load($try_server, $spare_server, $lowest_load);          $uint_dom = &Apache::lonnet::internet_dom($uprimary_id);
     }          my %udomdefaults = &Apache::lonnet::get_domain_defaults($udom);
           $remotesessions = $udomdefaults{'remotesessions'};
     my $found_server = ($spare_server ne '' && $lowest_load < 100);      }
       my $spareshash = &this_host_spares($udom);
       if (ref($spareshash) eq 'HASH') {
           if (ref($spareshash->{'primary'}) eq 'ARRAY') {
               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);
               }
           }
   
     if (!$found_server) {          my $found_server = ($spare_server ne '' && $lowest_load < 100);
  foreach my $try_server (@{ $spareid{'default'} }) {  
     ($spare_server, $lowest_load) =          if (!$found_server) {
  &compare_server_load($try_server, $spare_server, $lowest_load);              if (ref($spareshash->{'default'}) eq 'ARRAY') { 
  }          foreach my $try_server (@{ $spareshash->{'default'} }) {
                       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);
                   }
       }
           }
     }      }
   
     if (!$want_server_name) {      if (!$want_server_name) {
Line 695  sub spareserver { Line 856  sub spareserver {
         }          }
         if (defined($spare_server)) {          if (defined($spare_server)) {
             my $hostname = &hostname($spare_server);              my $hostname = &hostname($spare_server);
             if (defined($hostname)) {                if (defined($hostname)) {
         $spare_server = $protocol.'://'.$hostname;          $spare_server = $protocol.'://'.$hostname;
             }              }
         }          }
Line 710  sub compare_server_load { Line 871  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/) {
  next; #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 736  sub compare_server_load { Line 897  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 753  sub has_user_session { Line 923  sub has_user_session {
     return 0;      return 0;
 }  }
   
   # --------- determine least loaded server in a user's domain which allows login
   
   sub choose_server {
       my ($udom,$checkloginvia) = @_;
       my %domconfhash = &Apache::loncommon::get_domainconf($udom);
       my %servers = &get_servers($udom);
       my $lowest_load = 30000;
       my ($login_host,$hostname,$portal_path);
       foreach my $lonhost (keys(%servers)) {
           my $loginvia;
           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;
                   }
               } else {
                   ($login_host, $lowest_load) =
                       &compare_server_load($lonhost, $login_host, $lowest_load);
                   if ($login_host eq $lonhost) {
                       $portal_path = '';
                   }
               }
           } else {
               ($login_host, $lowest_load) =
                   &compare_server_load($lonhost, $login_host, $lowest_load);
           }
       }
       if ($login_host ne '') {
           $hostname = &hostname($login_host);
       }
       return ($login_host,$hostname,$portal_path);
   }
   
 # --------------------------------------------- Try to change a user's password  # --------------------------------------------- Try to change a user's password
   
 sub changepass {  sub changepass {
Line 811  sub queryauthenticate { Line 1018  sub queryauthenticate {
 # --------- Try to authenticate user from domain's lib servers (first this one)  # --------- Try to authenticate user from domain's lib servers (first this one)
   
 sub authenticate {  sub authenticate {
     my ($uname,$upass,$udom,$checkdefauth)=@_;      my ($uname,$upass,$udom,$checkdefauth,$clientcancheckhost)=@_;
     $upass=&escape($upass);      $upass=&escape($upass);
     $uname= &LONCAPA::clean_username($uname);      $uname= &LONCAPA::clean_username($uname);
     my $uhome=&homeserver($uname,$udom,1);      my $uhome=&homeserver($uname,$udom,1);
Line 834  sub authenticate { Line 1041  sub authenticate {
     return 'no_host';      return 'no_host';
         }          }
     }      }
     my $answer=reply("encrypt:auth:$udom:$uname:$upass:$checkdefauth",$uhome);      my $answer=reply("encrypt:auth:$udom:$uname:$upass:$checkdefauth:$clientcancheckhost",$uhome);
     if ($answer eq 'authorized') {      if ($answer eq 'authorized') {
         if ($newhome) {          if ($newhome) {
             &logthis("User $uname at $udom authorized by $uhome, but needs account");              &logthis("User $uname at $udom authorized by $uhome, but needs account");
Line 852  sub authenticate { Line 1059  sub authenticate {
     return 'no_host';      return 'no_host';
 }  }
   
   sub can_host_session {
       my ($udom,$lonhost,$remoterev,$remotesessions,$hostedsessions) = @_;
       my $canhost = 1;
       my $host_idn = &Apache::lonnet::internet_dom($lonhost);
       if (ref($remotesessions) eq 'HASH') {
           if (ref($remotesessions->{'excludedomain'}) eq 'ARRAY') {
               if (grep(/^\Q$host_idn\E$/,@{$remotesessions->{'excludedomain'}})) {
                   $canhost = 0;
               } else {
                   $canhost = 1;
               }
           }
           if (ref($remotesessions->{'includedomain'}) eq 'ARRAY') {
               if (grep(/^\Q$host_idn\E$/,@{$remotesessions->{'includedomain'}})) {
                   $canhost = 1;
               } else {
                   $canhost = 0;
               }
           }
           if ($canhost) {
               if ($remotesessions->{'version'} ne '') {
                   my ($reqmajor,$reqminor) = ($remotesessions->{'version'} =~ /^(\d+)\.(\d+)$/);
                   if ($reqmajor ne '' && $reqminor ne '') {
                       if ($remoterev =~ /^\'?(\d+)\.(\d+)/) {
                           my $major = $1;
                           my $minor = $2;
                           if (($major < $reqmajor ) ||
                               (($major == $reqmajor) && ($minor < $reqminor))) {
                               $canhost = 0;
                           }
                       } else {
                           $canhost = 0;
                       }
                   }
               }
           }
       }
       if ($canhost) {
           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 (($uint_dom ne '') && 
                       (grep(/^\Q$uint_dom\E$/,@{$hostedsessions->{'excludedomain'}}))) {
                       $canhost = 0;
                   } else {
                       $canhost = 1;
                   }
               }
               if (ref($hostedsessions->{'includedomain'}) eq 'ARRAY') {
                   if (($uint_dom ne '') && 
                       (grep(/^\Q$uint_dom\E$/,@{$hostedsessions->{'includedomain'}}))) {
                       $canhost = 1;
                   } else {
                       $canhost = 0;
                   }
               }
           }
       }
       return $canhost;
   }
   
   sub spare_can_host {
       my ($udom,$uint_dom,$remotesessions,$try_server)=@_;
       my $canhost=1;
       my @intdoms;
       my $internet_names = &Apache::lonnet::get_internet_names($try_server);
       if (ref($internet_names) eq 'ARRAY') {
           @intdoms = @{$internet_names};
       }
       unless (grep(/^\Q$uint_dom\E$/,@intdoms)) {
           my $serverhomeID = &Apache::lonnet::get_server_homeID($try_server);
           my $serverhomedom = &Apache::lonnet::host_domain($serverhomeID);
           my %defdomdefaults = &Apache::lonnet::get_domain_defaults($serverhomedom);
           my $remoterev = &Apache::lonnet::get_server_loncaparev(undef,$try_server);
           $canhost = &can_host_session($udom,$try_server,$remoterev,
                                        $remotesessions,
                                        $defdomdefaults{'hostedsessions'});
       }
       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,$dom_in_use,$homeintdom,$rule_in_effect,
           $offloadto,$otherserver);
       my $lonhost = $perlvar{'lonHostID'};
       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') {
           my $currbalancer = $result->{'lonhost'};
           my $currtargets = $result->{'targets'};
           my $currrules = $result->{'rules'};
           if ($currbalancer ne '') {
               my @hosts = &current_machine_ids();
               if (grep(/^\Q$currbalancer\E$/,@hosts)) {
                   $is_balancer = 1;
               }
           }
           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') {
               my $currbalancer = $result->{'lonhost'};
               my $currtargets = $result->{'targets'};
               my $currrules = $result->{'rules'};
   
               if ($currbalancer eq $lonhost) {
                   $is_balancer = 1;
                   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);
           }
       }
       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);
               }
           }
       }
       return ($is_balancer,$otherserver);
   }
   
   sub get_loadbalancer_targets {
       my ($rule_in_effect,$currtargets,$uname,$udom) = @_;
       my $offloadto;
       if ($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 = &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 1328  sub get_domain_defaults { Line 1913  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'],$domain);                                    'coursedefaults','usersessions'],$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'};
Line 1368  sub get_domain_defaults { Line 1953  sub get_domain_defaults {
             $domdefaults{$item} = $domconfig{'coursedefaults'}{$item};              $domdefaults{$item} = $domconfig{'coursedefaults'}{$item};
         }          }
     }      }
       if (ref($domconfig{'usersessions'}) eq 'HASH') {
           if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') {
               $domdefaults{'remotesessions'} = $domconfig{'usersessions'}{'remote'};
           }
           if (ref($domconfig{'usersessions'}{'hosted'}) eq 'HASH') {
               $domdefaults{'hostedsessions'} = $domconfig{'usersessions'}{'hosted'};
           }
       }
     &Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults,      &Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults,
                                   $cachetime);                                    $cachetime);
     return %domdefaults;      return %domdefaults;
Line 1553  sub getsection { Line 2146  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 %roleshash = &dump('roles',$udom,$unam,$courseid);      my $extra = &freeze_escape({'skipcheck' => 1});
       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 1619  sub is_cached_new { Line 2213  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 1785  sub getversion { Line 2379  sub getversion {
   
 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 1994  sub allowuploaded { Line 2597  sub allowuploaded {
 #        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 2020  sub allowuploaded { Line 2625  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 2048  sub process_coursefile { Line 2654  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 2170  sub resizeImage { Line 2779  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 2183  sub resizeImage { Line 2796  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 if $parser = parse.
 #   # 
 # 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 2225  sub userfileupload { Line 2861  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;              $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 2253  sub userfileupload { Line 2893  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'};
Line 2265  sub userfileupload { Line 2904  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);
     }      }
 }  }
   
 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 2297  sub finishuserfileupload { Line 2936  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 2313  sub finishuserfileupload { Line 2968  sub finishuserfileupload {
     }      }
     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.'/'.$file);          my $type = $mm->checktype_filename($filepath.'/'.$file);
         if ($mime_type eq 'text/html') {          if ($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 2322  sub finishuserfileupload { Line 2977  sub finishuserfileupload {
            ' for embedded media: '.$parse_result);              ' for embedded media: '.$parse_result); 
             }              }
         }          }
           if (ref($mimetype)) {
               $$mimetype = $type;
           }
     }      }
     if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {      if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {
         my $input = $filepath.'/'.$file;          my $input = $filepath.'/'.$file;
Line 2855  sub get_my_roles { Line 3513  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') {
         %dumphash = &dump('roles',$udom,$uname);          my $extra = &freeze_escape({'skipcheck' => 1});
           %dumphash = &dump('roles',$udom,$uname,'.',undef,$extra);
     } else {      } else {
         %dumphash=          %dumphash=
             &dump('nohist_userroles',$udom,$uname);              &dump('nohist_userroles',$udom,$uname);
Line 2916  sub get_my_roles { Line 3575  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;
                 }                  }
Line 3035  sub courseiddump { Line 3698  sub courseiddump {
     my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,      my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,
         $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,          $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,
         $selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone,          $selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone,
         $cloneonly,$createdbefore,$createdafter,$creationcontext)=@_;          $cloneonly,$createdbefore,$createdafter,$creationcontext,$domcloner)=@_;
     my $as_hash = 1;      my $as_hash = 1;
     my %returnhash;      my %returnhash;
     if (!$domfilter) { $domfilter=''; }      if (!$domfilter) { $domfilter=''; }
Line 3057  sub courseiddump { Line 3720  sub courseiddump {
                          $showhidden.':'.$caller.':'.&escape($cloner).':'.                           $showhidden.':'.$caller.':'.&escape($cloner).':'.
                          &escape($cc_clone).':'.$cloneonly.':'.                           &escape($cc_clone).':'.$cloneonly.':'.
                          &escape($createdbefore).':'.&escape($createdafter).':'.                           &escape($createdbefore).':'.&escape($createdafter).':'.
                          &escape($creationcontext),$tryserver);                           &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 3323  sub hashref2str { Line 3987  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 3475  sub tmpreset { Line 4139  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 3514  sub tmpstore { Line 4178  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 3560  sub tmprestore { Line 4224  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 3697  sub restore { Line 4361  sub restore {
 }  }
   
 # ---------------------------------------------------------- Course Description  # ---------------------------------------------------------- Course Description
   #
   #  
   
 sub coursedescription {  sub coursedescription {
     my ($courseid,$args)=@_;      my ($courseid,$args)=@_;
Line 3726  sub coursedescription { Line 4392  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 3734  sub coursedescription { Line 4401  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 3744  sub coursedescription { Line 4415  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 3757  sub coursedescription { Line 4428  sub coursedescription {
     return %returnhash;      return %returnhash;
 }  }
   
   sub update_released_required {
       my ($needsrelease,$cdom,$cnum,$chome,$cid) = @_;
       if ($cdom eq '' || $cnum eq '' || $chome eq '' || $cid eq '') {
           $cid = $env{'request.course.id'};
           $cdom = $env{'course.'.$cid.'.domain'};
           $cnum = $env{'course.'.$cid.'.num'};
           $chome = $env{'course.'.$cid.'.home'};
       }
       if ($needsrelease) {
           my %curr_reqd_hash = &userenvironment($cdom,$cnum,'internal.releaserequired');
           my $needsupdate;
           if ($curr_reqd_hash{'internal.releaserequired'} eq '') {
               $needsupdate = 1;
           } else {
               my ($currmajor,$currminor) = split(/\./,$curr_reqd_hash{'internal.releaserequired'});
               my ($needsmajor,$needsminor) = split(/\./,$needsrelease);
               if (($currmajor < $needsmajor) || ($currmajor == $needsmajor && $currminor < $needsminor)) {
                   $needsupdate = 1;
               }
           }
           if ($needsupdate) {
               my %needshash = (
                                'internal.releaserequired' => $needsrelease,
                               );
               my $putresult = &put('environment',\%needshash,$cdom,$cnum);
               if ($putresult eq 'ok') {
                   &appenv({'course.'.$cid.'.internal.releaserequired' => $needsrelease});
                   my %crsinfo = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,undef,'.');
                   if (ref($crsinfo{$cid}) eq 'HASH') {
                       $crsinfo{$cid}{'releaserequired'} = $needsrelease;
                       &courseidput($cdom,\%crsinfo,$chome,'notime');
                   }
               }
           }
       }
       return;
   }
   
 # -------------------------------------------------See if a user is privileged  # -------------------------------------------------See if a user is privileged
   
 sub privileged {  sub privileged {
Line 3796  sub rolesinit { Line 4505  sub rolesinit {
     my ($domain,$username,$authhost)=@_;      my ($domain,$username,$authhost)=@_;
     my $now=time;      my $now=time;
     my %userroles = ('user.login.time' => $now);      my %userroles = ('user.login.time' => $now);
     my $rolesdump=reply("dump:$domain:$username:roles",$authhost);      my $extra = &freeze_escape({'skipcheck' => 1});
       my $rolesdump=reply("dump:$domain:$username:roles:.::$extra",$authhost);
     if (($rolesdump eq 'con_lost') || ($rolesdump eq '') ||       if (($rolesdump eq 'con_lost') || ($rolesdump eq '') || 
         ($rolesdump =~ /^error:/)) {           ($rolesdump =~ /^error:/)) {
         return \%userroles;          return \%userroles;
     }      }
     my %allroles=();      my %allroles=();
     my %allgroups=();         my %allgroups=();   
     my $group_privs;  
   
     if ($rolesdump ne '') {      if ($rolesdump ne '') {
         foreach my $entry (split(/&/,$rolesdump)) {          foreach my $entry (split(/&/,$rolesdump)) {
Line 3820  sub rolesinit { Line 4529  sub rolesinit {
  }   }
             } elsif ($role =~ m|^gr/|) {              } elsif ($role =~ m|^gr/|) {
                 ($trole,$tend,$tstart) = split(/_/,$role);                  ($trole,$tend,$tstart) = split(/_/,$role);
                   next if ($tstart eq '-1');
                 ($trole,$group_privs) = split(/\//,$trole);                  ($trole,$group_privs) = split(/\//,$trole);
                 $group_privs = &unescape($group_privs);                  $group_privs = &unescape($group_privs);
     } else {      } else {
Line 3972  sub set_userprivs { Line 4682  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 3981  sub set_userprivs { Line 4691  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 3990  sub role_status { Line 4700  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 4015  sub role_status { Line 4725  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 4054  sub role_status { Line 4741  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 4064  sub role_status { Line 4751  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;
     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);
         }          }
     } else {      } else {
         &set_adhoc_privileges($cdom,$cnum,$checkrole);          &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller);
     }      }
 }  }
   
 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'},
Line 4090  sub set_adhoc_privileges { Line 4835  sub set_adhoc_privileges {
     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 4146  sub del { Line 4893  sub del {
 # -------------------------------------------------------------- dump interface  # -------------------------------------------------------------- dump interface
   
 sub dump {  sub dump {
     my ($namespace,$udomain,$uname,$regexp,$range)=@_;      my ($namespace,$udomain,$uname,$regexp,$range,$extra)=@_;
     if (!$udomain) { $udomain=$env{'user.domain'}; }      if (!$udomain) { $udomain=$env{'user.domain'}; }
     if (!$uname) { $uname=$env{'user.name'}; }      if (!$uname) { $uname=$env{'user.name'}; }
     my $uhome=&homeserver($uname,$udomain);      my $uhome=&homeserver($uname,$udomain);
Line 4155  sub dump { Line 4902  sub dump {
     } else {      } else {
  $regexp='.';   $regexp='.';
     }      }
     my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);      my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range:$extra",$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);
  $returnhash{$key}=&thaw_unescape($value);      next if ($key =~ /^error: 2 /);
       $returnhash{$key}=&thaw_unescape($value);
    }
     }      }
     return %returnhash;      return %returnhash;
 }  }
   
   
 # --------------------------------------------------------- dumpstore interface  # --------------------------------------------------------- dumpstore interface
   
 sub dumpstore {  sub dumpstore {
Line 4449  sub tmpget { Line 5199  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'}; }
Line 4700  sub is_portfolio_file { Line 5450  sub is_portfolio_file {
 }  }
   
 sub usertools_access {  sub usertools_access {
     my ($uname,$udom,$tool,$action,$context) = @_;      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 4742  sub usertools_access { Line 5492  sub usertools_access {
         $toolstatus = $env{'environment.'.$context.'.'.$tool};          $toolstatus = $env{'environment.'.$context.'.'.$tool};
         $inststatus = $env{'environment.inststatus'};          $inststatus = $env{'environment.inststatus'};
     } else {      } else {
         my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool,'inststatus');          if (ref($userenvref) eq 'HASH') {
         $toolstatus = $userenv{$context.'.'.$tool};              $toolstatus = $userenvref->{$context.'.'.$tool};
         $inststatus = $userenv{'inststatus'};              $inststatus = $userenvref->{'inststatus'};
           } else {
               my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool,'inststatus');
               $toolstatus = $userenv{$context.'.'.$tool};
               $inststatus = $userenv{'inststatus'};
           }
     }      }
   
     if ($toolstatus ne '') {      if ($toolstatus ne '') {
Line 4756  sub usertools_access { Line 5511  sub usertools_access {
         return $access;          return $access;
     }      }
   
     my $is_adv = &is_advanced_user($udom,$uname);      my ($is_adv,%domdef);
     my %domdef = &get_domain_defaults($udom);      if (ref($is_advref) eq 'HASH') {
           $is_adv = $is_advref->{'is_adv'};
       } else {
           $is_adv = &is_advanced_user($udom,$uname);
       }
       if (ref($domdefref) eq 'HASH') {
           %domdef = %{$domdefref};
       } else {
           %domdef = &get_domain_defaults($udom);
       }
     if (ref($domdef{$tool}) eq 'HASH') {      if (ref($domdef{$tool}) eq 'HASH') {
         if ($is_adv) {          if ($is_adv) {
             if ($domdef{$tool}{'_LC_adv'} ne '') {              if ($domdef{$tool}{'_LC_adv'} ne '') {
Line 4831  sub is_course_owner { Line 5595  sub is_course_owner {
   
 sub is_advanced_user {  sub is_advanced_user {
     my ($udom,$uname) = @_;      my ($udom,$uname) = @_;
       if ($udom ne '' && $uname ne '') {
           if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
               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 4847  sub is_advanced_user { Line 5620  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 4861  sub is_advanced_user { Line 5637  sub is_advanced_user {
             }              }
         }          }
     }      }
       if (wantarray) {
           return ($is_adv,$is_author);
       }
     return $is_adv;      return $is_adv;
 }  }
   
Line 5346  sub allowed { Line 6125  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 5356  sub allowed { Line 6135  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 5370  sub allowed { Line 6149  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 5401  sub allowed { Line 6180  sub allowed {
     }      }
    return 'F';     return 'F';
 }  }
   #
   #   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 5553  sub update_allusers_table { Line 6352  sub update_allusers_table {
                'generation='.&escape($names->{'generation'}).'%%'.                 'generation='.&escape($names->{'generation'}).'%%'.
                'permanentemail='.&escape($names->{'permanentemail'}).'%%'.                 'permanentemail='.&escape($names->{'permanentemail'}).'%%'.
                'id='.&escape($names->{'id'}),$homeserver);                 'id='.&escape($names->{'id'}),$homeserver);
     my $reply = &get_query_reply($queryid);      return;
     return $reply;  
 }  }
   
 # ------- Request retrieval of institutional classlists for course(s)  # ------- Request retrieval of institutional classlists for course(s)
Line 5598  sub fetch_enrollment_query { Line 6396  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 5628  sub fetch_enrollment_query { Line 6426  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 5724  sub auto_get_sections { Line 6522  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 6117  sub get_users_groups { Line 6915  sub get_users_groups {
     } else {        } else {  
         $grouplist = '';          $grouplist = '';
         my $courseurl = &courseid_to_courseurl($courseid);          my $courseurl = &courseid_to_courseurl($courseid);
         my %roleshash = &dump('roles',$udom,$uname,$courseurl);          my $extra = &freeze_escape({'skipcheck' => 1});
           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 6297  sub assignrole { Line 7096  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 6477  sub modifyuser { Line 7283  sub modifyuser {
              ' by '.$env{'user.name'}.' at '.$env{'user.domain'}.               ' by '.$env{'user.name'}.' at '.$env{'user.domain'}.
              ' in domain '.$env{'request.role.domain'});               ' in domain '.$env{'request.role.domain'});
     my $uhome=&homeserver($uname,$udom,'true');      my $uhome=&homeserver($uname,$udom,'true');
       my $newuser;
       if ($uhome eq 'no_host') {
           $newuser = 1;
       }
 # ----------------------------------------------------------------- Create User  # ----------------------------------------------------------------- Create User
     if (($uhome eq 'no_host') &&       if (($uhome eq 'no_host') && 
  (($umode && $upass) || ($umode eq 'localauth'))) {   (($umode && $upass) || ($umode eq 'localauth'))) {
Line 6529  sub modifyuser { Line 7339  sub modifyuser {
    ['firstname','middlename','lastname','generation','id',     ['firstname','middlename','lastname','generation','id',
                     'permanentemail','inststatus'],                      'permanentemail','inststatus'],
    $udom,$uname);     $udom,$uname);
     my %names;      my (%names,%oldnames);
     if ($tmp[0] =~ m/^error:.*/) {       if ($tmp[0] =~ m/^error:.*/) { 
         %names=();           %names=(); 
     } else {      } else {
         %names = @tmp;          %names = @tmp;
           %oldnames = %names;
     }      }
 #  #
 # If name, email and/or uid are blank (e.g., because an uploaded file  # If name, email and/or uid are blank (e.g., because an uploaded file
Line 6587  sub modifyuser { Line 7398  sub modifyuser {
             }              }
         }          }
     }      }
     my $reply = &put('environment', \%names, $udom,$uname);      my $logmsg = $udom.', '.$uname.', '.$uid.', '.
     if ($reply ne 'ok') { return 'error: '.$reply; }  
     my $sqlresult = &update_allusers_table($uname,$udom,\%names);  
     &devalidate_cache_new('namescache',$uname.':'.$udom);  
     my $logmsg = 'Success modifying user '.$udom.', '.$uname.', '.$uid.', '.  
                  $umode.', '.$first.', '.$middle.', '.                   $umode.', '.$first.', '.$middle.', '.
          $last.', '.$gene.', '.$email.', '.$inststatus;                   $last.', '.$gene.', '.$email.', '.$inststatus;
     if ($env{'user.name'} ne '' && $env{'user.domain'}) {      if ($env{'user.name'} ne '' && $env{'user.domain'}) {
         $logmsg .= ' by '.$env{'user.name'}.' at '.$env{'user.domain'};          $logmsg .= ' by '.$env{'user.name'}.' at '.$env{'user.domain'};
     } else {      } else {
         $logmsg .= ' during self creation';          $logmsg .= ' during self creation';
     }      }
       my $changed;
       if ($newuser) {
           $changed = 1;
       } else {
           foreach my $field (@fields) {
               if ($names{$field} ne $oldnames{$field}) {
                   $changed = 1;
                   last;
               }
           }
       }
       unless ($changed) {
           $logmsg = 'No changes in user information needed for: '.$logmsg;
           &logthis($logmsg);
           return 'ok';
       }
       my $reply = &put('environment', \%names, $udom,$uname);
       if ($reply ne 'ok') { 
           return 'error: '.$reply;
       }
       if ($names{'permanentemail'} ne $oldnames{'permanentemail'}) {
           &Apache::lonnet::devalidate_cache_new('emailscache',$uname.':'.$udom);
       }
       my $sqlresult = &update_allusers_table($uname,$udom,\%names);
       &devalidate_cache_new('namescache',$uname.':'.$udom);
       $logmsg = 'Success modifying user '.$logmsg;
     &logthis($logmsg);      &logthis($logmsg);
     return 'ok';      return 'ok';
 }  }
Line 6915  sub store_userdata { Line 7748  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'}:".                  $result =  &reply("store:$udom:$uname:$namespace:$datakey:".
                                   "$namespace:$datakey:$namevalue",$uhome);                                    $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 6969  sub diskusage { Line 7802  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 6981  sub is_locked { Line 7814  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 7032  sub save_selected_files { Line 7870  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 7042  sub files_in_path { Line 7880  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 7064  sub files_not_in_path { Line 7902  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 7412  sub dirlist { Line 8250  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 7450  sub dirlist { Line 8295  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 7488  sub GetFileTimestamp { Line 8332  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 7524  sub stat_file { Line 8370  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 8139  sub metadata { Line 8988  sub metadata {
     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|/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 =~ /^~/ || $uri =~ m{home/$match_username/public_html/}) 
Line 8185  sub metadata { Line 9034  sub metadata {
  &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 8584  sub symbverify { Line 9434  sub symbverify {
             $thisurl =~ s/\?.+$//;              $thisurl =~ s/\?.+$//;
         }          }
         my $ids=$bighash{'ids_'.&clutter($thisurl)};          my $ids=$bighash{'ids_'.&clutter($thisurl)};
         unless ($ids) {           unless ($ids) {
            $ids=$bighash{'ids_/'.$thisurl};              my $idkey = 'ids_'.($thisurl =~ m{^/}? '' : '/').$thisurl;  
               $ids=$bighash{$idkey};
         }          }
         if ($ids) {          if ($ids) {
 # ------------------------------------------------------------------- Has ID(s)  # ------------------------------------------------------------------- Has ID(s)
Line 8598  sub symbverify { Line 9449  sub symbverify {
   &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)    &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)
    eq $symb) {      eq $symb) { 
    if (($env{'request.role.adv'}) ||     if (($env{'request.role.adv'}) ||
        $bighash{'encrypted_'.$id} eq $env{'request.enc'}) {         ($bighash{'encrypted_'.$id} eq $env{'request.enc'}) ||
                          ($thisurl eq '/adm/navmaps')) {
        $okay=1;          $okay=1; 
    }     }
        }         }
Line 8873  sub getCODE { Line 9725  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; }
Line 8883  sub rndseed { Line 9752  sub rndseed {
     if (!$courseid) { $courseid=$wcourseid; }      if (!$courseid) { $courseid=$wcourseid; }
     if (!$domain) { $domain=$wdomain; }      if (!$domain) { $domain=$wdomain; }
     if (!$username) { $username=$wusername }      if (!$username) { $username=$wusername }
     my $which=&get_rand_alg();  
       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 9355  sub filelocation { Line 10231  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 9593  sub get_dns { Line 10469  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});
Line 9676  sub get_dns { Line 10553  sub get_dns {
     my %libserv;      my %libserv;
     my $loaded;      my $loaded;
     my %name_to_host;      my %name_to_host;
       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 =~ /^\^/) {
     my ($id,$domain,$role,$name,$protocol)=split(/:/,$configline);                  if ($configline =~ /^\^([\w.\-]+)/) {
                       $LC_dns_serv{$1} = 1;
                   }
                   next;
               }
       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) {
  $hostname{$id}=$name;   $hostname{$id}=$name;
Line 9699  sub get_dns { Line 10583  sub get_dns {
                 } else {                  } else {
                     $protocol{$id} = 'http';                      $protocol{$id} = 'http';
                 }                  }
                   if (defined($intdom)) {
                       $internetdom{$id} = $intdom;
                   }
     }      }
  }   }
     }      }
Line 9808  sub get_dns { Line 10695  sub get_dns {
  my @uniq = grep(!$seen{$_}++, values(%hostdom));   my @uniq = grep(!$seen{$_}++, values(%hostdom));
  return @uniq;   return @uniq;
     }      }
   
       sub internet_dom {
           &load_hosts_tab() if (!$loaded);
   
           my ($lonid) = @_;
           return $internetdom{$lonid};
       }
   
       sub is_LC_dns {
           &load_hosts_tab() if (!$loaded);
   
           my ($hostname) = @_;
           return exists($LC_dns_serv{$hostname});
       }
   
 }  }
   
 {   { 
Line 9925  sub get_dns { Line 10827  sub get_dns {
         return undef;          return undef;
     }      }
   
       sub get_internet_names {
           my ($lonid) = @_;
           return if ($lonid eq '');
           my ($idnref,$cached)=
               &Apache::lonnet::is_cached_new('internetnames',$lonid);
           if ($cached) {
               return $idnref;
           }
           my $ip = &get_host_ip($lonid);
           my @hosts = &get_hosts_from_ip($ip);
           my %iphost = &get_iphost();
           my (@idns,%seen);
           foreach my $id (@hosts) {
               my $dom = &host_domain($id);
               my $prim_id = &domain($dom,'primary');
               my $prim_ip = &get_host_ip($prim_id);
               next if ($seen{$prim_ip});
               if (ref($iphost{$prim_ip}) eq 'ARRAY') {
                   foreach my $id (@{$iphost{$prim_ip}}) {
                       my $intdom = &internet_dom($id);
                       unless (grep(/^\Q$intdom\E$/,@idns)) {
                           push(@idns,$intdom);
                       }
                   }
               }
               $seen{$prim_ip} = 1;
           }
           return &Apache::lonnet::do_cache_new('internetnames',$lonid,\@idns,12*60*60);
       }
   
   }
   
   sub all_loncaparevs {
       return qw(1.1 1.2 1.3 2.0 2.1 2.2 2.3 2.4 2.5 2.6 2.7 2.8 2.9 2.10);
 }  }
   
 BEGIN {  BEGIN {
Line 10002  BEGIN { Line 10938  BEGIN {
     close($config);      close($config);
 }  }
   
   # ---------------------------------------------------------- Read loncaparev table
   {
       if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") {
           if (open(my $config,"<$perlvar{'lonTabDir'}/loncaparevs.tab")) {
               while (my $configline=<$config>) {
                   chomp($configline);
                   my ($hostid,$loncaparev)=split(/:/,$configline);
                   $loncaparevs{$hostid}=$loncaparev;
               }
               close($config);
           }
       }
   }
   
   # ---------------------------------------------------------- Read serverhostID table
   {
       if (-e "$perlvar{'lonTabDir'}/serverhomeIDs.tab") {
           if (open(my $config,"<$perlvar{'lonTabDir'}/serverhomeIDs.tab")) {
               while (my $configline=<$config>) {
                   chomp($configline);
                   my ($name,$id)=split(/:/,$configline);
                   $serverhomeIDs{$name}=$id;
               }
               close($config);
           }
       }
   }
   
   {
       my $file = $Apache::lonnet::perlvar{'lonTabDir'}.'/releaseslist.xml';
       if (-e $file) {
           my $parser = HTML::LCParser->new($file);
           while (my $token = $parser->get_token()) {
               if ($token->[0] eq 'S') {
                   my $item = $token->[1];
                   my $name = $token->[2]{'name'};
                   my $value = $token->[2]{'value'};
                   if ($item ne '' && $name ne '' && $value ne '') {
                       my $release = $parser->get_text();
                       $release =~ s/(^\s*|\s*$ )//gx;
                       $needsrelease{$item.':'.$name.':'.$value} = $release;
                   }
               }
           }
       }
   }
   
   # ---------------------------------------------------------- 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 10232  authentication scheme Line 11231  authentication scheme
   
 =item *  =item *
 X<authenticate()>  X<authenticate()>
 B<authenticate($uname,$upass,$udom)>: try to  B<authenticate($uname,$upass,$udom,$checkdefauth,$clientcancheckhost)>: try to
 authenticate user from domain's lib servers (first use the current  authenticate user from domain's lib servers (first use the current
 one). C<$upass> should be the users password.  one). C<$upass> should be the users password.
   $checkdefauth is optional (value is 1 if a check should be made to
      authenticate user using default authentication method, and allow
      account creation if username does not have account in the domain).
   $clientcancheckhost is optional (value is 1 if checking whether the
      server can host will occur on the client side in lonauth.pm).   
   
 =item *  =item *
 X<homeserver()>  X<homeserver()>
Line 10493  revokecustomrole($udom,$uname,$url,$role Line 11497  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 10828  or lonTabs/domain.tab. Line 11853  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 10890  splitting on '&', supports elements that Line 11990  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 10910  logperm() : append a permanent message t Line 12011  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 10983  userfileupload(): main rotine for puttin Line 12085  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 11006  returns: the new clean filename Line 12110  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 *
   
Removed from v.1.1070  
changed lines
  Added in v.1.1138

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