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

version 1.567, 2004/11/10 19:03:04 version 1.1189, 2012/09/02 16:18:24
Line 27 Line 27
 #  #
 ###  ###
   
 package Apache::lonnet;  =pod
   
 use strict;  =head1 NAME
 use LWP::UserAgent();  
 use HTTP::Headers;  
 use HTTP::Date;  
 # use Date::Parse;  
 use vars   
 qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom   
    %libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache  
    %courselogs %accesshash %userrolehash $processmarker $dumpcount   
    %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseresdatacache   
    %userresdatacache %getsectioncache %domaindescription %domain_auth_def %domain_auth_arg_def   
    %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir $_64bit);  
   
 use IO::Socket;  Apache::lonnet.pm
 use GDBM_File;  
 use Apache::Constants qw(:common :http);  
 use HTML::LCParser;  
 use Fcntl qw(:flock);  
 use Apache::lonlocal;  
 use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze);  
 use Time::HiRes qw( gettimeofday tv_interval );  
 my $readit;  
 my $max_connection_retries = 10;     # Or some such value.  
   
 =pod  =head1 SYNOPSIS
   
   This file is an interface to the lonc processes of
   the LON-CAPA network as well as set of elaborated functions for handling information
   necessary for navigating through a given cluster of LON-CAPA machines within a
   domain. There are over 40 specialized functions in this module which handle the
   reading and transmission of metadata, user information (ids, names, environments, roles,
   logs), file information (storage, reading, directories, extensions, replication, embedded
   styles and descriptors), educational resources (course descriptions, section names and
   numbers), url hashing (to assign roles on a url basis), and translating abbreviated symbols to
   and from more descriptive phrases or explanations.
   
   This is part of the LearningOnline Network with CAPA project
   described at http://www.lon-capa.org.
   
 =head1 Package Variables  =head1 Package Variables
   
Line 75  delayed. Line 68  delayed.
   
 =cut  =cut
   
   package Apache::lonnet;
   
   use strict;
   use LWP::UserAgent();
   use HTTP::Date;
   use Image::Magick;
   
   
   use Encode;
   
   use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir
               $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease
               %managerstab);
   
   my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash,
       %userrolehash, $processmarker, $dumpcount, %coursedombuf,
       %coursenumbuf, %coursehombuf, %coursedescrbuf, %courseinstcodebuf,
       %courseownerbuf, %coursetypebuf,$locknum);
   
   use IO::Socket;
   use GDBM_File;
   use HTML::LCParser;
   use Fcntl qw(:flock);
   use Storable qw(thaw nfreeze);
   use Time::HiRes qw( gettimeofday tv_interval );
   use Cache::Memcached;
   use Digest::MD5;
   use Math::Random;
   use File::MMagic;
   use LONCAPA qw(:DEFAULT :match);
   use LONCAPA::Configuration;
   use LONCAPA::lonmetadata;
   use LONCAPA::Lond;
   
   use File::Copy;
   
   my $readit;
   my $max_connection_retries = 10;     # Or some such value.
   
   require Exporter;
   
 # --------------------------------------------------------------------- Logging  our @ISA = qw (Exporter);
   our @EXPORT = qw(%env);
   
   
   # ------------------------------------ Logging (parameters, docs, slots, roles)
   {
       my $logid;
       sub write_log {
    my ($context,$hash_name,$storehash,$delflag,$uname,$udom,$cnum,$cdom)=@_;
           if ($context eq 'course') {
               if (($cnum eq '') || ($cdom eq '')) {
                   $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
                   $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
               }
           }
    $logid ++;
           my $now = time();
    my $id=$now.'00000'.$$.'00000'.$logid;
           my $logentry = { 
                             $id => {
                                      'exe_uname' => $env{'user.name'},
                                      'exe_udom'  => $env{'user.domain'},
                                      'exe_time'  => $now,
                                      'exe_ip'    => $ENV{'REMOTE_ADDR'},
                                      'delflag'   => $delflag,
                                      'logentry'  => $storehash,
                                      'uname'     => $uname,
                                      'udom'      => $udom,
                                     }
                          };
    return &put('nohist_'.$hash_name,$logentry,$cdom,$cnum);
       }
   }
   
 sub logtouch {  sub logtouch {
     my $execdir=$perlvar{'lonDaemons'};      my $execdir=$perlvar{'lonDaemons'};
Line 94  sub logthis { Line 159  sub logthis {
     my $now=time;      my $now=time;
     my $local=localtime($now);      my $local=localtime($now);
     if (open(my $fh,">>$execdir/logs/lonnet.log")) {      if (open(my $fh,">>$execdir/logs/lonnet.log")) {
  print $fh "$local ($$): $message\n";   my $logstring = $local. " ($$): ".$message."\n"; # Keep any \'s in string.
    print $fh $logstring;
  close($fh);   close($fh);
     }      }
     return 1;      return 1;
Line 112  sub logperm { Line 178  sub logperm {
     return 1;      return 1;
 }  }
   
   sub create_connection {
       my ($hostname,$lonid) = @_;
       my $client=IO::Socket::UNIX->new(Peer    => $perlvar{'lonSockCreate'},
        Type    => SOCK_STREAM,
        Timeout => 10);
       return 0 if (!$client);
       print $client (join(':',$hostname,$lonid,&machine_ids($hostname))."\n");
       my $result = <$client>;
       chomp($result);
       return 1 if ($result eq 'done');
       return 0;
   }
   
   sub get_server_timezone {
       my ($cnum,$cdom) = @_;
       my $home=&homeserver($cnum,$cdom);
       if ($home ne 'no_host') {
           my $cachetime = 24*3600;
           my ($timezone,$cached)=&is_cached_new('servertimezone',$home);
           if (defined($cached)) {
               return $timezone;
           } else {
               my $timezone = &reply('servertimezone',$home);
               return &do_cache_new('servertimezone',$home,$timezone,$cachetime);
           }
       }
   }
   
   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 {
       my ($dom,$lonhost,$ignore_cache,$caller) = @_;
       if (defined($lonhost)) {
           if (!defined(&hostname($lonhost))) {
               undef($lonhost);
           }
       }
       if (!defined($lonhost)) {
           if (defined(&domain($dom,'primary'))) {
               $lonhost=&domain($dom,'primary');
               if ($lonhost eq 'no_host') {
                   undef($lonhost);
               }
           }
       }
       if (defined($lonhost)) {
           my $cachetime = 12*3600;
           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)) {
               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 {
               my $requested = &freeze_escape(\%whatneeded);
               my $rep=&reply('readlonnetglobal:'.$requested,$lonhost);
               if (($rep=~/^(refused|rejected|error)/) || ($rep eq 'con_lost') ||
                   ($rep eq 'unknown_cmd')) {
                   $result = $rep;
               } else {
                   $result = 'ok';
                   my @pairs=split(/\&/,$rep);
                   foreach my $item (@pairs) {
                       my ($key,$value)=split(/=/,$item,2);
                       my $what = &unescape($key);
                       my $hashid = $lonhost.'-'.$what;
                       $returnhash{$what}=&thaw_unescape($value);
                       &do_cache_new('lonnetglobal',$hashid,$returnhash{$what},600);
                   }
               }
           }
       }
       return ($result,\%returnhash);
   }
   
   sub remote_devalidate_cache {
       my ($lonhost,$name,$id) = @_;
       my $response = &reply('devalidatecache:'.&escape($name).':'.&escape($id),$lonhost);
       return $response;
   }
   
 # -------------------------------------------------- Non-critical communication  # -------------------------------------------------- Non-critical communication
 sub subreply {  sub subreply {
     my ($cmd,$server)=@_;      my ($cmd,$server)=@_;
     my $peerfile="$perlvar{'lonSockDir'}/$server";      my $peerfile="$perlvar{'lonSockDir'}/".&hostname($server);
     #      #
     #  With loncnew process trimming, there's a timing hole between lonc server      #  With loncnew process trimming, there's a timing hole between lonc server
     #  process exit and the master server picking up the listen on the AF_UNIX      #  process exit and the master server picking up the listen on the AF_UNIX
Line 136  sub subreply { Line 385  sub subreply {
  $client=IO::Socket::UNIX->new(Peer    =>"$peerfile",   $client=IO::Socket::UNIX->new(Peer    =>"$peerfile",
       Type    => SOCK_STREAM,        Type    => SOCK_STREAM,
       Timeout => 10);        Timeout => 10);
  if($client) {   if ($client) {
     last; # Connected!      last; # Connected!
    } else {
       &create_connection(&hostname($server),$server);
  }   }
  sleep(1); # Try again later if failed connection.          sleep(1); # Try again later if failed connection.
     }      }
     my $answer;      my $answer;
     if ($client) {      if ($client) {
  print $client "$cmd\n";   print $client "sethost:$server:$cmd\n";
  $answer=<$client>;   $answer=<$client>;
  if (!$answer) { $answer="con_lost"; }   if (!$answer) { $answer="con_lost"; }
  chomp($answer);   chomp($answer);
Line 155  sub subreply { Line 406  sub subreply {
   
 sub reply {  sub reply {
     my ($cmd,$server)=@_;      my ($cmd,$server)=@_;
     unless (defined($hostname{$server})) { return 'no_such_host'; }      unless (defined(&hostname($server))) { return 'no_such_host'; }
     my $answer=subreply($cmd,$server);      my $answer=subreply($cmd,$server);
     if ($answer eq 'con_lost') {  
         #sleep 5;   
         #$answer=subreply($cmd,$server);  
         #if ($answer eq 'con_lost') {  
  #   &logthis("Second attempt con_lost on $server");  
         #   my $peerfile="$perlvar{'lonSockDir'}/$server";  
         #   my $client=IO::Socket::UNIX->new(Peer    =>"$peerfile",  
         #                                    Type    => SOCK_STREAM,  
         #                                    Timeout => 10)  
         #              or return "con_lost";  
         #   &logthis("Killing socket");  
         #   print $client "close_connection_exit\n";  
            #sleep 5;  
         #   $answer=subreply($cmd,$server);         
        #}     
     }  
     if (($answer=~/^refused/) || ($answer=~/^rejected/)) {      if (($answer=~/^refused/) || ($answer=~/^rejected/)) {
        &logthis("<font color=blue>WARNING:".         &logthis("<font color=\"blue\">WARNING:".
                 " $cmd to $server returned $answer</font>");                  " $cmd to $server returned $answer</font>");
     }      }
     return $answer;      return $answer;
Line 183  sub reply { Line 418  sub reply {
 # ----------------------------------------------------------- Send USR1 to lonc  # ----------------------------------------------------------- Send USR1 to lonc
   
 sub reconlonc {  sub reconlonc {
     my $peerfile=shift;      my ($lonid) = @_;
     &logthis("Trying to reconnect for $peerfile");      my $hostname = &hostname($lonid);
       if ($lonid) {
    my $peerfile="$perlvar{'lonSockDir'}/$hostname";
    if ($hostname && -e $peerfile) {
       &logthis("Trying to reconnect lonc for $lonid ($hostname)");
       my $client=IO::Socket::UNIX->new(Peer    => $peerfile,
        Type    => SOCK_STREAM,
        Timeout => 10);
       if ($client) {
    print $client ("reset_retries\n");
    my $answer=<$client>;
    #reset just this one.
       }
    }
    return;
       }
   
       &logthis("Trying to reconnect lonc");
     my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";      my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
     if (open(my $fh,"<$loncfile")) {      if (open(my $fh,"<$loncfile")) {
  my $loncpid=<$fh>;   my $loncpid=<$fh>;
Line 193  sub reconlonc { Line 445  sub reconlonc {
     &logthis("lonc at pid $loncpid responding, sending USR1");      &logthis("lonc at pid $loncpid responding, sending USR1");
             kill USR1 => $loncpid;              kill USR1 => $loncpid;
             sleep 1;              sleep 1;
             if (-e "$peerfile") { return; }           } else {
             &logthis("$peerfile still not there, give it another try");  
             sleep 5;  
             if (-e "$peerfile") { return; }  
             &logthis(  
   "<font color=blue>WARNING: $peerfile still not there, giving up</font>");  
         } else {  
     &logthis(      &logthis(
                "<font color=blue>WARNING:".                 "<font color=\"blue\">WARNING:".
                " lonc at pid $loncpid not responding, giving up</font>");                 " lonc at pid $loncpid not responding, giving up</font>");
         }          }
     } else {      } else {
      &logthis('<font color=blue>WARNING: lonc not running, giving up</font>');   &logthis('<font color="blue">WARNING: lonc not running, giving up</font>');
     }      }
 }  }
   
Line 213  sub reconlonc { Line 459  sub reconlonc {
   
 sub critical {  sub critical {
     my ($cmd,$server)=@_;      my ($cmd,$server)=@_;
     unless ($hostname{$server}) {      unless (&hostname($server)) {
         &logthis("<font color=blue>WARNING:".          &logthis("<font color=\"blue\">WARNING:".
                " Critical message to unknown server ($server)</font>");                 " Critical message to unknown server ($server)</font>");
         return 'no_such_host';          return 'no_such_host';
     }      }
     my $answer=reply($cmd,$server);      my $answer=reply($cmd,$server);
     if ($answer eq 'con_lost') {      if ($answer eq 'con_lost') {
         my $pingreply=reply('ping',$server);  
  &reconlonc("$perlvar{'lonSockDir'}/$server");   &reconlonc("$perlvar{'lonSockDir'}/$server");
         my $pongreply=reply('pong',$server);   my $answer=reply($cmd,$server);
         &logthis("Ping/Pong for $server: $pingreply/$pongreply");  
         $answer=reply($cmd,$server);  
         if ($answer eq 'con_lost') {          if ($answer eq 'con_lost') {
             my $now=time;              my $now=time;
             my $middlename=$cmd;              my $middlename=$cmd;
Line 251  sub critical { Line 494  sub critical {
             }              }
             chomp($wcmd);              chomp($wcmd);
             if ($wcmd eq $cmd) {              if ($wcmd eq $cmd) {
  &logthis("<font color=blue>WARNING: ".   &logthis("<font color=\"blue\">WARNING: ".
                          "Connection buffer $dfilename: $cmd</font>");                           "Connection buffer $dfilename: $cmd</font>");
                 &logperm("D:$server:$cmd");                  &logperm("D:$server:$cmd");
         return 'con_delayed';          return 'con_delayed';
             } else {              } else {
                 &logthis("<font color=red>CRITICAL:"                  &logthis("<font color=\"red\">CRITICAL:"
                         ." Critical connection failed: $server $cmd</font>");                          ." Critical connection failed: $server $cmd</font>");
                 &logperm("F:$server:$cmd");                  &logperm("F:$server:$cmd");
                 return 'con_failed';                  return 'con_failed';
Line 266  sub critical { Line 509  sub critical {
     return $answer;      return $answer;
 }  }
   
 #  # ------------------------------------------- check if return value is an error
 # -------------- Remove all key from the env that start witha lowercase letter  
 #                (Which is always a lon-capa value)  
   
 sub cleanenv {  sub error {
 #    unless (defined(&Apache::exists_config_define("MODPERL2"))) { return; }      my ($result) = @_;
 #    unless (&Apache::exists_config_define("MODPERL2")) { return; }      if ($result =~ /^(con_lost|no_such_host|error: (\d+) (.*))/) {
     foreach my $key (keys(%ENV)) {   if ($2 == 2) { return undef; }
  if ($key =~ /^[a-z]/) {   return $1;
     delete($ENV{$key});  
  }  
     }      }
       return undef;
 }  }
    
 # ------------------------------------------- Transfer profile into environment  
   
 sub transfer_profile_to_env {  sub convert_and_load_session_env {
     my ($lonidsdir,$handle)=@_;      my ($lonidsdir,$handle)=@_;
     my @profile;      my @profile;
     {      {
  open(my $idf,"$lonidsdir/$handle.id");   my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");
    if (!$opened) {
       return 0;
    }
  flock($idf,LOCK_SH);   flock($idf,LOCK_SH);
  @profile=<$idf>;   @profile=<$idf>;
  close($idf);   close($idf);
     }      }
     my $envi;      my %temp_env;
     my %Remove;      foreach my $line (@profile) {
     for ($envi=0;$envi<=$#profile;$envi++) {   if ($line !~ m/=/) {
  chomp($profile[$envi]);      return 0;
  my ($envname,$envvalue)=split(/=/,$profile[$envi]);   }
  $ENV{$envname} = $envvalue;   chomp($line);
    my ($envname,$envvalue)=split(/=/,$line,2);
    $temp_env{&unescape($envname)} = &unescape($envvalue);
       }
       unlink("$lonidsdir/$handle.id");
       if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",&GDBM_WRCREAT(),
       0640)) {
    %disk_env = %temp_env;
    @env{keys(%temp_env)} = @disk_env{keys(%temp_env)};
    untie(%disk_env);
       }
       return 1;
   }
   
   # ------------------------------------------- Transfer profile into environment
   my $env_loaded;
   sub transfer_profile_to_env {
       my ($lonidsdir,$handle,$force_transfer) = @_;
       if (!$force_transfer && $env_loaded) { return; } 
   
       if (!defined($lonidsdir)) {
    $lonidsdir = $perlvar{'lonIDsDir'};
       }
       if (!defined($handle)) {
           ($handle) = ($env{'user.environment'} =~m|/([^/]+)\.id$| );
       }
   
       my $convert;
       {
       my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");
    if (!$opened) {
       return;
    }
    flock($idf,LOCK_SH);
    if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",
    &GDBM_READER(),0640)) {
       @env{keys(%disk_env)} = @disk_env{keys(%disk_env)};
       untie(%disk_env);
    } else {
       $convert = 1;
    }
       }
       if ($convert) {
    if (!&convert_and_load_session_env($lonidsdir,$handle)) {
       &logthis("Failed to load session, or convert session.");
    }
       }
   
       my %remove;
       while ( my $envname = each(%env) ) {
         if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {          if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {
             if ($time < time-300) {              if ($time < time-300) {
                 $Remove{$key}++;                  $remove{$key}++;
             }              }
         }          }
     }      }
     $ENV{'user.environment'} = "$lonidsdir/$handle.id";  
     foreach my $expired_key (keys(%Remove)) {      $env{'user.environment'} = "$lonidsdir/$handle.id";
       $env_loaded=1;
       foreach my $expired_key (keys(%remove)) {
         &delenv($expired_key);          &delenv($expired_key);
     }      }
 }  }
   
 # ---------------------------------------------------------- Append Environment  # ---------------------------------------------------- Check for valid session 
   sub check_for_valid_session {
 sub appenv {      my ($r,$name) = @_;
     my %newenv=@_;      my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));
     foreach (keys %newenv) {      if ($name eq '') {
  if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) {          $name = 'lonID';
             &logthis("<font color=blue>WARNING: ".      }
                 "Attempt to modify environment ".$_." to ".$newenv{$_}      my $lonid=$cookies{$name};
                 .'</font>');      return undef if (!$lonid);
     delete($newenv{$_});  
         } else {      my $handle=&LONCAPA::clean_handle($lonid->value);
             $ENV{$_}=$newenv{$_};      my $lonidsdir;
         }      if ($name eq 'lonDAV') {
           $lonidsdir=$r->dir_config('lonDAVsessDir');
       } else {
           $lonidsdir=$r->dir_config('lonIDsDir');
       }
       return undef if (!-e "$lonidsdir/$handle.id");
   
       my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");
       return undef if (!$opened);
   
       flock($idf,LOCK_SH);
       my %disk_env;
       if (!tie(%disk_env,'GDBM_File',"$lonidsdir/$handle.id",
       &GDBM_READER(),0640)) {
    return undef;
     }      }
   
     my $lockfh;      if (!defined($disk_env{'user.name'})
     unless (open($lockfh,"$ENV{'user.environment'}")) {   || !defined($disk_env{'user.domain'})) {
  return 'error: '.$!;   return undef;
     }  
     unless (flock($lockfh,LOCK_EX)) {  
          &logthis("<font color=blue>WARNING: ".  
                   'Could not obtain exclusive lock in appenv: '.$!);  
          close($lockfh);  
          return 'error: '.$!;  
     }      }
       return $handle;
   }
   
     my @oldenv;  sub timed_flock {
     {      my ($file,$lock_type) = @_;
  my $fh;      my $failed=0;
  unless (open($fh,"$ENV{'user.environment'}")) {      eval {
     return 'error: '.$!;   local $SIG{__DIE__}='DEFAULT';
  }   local $SIG{ALRM}=sub {
  @oldenv=<$fh>;      $failed=1;
  close($fh);      die("failed lock");
    };
    alarm(13);
    flock($file,$lock_type);
    alarm(0);
       };
       if ($failed) {
    return undef;
       } else {
    return 1;
     }      }
     for (my $i=0; $i<=$#oldenv; $i++) {  }
         chomp($oldenv[$i]);  
         if ($oldenv[$i] ne '') {  # ---------------------------------------------------------- Append Environment
     my ($name,$value)=split(/=/,$oldenv[$i]);  
     unless (defined($newenv{$name})) {  sub appenv {
  $newenv{$name}=$value;      my ($newenv,$roles) = @_;
       if (ref($newenv) eq 'HASH') {
           foreach my $key (keys(%{$newenv})) {
               my $refused = 0;
       if (($key =~ /^user\.role/) || ($key =~ /^user\.priv/)) {
                   $refused = 1;
                   if (ref($roles) eq 'ARRAY') {
                       my ($type,$role) = ($key =~ /^user\.(role|priv)\.([^.]+)\./);
                       if (grep(/^\Q$role\E$/,@{$roles})) {
                           $refused = 0;
                       }
                   }
               }
               if ($refused) {
                   &logthis("<font color=\"blue\">WARNING: ".
                            "Attempt to modify environment ".$key." to ".$newenv->{$key}
                            .'</font>');
           delete($newenv->{$key});
               } else {
                   $env{$key}=$newenv->{$key};
               }
           }
           my $opened = open(my $env_file,'+<',$env{'user.environment'});
           if ($opened
       && &timed_flock($env_file,LOCK_EX)
       &&
       tie(my %disk_env,'GDBM_File',$env{'user.environment'},
           (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
       while (my ($key,$value) = each(%{$newenv})) {
           $disk_env{$key} = $value;
     }      }
       untie(%disk_env);
         }          }
     }      }
     {  
  my $fh;  
  unless (open($fh,">$ENV{'user.environment'}")) {  
     return 'error';  
  }  
  my $newname;  
  foreach $newname (keys %newenv) {  
     print $fh "$newname=$newenv{$newname}\n";  
  }  
  close($fh);  
     }  
   
     close($lockfh);  
     return 'ok';      return 'ok';
 }  }
 # ----------------------------------------------------- Delete from Environment  # ----------------------------------------------------- Delete from Environment
   
 sub delenv {  sub delenv {
     my $delthis=shift;      my ($delthis,$regexp,$roles) = @_;
     my %newenv=();      if (($delthis=~/^user\.role/) || ($delthis=~/^user\.priv/)) {
     if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {          my $refused = 1;
         &logthis("<font color=blue>WARNING: ".          if (ref($roles) eq 'ARRAY') {
                 "Attempt to delete from environment ".$delthis);              my ($type,$role) = ($delthis =~ /^user\.(role|priv)\.([^.]+)\./);
         return 'error';              if (grep(/^\Q$role\E$/,@{$roles})) {
     }                  $refused = 0;
     my @oldenv;              }
     {          }
  my $fh;          if ($refused) {
  unless (open($fh,"$ENV{'user.environment'}")) {              &logthis("<font color=\"blue\">WARNING: ".
     return 'error';                       "Attempt to delete from environment ".$delthis);
  }              return 'error';
  unless (flock($fh,LOCK_SH)) {          }
     &logthis("<font color=blue>WARNING: ".      }
      'Could not obtain shared lock in delenv: '.$!);      my $opened = open(my $env_file,'+<',$env{'user.environment'});
     close($fh);      if ($opened
     return 'error: '.$!;   && &timed_flock($env_file,LOCK_EX)
  }   &&
  @oldenv=<$fh>;   tie(my %disk_env,'GDBM_File',$env{'user.environment'},
  close($fh);      (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
     }   foreach my $key (keys(%disk_env)) {
     {      if ($regexp) {
  my $fh;                  if ($key=~/^$delthis/) {
  unless (open($fh,">$ENV{'user.environment'}")) {                      delete($env{$key});
     return 'error';                      delete($disk_env{$key});
  }                  } 
  unless (flock($fh,LOCK_EX)) {  
     &logthis("<font color=blue>WARNING: ".  
      'Could not obtain exclusive lock in delenv: '.$!);  
     close($fh);  
     return 'error: '.$!;  
  }  
  foreach (@oldenv) {  
     if ($_=~/^$delthis/) {   
                 my ($key,undef) = split('=',$_);  
                 delete($ENV{$key});  
             } else {              } else {
                 print $fh $_;                   if ($key=~/^\Q$delthis\E/) {
       delete($env{$key});
       delete($disk_env{$key});
           }
             }              }
  }   }
  close($fh);   untie(%disk_env);
     }      }
     return 'ok';      return 'ok';
 }  }
   
   sub get_env_multiple {
       my ($name) = @_;
       my @values;
       if (defined($env{$name})) {
           # exists is it an array
           if (ref($env{$name})) {
               @values=@{ $env{$name} };
           } else {
               $values[0]=$env{$name};
           }
       }
       return(@values);
   }
   
   # ------------------------------------------------------------------- Locking
   
   sub set_lock {
       my ($text)=@_;
       $locknum++;
       my $id=$$.'-'.$locknum;
       &appenv({'session.locks' => $env{'session.locks'}.','.$id,
                'session.lock.'.$id => $text});
       return $id;
   }
   
   sub get_locks {
       my $num=0;
       my %texts=();
       foreach my $lock (split(/\,/,$env{'session.locks'})) {
          if ($lock=~/\w/) {
             $num++;
             $texts{$lock}=$env{'session.lock.'.$lock};
          }
      }
      return ($num,%texts);
   }
   
   sub remove_lock {
       my ($id)=@_;
       my $newlocks='';
       foreach my $lock (split(/\,/,$env{'session.locks'})) {
          if (($lock=~/\w/) && ($lock ne $id)) {
             $newlocks.=','.$lock;
          }
       }
       &appenv({'session.locks' => $newlocks});
       &delenv('session.lock.'.$id);
   }
   
   sub remove_all_locks {
       my $activelocks=$env{'session.locks'};
       foreach my $lock (split(/\,/,$env{'session.locks'})) {
          if ($lock=~/\w/) {
             &remove_lock($lock);
          }
       }
   }
   
   
 # ------------------------------------------ Find out current server userload  # ------------------------------------------ Find out current server userload
 # there is a copy in lond  
 sub userload {  sub userload {
     my $numusers=0;      my $numusers=0;
     {      {
Line 426  sub userload { Line 805  sub userload {
  my $filename;   my $filename;
  my $curtime=time;   my $curtime=time;
  while ($filename=readdir(LONIDS)) {   while ($filename=readdir(LONIDS)) {
     if ($filename eq '.' || $filename eq '..') {next;}      next if ($filename eq '.' || $filename eq '..');
       next if ($filename =~ /publicuser_\d+\.id/);
     my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];      my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];
     if ($curtime-$mtime < 1800) { $numusers++; }      if ($curtime-$mtime < 1800) { $numusers++; }
  }   }
Line 441  sub userload { Line 821  sub userload {
     return $userloadpercent;      return $userloadpercent;
 }  }
   
 # ------------------------------------------ Fight off request when overloaded  
   
 sub overloaderror {  
     my ($r,$checkserver)=@_;  
     unless ($checkserver) { $checkserver=$perlvar{'lonHostID'}; }  
     my $loadavg;  
     if ($checkserver eq $perlvar{'lonHostID'}) {  
        open(my $loadfile,'/proc/loadavg');  
        $loadavg=<$loadfile>;  
        $loadavg =~ s/\s.*//g;  
        $loadavg = 100*$loadavg/$perlvar{'lonLoadLim'};  
        close($loadfile);  
     } else {  
        $loadavg=&reply('load',$checkserver);  
     }  
     my $overload=$loadavg-100;  
     if ($overload>0) {  
  $r->err_headers_out->{'Retry-After'}=$overload;  
         $r->log_error('Overload of '.$overload.' on '.$checkserver);  
         return 413;  
     }      
     return '';  
 }  
   
 # ------------------------------ Find server with least workload from spare.tab  # ------------------------------ Find server with least workload from spare.tab
   
 sub spareserver {  sub spareserver {
     my ($loadpercent,$userloadpercent) = @_;      my ($loadpercent,$userloadpercent,$want_server_name,$udom) = @_;
     my $tryserver;      my $spare_server;
     my $spareserver='';  
     if ($userloadpercent !~ /\d/) { $userloadpercent=0; }      if ($userloadpercent !~ /\d/) { $userloadpercent=0; }
     my $lowestserver=$loadpercent > $userloadpercent?      my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent 
              $loadpercent :  $userloadpercent;                                                       :  $userloadpercent;
     foreach $tryserver (keys %spareid) {      my ($uint_dom,$remotesessions);
  my $loadans=reply('load',$tryserver);      if (($udom ne '') && (&domain($udom) ne '')) {
  my $userloadans=reply('userload',$tryserver);          my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
  if ($loadans !~ /\d/ && $userloadans !~ /\d/) {          $uint_dom = &Apache::lonnet::internet_dom($uprimary_id);
     next; #didn't get a number from the server          my %udomdefaults = &Apache::lonnet::get_domain_defaults($udom);
  }          $remotesessions = $udomdefaults{'remotesessions'};
  my $answer;      }
  if ($loadans =~ /\d/) {      my $spareshash = &this_host_spares($udom);
     if ($userloadans =~ /\d/) {      if (ref($spareshash) eq 'HASH') {
  #both are numbers, pick the bigger one          if (ref($spareshash->{'primary'}) eq 'ARRAY') {
  $answer=$loadans > $userloadans?              foreach my $try_server (@{ $spareshash->{'primary'} }) {
     $loadans :  $userloadans;                  if ($uint_dom) {
     } else {                      next unless (&spare_can_host($udom,$uint_dom,$remotesessions,
  $answer = $loadans;                                                   $try_server));
                   }
           ($spare_server, $lowest_load) =
               &compare_server_load($try_server, $spare_server, $lowest_load);
               }
           }
   
           my $found_server = ($spare_server ne '' && $lowest_load < 100);
   
           if (!$found_server) {
               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) {
           my $protocol = 'http';
           if ($protocol{$spare_server} eq 'https') {
               $protocol = $protocol{$spare_server};
           }
           if (defined($spare_server)) {
               my $hostname = &hostname($spare_server);
               if (defined($hostname)) {
           $spare_server = $protocol.'://'.$hostname;
               }
           }
       }
       return $spare_server;
   }
   
   sub compare_server_load {
       my ($try_server, $spare_server, $lowest_load) = @_;
   
       my $loadans     = &reply('load',    $try_server);
       my $userloadans = &reply('userload',$try_server);
   
       if ($loadans !~ /\d/ && $userloadans !~ /\d/) {
    return ($spare_server, $lowest_load); #didn't get a number from the server
       }
   
       my $load;
       if ($loadans =~ /\d/) {
    if ($userloadans =~ /\d/) {
       #both are numbers, pick the bigger one
       $load = ($loadans > $userloadans) ? $loadans 
                                 : $userloadans;
  } else {   } else {
     $answer = $userloadans;      $load = $loadans;
  }  
  if (($answer =~ /\d/) && ($answer<$lowestserver)) {  
     $spareserver="http://$hostname{$tryserver}";  
     $lowestserver=$answer;  
  }   }
       } else {
    $load = $userloadans;
       }
   
       if (($load =~ /\d/) && ($load < $lowest_load)) {
    $spare_server = $try_server;
    $lowest_load  = $load;
     }      }
     return $spareserver;      return ($spare_server,$lowest_load);
   }
   
   # --------------------------- ask offload servers if user already has a session
   sub find_existing_session {
       my ($udom,$uname) = @_;
       my $spareshash = &this_host_spares($udom);
       if (ref($spareshash) eq 'HASH') {
           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;
   }
   
   # -------------------------------- ask if server already has a session for user
   sub has_user_session {
       my ($lonid,$udom,$uname) = @_;
       my $result = &reply(join(':','userhassession',
        map {&escape($_)} ($udom,$uname)),$lonid);
       return 1 if ($result eq 'ok');
   
       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,$isredirect);
       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;
                       $isredirect = 1;
                   }
               } else {
                   ($login_host, $lowest_load) =
                       &compare_server_load($lonhost, $login_host, $lowest_load);
                   if ($login_host eq $lonhost) {
                       $portal_path = '';
                       $isredirect = ''; 
                   }
               }
           } else {
               ($login_host, $lowest_load) =
                   &compare_server_load($lonhost, $login_host, $lowest_load);
           }
       }
       if ($login_host ne '') {
           $hostname = &hostname($login_host);
       }
       return ($login_host,$hostname,$portal_path,$isredirect);
 }  }
   
 # --------------------------------------------- Try to change a user's password  # --------------------------------------------- Try to change a user's password
   
 sub changepass {  sub changepass {
     my ($uname,$udom,$currentpass,$newpass,$server)=@_;      my ($uname,$udom,$currentpass,$newpass,$server,$context)=@_;
     $currentpass = &escape($currentpass);      $currentpass = &escape($currentpass);
     $newpass     = &escape($newpass);      $newpass     = &escape($newpass);
     my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass",      my $lonhost = $perlvar{'lonHostID'};
       my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass:$context:$lonhost",
        $server);         $server);
     if (! $answer) {      if (! $answer) {
  &logthis("No reply on password change request to $server ".   &logthis("No reply on password change request to $server ".
Line 531  sub changepass { Line 1010  sub changepass {
     } elsif ($answer =~ "^refused") {      } elsif ($answer =~ "^refused") {
  &logthis("$server refused to change $uname in $udom password because ".   &logthis("$server refused to change $uname in $udom password because ".
  "it was sent an unencrypted request to change the password.");   "it was sent an unencrypted request to change the password.");
       } elsif ($answer =~ "invalid_client") {
           &logthis("$server refused to change $uname in $udom password because ".
                    "it was a reset by e-mail originating from an invalid server.");
     }      }
     return $answer;      return $answer;
 }  }
Line 554  sub queryauthenticate { Line 1036  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)=@_;      my ($uname,$upass,$udom,$checkdefauth,$clientcancheckhost)=@_;
     $upass=escape($upass);      $upass=&escape($upass);
     $uname=~s/\W//g;      $uname= &LONCAPA::clean_username($uname);
     my $uhome=&homeserver($uname,$udom);      my $uhome=&homeserver($uname,$udom,1);
     if (!$uhome) {      my $newhome;
  &logthis("User $uname at $udom is unknown in authenticate");      if ((!$uhome) || ($uhome eq 'no_host')) {
  return 'no_host';  # Maybe the machine was offline and only re-appeared again recently?
           &reconlonc();
   # One more
    $uhome=&homeserver($uname,$udom,1);
           if (($uhome eq 'no_host') && $checkdefauth) {
               if (defined(&domain($udom,'primary'))) {
                   $newhome=&domain($udom,'primary');
               }
               if ($newhome ne '') {
                   $uhome = $newhome;
               }
           }
    if ((!$uhome) || ($uhome eq 'no_host')) {
       &logthis("User $uname at $udom is unknown in authenticate");
       return 'no_host';
           }
     }      }
     my $answer=reply("encrypt:auth:$udom:$uname:$upass",$uhome);      my $answer=reply("encrypt:auth:$udom:$uname:$upass:$checkdefauth:$clientcancheckhost",$uhome);
     if ($answer eq 'authorized') {      if ($answer eq 'authorized') {
  &logthis("User $uname at $udom authorized by $uhome");           if ($newhome) {
  return $uhome;               &logthis("User $uname at $udom authorized by $uhome, but needs account");
               return 'no_account_on_host'; 
           } else {
               &logthis("User $uname at $udom authorized by $uhome");
               return $uhome;
           }
     }      }
     if ($answer eq 'non_authorized') {      if ($answer eq 'non_authorized') {
  &logthis("User $uname at $udom rejected by $uhome");   &logthis("User $uname at $udom rejected by $uhome");
Line 575  sub authenticate { Line 1077  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 @hosts = &current_machine_ids();
       my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
       my $uintdom = &Apache::lonnet::internet_dom($uprimary_id);
       my $intdom = &Apache::lonnet::internet_dom($lonhost);
       my $serverhomedom = &host_domain($lonhost);
   
       my $cachetime = 60*60*24;
   
       if (($uintdom ne '') && ($uintdom eq $intdom)) {
           $dom_in_use = $udom;
           $homeintdom = 1;
       } else {
           $dom_in_use = $serverhomedom;
       }
       my ($result,$cached)=&is_cached_new('loadbalancing',$dom_in_use);
       unless (defined($cached)) {
           my %domconfig =
               &Apache::lonnet::get_dom('configuration',['loadbalancing'],$dom_in_use);
           if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
               $result = &do_cache_new('loadbalancing',$dom_in_use,$domconfig{'loadbalancing'},$cachetime);
           }
       }
       if (ref($result) eq 'HASH') {
           my $currbalancer = $result->{'lonhost'};
           my $currtargets = $result->{'targets'};
           my $currrules = $result->{'rules'};
           if ($currbalancer ne '') {
               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);
           }
       }
       if ($is_balancer) {
           my $lowest_load = 30000;
           if (ref($offloadto) eq 'HASH') {
               if (ref($offloadto->{'primary'}) eq 'ARRAY') {
                   foreach my $try_server (@{$offloadto->{'primary'}}) {
                       ($otherserver,$lowest_load) =
                           &compare_server_load($try_server,$otherserver,$lowest_load);
                   }
               }
               my $found_server = ($otherserver ne '' && $lowest_load < 100);
   
               if (!$found_server) {
                   if (ref($offloadto->{'default'}) eq 'ARRAY') {
                       foreach my $try_server (@{$offloadto->{'default'}}) {
                           ($otherserver,$lowest_load) =
                               &compare_server_load($try_server,$otherserver,$lowest_load);
                       }
                   }
               }
           } elsif (ref($offloadto) eq 'ARRAY') {
               if (@{$offloadto} == 1) {
                   $otherserver = $offloadto->[0];
               } elsif (@{$offloadto} > 1) {
                   foreach my $try_server (@{$offloadto}) {
                       ($otherserver,$lowest_load) =
                           &compare_server_load($try_server,$otherserver,$lowest_load);
                   }
               }
           }
           if (($otherserver ne '') && (grep(/^\Q$otherserver\E$/,@hosts))) {
               $is_balancer = 0;
               if ($uname ne '' && $udom ne '') {
                   if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) {
                       
                       &appenv({'user.loadbalexempt'     => $lonhost,  
                                'user.loadbalcheck.time' => time});
                   }
               }
           }
       }
       return ($is_balancer,$otherserver);
   }
   
   sub get_loadbalancer_targets {
       my ($rule_in_effect,$currtargets,$uname,$udom) = @_;
       my $offloadto;
       if ($rule_in_effect eq 'none') {
           return [$perlvar{'lonHostID'}];
       } elsif ($rule_in_effect eq '') {
           $offloadto = $currtargets;
       } else {
           if ($rule_in_effect eq 'homeserver') {
               my $homeserver = &homeserver($uname,$udom);
               if ($homeserver ne 'no_host') {
                   $offloadto = [$homeserver];
               }
           } elsif ($rule_in_effect eq 'externalbalancer') {
               my %domconfig =
                   &Apache::lonnet::get_dom('configuration',['loadbalancing'],$udom);
               if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
                   if ($domconfig{'loadbalancing'}{'lonhost'} ne '') {
                       if (&hostname($domconfig{'loadbalancing'}{'lonhost'}) ne '') {
                           $offloadto = [$domconfig{'loadbalancing'}{'lonhost'}];
                       }
                   }
               } else {
                   my %servers = &internet_dom_servers($udom);
                   my ($remotebalancer,$remotetargets) = &get_lonbalancer_config(\%servers);
                   if (&hostname($remotebalancer) ne '') {
                       $offloadto = [$remotebalancer];
                   }
               }
           } elsif (&hostname($rule_in_effect) ne '') {
               $offloadto = [$rule_in_effect];
           }
       }
       return $offloadto;
   }
   
   sub internet_dom_servers {
       my ($dom) = @_;
       my (%uniqservers,%servers);
       my $primaryserver = &hostname(&domain($dom,'primary'));
       my @machinedoms = &machine_domains($primaryserver);
       foreach my $mdom (@machinedoms) {
           my %currservers = %servers;
           my %server = &get_servers($mdom);
           %servers = (%currservers,%server);
       }
       my %by_hostname;
       foreach my $id (keys(%servers)) {
           push(@{$by_hostname{$servers{$id}}},$id);
       }
       foreach my $hostname (sort(keys(%by_hostname))) {
           if (@{$by_hostname{$hostname}} > 1) {
               my $match = 0;
               foreach my $id (@{$by_hostname{$hostname}}) {
                   if (&host_domain($id) eq $dom) {
                       $uniqservers{$id} = $hostname;
                       $match = 1;
                   }
               }
               unless ($match) {
                   $uniqservers{$by_hostname{$hostname}[0]} = $hostname;
               }
           } else {
               $uniqservers{$by_hostname{$hostname}[0]} = $hostname;
           }
       }
       return %uniqservers;
   }
   
 # ---------------------- Find the homebase for a user from domain's lib servers  # ---------------------- Find the homebase for a user from domain's lib servers
   
   my %homecache;
 sub homeserver {  sub homeserver {
     my ($uname,$udom,$ignoreBadCache)=@_;      my ($uname,$udom,$ignoreBadCache)=@_;
     my $index="$uname:$udom";      my $index="$uname:$udom";
   
     my ($result,$cached)=&is_cached(\%homecache,$index,'home',86400);      if (exists($homecache{$index})) { return $homecache{$index}; }
     if (defined($cached)) { return $result; }  
     my $tryserver;      my %servers = &get_servers($udom,'library');
     foreach $tryserver (keys %libserv) {      foreach my $tryserver (keys(%servers)) {
         next if ($ignoreBadCache ne 'true' &&           next if ($ignoreBadCache ne 'true' && 
  exists($badServerCache{$tryserver}));   exists($badServerCache{$tryserver}));
  if ($hostdom{$tryserver} eq $udom) {  
            my $answer=reply("home:$udom:$uname",$tryserver);   my $answer=reply("home:$udom:$uname",$tryserver);
            if ($answer eq 'found') {    if ($answer eq 'found') {
        return &do_cache(\%homecache,$index,$tryserver,'home');      delete($badServerCache{$tryserver}); 
            } elsif ($answer eq 'no_host') {      return $homecache{$index}=$tryserver;
        $badServerCache{$tryserver}=1;   } elsif ($answer eq 'no_host') {
            }      $badServerCache{$tryserver}=1;
        }   }
     }          }    
     return 'no_host';      return 'no_host';
 }  }
Line 605  sub idget { Line 1500  sub idget {
     my ($udom,@ids)=@_;      my ($udom,@ids)=@_;
     my %returnhash=();      my %returnhash=();
           
     my $tryserver;      my %servers = &get_servers($udom,'library');
     foreach $tryserver (keys %libserv) {      foreach my $tryserver (keys(%servers)) {
        if ($hostdom{$tryserver} eq $udom) {   my $idlist=join('&',@ids);
   my $idlist=join('&',@ids);   $idlist=~tr/A-Z/a-z/; 
           $idlist=~tr/A-Z/a-z/;    my $reply=&reply("idget:$udom:".$idlist,$tryserver);
   my $reply=&reply("idget:$udom:".$idlist,$tryserver);   my @answer=();
           my @answer=();   if (($reply ne 'con_lost') && ($reply!~/^error\:/)) {
           if (($reply ne 'con_lost') && ($reply!~/^error\:/)) {      @answer=split(/\&/,$reply);
       @answer=split(/\&/,$reply);   }                    ;
           }                    ;   my $i;
           my $i;   for ($i=0;$i<=$#ids;$i++) {
           for ($i=0;$i<=$#ids;$i++) {      if ($answer[$i]) {
               if ($answer[$i]) {   $returnhash{$ids[$i]}=$answer[$i];
   $returnhash{$ids[$i]}=$answer[$i];      } 
               }    }
           }      } 
        }  
     }      
     return %returnhash;      return %returnhash;
 }  }
   
Line 631  sub idget { Line 1524  sub idget {
 sub idrget {  sub idrget {
     my ($udom,@unames)=@_;      my ($udom,@unames)=@_;
     my %returnhash=();      my %returnhash=();
     foreach (@unames) {      foreach my $uname (@unames) {
         $returnhash{$_}=(&userenvironment($udom,$_,'id'))[1];          $returnhash{$uname}=(&userenvironment($udom,$uname,'id'))[1];
     }      }
     return %returnhash;      return %returnhash;
 }  }
Line 642  sub idrget { Line 1535  sub idrget {
 sub idput {  sub idput {
     my ($udom,%ids)=@_;      my ($udom,%ids)=@_;
     my %servers=();      my %servers=();
     foreach (keys %ids) {      foreach my $uname (keys(%ids)) {
  &cput('environment',{'id'=>$ids{$_}},$udom,$_);   &cput('environment',{'id'=>$ids{$uname}},$udom,$uname);
         my $uhom=&homeserver($_,$udom);          my $uhom=&homeserver($uname,$udom);
         if ($uhom ne 'no_host') {          if ($uhom ne 'no_host') {
             my $id=&escape($ids{$_});              my $id=&escape($ids{$uname});
             $id=~tr/A-Z/a-z/;              $id=~tr/A-Z/a-z/;
             my $unam=&escape($_);              my $esc_unam=&escape($uname);
     if ($servers{$uhom}) {      if ($servers{$uhom}) {
  $servers{$uhom}.='&'.$id.'='.$unam;   $servers{$uhom}.='&'.$id.'='.$esc_unam;
             } else {              } else {
                 $servers{$uhom}=$id.'='.$unam;                  $servers{$uhom}=$id.'='.$esc_unam;
               }
           }
       }
       foreach my $server (keys(%servers)) {
           &critical('idput:'.$udom.':'.$servers{$server},$server);
       }
   }
   
   # ------------------------------dump from db file owned by domainconfig user
   sub dump_dom {
       my ($namespace, $udom, $regexp) = @_;
   
       $udom ||= $env{'user.domain'};
   
       return () unless $udom;
   
       return &dump($namespace, $udom, &get_domainconfiguser($udom), $regexp);
   }
   
   # ------------------------------------------ get items from domain db files   
   
   sub get_dom {
       my ($namespace,$storearr,$udom,$uhome)=@_;
       my $items='';
       foreach my $item (@$storearr) {
           $items.=&escape($item).'&';
       }
       $items=~s/\&$//;
       if (!$udom) {
           $udom=$env{'user.domain'};
           if (defined(&domain($udom,'primary'))) {
               $uhome=&domain($udom,'primary');
           } else {
               undef($uhome);
           }
       } else {
           if (!$uhome) {
               if (defined(&domain($udom,'primary'))) {
                   $uhome=&domain($udom,'primary');
               }
           }
       }
       if ($udom && $uhome && ($uhome ne 'no_host')) {
           my $rep=&reply("getdom:$udom:$namespace:$items",$uhome);
           my %returnhash;
           if ($rep eq '' || $rep =~ /^error: 2 /) {
               return %returnhash;
           }
           my @pairs=split(/\&/,$rep);
           if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) {
               return @pairs;
           }
           my $i=0;
           foreach my $item (@$storearr) {
               $returnhash{$item}=&thaw_unescape($pairs[$i]);
               $i++;
           }
           return %returnhash;
       } else {
           &logthis("get_dom failed - no homeserver and/or domain ($udom) ($uhome)");
       }
   }
   
   # -------------------------------------------- put items in domain db files 
   
   sub put_dom {
       my ($namespace,$storehash,$udom,$uhome)=@_;
       if (!$udom) {
           $udom=$env{'user.domain'};
           if (defined(&domain($udom,'primary'))) {
               $uhome=&domain($udom,'primary');
           } else {
               undef($uhome);
           }
       } else {
           if (!$uhome) {
               if (defined(&domain($udom,'primary'))) {
                   $uhome=&domain($udom,'primary');
             }              }
         }          }
       } 
       if ($udom && $uhome && ($uhome ne 'no_host')) {
           my $items='';
           foreach my $item (keys(%$storehash)) {
               $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
           }
           $items=~s/\&$//;
           return &reply("putdom:$udom:$namespace:$items",$uhome);
       } else {
           &logthis("put_dom failed - no homeserver and/or domain");
     }      }
     foreach (keys %servers) {  }
         &critical('idput:'.$udom.':'.$servers{$_},$_);  
   # --------------------- newput for items in db file owned by domainconfig user
   sub newput_dom {
       my ($namespace,$storehash,$udom) = @_;
       my $result;
       if (!$udom) {
           $udom=$env{'user.domain'};
       }
       if ($udom) {
           my $uname = &get_domainconfiguser($udom);
           $result = &newput($namespace,$storehash,$udom,$uname);
     }      }
       return $result;
   }
   
   # --------------------- delete for items in db file owned by domainconfig user
   sub del_dom {
       my ($namespace,$storearr,$udom)=@_;
       if (ref($storearr) eq 'ARRAY') {
           if (!$udom) {
               $udom=$env{'user.domain'};
           }
           if ($udom) {
               my $uname = &get_domainconfiguser($udom); 
               return &del($namespace,$storearr,$udom,$uname);
           }
       }
   }
   
   # ----------------------------------construct domainconfig user for a domain 
   sub get_domainconfiguser {
       my ($udom) = @_;
       return $udom.'-domainconfig';
   }
   
   sub retrieve_inst_usertypes {
       my ($udom) = @_;
       my (%returnhash,@order);
       my %domdefs = &Apache::lonnet::get_domain_defaults($udom);
       if ((ref($domdefs{'inststatustypes'}) eq 'HASH') && 
           (ref($domdefs{'inststatusorder'}) eq 'ARRAY')) {
           %returnhash = %{$domdefs{'inststatustypes'}};
           @order = @{$domdefs{'inststatusorder'}};
       } else {
           if (defined(&domain($udom,'primary'))) {
               my $uhome=&domain($udom,'primary');
               my $rep=&reply("inst_usertypes:$udom",$uhome);
               if ($rep =~ /^(con_lost|error|no_such_host|refused)/) {
                   &logthis("get_dom failed - $rep returned from $uhome in domain: $udom");
                   return (\%returnhash,\@order);
               }
               my ($hashitems,$orderitems) = split(/:/,$rep); 
               my @pairs=split(/\&/,$hashitems);
               foreach my $item (@pairs) {
                   my ($key,$value)=split(/=/,$item,2);
                   $key = &unescape($key);
                   next if ($key =~ /^error: 2 /);
                   $returnhash{$key}=&thaw_unescape($value);
               }
               my @esc_order = split(/\&/,$orderitems);
               foreach my $item (@esc_order) {
                   push(@order,&unescape($item));
               }
           } else {
               &logthis("get_dom failed - no primary domain server for $udom");
           }
       }
       return (\%returnhash,\@order);
   }
   
   sub is_domainimage {
       my ($url) = @_;
       if ($url=~m-^/+res/+($match_domain)/+\1\-domainconfig/+(img|logo|domlogo)/+-) {
           if (&domain($1) ne '') {
               return '1';
           }
       }
       return;
   }
   
   sub inst_directory_query {
       my ($srch) = @_;
       my $udom = $srch->{'srchdomain'};
       my %results;
       my $homeserver = &domain($udom,'primary');
       my $outcome;
       if ($homeserver ne '') {
    my $queryid=&reply("querysend:instdirsearch:".
      &escape($srch->{'srchby'}).':'.
      &escape($srch->{'srchterm'}).':'.
      &escape($srch->{'srchtype'}),$homeserver);
    my $host=&hostname($homeserver);
    if ($queryid !~/^\Q$host\E\_/) {
       &logthis('instituional directory search invalid queryid: '.$queryid.' for host: '.$homeserver.'in domain '.$udom);
       return;
    }
    my $response = &get_query_reply($queryid);
    my $maxtries = 5;
    my $tries = 1;
    while (($response=~/^timeout/) && ($tries < $maxtries)) {
       $response = &get_query_reply($queryid);
       $tries ++;
    }
   
           if (!&error($response) && $response ne 'refused') {
               if ($response eq 'unavailable') {
                   $outcome = $response;
               } else {
                   $outcome = 'ok';
                   my @matches = split(/\n/,$response);
                   foreach my $match (@matches) {
                       my ($key,$value) = split(/=/,$match);
                       $results{&unescape($key).':'.$udom} = &thaw_unescape($value);
                   }
               }
           }
       }
       return ($outcome,%results);
   }
   
   sub usersearch {
       my ($srch) = @_;
       my $dom = $srch->{'srchdomain'};
       my %results;
       my %libserv = &all_library();
       my $query = 'usersearch';
       foreach my $tryserver (keys(%libserv)) {
           if (&host_domain($tryserver) eq $dom) {
               my $host=&hostname($tryserver);
               my $queryid=
                   &reply("querysend:".&escape($query).':'.
                          &escape($srch->{'srchby'}).':'.
                          &escape($srch->{'srchtype'}).':'.
                          &escape($srch->{'srchterm'}),$tryserver);
               if ($queryid !~/^\Q$host\E\_/) {
                   &logthis('usersearch: invalid queryid: '.$queryid.' for host: '.$host.'in domain '.$dom.' and server: '.$tryserver);
                   next;
               }
               my $reply = &get_query_reply($queryid);
               my $maxtries = 1;
               my $tries = 1;
               while (($reply=~/^timeout/) && ($tries < $maxtries)) {
                   $reply = &get_query_reply($queryid);
                   $tries ++;
               }
               if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
                   &logthis('usersrch error: '.$reply.' for '.$dom.' - searching for : '.$srch->{'srchterm'}.' by '.$srch->{'srchby'}.' ('.$srch->{'srchtype'}.') -  maxtries: '.$maxtries.' tries: '.$tries);
               } else {
                   my @matches;
                   if ($reply =~ /\n/) {
                       @matches = split(/\n/,$reply);
                   } else {
                       @matches = split(/\&/,$reply);
                   }
                   foreach my $match (@matches) {
                       my ($uname,$udom,%userhash);
                       foreach my $entry (split(/:/,$match)) {
                           my ($key,$value) =
                               map {&unescape($_);} split(/=/,$entry);
                           $userhash{$key} = $value;
                           if ($key eq 'username') {
                               $uname = $value;
                           } elsif ($key eq 'domain') {
                               $udom = $value;
                           }
                       }
                       $results{$uname.':'.$udom} = \%userhash;
                   }
               }
           }
       }
       return %results;
   }
   
   sub get_instuser {
       my ($udom,$uname,$id) = @_;
       my $homeserver = &domain($udom,'primary');
       my ($outcome,%results);
       if ($homeserver ne '') {
           my $queryid=&reply("querysend:getinstuser:".&escape($uname).':'.
                              &escape($id).':'.&escape($udom),$homeserver);
           my $host=&hostname($homeserver);
           if ($queryid !~/^\Q$host\E\_/) {
               &logthis('get_instuser invalid queryid: '.$queryid.' for host: '.$homeserver.'in domain '.$udom);
               return;
           }
           my $response = &get_query_reply($queryid);
           my $maxtries = 5;
           my $tries = 1;
           while (($response=~/^timeout/) && ($tries < $maxtries)) {
               $response = &get_query_reply($queryid);
               $tries ++;
           }
           if (!&error($response) && $response ne 'refused') {
               if ($response eq 'unavailable') {
                   $outcome = $response;
               } else {
                   $outcome = 'ok';
                   my @matches = split(/\n/,$response);
                   foreach my $match (@matches) {
                       my ($key,$value) = split(/=/,$match);
                       $results{&unescape($key)} = &thaw_unescape($value);
                   }
               }
           }
       }
       my %userinfo;
       if (ref($results{$uname}) eq 'HASH') {
           %userinfo = %{$results{$uname}};
       } 
       return ($outcome,%userinfo);
   }
   
   sub inst_rulecheck {
       my ($udom,$uname,$id,$item,$rules) = @_;
       my %returnhash;
       if ($udom ne '') {
           if (ref($rules) eq 'ARRAY') {
               @{$rules} = map {&escape($_);} (@{$rules});
               my $rulestr = join(':',@{$rules});
               my $homeserver=&domain($udom,'primary');
               if (($homeserver ne '') && ($homeserver ne 'no_host')) {
                   my $response;
                   if ($item eq 'username') {                
                       $response=&unescape(&reply('instrulecheck:'.&escape($udom).
                                                 ':'.&escape($uname).':'.$rulestr,
                                                 $homeserver));
                   } elsif ($item eq 'id') {
                       $response=&unescape(&reply('instidrulecheck:'.&escape($udom).
                                                 ':'.&escape($id).':'.$rulestr,
                                                 $homeserver));
                   } elsif ($item eq 'selfcreate') {
                       $response=&unescape(&reply('instselfcreatecheck:'.
                                                  &escape($udom).':'.&escape($uname).
                                                 ':'.$rulestr,$homeserver));
                   }
                   if ($response ne 'refused') {
                       my @pairs=split(/\&/,$response);
                       foreach my $item (@pairs) {
                           my ($key,$value)=split(/=/,$item,2);
                           $key = &unescape($key);
                           next if ($key =~ /^error: 2 /);
                           $returnhash{$key}=&thaw_unescape($value);
                       }
                   }
               }
           }
       }
       return %returnhash;
   }
   
   sub inst_userrules {
       my ($udom,$check) = @_;
       my (%ruleshash,@ruleorder);
       if ($udom ne '') {
           my $homeserver=&domain($udom,'primary');
           if (($homeserver ne '') && ($homeserver ne 'no_host')) {
               my $response;
               if ($check eq 'id') {
                   $response=&reply('instidrules:'.&escape($udom),
                                    $homeserver);
               } elsif ($check eq 'email') {
                   $response=&reply('instemailrules:'.&escape($udom),
                                    $homeserver);
               } else {
                   $response=&reply('instuserrules:'.&escape($udom),
                                    $homeserver);
               }
               if (($response ne 'refused') && ($response ne 'error') && 
                   ($response ne 'unknown_cmd') && 
                   ($response ne 'no_such_host')) {
                   my ($hashitems,$orderitems) = split(/:/,$response);
                   my @pairs=split(/\&/,$hashitems);
                   foreach my $item (@pairs) {
                       my ($key,$value)=split(/=/,$item,2);
                       $key = &unescape($key);
                       next if ($key =~ /^error: 2 /);
                       $ruleshash{$key}=&thaw_unescape($value);
                   }
                   my @esc_order = split(/\&/,$orderitems);
                   foreach my $item (@esc_order) {
                       push(@ruleorder,&unescape($item));
                   }
               }
           }
       }
       return (\%ruleshash,\@ruleorder);
   }
   
   # ------------- Get Authentication, Language and User Tools Defaults for Domain
   
   sub get_domain_defaults {
       my ($domain) = @_;
       my $cachetime = 60*60*24;
       my ($result,$cached)=&is_cached_new('domdefaults',$domain);
       if (defined($cached)) {
           if (ref($result) eq 'HASH') {
               return %{$result};
           }
       }
       my %domdefaults;
       my %domconfig =
            &Apache::lonnet::get_dom('configuration',['defaults','quotas',
                                     'requestcourses','inststatus',
                                     'coursedefaults','usersessions',
                                     'requestauthor'],$domain);
       if (ref($domconfig{'defaults'}) eq 'HASH') {
           $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; 
           $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'};
           $domdefaults{'auth_arg_def'} = $domconfig{'defaults'}{'auth_arg_def'};
           $domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'};
           $domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'};
           $domdefaults{'portal_def'} = $domconfig{'defaults'}{'portal_def'};
       } else {
           $domdefaults{'lang_def'} = &domain($domain,'lang_def');
           $domdefaults{'auth_def'} = &domain($domain,'auth_def');
           $domdefaults{'auth_arg_def'} = &domain($domain,'auth_arg_def');
       }
       if (ref($domconfig{'quotas'}) eq 'HASH') {
           if (ref($domconfig{'quotas'}{'defaultquota'}) eq 'HASH') {
               $domdefaults{'defaultquota'} = $domconfig{'quotas'}{'defaultquota'};
           } else {
               $domdefaults{'defaultquota'} = $domconfig{'quotas'};
           } 
           my @usertools = ('aboutme','blog','webdav','portfolio');
           foreach my $item (@usertools) {
               if (ref($domconfig{'quotas'}{$item}) eq 'HASH') {
                   $domdefaults{$item} = $domconfig{'quotas'}{$item};
               }
           }
       }
       if (ref($domconfig{'requestcourses'}) eq 'HASH') {
           foreach my $item ('official','unofficial','community') {
               $domdefaults{$item} = $domconfig{'requestcourses'}{$item};
           }
       }
       if (ref($domconfig{'requestauthor'}) eq 'HASH') {
           $domdefaults{'requestauthor'} = $domconfig{'requestauthor'};
       }
       if (ref($domconfig{'inststatus'}) eq 'HASH') {
           foreach my $item ('inststatustypes','inststatusorder') {
               $domdefaults{$item} = $domconfig{'inststatus'}{$item};
           }
       }
       if (ref($domconfig{'coursedefaults'}) eq 'HASH') {
           foreach my $item ('canuse_pdfforms') {
               $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,
                                     $cachetime);
       return %domdefaults;
 }  }
   
 # --------------------------------------------------- Assign a key to a student  # --------------------------------------------------- Assign a key to a student
Line 670  sub assign_access_key { Line 2009  sub assign_access_key {
 #  #
     my ($ckey,$kdom,$knum,$cdom,$cnum,$udom,$uname,$logentry)=@_;      my ($ckey,$kdom,$knum,$cdom,$cnum,$udom,$uname,$logentry)=@_;
     $kdom=      $kdom=
    $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($kdom));     $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($kdom));
     $knum=      $knum=
    $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($knum));     $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($knum));
     $cdom=      $cdom=
    $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));     $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($cdom));
     $cnum=      $cnum=
    $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));     $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($cnum));
     $udom=$ENV{'user.name'} unless (defined($udom));      $udom=$env{'user.name'} unless (defined($udom));
     $uname=$ENV{'user.domain'} unless (defined($uname));      $uname=$env{'user.domain'} unless (defined($uname));
     my %existing=&get('accesskeys',[$ckey],$kdom,$knum);      my %existing=&get('accesskeys',[$ckey],$kdom,$knum);
     if (($existing{$ckey}=~/^\#(.*)$/) || # - new key      if (($existing{$ckey}=~/^\#(.*)$/) || # - new key
         ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#(.*)$/)) {           ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#(.*)$/)) { 
Line 693  sub assign_access_key { Line 2032  sub assign_access_key {
 # key now belongs to user  # key now belongs to user
     my $envkey='key.'.$cdom.'_'.$cnum;      my $envkey='key.'.$cdom.'_'.$cnum;
             if (&put('environment',{$envkey => $ckey}) eq 'ok') {              if (&put('environment',{$envkey => $ckey}) eq 'ok') {
                 &appenv('environment.'.$envkey => $ckey);                  &appenv({'environment.'.$envkey => $ckey});
                 return 'ok';                  return 'ok';
             } else {              } else {
                 return                   return 
Line 720  sub comment_access_key { Line 2059  sub comment_access_key {
 #  #
     my ($ckey,$cdom,$cnum,$logentry)=@_;      my ($ckey,$cdom,$cnum,$logentry)=@_;
     $cdom=      $cdom=
    $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));     $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($cdom));
     $cnum=      $cnum=
    $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));     $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($cnum));
     my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);      my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
     if ($existing{$ckey}) {      if ($existing{$ckey}) {
         $existing{$ckey}.='; '.$logentry;          $existing{$ckey}.='; '.$logentry;
Line 744  sub comment_access_key { Line 2083  sub comment_access_key {
 sub generate_access_keys {  sub generate_access_keys {
     my ($number,$cdom,$cnum,$logentry)=@_;      my ($number,$cdom,$cnum,$logentry)=@_;
     $cdom=      $cdom=
    $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));     $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($cdom));
     $cnum=      $cnum=
    $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));     $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($cnum));
     unless (&allowed('mky',$cdom)) { return 0; }      unless (&allowed('mky',$cdom)) { return 0; }
     unless (($cdom) && ($cnum)) { return 0; }      unless (($cdom) && ($cnum)) { return 0; }
     if ($number>10000) { return 0; }      if ($number>10000) { return 0; }
Line 765  sub generate_access_keys { Line 2104  sub generate_access_keys {
        } else {         } else {
   if (&put('accesskeys',    if (&put('accesskeys',
               { $newkey => '# generated '.localtime().                { $newkey => '# generated '.localtime().
                            ' by '.$ENV{'user.name'}.'@'.$ENV{'user.domain'}.                             ' by '.$env{'user.name'}.'@'.$env{'user.domain'}.
                            '; '.$logentry },                             '; '.$logentry },
    $cdom,$cnum) eq 'ok') {     $cdom,$cnum) eq 'ok') {
               $total++;                $total++;
   }    }
        }         }
     }      }
     &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.home'},      &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},
          'Generated '.$total.' keys for '.$cnum.' at '.$cdom);           'Generated '.$total.' keys for '.$cnum.' at '.$cdom);
     return $total;      return $total;
 }  }
Line 782  sub generate_access_keys { Line 2121  sub generate_access_keys {
 sub validate_access_key {  sub validate_access_key {
     my ($ckey,$cdom,$cnum,$udom,$uname)=@_;      my ($ckey,$cdom,$cnum,$udom,$uname)=@_;
     $cdom=      $cdom=
    $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));     $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($cdom));
     $cnum=      $cnum=
    $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));     $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($cnum));
     $udom=$ENV{'user.domain'} unless (defined($udom));      $udom=$env{'user.domain'} unless (defined($udom));
     $uname=$ENV{'user.name'} unless (defined($uname));      $uname=$env{'user.name'} unless (defined($uname));
     my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);      my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
     return ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#/);      return ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#/);
 }  }
   
 # ------------------------------------- Find the section of student in a course  # ------------------------------------- Find the section of student in a course
   sub devalidate_getsection_cache {
       my ($udom,$unam,$courseid)=@_;
       my $hashid="$udom:$unam:$courseid";
       &devalidate_cache_new('getsection',$hashid);
   }
   
   sub courseid_to_courseurl {
       my ($courseid) = @_;
       #already url style courseid
       return $courseid if ($courseid =~ m{^/});
   
       if (exists($env{'course.'.$courseid.'.num'})) {
    my $cnum = $env{'course.'.$courseid.'.num'};
    my $cdom = $env{'course.'.$courseid.'.domain'};
    return "/$cdom/$cnum";
       }
   
       my %courseinfo=&Apache::lonnet::coursedescription($courseid);
       if (exists($courseinfo{'num'})) {
    return "/$courseinfo{'domain'}/$courseinfo{'num'}";
       }
   
       return undef;
   }
   
 sub getsection {  sub getsection {
     my ($udom,$unam,$courseid)=@_;      my ($udom,$unam,$courseid)=@_;
     $courseid=~s/\_/\//g;      my $cachetime=1800;
     $courseid=~s/^(\w)/\/$1/;  
   
     my $hashid="$udom:$unam:$courseid";      my $hashid="$udom:$unam:$courseid";
     my ($result,$cached)=&is_cached(\%getsectioncache,$hashid,'getsection');      my ($result,$cached)=&is_cached_new('getsection',$hashid);
     if (defined($cached)) { return $result; }      if (defined($cached)) { return $result; }
   
     my %Pending;       my %Pending; 
Line 817  sub getsection { Line 2179  sub getsection {
     # If there is more than one expired role, choose the one which ended last.      # If there is more than one expired role, choose the one which ended last.
     # If there is a role which has expired, return it.      # If there is a role which has expired, return it.
     #      #
     foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',      $courseid = &courseid_to_courseurl($courseid);
                         &homeserver($unam,$udom)))) {      my %roleshash = &dump('roles',$udom,$unam,$courseid);
         my ($key,$value)=split(/\=/,$_);      foreach my $key (keys(%roleshash)) {
         $key=&unescape($key);  
         next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/);          next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/);
         my $section=$1;          my $section=$1;
         if ($key eq $courseid.'_st') { $section=''; }          if ($key eq $courseid.'_st') { $section=''; }
         my ($dummy,$end,$start)=split(/\_/,&unescape($value));          my ($dummy,$end,$start)=split(/\_/,&unescape($roleshash{$key}));
         my $now=time;          my $now=time;
         if (defined($end) && $end && ($now > $end)) {          if (defined($end) && $end && ($now > $end)) {
             $Expired{$end}=$section;              $Expired{$end}=$section;
Line 834  sub getsection { Line 2195  sub getsection {
             $Pending{$start}=$section;              $Pending{$start}=$section;
             next;              next;
         }          }
         return &do_cache(\%getsectioncache,$hashid,$section,'getsection');          return &do_cache_new('getsection',$hashid,$section,$cachetime);
     }      }
     #      #
     # Presumedly there will be few matching roles from the above      # Presumedly there will be few matching roles from the above
     # loop and the sorting time will be negligible.      # loop and the sorting time will be negligible.
     if (scalar(keys(%Pending))) {      if (scalar(keys(%Pending))) {
         my ($time) = sort {$a <=> $b} keys(%Pending);          my ($time) = sort {$a <=> $b} keys(%Pending);
         return &do_cache(\%getsectioncache,$hashid,$Pending{$time},'getsection');          return &do_cache_new('getsection',$hashid,$Pending{$time},$cachetime);
     }       } 
     if (scalar(keys(%Expired))) {      if (scalar(keys(%Expired))) {
         my @sorted = sort {$a <=> $b} keys(%Expired);          my @sorted = sort {$a <=> $b} keys(%Expired);
         my $time = pop(@sorted);          my $time = pop(@sorted);
         return &do_cache(\%getsectioncache,$hashid,$Expired{$time},'getsection');          return &do_cache_new('getsection',$hashid,$Expired{$time},$cachetime);
     }      }
     return &do_cache(\%getsectioncache,$hashid,'-1','getsection');      return &do_cache_new('getsection',$hashid,'-1',$cachetime);
 }  }
   
   sub save_cache {
 my $disk_caching_disabled=1;      &purge_remembered();
       #&Apache::loncommon::validate_page();
 sub devalidate_cache {      undef(%env);
     my ($cache,$id,$name) = @_;      undef($env_loaded);
     delete $$cache{$id.'.time'};  }
     delete $$cache{$id.'.file'};  
     delete $$cache{$id};  my $to_remember=-1;
     if (1 || $disk_caching_disabled) { return; }  my %remembered;
     my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";  my %accessed;
     if (!-e $filename) { return; }  my $kicks=0;
     open(DB,">$filename.lock");  my $hits=0;
     flock(DB,LOCK_EX);  sub make_key {
     my %hash;      my ($name,$id) = @_;
     if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {      if (length($id) > 65 
  eval <<'EVALBLOCK';   && length(&escape($id)) > 200) {
     delete($hash{$id});   $id=length($id).':'.&Digest::MD5::md5_hex($id);
     delete($hash{$id.'.time'});      }
 EVALBLOCK      return &escape($name.':'.$id);
         if ($@) {  }
     &logthis("<font color='red'>devalidate_cache blew up :$@:$name</font>");  
     unlink($filename);  sub devalidate_cache_new {
  }      my ($name,$id,$debug) = @_;
     } else {      if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); }
  if (-e $filename) {      $id=&make_key($name,$id);
     &logthis("Unable to tie hash (devalidate cache): $name");      $memcache->delete($id);
     unlink($filename);      delete($remembered{$id});
  }      delete($accessed{$id});
     }  }
     untie(%hash);  
     flock(DB,LOCK_UN);  sub is_cached_new {
     close(DB);      my ($name,$id,$debug) = @_;
 }      $id=&make_key($name,$id);
       if (exists($remembered{$id})) {
 sub is_cached {   if ($debug) { &Apache::lonnet::logthis("Early return $id of $remembered{$id} "); }
     my ($cache,$id,$name,$time) = @_;   $accessed{$id}=[&gettimeofday()];
     if (!$time) { $time=300; }   $hits++;
     if (!exists($$cache{$id.'.time'})) {   return ($remembered{$id},1);
  &load_cache_item($cache,$name,$id,$time);      }
     }      my $value = $memcache->get($id);
     if (!exists($$cache{$id.'.time'})) {      if (!(defined($value))) {
 # &logthis("Didn't find $id");   if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); }
  return (undef,undef);   return (undef,undef);
     } else {  
  if (time-($$cache{$id.'.time'})>$time) {  
     if (exists($$cache{$id.'.file'})) {  
  foreach my $filename (@{ $$cache{$id.'.file'} }) {  
     my $mtime=(stat($filename))[9];  
     #+1 is to take care of edge effects  
     if ($mtime && (($mtime+1) < ($$cache{$id.'.time'}))) {  
 # &logthis("Upping $mtime - ".$$cache{$id.'.time'}.  
 # "$id because of $filename");  
     } else {  
  &logthis("Devalidating $filename $id - ".(time-($$cache{$id.'.time'})));  
  &devalidate_cache($cache,$id,$name);  
  return (undef,undef);  
     }  
  }  
  $$cache{$id.'.time'}=time;  
     } else {  
 # &logthis("Devalidating $id - ".time-($$cache{$id.'.time'}));  
  &devalidate_cache($cache,$id,$name);  
  return (undef,undef);  
     }  
  }  
     }      }
     return ($$cache{$id},1);      if ($value eq '__undef__') {
 }   if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); }
    $value=undef;
 sub do_cache {      }
     my ($cache,$id,$value,$name) = @_;      &make_room($id,$value,$debug);
     $$cache{$id.'.time'}=time;      if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); }
     $$cache{$id}=$value;      return ($value,1);
 #    &logthis("Caching $id as :$value:");  }
     &save_cache_item($cache,$name,$id);  
     # do_cache implictly return the set value  sub do_cache_new {
     $$cache{$id};      my ($name,$id,$value,$time,$debug) = @_;
 }      $id=&make_key($name,$id);
       my $setvalue=$value;
 my %do_save_item;      if (!defined($setvalue)) {
 my %do_save;   $setvalue='__undef__';
 sub save_cache_item {      }
     my ($cache,$name,$id)=@_;      if (!defined($time) ) {
     if ($disk_caching_disabled) { return; }   $time=600;
     $do_save{$name}=$cache;      }
     if (!exists($do_save_item{$name})) { $do_save_item{$name}={} }      if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); }
     $do_save_item{$name}->{$id}=1;      my $result = $memcache->set($id,$setvalue,$time);
       if (! $result) {
    &logthis("caching of id -> $id  failed");
    $memcache->disconnect_all();
       }
       # need to make a copy of $value
       &make_room($id,$value,$debug);
       return $value;
   }
   
   sub make_room {
       my ($id,$value,$debug)=@_;
   
       $remembered{$id}= (ref($value)) ? &Storable::dclone($value)
                                       : $value;
       if ($to_remember<0) { return; }
       $accessed{$id}=[&gettimeofday()];
       if (scalar(keys(%remembered)) <= $to_remember) { return; }
       my $to_kick;
       my $max_time=0;
       foreach my $other (keys(%accessed)) {
    if (&tv_interval($accessed{$other}) > $max_time) {
       $to_kick=$other;
       $max_time=&tv_interval($accessed{$other});
    }
       }
       delete($remembered{$to_kick});
       delete($accessed{$to_kick});
       $kicks++;
       if ($debug) { &logthis("kicking $to_kick $max_time $kicks\n"); }
     return;      return;
 }  }
   
 sub save_cache {  sub purge_remembered {
     if ($disk_caching_disabled) { return; }      #&logthis("Tossing ".scalar(keys(%remembered)));
     my ($cache,$name,$id);      #&logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered))));
     foreach $name (keys(%do_save)) {      undef(%remembered);
  $cache=$do_save{$name};      undef(%accessed);
   
  my $starttime=&Time::HiRes::time();  
  &logthis("Saving :$name:");  
  my %hash;  
  my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";  
  open(DB,">$filename.lock");  
  flock(DB,LOCK_EX);  
  if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {  
     foreach $id (keys(%{ $do_save_item{$name} })) {  
  eval <<'EVALBLOCK';  
  $hash{$id.'.time'}=$$cache{$id.'.time'};  
  $hash{$id}=freeze({'item'=>$$cache{$id}});  
  if (exists($$cache{$id.'.file'})) {  
     $hash{$id.'.file'}=freeze({'item'=>$$cache{$id.'.file'}});  
  }  
 EVALBLOCK  
                 if ($@) {  
     &logthis("<font color='red'>save_cache blew up :$@:$name</font>");  
     unlink($filename);  
     last;  
  }  
     }  
  } else {  
     if (-e $filename) {  
  &logthis("Unable to tie hash (save cache): $name ($!)");  
  unlink($filename);  
     }  
  }  
  untie(%hash);  
  flock(DB,LOCK_UN);  
  close(DB);  
  &logthis("save_cache $name took ".(&Time::HiRes::time()-$starttime));  
     }  
     undef(%do_save);  
     undef(%do_save_item);  
   
 }  
   
 sub load_cache_item {  
     my ($cache,$name,$id,$time)=@_;  
     if ($disk_caching_disabled) { return; }  
     my $starttime=&Time::HiRes::time();  
 #    &logthis("Before Loading $name  for $id size is ".scalar(%$cache));  
     my %hash;  
     my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";  
     if (!-e $filename) { return; }  
     open(DB,">$filename.lock");  
     flock(DB,LOCK_SH);  
     if (tie(%hash,'GDBM_File',$filename,&GDBM_READER(),0640)) {  
  eval <<'EVALBLOCK';  
     if (!%$cache) {  
  my $count;  
  while (my ($key,$value)=each(%hash)) {   
     $count++;  
     if ($key =~ /\.time$/) {  
  $$cache{$key}=$value;  
     } else {  
  my $hashref=thaw($value);  
  $$cache{$key}=$hashref->{'item'};  
     }  
  }  
 #    &logthis("Initial load: $count");  
     } else {  
  if (($$cache{$id.'.time'}+$time) < time) {  
     $$cache{$id.'.time'}=$hash{$id.'.time'};  
     {  
  my $hashref=thaw($hash{$id});  
  $$cache{$id}=$hashref->{'item'};  
     }  
     if (exists($hash{$id.'.file'})) {  
  my $hashref=thaw($hash{$id.'.file'});  
  $$cache{$id.'.file'}=$hashref->{'item'};  
     }  
  }  
     }  
 EVALBLOCK  
         if ($@) {  
     &logthis("<font color='red'>load_cache blew up :$@:$name</font>");  
     unlink($filename);  
  }          
     } else {  
  if (-e $filename) {  
     &logthis("Unable to tie hash (load cache item): $name ($!)");  
     unlink($filename);  
  }  
     }  
     untie(%hash);  
     flock(DB,LOCK_UN);  
     close(DB);  
 #    &logthis("After Loading $name size is ".scalar(%$cache));  
 #    &logthis("load_cache_item $name took ".(&Time::HiRes::time()-$starttime));  
 }  }
   
 # ------------------------------------- Read an entry from a user's environment  # ------------------------------------- Read an entry from a user's environment
   
 sub userenvironment {  sub userenvironment {
     my ($udom,$unam,@what)=@_;      my ($udom,$unam,@what)=@_;
       my $items;
       foreach my $item (@what) {
           $items.=&escape($item).'&';
       }
       $items=~s/\&$//;
     my %returnhash=();      my %returnhash=();
     my @answer=split(/\&/,      my $uhome = &homeserver($unam,$udom);
                 &reply('get:'.$udom.':'.$unam.':environment:'.join('&',@what),      unless ($uhome eq 'no_host') {
                       &homeserver($unam,$udom)));          my @answer=split(/\&/, 
     my $i;              &reply('get:'.$udom.':'.$unam.':environment:'.$items,$uhome));
     for ($i=0;$i<=$#what;$i++) {          if ($#answer==0 && $answer[0] =~ /^(con_lost|error:|no_such_host)/i) {
  $returnhash{$what[$i]}=&unescape($answer[$i]);              return %returnhash;
           }
           my $i;
           for ($i=0;$i<=$#what;$i++) {
       $returnhash{$what[$i]}=&unescape($answer[$i]);
           }
     }      }
     return %returnhash;      return %returnhash;
 }  }
   
   # ---------------------------------------------------------- Get a studentphoto
   sub studentphoto {
       my ($udom,$unam,$ext) = @_;
       my $home=&Apache::lonnet::homeserver($unam,$udom);
       if (defined($env{'request.course.id'})) {
           if ($env{'course.'.$env{'request.course.id'}.'.internal.showphoto'}) {
               if ($udom eq $env{'course.'.$env{'request.course.id'}.'.domain'}) {
                   return(&retrievestudentphoto($udom,$unam,$ext)); 
               } else {
                   my ($result,$perm_reqd)=
       &Apache::lonnet::auto_photo_permission($unam,$udom);
                   if ($result eq 'ok') {
                       if (!($perm_reqd eq 'yes')) {
                           return(&retrievestudentphoto($udom,$unam,$ext));
                       }
                   }
               }
           }
       } else {
           my ($result,$perm_reqd) = 
       &Apache::lonnet::auto_photo_permission($unam,$udom);
           if ($result eq 'ok') {
               if (!($perm_reqd eq 'yes')) {
                   return(&retrievestudentphoto($udom,$unam,$ext));
               }
           }
       }
       return '/adm/lonKaputt/lonlogo_broken.gif';
   }
   
   sub retrievestudentphoto {
       my ($udom,$unam,$ext,$type) = @_;
       my $home=&Apache::lonnet::homeserver($unam,$udom);
       my $ret=&Apache::lonnet::reply("studentphoto:$udom:$unam:$ext:$type",$home);
       if ($ret eq 'ok') {
           my $url="/uploaded/$udom/$unam/internal/studentphoto.$ext";
           if ($type eq 'thumbnail') {
               $url="/uploaded/$udom/$unam/internal/studentphoto_tn.$ext"; 
           }
           my $tokenurl=&Apache::lonnet::tokenwrapper($url);
           return $tokenurl;
       } else {
           if ($type eq 'thumbnail') {
               return '/adm/lonKaputt/genericstudent_tn.gif';
           } else { 
               return '/adm/lonKaputt/lonlogo_broken.gif';
           }
       }
   }
   
 # -------------------------------------------------------------------- New chat  # -------------------------------------------------------------------- New chat
   
 sub chatsend {  sub chatsend {
     my ($newentry,$anon)=@_;      my ($newentry,$anon,$group)=@_;
     my $cnum=$ENV{'course.'.$ENV{'request.course.id'}.'.num'};      my $cnum=$env{'course.'.$env{'request.course.id'}.'.num'};
     my $cdom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'};      my $cdom=$env{'course.'.$env{'request.course.id'}.'.domain'};
     my $chome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'};      my $chome=$env{'course.'.$env{'request.course.id'}.'.home'};
     &reply('chatsend:'.$cdom.':'.$cnum.':'.      &reply('chatsend:'.$cdom.':'.$cnum.':'.
    &escape($ENV{'user.domain'}.':'.$ENV{'user.name'}.':'.$anon.':'.     &escape($env{'user.domain'}.':'.$env{'user.name'}.':'.$anon.':'.
    &escape($newentry)),$chome);     &escape($newentry)).':'.$group,$chome);
 }  }
   
 # ------------------------------------------ Find current version of a resource  # ------------------------------------------ Find current version of a resource
   
 sub getversion {  sub getversion {
     my $fname=&clutter(shift);      my $fname=&clutter(shift);
     unless ($fname=~/^\/res\//) { return -1; }      unless ($fname=~m{^(/adm/wrapper|)/res/}) { return -1; }
     return &currentversion(&filelocation('',$fname));      return &currentversion(&filelocation('',$fname));
 }  }
   
 sub currentversion {  sub currentversion {
     my $fname=shift;      my $fname=shift;
     my ($result,$cached)=&is_cached(\%resversioncache,$fname,'resversion',600);  
     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(\%resversioncache,$fname,$answer,'resversion');      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 1117  sub subscribe { Line 2462  sub subscribe {
 sub repcopy {  sub repcopy {
     my $filename=shift;      my $filename=shift;
     $filename=~s/\/+/\//g;      $filename=~s/\/+/\//g;
     if ($filename=~m|^/home/httpd/html/adm/|) { return OK; }      my $londocroot = $perlvar{'lonDocRoot'};
     if ($filename=~m|^/home/httpd/html/lonUsers/|) { return OK; }      if ($filename=~m{^\Q$londocroot/adm/\E}) { return 'ok'; }
     if ($filename=~m|^/home/httpd/html/userfiles/| or      if ($filename=~m{^\Q/home/httpd/lonUsers/\E}) { return 'ok'; }
  $filename=~m|^/*uploaded/|) {       if ($filename=~m{^\Q$londocroot/userfiles/\E} or
    $filename=~m{^/*(uploaded|editupload)/}) {
  return &repcopy_userfile($filename);   return &repcopy_userfile($filename);
     }      }
     $filename=~s/[\n\r]//g;      $filename=~s/[\n\r]//g;
     my $transname="$filename.in.transfer";      my $transname="$filename.in.transfer";
     if ((-e $filename) || (-e $transname)) { return OK; }  # FIXME: this should flock
       if ((-e $filename) || (-e $transname)) { return 'ok'; }
     my $remoteurl=subscribe($filename);      my $remoteurl=subscribe($filename);
     if ($remoteurl =~ /^con_lost by/) {      if ($remoteurl =~ /^con_lost by/) {
    &logthis("Subscribe returned $remoteurl: $filename");     &logthis("Subscribe returned $remoteurl: $filename");
            return HTTP_SERVICE_UNAVAILABLE;             return 'unavailable';
     } elsif ($remoteurl eq 'not_found') {      } elsif ($remoteurl eq 'not_found') {
    #&logthis("Subscribe returned not_found: $filename");     #&logthis("Subscribe returned not_found: $filename");
    return HTTP_NOT_FOUND;     return 'not_found';
     } elsif ($remoteurl =~ /^rejected by/) {      } elsif ($remoteurl =~ /^rejected by/) {
    &logthis("Subscribe returned $remoteurl: $filename");     &logthis("Subscribe returned $remoteurl: $filename");
            return FORBIDDEN;             return 'forbidden';
     } elsif ($remoteurl eq 'directory') {      } elsif ($remoteurl eq 'directory') {
            return OK;             return 'ok';
     } else {      } else {
         my $author=$filename;          my $author=$filename;
         $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;          $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
Line 1146  sub repcopy { Line 2493  sub repcopy {
         unless ($home eq $perlvar{'lonHostID'}) {          unless ($home eq $perlvar{'lonHostID'}) {
            my @parts=split(/\//,$filename);             my @parts=split(/\//,$filename);
            my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";             my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";
            if ($path ne "$perlvar{'lonDocRoot'}/res") {             if ($path ne "$londocroot/res") {
                &logthis("Malconfiguration for replication: $filename");                 &logthis("Malconfiguration for replication: $filename");
        return HTTP_BAD_REQUEST;         return 'bad_request';
            }             }
            my $count;             my $count;
            for ($count=5;$count<$#parts;$count++) {             for ($count=5;$count<$#parts;$count++) {
Line 1163  sub repcopy { Line 2510  sub repcopy {
            if ($response->is_error()) {             if ($response->is_error()) {
        unlink($transname);         unlink($transname);
                my $message=$response->status_line;                 my $message=$response->status_line;
                &logthis("<font color=blue>WARNING:"                 &logthis("<font color=\"blue\">WARNING:"
                        ." LWP get: $message: $filename</font>");                         ." LWP get: $message: $filename</font>");
                return HTTP_SERVICE_UNAVAILABLE;                 return 'unavailable';
            } else {             } else {
        if ($remoteurl!~/\.meta$/) {         if ($remoteurl!~/\.meta$/) {
                   my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');                    my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');
Line 1173  sub repcopy { Line 2520  sub repcopy {
                   if ($mresponse->is_error()) {                    if ($mresponse->is_error()) {
       unlink($filename.'.meta');        unlink($filename.'.meta');
                       &logthis(                        &logthis(
                      "<font color=yellow>INFO: No metadata: $filename</font>");                       "<font color=\"yellow\">INFO: No metadata: $filename</font>");
                   }                    }
        }         }
                rename($transname,$filename);                 rename($transname,$filename);
                return OK;                 return 'ok';
            }             }
        }         }
     }      }
Line 1186  sub repcopy { Line 2533  sub repcopy {
 # ------------------------------------------------ Get server side include body  # ------------------------------------------------ Get server side include body
 sub ssi_body {  sub ssi_body {
     my ($filelink,%form)=@_;      my ($filelink,%form)=@_;
     my $output=($filelink=~/^http\:/?&externalssi($filelink):      if (! exists($form{'LONCAPA_INTERNAL_no_discussion'})) {
                                      &ssi($filelink,%form));          $form{'LONCAPA_INTERNAL_no_discussion'}='true';
     $output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+// END LON-CAPA Internal\s*(-->)?\s||gs;      }
       my $output='';
       my $response;
       if ($filelink=~/^https?\:/) {
          ($output,$response)=&externalssi($filelink);
       } else {
          $filelink .= $filelink=~/\?/ ? '&' : '?';
          $filelink .= 'inhibitmenu=yes';
          ($output,$response)=&ssi($filelink,%form);
       }
       $output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+?// END LON-CAPA Internal\s*(-->)?\s||gs;
     $output=~s/^.*?\<body[^\>]*\>//si;      $output=~s/^.*?\<body[^\>]*\>//si;
     $output=~s/(.*)\<\/body\s*\>.*?$/$1/si;      $output=~s/\<\/body\s*\>.*?$//si;
     return $output;      if (wantarray) {
           return ($output, $response);
       } else {
           return $output;
       }
 }  }
   
 # --------------------------------------------------------- Server Side Include  # --------------------------------------------------------- Server Side Include
   
   sub absolute_url {
       my ($host_name) = @_;
       my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://');
       if ($host_name eq '') {
    $host_name = $ENV{'SERVER_NAME'};
       }
       return $protocol.$host_name;
   }
   
   #
   #   Server side include.
   # Parameters:
   #  fn     Possibly encrypted resource name/id.
   #  form   Hash that describes how the rendering should be done
   #         and other things.
   # Returns:
   #   Scalar context: The content of the response.
   #   Array context:  2 element list of the content and the full response object.
   #     
 sub ssi {  sub ssi {
   
     my ($fn,%form)=@_;      my ($fn,%form)=@_;
   
     my $ua=new LWP::UserAgent;      my $ua=new LWP::UserAgent;
       
     my $request;      my $request;
       
       $form{'no_update_last_known'}=1;
       &Apache::lonenc::check_encrypt(\$fn);
     if (%form) {      if (%form) {
       $request=new HTTP::Request('POST',"http://".$ENV{'HTTP_HOST'}.$fn);        $request=new HTTP::Request('POST',&absolute_url().$fn);
       $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form));        $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys(%form)));
     } else {      } else {
       $request=new HTTP::Request('GET',"http://".$ENV{'HTTP_HOST'}.$fn);        $request=new HTTP::Request('GET',&absolute_url().$fn);
     }      }
   
     $request->header(Cookie => $ENV{'HTTP_COOKIE'});      $request->header(Cookie => $ENV{'HTTP_COOKIE'});
     my $response=$ua->request($request);      my $response= $ua->request($request);
       my $content = $response->content;
   
     return $response->content;  
       if (wantarray) {
    return ($content, $response);
       } else {
    return $content;
       }
 }  }
   
 sub externalssi {  sub externalssi {
Line 1222  sub externalssi { Line 2608  sub externalssi {
     my $ua=new LWP::UserAgent;      my $ua=new LWP::UserAgent;
     my $request=new HTTP::Request('GET',$url);      my $request=new HTTP::Request('GET',$url);
     my $response=$ua->request($request);      my $response=$ua->request($request);
     return $response->content;      if (wantarray) {
           return ($response->content, $response);
       } else {
           return $response->content;
       }
 }  }
   
 # -------------------------------- Allow a /uploaded/ URI to be vouched for  # -------------------------------- Allow a /uploaded/ URI to be vouched for
Line 1235  sub allowuploaded { Line 2625  sub allowuploaded {
     my %httpref=();      my %httpref=();
     my $httpurl=&hreflocation('',$url);      my $httpurl=&hreflocation('',$url);
     $httpref{'httpref.'.$httpurl}=$srcurl;      $httpref{'httpref.'.$httpurl}=$srcurl;
     &Apache::lonnet::appenv(%httpref);      &Apache::lonnet::appenv(\%httpref);
 }  }
   
 # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course  # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course
 # input: action, courseID, current domain, home server for course, intended  # input: action, courseID, current domain, intended
 #        path to file, source of file.  #        path to file, source of file, instruction to parse file for objects,
   #        ref to hash for embedded 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 1259  sub allowuploaded { Line 2654  sub allowuploaded {
 #         course's home server.  #         course's home server.
 #  #
 # action = uploaddoc - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file  # action = uploaddoc - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
 #         will be retrived from $ENV{form.uploaddoc} (from DOCS interface) to  #         will be retrived from $env{form.uploaddoc} (from DOCS interface) to
 #         /home/httpd/html/userfiles/$domain/1/2/3/$course/$file  #         /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
 #         and will then be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles/$file  #         and will then be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles/$file
 #         in course's home server.  #         in course's home server.
   #
   
 sub process_coursefile {  sub process_coursefile {
     my ($action,$docuname,$docudom,$docuhome,$file,$source)=@_;      my ($action,$docuname,$docudom,$file,$source,$parser,$allfiles,$codebase,
           $mimetype)=@_;
     my $fetchresult;      my $fetchresult;
       my $home=&homeserver($docuname,$docudom);
     if ($action eq 'propagate') {      if ($action eq 'propagate') {
         $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file          $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
                             ,$docuhome);       $home);
     } else {      } else {
         my $fetchresult = '';  
         my $fpath = '';          my $fpath = '';
         my $fname = $file;          my $fname = $file;
         ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|);          ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|);
         $fpath=$docudom.'/'.$docuname.'/'.$fpath;          $fpath=$docudom.'/'.$docuname.'/'.$fpath;
         my $filepath=$perlvar{'lonDocRoot'}.'/userfiles';          my $filepath = &build_filepath($fpath);
         unless ($fpath eq '') {  
             my @parts=split('/',$fpath);  
             foreach my $part (@parts) {  
                 $filepath.= '/'.$part;  
                 if ((-e $filepath)!=1) {  
                     mkdir($filepath,0777);  
                 }  
             }  
         }  
         if ($action eq 'copy') {          if ($action eq 'copy') {
             if ($source eq '') {              if ($source eq '') {
                 $fetchresult = 'no source file';                  $fetchresult = 'no source file';
Line 1295  sub process_coursefile { Line 2682  sub process_coursefile {
                 my $destination = $filepath.'/'.$fname;                  my $destination = $filepath.'/'.$fname;
                 rename($source,$destination);                  rename($source,$destination);
                 $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,                  $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
                                  $docuhome);                                   $home);
             }              }
         } elsif ($action eq 'uploaddoc') {          } elsif ($action eq 'uploaddoc') {
             open(my $fh,'>'.$filepath.'/'.$fname);              open(my $fh,'>'.$filepath.'/'.$fname);
             print $fh $ENV{'form.'.$source};              print $fh $env{'form.'.$source};
             close($fh);              close($fh);
               if ($parser eq 'parse') {
                   my $mm = new File::MMagic;
                   my $type = $mm->checktype_filename($filepath.'/'.$fname);
                   if ($type eq 'text/html') {
                       my $parse_result = &extract_embedded_items($filepath.'/'.$fname,$allfiles,$codebase);
                       unless ($parse_result eq 'ok') {
                           &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,
                                  $docuhome);                                   $home);
             if ($fetchresult eq 'ok') {              if ($fetchresult eq 'ok') {
                 return '/uploaded/'.$fpath.'/'.$fname;                  return '/uploaded/'.$fpath.'/'.$fname;
             } else {              } else {
                 &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.                  &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.
                         ' to host '.$docuhome.': '.$fetchresult);                          ' to host '.$home.': '.$fetchresult);
                 return '/adm/notfound.html';                  return '/adm/notfound.html';
             }              }
         }          }
     }      }
     unless ( $fetchresult eq 'ok') {      unless ( $fetchresult eq 'ok') {
         &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.          &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.
              ' to host '.$docuhome.': '.$fetchresult);               ' to host '.$home.': '.$fetchresult);
     }      }
     return $fetchresult;      return $fetchresult;
 }  }
   
 # --------------- Take an uploaded file and put it into the userfiles directory  sub build_filepath {
 # input: name of form element, coursedoc=1 means this is for the course      my ($fpath) = @_;
 # output: url of file in userspace      my $filepath=$perlvar{'lonDocRoot'}.'/userfiles';
       unless ($fpath eq '') {
           my @parts=split('/',$fpath);
           foreach my $part (@parts) {
               $filepath.= '/'.$part;
               if ((-e $filepath)!=1) {
                   mkdir($filepath,0777);
               }
           }
       }
       return $filepath;
   }
   
   sub store_edited_file {
       my ($primary_url,$content,$docudom,$docuname,$fetchresult) = @_;
       my $file = $primary_url;
       $file =~ s#^/uploaded/$docudom/$docuname/##;
       my $fpath = '';
       my $fname = $file;
       ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|);
       $fpath=$docudom.'/'.$docuname.'/'.$fpath;
       my $filepath = &build_filepath($fpath);
       open(my $fh,'>'.$filepath.'/'.$fname);
       print $fh $content;
       close($fh);
       my $home=&homeserver($docuname,$docudom);
       $$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
     $home);
       if ($$fetchresult eq 'ok') {
           return '/uploaded/'.$fpath.'/'.$fname;
       } else {
           &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.
    ' to host '.$home.': '.$$fetchresult);
           return '/adm/notfound.html';
       }
   }
   
 sub clean_filename {  sub clean_filename {
     my ($fname)=@_;      my ($fname,$args)=@_;
 # Replace Windows backslashes by forward slashes  # Replace Windows backslashes by forward slashes
     $fname=~s/\\/\//g;      $fname=~s/\\/\//g;
 # Get rid of everything but the actual filename      if (!$args->{'keep_path'}) {
     $fname=~s/^.*\/([^\/]+)$/$1/;          # Get rid of everything but the actual filename
    $fname=~s/^.*\/([^\/]+)$/$1/;
       }
 # Replace spaces by underscores  # Replace spaces by underscores
     $fname=~s/\s+/\_/g;      $fname=~s/\s+/\_/g;
 # Replace all other weird characters by nothing  # Replace all other weird characters by nothing
     $fname=~s/[^\w\.\-]//g;      $fname=~s{[^/\w\.\-]}{}g;
 # Replace all .\d. sequences with _\d. so they no longer look like version  # Replace all .\d. sequences with _\d. so they no longer look like version
 # numbers  # numbers
     $fname=~s/\.(\d+)(?=\.)/_$1/g;      $fname=~s/\.(\d+)(?=\.)/_$1/g;
     return $fname;      return $fname;
 }  }
   # This Function checks if an Image's dimensions exceed either $resizewidth (width) 
   # or $resizeheight (height) - both pixels. If so, the image is scaled to produce an 
   # image with the same aspect ratio as the original, but with dimensions which do 
   # not exceed $resizewidth and $resizeheight.
    
   sub resizeImage {
       my ($img_path,$resizewidth,$resizeheight) = @_;
       my $ima = Image::Magick->new;
       my $resized;
       if (-e $img_path) {
           $ima->Read($img_path);
           if (($resizewidth =~ /^\d+$/) && ($resizeheight > 0)) {
               my $width = $ima->Get('width');
               my $height = $ima->Get('height');
               if ($width > $resizewidth) {
           my $factor = $width/$resizewidth;
                   my $newheight = $height/$factor;
                   $ima->Scale(width=>$resizewidth,height=>$newheight);
                   $resized = 1;
               }
           }
           if (($resizeheight =~ /^\d+$/) && ($resizeheight > 0)) {
               my $width = $ima->Get('width');
               my $height = $ima->Get('height');
               if ($height > $resizeheight) {
                   my $factor = $height/$resizeheight;
                   my $newwidth = $width/$factor;
                   $ima->Scale(width=>$newwidth,height=>$resizeheight);
                   $resized = 1;
               }
           }
           if ($resized) {
               $ima->Write($img_path);
           }
       }
       return;
   }
   
   # --------------- Take an uploaded file and put it into the userfiles directory
   # input: $formname - the contents of the file are in $env{"form.$formname"}
   #                    the desired filename is in $env{"form.$formname.filename"}
   #        $context - possible values: coursedoc, existingfile, overwrite, 
   #                                    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
   #        $parser - instruction to parse file for objects ($parser = parse)    
   #        $allfiles - reference to hash for embedded objects
   #        $codebase - reference to hash for codebase of java objects
   #        $desuname - username for permanent storage of uploaded file
   #        $dsetudom - domain for permanaent storage of uploaded file
   #        $thumbwidth - width (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
   #        $resizeheight - height (pixels) to which to resize uploaded image
   #        $mimetype - reference to scalar to accommodate mime type determined
   #                    from File::MMagic.
   # 
   # output: url of file in userspace, or error: <message> 
   #             or /adm/notfound.html if failure to upload occurse
   
 sub userfileupload {  sub userfileupload {
     my ($formname,$coursedoc,$subdir)=@_;      my ($formname,$context,$subdir,$parser,$allfiles,$codebase,$destuname,
           $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;
           if (($formname eq 'screenshot') && ($subdir eq 'helprequests')) {
                $filepath = 'tmp/helprequests/'.$now;
           } elsif (($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) {
                $filepath = 'tmp/addcourse/'.$destudom.'/web/'.$env{'user.name'}.
                            '_'.$env{'user.domain'}.'/pending';
           } 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;
               }
           }
           # Create the directory if not present
         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 1359  sub userfileupload { Line 2895  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;
           }
     }      }
 # Create the directory if not present      if ($subdir eq 'scantron') {
     my $docuname='';          $fname = 'scantron_orig_'.$fname;
     my $docudom='';      } else {
     my $docuhome='';          $fname="$subdir/$fname";
     $fname="$subdir/$fname";      }
     if ($coursedoc) {      if ($context eq 'coursedoc') {
  $docuname=$ENV{'course.'.$ENV{'request.course.id'}.'.num'};   my $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
  $docudom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'};   my $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
  $docuhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'};          if ($env{'form.folder'} =~ m/^(default|supplemental)/) {
         if ($ENV{'form.folder'} =~ m/^default/) {              return &finishuserfileupload($docuname,$docudom,
             return &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname);   $formname,$fname,$parser,$allfiles,
         } else {   $codebase,$thumbwidth,$thumbheight,
             $fname=$ENV{'form.folder'}.'/'.$fname;                                           $resizewidth,$resizeheight,$context,$mimetype);
             return &process_coursefile('uploaddoc',$docuname,$docudom,$docuhome,$fname,$formname);          } else {
         }              $fname=$env{'form.folder'}.'/'.$fname;
     } else {              return &process_coursefile('uploaddoc',$docuname,$docudom,
         $docuname=$ENV{'user.name'};         $fname,$formname,$parser,
         $docudom=$ENV{'user.domain'};         $allfiles,$codebase,$mimetype);
         $docuhome=$ENV{'user.home'};          }
         return &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname);      } elsif (defined($destuname)) {
           my $docuname=$destuname;
           my $docudom=$destudom;
    return &finishuserfileupload($docuname,$docudom,$formname,$fname,
        $parser,$allfiles,$codebase,
                                        $thumbwidth,$thumbheight,
                                        $resizewidth,$resizeheight,$context,$mimetype);
       } else {
           my $docuname=$env{'user.name'};
           my $docudom=$env{'user.domain'};
           if (exists($env{'form.group'})) {
               $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
               $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
           }
    return &finishuserfileupload($docuname,$docudom,$formname,$fname,
        $parser,$allfiles,$codebase,
                                        $thumbwidth,$thumbheight,
                                        $resizewidth,$resizeheight,$context,$mimetype);
     }      }
 }  }
   
 sub finishuserfileupload {  sub finishuserfileupload {
     my ($docuname,$docudom,$docuhome,$formname,$fname)=@_;      my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase,
           $thumbwidth,$thumbheight,$resizewidth,$resizeheight,$context,$mimetype) = @_;
     my $path=$docudom.'/'.$docuname.'/';      my $path=$docudom.'/'.$docuname.'/';
     my $filepath=$perlvar{'lonDocRoot'};      my $filepath=$perlvar{'lonDocRoot'};
     my ($fnamepath,$file);    
       my ($fnamepath,$file,$fetchthumb);
     $file=$fname;      $file=$fname;
     if ($fname=~m|/|) {      if ($fname=~m|/|) {
         ($fnamepath,$file) = ($fname =~ m|^(.*)/([^/]+)$|);          ($fnamepath,$file) = ($fname =~ m|^(.*)/([^/]+)$|);
Line 1404  sub finishuserfileupload { Line 2964  sub finishuserfileupload {
     mkdir($filepath,0777);      mkdir($filepath,0777);
         }          }
     }      }
   
 # Save the file  # Save the file
     {      {
  #&Apache::lonnet::logthis("Saving to $filepath $file");   if (!open(FH,'>'.$filepath.'/'.$file)) {
        open(my $fh,'>'.$filepath.'/'.$file);      &logthis('Failed to create '.$filepath.'/'.$file);
        print $fh $ENV{'form.'.$formname};      print STDERR ('Failed to create '.$filepath.'/'.$file."\n");
        close($fh);      return '/adm/notfound.html';
    }
           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);
       print STDERR ('Failed to write to '.$filepath.'/'.$file."\n");
       return '/adm/notfound.html';
    }
    close(FH);
           if ($resizewidth && $resizeheight) {
               my $mm = new File::MMagic;
               my $mime_type = $mm->checktype_filename($filepath.'/'.$file);
               if ($mime_type =~ m{^image/}) {
           &resizeImage($filepath.'/'.$file,$resizewidth,$resizeheight);
               }  
    }
       }
       if (($context eq 'coursedoc') || ($parser eq 'parse')) {
           if (ref($mimetype)) {
               if ($$mimetype eq '') {
                   my $mm = new File::MMagic;
                   my $type = $mm->checktype_filename($filepath.'/'.$file);
                   $$mimetype = $type;
               }
           }
     }      }
       if ($parser eq 'parse') {
           if ((ref($mimetype)) && ($$mimetype eq 'text/html')) {
               my $parse_result = &extract_embedded_items($filepath.'/'.$file,
                                                          $allfiles,$codebase);
               unless ($parse_result eq 'ok') {
                   &logthis('Failed to parse '.$filepath.$file.
              ' for embedded media: '.$parse_result); 
               }
           }
       }
       if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {
           my $input = $filepath.'/'.$file;
           my $output = $filepath.'/'.'tn-'.$file;
           my $thumbsize = $thumbwidth.'x'.$thumbheight;
           system("convert -sample $thumbsize $input $output");
           if (-e $filepath.'/'.'tn-'.$file) {
               $fetchthumb  = 1; 
           }
       }
    
 # Notify homeserver to grep it  # Notify homeserver to grep it
 #  #
       my $docuhome=&homeserver($docuname,$docudom);
     my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);      my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);
     if ($fetchresult eq 'ok') {      if ($fetchresult eq 'ok') {
           if ($fetchthumb) {
               my $thumbresult= &reply('fetchuserfile:'.$path.'tn-'.$file,$docuhome);
               if ($thumbresult ne 'ok') {
                   &logthis('Failed to transfer '.$path.'tn-'.$file.' to host '.
                            $docuhome.': '.$thumbresult);
               }
           }
 #  #
 # Return the URL to it  # Return the URL to it
         return '/uploaded/'.$path.$file;          return '/uploaded/'.$path.$file;
Line 1422  sub finishuserfileupload { Line 3050  sub finishuserfileupload {
         &logthis('Failed to transfer '.$path.$file.' to host '.$docuhome.          &logthis('Failed to transfer '.$path.$file.' to host '.$docuhome.
  ': '.$fetchresult);   ': '.$fetchresult);
         return '/adm/notfound.html';          return '/adm/notfound.html';
     }          }
   }
   
   sub extract_embedded_items {
       my ($fullpath,$allfiles,$codebase,$content) = @_;
       my @state = ();
       my (%lastids,%related,%shockwave,%flashvars);
       my %javafiles = (
                         codebase => '',
                         code => '',
                         archive => ''
                       );
       my %mediafiles = (
                         src => '',
                         movie => '',
                        );
       my $p;
       if ($content) {
           $p = HTML::LCParser->new($content);
       } else {
           $p = HTML::LCParser->new($fullpath);
       }
       while (my $t=$p->get_token()) {
    if ($t->[0] eq 'S') {
       my ($tagname, $attr) = ($t->[1],$t->[2]);
       push(@state, $tagname);
               if (lc($tagname) eq 'allow') {
                   &add_filetype($allfiles,$attr->{'src'},'src');
               }
       if (lc($tagname) eq 'img') {
    &add_filetype($allfiles,$attr->{'src'},'src');
       }
       if (lc($tagname) eq 'a') {
    &add_filetype($allfiles,$attr->{'href'},'href');
       }
               if (lc($tagname) eq 'script') {
                   my $src;
                   if ($attr->{'archive'} =~ /\.jar$/i) {
                       &add_filetype($allfiles,$attr->{'archive'},'archive');
                   } else {
                       if ($attr->{'src'} ne '') {
                           $src = $attr->{'src'};
                           &add_filetype($allfiles,$src,'src');
                       }
                   }
                   my $text = $p->get_trimmed_text();
                   if ($text =~ /\Qswfobject.registerObject(\E([^\)]+)\)/) {
                       my @swfargs = split(/,/,$1);
                       foreach my $item (@swfargs) {
                           $item =~ s/["']//g;
                           $item =~ s/^\s+//;
                           $item =~ s/\s+$//;
                       }
                       if (($swfargs[0] ne'') && ($swfargs[2] ne '')) {
                           if (ref($related{$swfargs[0]}) eq 'ARRAY') {
                               push(@{$related{$swfargs[0]}},$swfargs[2]);
                           } else {
                               $related{$swfargs[0]} = [$swfargs[2]];
                           }
                       }
                   }
               }
               if (lc($tagname) eq 'link') {
                   if (lc($attr->{'rel'}) eq 'stylesheet') { 
                       &add_filetype($allfiles,$attr->{'href'},'href');
                   }
               }
       if (lc($tagname) eq 'object' ||
    (lc($tagname) eq 'embed' && lc($state[-2]) ne 'object')) {
    foreach my $item (keys(%javafiles)) {
       $javafiles{$item} = '';
    }
                   if ((lc($tagname) eq 'object') && (lc($state[-2]) ne 'object')) {
                       $lastids{lc($tagname)} = $attr->{'id'};
                   }
       }
       if (lc($state[-2]) eq 'object' && lc($tagname) eq 'param') {
    my $name = lc($attr->{'name'});
    foreach my $item (keys(%javafiles)) {
       if ($name eq $item) {
    $javafiles{$item} = $attr->{'value'};
    last;
       }
    }
                   my $pathfrom;
    foreach my $item (keys(%mediafiles)) {
       if ($name eq $item) {
                           $pathfrom = $attr->{'value'};
                           $shockwave{$lastids{lc($state[-2])}} = $pathfrom;
    &add_filetype($allfiles,$pathfrom,$name);
    last;
       }
    }
                   if ($name eq 'flashvars') {
                       $flashvars{$lastids{lc($state[-2])}} = $attr->{'value'};
                   }
                   if ($pathfrom ne '') {
                       &embedded_dependency($allfiles,\%related,$lastids{lc($state[-2])},
                                            $pathfrom);
                   }
       }
       if (lc($tagname) eq 'embed' || lc($tagname) eq 'applet') {
    foreach my $item (keys(%javafiles)) {
       if ($attr->{$item}) {
    $javafiles{$item} = $attr->{$item};
    last;
       }
    }
    foreach my $item (keys(%mediafiles)) {
       if ($attr->{$item}) {
    &add_filetype($allfiles,$attr->{$item},$item);
    last;
       }
    }
                   if (lc($tagname) eq 'embed') {
                       if (($attr->{'name'} ne '') && ($attr->{'src'} ne '')) {
                           &embedded_dependency($allfiles,\%related,$attr->{'name'},
                                                $attr->{'src'});
                       }
                   }
       }
               if ($t->[4] =~ m{/>$}) {
                   pop(@state);  
               }
    } elsif ($t->[0] eq 'E') {
       my ($tagname) = ($t->[1]);
       if ($javafiles{'codebase'} ne '') {
    $javafiles{'codebase'} .= '/';
       }  
       if (lc($tagname) eq 'applet' ||
    lc($tagname) eq 'object' ||
    (lc($tagname) eq 'embed' && lc($state[-2]) ne 'object')
    ) {
    foreach my $item (keys(%javafiles)) {
       if ($item ne 'codebase' && $javafiles{$item} ne '') {
    my $file=$javafiles{'codebase'}.$javafiles{$item};
    &add_filetype($allfiles,$file,$item);
       }
    }
       } 
       pop @state;
    }
       }
       foreach my $id (sort(keys(%flashvars))) {
           if ($shockwave{$id} ne '') {
               my @pairs = split(/\&/,$flashvars{$id});
               foreach my $pair (@pairs) {
                   my ($key,$value) = split(/\=/,$pair);
                   if ($key eq 'thumb') {
                       &add_filetype($allfiles,$value,$key);
                   } elsif ($key eq 'content') {
                       my ($path) = ($shockwave{$id} =~ m{^(.+/)[^/]+$});
                       my ($ext) = ($value =~ /\.([^.]+)$/);
                       if ($ext ne '') {
                           &add_filetype($allfiles,$path.$value,$ext);
                       }
                   }
               }
           }
       }
       return 'ok';
   }
   
   sub add_filetype {
       my ($allfiles,$file,$type)=@_;
       if (exists($allfiles->{$file})) {
    unless (grep/^\Q$type\E$/, @{$allfiles->{$file}}) {
       push(@{$allfiles->{$file}}, &escape($type));
    }
       } else {
    @{$allfiles->{$file}} = (&escape($type));
       }
   }
   
   sub embedded_dependency {
       my ($allfiles,$related,$identifier,$pathfrom) = @_;
       if ((ref($allfiles) eq 'HASH') && (ref($related) eq 'HASH')) {
           if (($identifier ne '') &&
               (ref($related->{$identifier}) eq 'ARRAY') &&
               ($pathfrom ne '')) {
               my ($path) = ($pathfrom =~ m{^(.+/)[^/]+$});
               foreach my $dep (@{$related->{$identifier}}) {
                   &add_filetype($allfiles,$path.$dep,'object');
               }
           }
       }
       return;
 }  }
   
 sub removeuploadedurl {  sub removeuploadedurl {
     my ($url)=@_;      my ($url)=@_;
     my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);      my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);    
     return &Apache::lonnet::removeuserfile($uname,$udom,$fname);      return &removeuserfile($uname,$udom,$fname);
 }  }
   
 sub removeuserfile {  sub removeuserfile {
     my ($docuname,$docudom,$fname)=@_;      my ($docuname,$docudom,$fname)=@_;
     my $home=&homeserver($docuname,$docudom);      my $home=&homeserver($docuname,$docudom);    
     return &reply("removeuserfile:$docudom/$docuname/$fname",$home);      my $result = &reply("removeuserfile:$docudom/$docuname/$fname",$home);
       if ($result eq 'ok') {
           if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) {
               my $metafile = $fname.'.meta';
               my $metaresult = &removeuserfile($docuname,$docudom,$metafile); 
       my $url = "/uploaded/$docudom/$docuname/$fname";
               my ($file,$group) = (&parse_portfolio_url($url))[3,4];   
               my $sqlresult = 
                   &update_portfolio_table($docuname,$docudom,$file,
                                           'portfolio_metadata',$group,
                                           'delete');
           }
       }
       return $result;
 }  }
   
 sub mkdiruserfile {  sub mkdiruserfile {
Line 1446  sub mkdiruserfile { Line 3273  sub mkdiruserfile {
 sub renameuserfile {  sub renameuserfile {
     my ($docuname,$docudom,$old,$new)=@_;      my ($docuname,$docudom,$old,$new)=@_;
     my $home=&homeserver($docuname,$docudom);      my $home=&homeserver($docuname,$docudom);
     return &reply("renameuserfile:$docudom:$docuname:".&escape("$old").':'.      my $result = &reply("renameuserfile:$docudom:$docuname:".
   &escape("$new"),$home);                          &escape("$old").':'.&escape("$new"),$home);
       if ($result eq 'ok') {
           if (($old !~ /\.meta$/) && (&is_portfolio_file($old))) {
               my $oldmeta = $old.'.meta';
               my $newmeta = $new.'.meta';
               my $metaresult = 
                   &renameuserfile($docuname,$docudom,$oldmeta,$newmeta);
       my $url = "/uploaded/$docudom/$docuname/$old";
               my ($file,$group) = (&parse_portfolio_url($url))[3,4];
               my $sqlresult = 
                   &update_portfolio_table($docuname,$docudom,$file,
                                           'portfolio_metadata',$group,
                                           'delete');
           }
       }
       return $result;
 }  }
   
 # ------------------------------------------------------------------------- Log  # ------------------------------------------------------------------------- Log
Line 1473  sub flushcourselogs { Line 3315  sub flushcourselogs {
 # times and course titles for all courseids  # times and course titles for all courseids
 #  #
     my %courseidbuffer=();      my %courseidbuffer=();
     foreach (keys %courselogs) {      foreach my $crsid (keys(%courselogs)) {
         my $crsid=$_;  
         if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$crsid}.':'.          if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$crsid}.':'.
           &escape($courselogs{$crsid}),            &escape($courselogs{$crsid}),
           $coursehombuf{$crsid}) eq 'ok') {            $coursehombuf{$crsid}) eq 'ok') {
Line 1482  sub flushcourselogs { Line 3323  sub flushcourselogs {
         } else {          } else {
             &logthis('Failed to flush log buffer for '.$crsid);              &logthis('Failed to flush log buffer for '.$crsid);
             if (length($courselogs{$crsid})>40000) {              if (length($courselogs{$crsid})>40000) {
                &logthis("<font color=blue>WARNING: Buffer for ".$crsid.                 &logthis("<font color=\"blue\">WARNING: Buffer for ".$crsid.
                         " exceeded maximum size, deleting.</font>");                          " exceeded maximum size, deleting.</font>");
                delete $courselogs{$crsid};                 delete $courselogs{$crsid};
             }              }
         }          }
         if ($courseidbuffer{$coursehombuf{$crsid}}) {          $courseidbuffer{$coursehombuf{$crsid}}{$crsid} = {
            $courseidbuffer{$coursehombuf{$crsid}}.='&'.              'description' => $coursedescrbuf{$crsid},
  &escape($crsid).'='.&escape($coursedescrbuf{$crsid}).              'inst_code'    => $courseinstcodebuf{$crsid},
                          '='.&escape($courseinstcodebuf{$crsid});              'type'        => $coursetypebuf{$crsid},
         } else {              'owner'       => $courseownerbuf{$crsid},
            $courseidbuffer{$coursehombuf{$crsid}}=          };
  &escape($crsid).'='.&escape($coursedescrbuf{$crsid}).  
                          '='.&escape($courseinstcodebuf{$crsid});  
         }      
     }      }
 #  #
 # Write course id database (reverse lookup) to homeserver of courses   # Write course id database (reverse lookup) to homeserver of courses 
 # Is used in pickcourse  # Is used in pickcourse
 #  #
     foreach (keys %courseidbuffer) {      foreach my $crs_home (keys(%courseidbuffer)) {
         &courseidput($hostdom{$_},$courseidbuffer{$_},$_);          my $response = &courseidput(&host_domain($crs_home),
                                       $courseidbuffer{$crs_home},
                                       $crs_home,'timeonly');
     }      }
 #  #
 # File accesses  # File accesses
Line 1511  sub flushcourselogs { Line 3351  sub flushcourselogs {
     foreach my $entry (keys(%accesshash)) {      foreach my $entry (keys(%accesshash)) {
         if ($entry =~ /___count$/) {          if ($entry =~ /___count$/) {
             my ($dom,$name);              my ($dom,$name);
             ($dom,$name,undef)=($entry=~m:___(\w+)/(\w+)/(.*)___count$:);              ($dom,$name,undef)=
    ($entry=~m{___($match_domain)/($match_name)/(.*)___count$});
             if (! defined($dom) || $dom eq '' ||               if (! defined($dom) || $dom eq '' || 
                 ! defined($name) || $name eq '') {                  ! defined($name) || $name eq '') {
                 my $cid = $ENV{'request.course.id'};                  my $cid = $env{'request.course.id'};
                 $dom  = $ENV{'request.'.$cid.'.domain'};                  $dom  = $env{'request.'.$cid.'.domain'};
                 $name = $ENV{'request.'.$cid.'.num'};                  $name = $env{'request.'.$cid.'.num'};
             }              }
             my $value = $accesshash{$entry};              my $value = $accesshash{$entry};
             my (undef,$url,undef) = ($entry =~ /^(.*)___(.*)___count$/);              my (undef,$url,undef) = ($entry =~ /^(.*)___(.*)___count$/);
Line 1524  sub flushcourselogs { Line 3365  sub flushcourselogs {
             my $result = &inc('nohist_accesscount',\%temphash,$dom,$name);              my $result = &inc('nohist_accesscount',\%temphash,$dom,$name);
             if ($result eq 'ok') {              if ($result eq 'ok') {
                 delete $accesshash{$entry};                  delete $accesshash{$entry};
             } elsif ($result eq 'unknown_cmd') {  
                 # Target server has old code running on it.  
                 my %temphash=($entry => $value);  
                 if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {  
                     delete $accesshash{$entry};  
                 }  
             }              }
         } else {          } else {
             my ($dom,$name) = ($entry=~m:___(\w+)/(\w+)/(.*)___(\w+)$:);              my ($dom,$name) = ($entry=~m{___($match_domain)/($match_name)/(.*)___(\w+)$});
               if (($dom eq 'uploaded') || ($dom eq 'adm')) { next; }
             my %temphash=($entry => $accesshash{$entry});              my %temphash=($entry => $accesshash{$entry});
             if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {              if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {
                 delete $accesshash{$entry};                  delete $accesshash{$entry};
Line 1543  sub flushcourselogs { Line 3379  sub flushcourselogs {
 # Roles  # Roles
 # Reverse lookup of user roles for course faculty/staff and co-authorship  # Reverse lookup of user roles for course faculty/staff and co-authorship
 #  #
     foreach (keys %userrolehash) {      foreach my $entry (keys(%userrolehash)) {
         my $entry=$_;  
         my ($role,$uname,$udom,$runame,$rudom,$rsec)=          my ($role,$uname,$udom,$runame,$rudom,$rsec)=
     split(/\:/,$entry);      split(/\:/,$entry);
         if (&Apache::lonnet::put('nohist_userroles',          if (&Apache::lonnet::put('nohist_userroles',
Line 1553  sub flushcourselogs { Line 3388  sub flushcourselogs {
     delete $userrolehash{$entry};      delete $userrolehash{$entry};
         }          }
     }      }
   #
   # Reverse lookup of domain roles (dc, ad, li, sc, au)
   #
       my %domrolebuffer = ();
       foreach my $entry (keys(%domainrolehash)) {
           my ($role,$uname,$udom,$runame,$rudom,$rsec)=split(/:/,$entry);
           if ($domrolebuffer{$rudom}) {
               $domrolebuffer{$rudom}.='&'.&escape($entry).
                         '='.&escape($domainrolehash{$entry});
           } else {
               $domrolebuffer{$rudom}.=&escape($entry).
                         '='.&escape($domainrolehash{$entry});
           }
           delete $domainrolehash{$entry};
       }
       foreach my $dom (keys(%domrolebuffer)) {
    my %servers = &get_servers($dom,'library');
    foreach my $tryserver (keys(%servers)) {
       unless (&reply('domroleput:'.$dom.':'.
      $domrolebuffer{$dom},$tryserver) eq 'ok') {
    &logthis('Put of domain roles failed for '.$dom.' and  '.$tryserver);
       }
           }
       }
     $dumpcount++;      $dumpcount++;
 }  }
   
 sub courselog {  sub courselog {
     my $what=shift;      my $what=shift;
     $what=time.':'.$what;      $what=time.':'.$what;
     unless ($ENV{'request.course.id'}) { return ''; }      unless ($env{'request.course.id'}) { return ''; }
     $coursedombuf{$ENV{'request.course.id'}}=      $coursedombuf{$env{'request.course.id'}}=
        $ENV{'course.'.$ENV{'request.course.id'}.'.domain'};         $env{'course.'.$env{'request.course.id'}.'.domain'};
     $coursenumbuf{$ENV{'request.course.id'}}=      $coursenumbuf{$env{'request.course.id'}}=
        $ENV{'course.'.$ENV{'request.course.id'}.'.num'};         $env{'course.'.$env{'request.course.id'}.'.num'};
     $coursehombuf{$ENV{'request.course.id'}}=      $coursehombuf{$env{'request.course.id'}}=
        $ENV{'course.'.$ENV{'request.course.id'}.'.home'};         $env{'course.'.$env{'request.course.id'}.'.home'};
     $coursedescrbuf{$ENV{'request.course.id'}}=      $coursedescrbuf{$env{'request.course.id'}}=
        $ENV{'course.'.$ENV{'request.course.id'}.'.description'};         $env{'course.'.$env{'request.course.id'}.'.description'};
     $courseinstcodebuf{$ENV{'request.course.id'}}=      $courseinstcodebuf{$env{'request.course.id'}}=
        $ENV{'course.'.$ENV{'request.course.id'}.'.internal.coursecode'};         $env{'course.'.$env{'request.course.id'}.'.internal.coursecode'};
     if (defined $courselogs{$ENV{'request.course.id'}}) {      $courseownerbuf{$env{'request.course.id'}}=
  $courselogs{$ENV{'request.course.id'}}.='&'.$what;         $env{'course.'.$env{'request.course.id'}.'.internal.courseowner'};
       $coursetypebuf{$env{'request.course.id'}}=
          $env{'course.'.$env{'request.course.id'}.'.type'};
       if (defined $courselogs{$env{'request.course.id'}}) {
    $courselogs{$env{'request.course.id'}}.='&'.$what;
     } else {      } else {
  $courselogs{$ENV{'request.course.id'}}.=$what;   $courselogs{$env{'request.course.id'}}.=$what;
     }      }
     if (length($courselogs{$ENV{'request.course.id'}})>4048) {      if (length($courselogs{$env{'request.course.id'}})>4048) {
  &flushcourselogs();   &flushcourselogs();
     }      }
 }  }
   
 sub courseacclog {  sub courseacclog {
     my $fnsymb=shift;      my $fnsymb=shift;
     unless ($ENV{'request.course.id'}) { return ''; }      unless ($env{'request.course.id'}) { return ''; }
     my $what=$fnsymb.':'.$ENV{'user.name'}.':'.$ENV{'user.domain'};      my $what=$fnsymb.':'.$env{'user.name'}.':'.$env{'user.domain'};
     if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|page)$/) {      if ($fnsymb=~/$LONCAPA::assess_re/) {
         $what.=':POST';          $what.=':POST';
  foreach (keys %ENV) {          # FIXME: Probably ought to escape things....
             if ($_=~/^form\.(.*)/) {   foreach my $key (keys(%env)) {
  $what.=':'.$1.'='.$ENV{$_};              if ($key=~/^form\.(.*)/) {
                   my $formitem = $1;
                   if ($formitem =~ /^HWFILE(?:SIZE|TOOBIG)/) {
                       $what.=':'.$formitem.'='.$env{$key};
                   } elsif ($formitem !~ /^HWFILE(?:[^.]+)$/) {
                       $what.=':'.$formitem.'='.$env{$key};
                   }
               }
           }
       } elsif ($fnsymb =~ m:^/adm/searchcat:) {
           # FIXME: We should not be depending on a form parameter that someone
           # editing lonsearchcat.pm might change in the future.
           if ($env{'form.phase'} eq 'course_search') {
               $what.= ':POST';
               # FIXME: Probably ought to escape things....
               foreach my $element ('courseexp','crsfulltext','crsrelated',
                                    'crsdiscuss') {
                   $what.=':'.$element.'='.$env{'form.'.$element};
             }              }
         }          }
     }      }
Line 1598  sub courseacclog { Line 3478  sub courseacclog {
 sub countacc {  sub countacc {
     my $url=&declutter(shift);      my $url=&declutter(shift);
     return if (! defined($url) || $url eq '');      return if (! defined($url) || $url eq '');
     unless ($ENV{'request.course.id'}) { return ''; }      unless ($env{'request.course.id'}) { return ''; }
     $accesshash{$ENV{'request.course.id'}.'___'.$url.'___course'}=1;  #
   # Mark that this url was used in this course
   #
       $accesshash{$env{'request.course.id'}.'___'.$url.'___course'}=1;
   #
   # Increase the access count for this resource in this child process
   #
     my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count';      my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count';
     $accesshash{$key}++;      $accesshash{$key}++;
 }  }
Line 1611  sub linklog { Line 3497  sub linklog {
     $accesshash{$from.'___'.$to.'___comefrom'}=1;      $accesshash{$from.'___'.$to.'___comefrom'}=1;
     $accesshash{$to.'___'.$from.'___goto'}=1;      $accesshash{$to.'___'.$from.'___goto'}=1;
 }  }
   
   sub statslog {
       my ($symb,$part,$users,$av_attempts,$degdiff)=@_;
       if ($users<2) { return; }
       my %dynstore=&LONCAPA::lonmetadata::dynamic_metadata_storage({
               'course'       => $env{'request.course.id'},
               'sections'     => '"all"',
               'num_students' => $users,
               'part'         => $part,
               'symb'         => $symb,
               'mean_tries'   => $av_attempts,
               'deg_of_diff'  => $degdiff});
       foreach my $key (keys(%dynstore)) {
           $accesshash{$key}=$dynstore{$key};
       }
   }
       
 sub userrolelog {  sub userrolelog {
     my ($trole,$username,$domain,$area,$tstart,$tend)=@_;      my ($trole,$username,$domain,$area,$tstart,$tend)=@_;
     if (($trole=~/^ca/) || ($trole=~/^in/) ||       if ( $trole =~ /^(ca|aa|in|cc|ep|cr|ta|co)/ ) {
         ($trole=~/^cc/) || ($trole=~/^ep/) ||  
         ($trole=~/^cr/) || ($trole=~/^ta/)) {  
        my (undef,$rudom,$runame,$rsec)=split(/\//,$area);         my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
        $userrolehash         $userrolehash
          {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}           {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
                     =$tend.':'.$tstart;                      =$tend.':'.$tstart;
    }      }
       if ($env{'request.role'} =~ /dc\./ && $trole =~ /^(au|in|cc|ep|cr|ta|co)/) {
          $userrolehash
            {$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'}
                       =$tend.':'.$tstart;
       }
       if ($trole =~ /^(dc|ad|li|au|dg|sc)/ ) {
          my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
          $domainrolehash
            {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
                       = $tend.':'.$tstart;
       }
   }
   
   sub courserolelog {
       my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$selfenroll,$context)=@_;
       if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) {
           my $cdom = $1;
           my $cnum = $2;
           my $sec = $3;
           my $namespace = 'rolelog';
           my %storehash = (
                              role    => $trole,
                              start   => $tstart,
                              end     => $tend,
                              selfenroll => $selfenroll,
                              context    => $context,
                           );
           if ($trole eq 'gr') {
               $namespace = 'groupslog';
               $storehash{'group'} = $sec;
           } else {
               $storehash{'section'} = $sec;
           }
           &write_log('course',$namespace,\%storehash,$delflag,$username,
                      $domain,$cnum,$cdom);
           if (($trole ne 'st') || ($sec ne '')) {
               &devalidate_cache_new('getcourseroles',$cdom.'_'.$cnum);
           }
       }
       return;
   }
   
   sub domainrolelog {
       my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$context)=@_;
       if ($area =~ m{^/($match_domain)/$}) {
           my $cdom = $1;
           my $domconfiguser = &Apache::lonnet::get_domainconfiguser($cdom);
           my $namespace = 'rolelog';
           my %storehash = (
                              role    => $trole,
                              start   => $tstart,
                              end     => $tend,
                              context => $context,
                           );
           &write_log('domain',$namespace,\%storehash,$delflag,$username,
                      $domain,$domconfiguser,$cdom);
       }
       return;
   
   }
   
   sub coauthorrolelog {
       my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$context)=@_;
       if ($area =~ m{^/($match_domain)/($match_username)$}) {
           my $audom = $1;
           my $auname = $2;
           my $namespace = 'rolelog';
           my %storehash = (
                              role    => $trole,
                              start   => $tstart,
                              end     => $tend,
                              context => $context,
                           );
           &write_log('author',$namespace,\%storehash,$delflag,$username,
                      $domain,$auname,$audom);
       }
       return;
 }  }
   
 sub get_course_adv_roles {  sub get_course_adv_roles {
     my $cid=shift;      my ($cid,$codes) = @_;
     $cid=$ENV{'request.course.id'} unless (defined($cid));      $cid=$env{'request.course.id'} unless (defined($cid));
     my %coursehash=&coursedescription($cid);      my %coursehash=&coursedescription($cid);
       my $crstype = &Apache::loncommon::course_type($cid);
     my %nothide=();      my %nothide=();
     foreach (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {      foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
  $nothide{join(':',split(/[\@\:]/,$_))}=1;          if ($user !~ /:/) {
       $nothide{join(':',split(/[\@]/,$user))}=1;
           } else {
               $nothide{$user}=1;
           }
     }      }
     my %returnhash=();      my %returnhash=();
     my %dumphash=      my %dumphash=
             &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});              &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});
     my $now=time;      my $now=time;
     foreach (keys %dumphash) {      my %privileged;
  my ($tend,$tstart)=split(/\:/,$dumphash{$_});      foreach my $entry (keys(%dumphash)) {
    my ($tend,$tstart)=split(/\:/,$dumphash{$entry});
         if (($tstart) && ($tstart<0)) { next; }          if (($tstart) && ($tstart<0)) { next; }
         if (($tend) && ($tend<$now)) { next; }          if (($tend) && ($tend<$now)) { next; }
         if (($tstart) && ($now<$tstart)) { next; }          if (($tstart) && ($now<$tstart)) { next; }
         my ($role,$username,$domain,$section)=split(/\:/,$_);          my ($role,$username,$domain,$section)=split(/\:/,$entry);
  if ((&privileged($username,$domain)) &&    if ($username eq '' || $domain eq '') { next; }
     (!$nothide{$username.':'.$domain})) { next; }          unless (ref($privileged{$domain}) eq 'HASH') {
         my $key=&plaintext($role);              my %dompersonnel =
         if ($section) { $key.=' (Sec/Grp '.$section.')'; }                  &Apache::lonnet::get_domain_roles($domain,['dc'],$now,$now);
         if ($returnhash{$key}) {              $privileged{$domain} = {};
     $returnhash{$key}.=','.$username.':'.$domain;              foreach my $server (keys(%dompersonnel)) {
                   if (ref($dompersonnel{$server}) eq 'HASH') {
                       foreach my $user (keys(%{$dompersonnel{$server}})) {
                           my ($trole,$uname,$udom) = split(/:/,$user);
                           $privileged{$udom}{$uname} = 1;
                       }
                   }
               }
           }
           if ((exists($privileged{$domain}{$username})) && 
               (!$nothide{$username.':'.$domain})) { next; }
    if ($role eq 'cr') { next; }
           if ($codes) {
               if ($section) { $role .= ':'.$section; }
               if ($returnhash{$role}) {
                   $returnhash{$role}.=','.$username.':'.$domain;
               } else {
                   $returnhash{$role}=$username.':'.$domain;
               }
         } else {          } else {
             $returnhash{$key}=$username.':'.$domain;              my $key=&plaintext($role,$crstype);
               if ($section) { $key.=' ('.&Apache::lonlocal::mt('Section [_1]',$section).')'; }
               if ($returnhash{$key}) {
           $returnhash{$key}.=','.$username.':'.$domain;
               } else {
                   $returnhash{$key}=$username.':'.$domain;
               }
         }          }
      }      }
     return %returnhash;      return %returnhash;
 }  }
   
 sub get_my_roles {  sub get_my_roles {
     my ($uname,$udom)=@_;      my ($uname,$udom,$context,$types,$roles,$roledoms,$withsec,$hidepriv)=@_;
     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=      my (%dumphash,%nothide);
       if ($context eq 'userroles') {
           %dumphash = &dump('roles',$udom,$uname);
       } else {
           %dumphash=
             &dump('nohist_userroles',$udom,$uname);              &dump('nohist_userroles',$udom,$uname);
           if ($hidepriv) {
               my %coursehash=&coursedescription($udom.'_'.$uname);
               foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
                   if ($user !~ /:/) {
                       $nothide{join(':',split(/[\@]/,$user))} = 1;
                   } else {
                       $nothide{$user} = 1;
                   }
               }
           }
       }
     my %returnhash=();      my %returnhash=();
     my $now=time;      my $now=time;
     foreach (keys %dumphash) {      my %privileged;
  my ($tend,$tstart)=split(/\:/,$dumphash{$_});      foreach my $entry (keys(%dumphash)) {
           my ($role,$tend,$tstart);
           if ($context eq 'userroles') {
               next if ($entry =~ /^rolesdef/);
       ($role,$tend,$tstart)=split(/_/,$dumphash{$entry});
           } else {
               ($tend,$tstart)=split(/\:/,$dumphash{$entry});
           }
         if (($tstart) && ($tstart<0)) { next; }          if (($tstart) && ($tstart<0)) { next; }
         if (($tend) && ($tend<$now)) { next; }          my $status = 'active';
         if (($tstart) && ($now<$tstart)) { next; }          if (($tend) && ($tend<=$now)) {
         my ($role,$username,$domain,$section)=split(/\:/,$_);              $status = 'previous';
  $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;          } 
      }          if (($tstart) && ($now<$tstart)) {
               $status = 'future';
           }
           if (ref($types) eq 'ARRAY') {
               if (!grep(/^\Q$status\E$/,@{$types})) {
                   next;
               } 
           } else {
               if ($status ne 'active') {
                   next;
               }
           }
           my ($rolecode,$username,$domain,$section,$area);
           if ($context eq 'userroles') {
               ($area,$rolecode) = ($entry =~ /^(.+)_([^_]+)$/);
               (undef,$domain,$username,$section) = split(/\//,$area);
           } else {
               ($role,$username,$domain,$section) = split(/\:/,$entry);
           }
           if (ref($roledoms) eq 'ARRAY') {
               if (!grep(/^\Q$domain\E$/,@{$roledoms})) {
                   next;
               }
           }
           if (ref($roles) eq 'ARRAY') {
               if (!grep(/^\Q$role\E$/,@{$roles})) {
                   if ($role =~ /^cr\//) {
                       if (!grep(/^cr$/,@{$roles})) {
                           next;
                       }
                   } elsif ($role =~ /^gr\//) {
                       if (!grep(/^gr$/,@{$roles})) {
                           next;
                       }
                   } else {
                       next;
                   }
               }
           }
           if ($hidepriv) {
               if ($context eq 'userroles') {
                   if ((&privileged($username,$domain)) &&
                       (!$nothide{$username.':'.$domain})) {
                       next;
                   }
               } else {
                   unless (ref($privileged{$domain}) eq 'HASH') {
                       my %dompersonnel =
                           &Apache::lonnet::get_domain_roles($domain,['dc'],$now,$now);
                       $privileged{$domain} = {};
                       if (keys(%dompersonnel)) {
                           foreach my $server (keys(%dompersonnel)) {
                               if (ref($dompersonnel{$server}) eq 'HASH') {
                                   foreach my $user (keys(%{$dompersonnel{$server}})) {
                                       my ($trole,$uname,$udom) = split(/:/,$user);
                                       $privileged{$udom}{$uname} = $trole;
                                   }
                               }
                           }
                       }
                   }
                   if (exists($privileged{$domain}{$username})) {
                       if (!$nothide{$username.':'.$domain}) {
                           next;
                       }
                   }
               }
           }
           if ($withsec) {
               $returnhash{$username.':'.$domain.':'.$role.':'.$section} =
                   $tstart.':'.$tend;
           } else {
               $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;
           }
       }
     return %returnhash;      return %returnhash;
 }  }
   
Line 1680  sub get_my_roles { Line 3783  sub get_my_roles {
   
 sub postannounce {  sub postannounce {
     my ($server,$text)=@_;      my ($server,$text)=@_;
     unless (&allowed('psa',$hostdom{$server})) { return 'refused'; }      unless (&allowed('psa',&host_domain($server))) { return 'refused'; }
     unless ($text=~/\w/) { $text=''; }      unless ($text=~/\w/) { $text=''; }
     return &reply('setannounce:'.&escape($text),$server);      return &reply('setannounce:'.&escape($text),$server);
 }  }
Line 1689  sub getannounce { Line 3792  sub getannounce {
   
     if (open(my $fh,$perlvar{'lonDocRoot'}.'/announcement.txt')) {      if (open(my $fh,$perlvar{'lonDocRoot'}.'/announcement.txt')) {
  my $announcement='';   my $announcement='';
  while (<$fh>) { $announcement .=$_; }   while (my $line = <$fh>) { $announcement .= $line; }
  close($fh);   close($fh);
  if ($announcement=~/\w/) {    if ($announcement=~/\w/) { 
     return       return 
Line 1708  sub getannounce { Line 3811  sub getannounce {
 #  #
   
 sub courseidput {  sub courseidput {
     my ($domain,$what,$coursehome)=@_;      my ($domain,$storehash,$coursehome,$caller) = @_;
     return &reply('courseidput:'.$domain.':'.$what,$coursehome);      return unless (ref($storehash) eq 'HASH');
       my $outcome;
       if ($caller eq 'timeonly') {
           my $cids = '';
           foreach my $item (keys(%$storehash)) {
               $cids.=&escape($item).'&';
           }
           $cids=~s/\&$//;
           $outcome = &reply('courseidputhash:'.$domain.':'.$caller.':'.$cids,
                             $coursehome);       
       } else {
           my $items = '';
           foreach my $item (keys(%$storehash)) {
               $items.= &escape($item).'='.
                        &freeze_escape($$storehash{$item}).'&';
           }
           $items=~s/\&$//;
           $outcome = &reply('courseidputhash:'.$domain.':'.$caller.':'.$items,
                             $coursehome);
       }
       if ($outcome eq 'unknown_cmd') {
           my $what;
           foreach my $cid (keys(%$storehash)) {
               $what .= &escape($cid).'=';
               foreach my $item ('description','inst_code','owner','type') {
                   $what .= &escape($storehash->{$cid}{$item}).':';
               }
               $what =~ s/\:$/&/;
           }
           $what =~ s/\&$//;  
           return &reply('courseidput:'.$domain.':'.$what,$coursehome);
       } else {
           return $outcome;
       }
 }  }
   
 sub courseiddump {  sub courseiddump {
     my ($domfilter,$descfilter,$sincefilter,$hostidflag,$hostidref)=@_;      my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,
     my %returnhash=();          $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,
     unless ($domfilter) { $domfilter=''; }          $selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone,
     foreach my $tryserver (keys %libserv) {          $cloneonly,$createdbefore,$createdafter,$creationcontext,$domcloner)=@_;
         if ( ($hostidflag == 1 && grep/^$tryserver$/,@{$hostidref}) || (!defined($hostidflag)) ) {      my $as_hash = 1;
     if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) {      my %returnhash;
         foreach (      if (!$domfilter) { $domfilter=''; }
                  split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'.      my %libserv = &all_library();
        $sincefilter.':'.&escape($descfilter),      foreach my $tryserver (keys(%libserv)) {
                                $tryserver))) {          if ( (  $hostidflag == 1 
     my ($key,$value)=split(/\=/,$_);          && grep(/^\Q$tryserver\E$/,@{$hostidref}) ) 
                     if (($key) && ($value)) {       || (!defined($hostidflag)) ) {
         $returnhash{&unescape($key)}=$value;  
       if (($domfilter eq '') ||
    (&host_domain($tryserver) eq $domfilter)) {
                   my $rep;
                   if (grep { $_ eq $tryserver } current_machine_ids()) {
                       $rep = LONCAPA::Lond::dump_course_id_handler(
                           join(":", (&host_domain($tryserver), $sincefilter, 
                                   &escape($descfilter), &escape($instcodefilter), 
                                   &escape($ownerfilter), &escape($coursefilter),
                                   &escape($typefilter), &escape($regexp_ok), 
                                   $as_hash, &escape($selfenrollonly), 
                                   &escape($catfilter), $showhidden, $caller, 
                                   &escape($cloner), &escape($cc_clone), $cloneonly, 
                                   &escape($createdbefore), &escape($createdafter), 
                                   &escape($creationcontext), $domcloner)));
                   } else {
                       $rep = &reply('courseiddump:'.&host_domain($tryserver).':'.
                                $sincefilter.':'.&escape($descfilter).':'.
                                &escape($instcodefilter).':'.&escape($ownerfilter).
                                ':'.&escape($coursefilter).':'.&escape($typefilter).
                                ':'.&escape($regexp_ok).':'.$as_hash.':'.
                                &escape($selfenrollonly).':'.&escape($catfilter).':'.
                                $showhidden.':'.$caller.':'.&escape($cloner).':'.
                                &escape($cc_clone).':'.$cloneonly.':'.
                                &escape($createdbefore).':'.&escape($createdafter).':'.
                                &escape($creationcontext).':'.$domcloner,
                                $tryserver);
                   }
                        
                   my @pairs=split(/\&/,$rep);
                   foreach my $item (@pairs) {
                       my ($key,$value)=split(/\=/,$item,2);
                       $key = &unescape($key);
                       next if ($key =~ /^error: 2 /);
                       my $result = &thaw_unescape($value);
                       if (ref($result) eq 'HASH') {
                           $returnhash{$key}=$result;
                       } else {
                           my @responses = split(/:/,$value);
                           my @items = ('description','inst_code','owner','type');
                           for (my $i=0; $i<@responses; $i++) {
                               $returnhash{$key}{$items[$i]} = &unescape($responses[$i]);
                           }
                     }                      }
                 }                  }
             }              }
Line 1734  sub courseiddump { Line 3912  sub courseiddump {
     return %returnhash;      return %returnhash;
 }  }
   
 #  sub courselastaccess {
 # ----------------------------------------------------------- Check out an item      my ($cdom,$cnum,$hostidref) = @_;
       my %returnhash;
 sub get_first_access {      if ($cdom && $cnum) {
     my ($type,$argsymb)=@_;          my $chome = &homeserver($cnum,$cdom);
     my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();          if ($chome ne 'no_host') {
     if ($argsymb) { $symb=$argsymb; }              my $rep = &reply('courselastaccess:'.$cdom.':'.$cnum,$chome);
     my ($map,$id,$res)=&decode_symb($symb);              &extract_lastaccess(\%returnhash,$rep);
     if ($type eq 'map') { $res=$map; }          }
     my %times=&get('firstaccesstimes',[$res],$udom,$uname);      } else {
     return $times{$res};          if (!$cdom) { $cdom=''; }
           my %libserv = &all_library();
           foreach my $tryserver (keys(%libserv)) {
               if (ref($hostidref) eq 'ARRAY') {
                   next unless (grep(/^\Q$tryserver\E$/,@{$hostidref}));
               } 
               if (($cdom eq '') || (&host_domain($tryserver) eq $cdom)) {
                   my $rep = &reply('courselastaccess:'.&host_domain($tryserver).':',$tryserver);
                   &extract_lastaccess(\%returnhash,$rep);
               }
           }
       }
       return %returnhash;
 }  }
   
 sub set_first_access {  sub extract_lastaccess {
     my ($type)=@_;      my ($returnhash,$rep) = @_;
     my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();      if (ref($returnhash) eq 'HASH') {
     my ($map,$id,$res)=&decode_symb($symb);          unless ($rep eq 'unknown_command' || $rep eq 'no_such_host' || 
     if ($type eq 'map') { $res=$map; }                  $rep eq 'con_lost' || $rep eq 'rejected' || $rep eq 'refused' ||
     my $firstaccess=&get_first_access($type);                   $rep eq '') {
     if (!$firstaccess) {              my @pairs=split(/\&/,$rep);
  return &put('firstaccesstimes',{$res=>time},$udom,$uname);              foreach my $item (@pairs) {
                   my ($key,$value)=split(/\=/,$item,2);
                   $key = &unescape($key);
                   next if ($key =~ /^error: 2 /);
                   $returnhash->{$key} = &thaw_unescape($value);
               }
           }
     }      }
     return 'already_set';      return;
 }  }
   
 sub checkout {  # ---------------------------------------------------------- DC e-mail
     my ($symb,$tuname,$tudom,$tcrsid)=@_;  
     my $now=time;  
     my $lonhost=$perlvar{'lonHostID'};  
     my $infostr=&escape(  
                  'CHECKOUTTOKEN&'.  
                  $tuname.'&'.  
                  $tudom.'&'.  
                  $tcrsid.'&'.  
                  $symb.'&'.  
  $now.'&'.$ENV{'REMOTE_ADDR'});  
     my $token=&reply('tmpput:'.$infostr,$lonhost);  
     if ($token=~/^error\:/) {   
         &logthis("<font color=blue>WARNING: ".  
                 "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.  
                  "</font>");  
         return '';   
     }  
   
     $token=~s/^(\d+)\_.*\_(\d+)$/$1\*$2\*$lonhost/;  
     $token=~tr/a-z/A-Z/;  
   
     my %infohash=('resource.0.outtoken' => $token,  
                   'resource.0.checkouttime' => $now,  
                   'resource.0.outremote' => $ENV{'REMOTE_ADDR'});  
   
     unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {  
        return '';  
     } else {  
         &logthis("<font color=blue>WARNING: ".  
                 "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.  
                  "</font>");  
     }      
   
     if (&log($tudom,$tuname,&homeserver($tuname,$tudom),  sub dcmailput {
                          &escape('Checkout '.$infostr.' - '.      my ($domain,$msgid,$message,$server)=@_;
                                                  $token)) ne 'ok') {      my $status = &Apache::lonnet::critical(
  return '';         'dcmailput:'.$domain.':'.&escape($msgid).'='.
     } else {         &escape($message),$server);
         &logthis("<font color=blue>WARNING: ".      return $status;
                 "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.  
                  "</font>");  
     }  
     return $token;  
 }  }
   
 # ------------------------------------------------------------ Check in an item  sub dcmaildump {
       my ($dom,$startdate,$enddate,$senders) = @_;
 sub checkin {      my %returnhash=();
     my $token=shift;  
     my $now=time;  
     my ($ta,$tb,$lonhost)=split(/\*/,$token);  
     $lonhost=~tr/A-Z/a-z/;  
     my $dtoken=$ta.'_'.$hostip{$lonhost}.'_'.$tb;  
     $dtoken=~s/\W/\_/g;  
     my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=  
                  split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));  
   
     unless (($tuname) && ($tudom)) {      if (defined(&domain($dom,'primary'))) {
         &logthis('Check in '.$token.' ('.$dtoken.') failed');          my $cmd='dcmaildump:'.$dom.':'.&escape($startdate).':'.
         return '';                                                           &escape($enddate).':';
    my @esc_senders=map { &escape($_)} @$senders;
    $cmd.=&escape(join('&',@esc_senders));
    foreach my $line (split(/\&/,&reply($cmd,&domain($dom,'primary')))) {
               my ($key,$value) = split(/\=/,$line,2);
               if (($key) && ($value)) {
                   $returnhash{&unescape($key)} = &unescape($value);
               }
           }
     }      }
           return %returnhash;
     unless (&allowed('mgr',$tcrsid)) {  }
         &logthis('Check in '.$token.' ('.$dtoken.') unauthorized: '.  # ---------------------------------------------------------- Domain roles
                  $ENV{'user.name'}.' - '.$ENV{'user.domain'});  
         return '';  sub get_domain_roles {
       my ($dom,$roles,$startdate,$enddate)=@_;
       if ((!defined($startdate)) || ($startdate eq '')) {
           $startdate = '.';
       }
       if ((!defined($enddate)) || ($enddate eq '')) {
           $enddate = '.';
       }
       my $rolelist;
       if (ref($roles) eq 'ARRAY') {
           $rolelist = join(':',@{$roles});
       }
       my %personnel = ();
   
       my %servers = &get_servers($dom,'library');
       foreach my $tryserver (keys(%servers)) {
    %{$personnel{$tryserver}}=();
    foreach my $line (split(/\&/,&reply('domrolesdump:'.$dom.':'.
       &escape($startdate).':'.
       &escape($enddate).':'.
       &escape($rolelist), $tryserver))) {
       my ($key,$value) = split(/\=/,$line,2);
       if (($key) && ($value)) {
    $personnel{$tryserver}{&unescape($key)} = &unescape($value);
       }
    }
     }      }
       return %personnel;
   }
   
     my %infohash=('resource.0.intoken' => $token,  # ----------------------------------------------------------- Interval timing 
                   'resource.0.checkintime' => $now,  
                   'resource.0.inremote' => $ENV{'REMOTE_ADDR'});  
   
     unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {  {
        return '';  # Caches needed for speedup of navmaps
     }      # We don't want to cache this for very long at all (5 seconds at most)
   # 
   # The user for whom we cache
   my $cachedkey='';
   # The cached times for this user
   my %cachedtimes=();
   # When this was last done
   my $cachedtime=();
   
     if (&log($tudom,$tuname,&homeserver($tuname,$tudom),  sub load_all_first_access {
                          &escape('Checkin - '.$token)) ne 'ok') {      my ($uname,$udom)=@_;
  return '';      if (($cachedkey eq $uname.':'.$udom) &&
     }          (abs($cachedtime-time)<5) && (!$env{'form.markaccess'})) {
           return;
       }
       $cachedtime=time;
       $cachedkey=$uname.':'.$udom;
       %cachedtimes=&dump('firstaccesstimes',$udom,$uname);
   }
   
     return ($symb,$tuname,$tudom,$tcrsid);      sub get_first_access {
       my ($type,$argsymb,$argmap)=@_;
       my ($symb,$courseid,$udom,$uname)=&whichuser();
       if ($argsymb) { $symb=$argsymb; }
       my ($map,$id,$res)=&decode_symb($symb);
       if ($argmap) { $map = $argmap; }
       if ($type eq 'course') {
    $res='course';
       } elsif ($type eq 'map') {
    $res=&symbread($map);
       } else {
    $res=$symb;
       }
       &load_all_first_access($uname,$udom);
       return $cachedtimes{"$courseid\0$res"};
 }  }
   
   sub set_first_access {
       my ($type,$interval)=@_;
       my ($symb,$courseid,$udom,$uname)=&whichuser();
       my ($map,$id,$res)=&decode_symb($symb);
       if ($type eq 'course') {
    $res='course';
       } elsif ($type eq 'map') {
    $res=&symbread($map);
       } else {
    $res=$symb;
       }
       $cachedkey='';
       my $firstaccess=&get_first_access($type,$symb,$map);
       if (!$firstaccess) {
           my $start = time;
    my $putres = &put('firstaccesstimes',{"$courseid\0$res"=>$start},
                             $udom,$uname);
           if ($putres eq 'ok') {
               &put('timerinterval',{"$courseid\0$res"=>$interval},
                    $udom,$uname); 
               &appenv(
                        {
                           'course.'.$courseid.'.firstaccess.'.$res   => $start,
                           'course.'.$courseid.'.timerinterval.'.$res => $interval,
                        }
                     );
           }
           return $putres;
       }
       return 'already_set';
   }
   }
 # --------------------------------------------- Set Expire Date for Spreadsheet  # --------------------------------------------- Set Expire Date for Spreadsheet
   
 sub expirespread {  sub expirespread {
     my ($uname,$udom,$stype,$usymb)=@_;      my ($uname,$udom,$stype,$usymb)=@_;
     my $cid=$ENV{'request.course.id'};       my $cid=$env{'request.course.id'}; 
     if ($cid) {      if ($cid) {
        my $now=time;         my $now=time;
        my $key=$uname.':'.$udom.':'.$stype.':'.$usymb;         my $key=$uname.':'.$udom.':'.$stype.':'.$usymb;
        return &reply('put:'.$ENV{'course.'.$cid.'.domain'}.':'.         return &reply('put:'.$env{'course.'.$cid.'.domain'}.':'.
                             $ENV{'course.'.$cid.'.num'}.                              $env{'course.'.$cid.'.num'}.
             ':nohist_expirationdates:'.              ':nohist_expirationdates:'.
                             &escape($key).'='.$now,                              &escape($key).'='.$now,
                             $ENV{'course.'.$cid.'.home'})                              $env{'course.'.$cid.'.home'})
     }      }
     return 'ok';      return 'ok';
 }  }
Line 1865  sub expirespread { Line 4109  sub expirespread {
   
 sub devalidate {  sub devalidate {
     my ($symb,$uname,$udom)=@_;      my ($symb,$uname,$udom)=@_;
     my $cid=$ENV{'request.course.id'};       my $cid=$env{'request.course.id'}; 
     if ($cid) {      if ($cid) {
         # delete the stored spreadsheets for          # delete the stored spreadsheets for
         # - the student level sheet of this user in course's homespace          # - the student level sheet of this user in course's homespace
Line 1876  sub devalidate { Line 4120  sub devalidate {
         my $status=          my $status=
     &del('nohist_calculatedsheets',      &del('nohist_calculatedsheets',
  [$key.'studentcalc:'],   [$key.'studentcalc:'],
  $ENV{'course.'.$cid.'.domain'},   $env{'course.'.$cid.'.domain'},
  $ENV{'course.'.$cid.'.num'})   $env{'course.'.$cid.'.num'})
  .' '.   .' '.
     &del('nohist_calculatedsheets_'.$cid,      &del('nohist_calculatedsheets_'.$cid,
  [$key.'assesscalc:'.$symb],$udom,$uname);   [$key.'assesscalc:'.$symb],$udom,$uname);
Line 1939  sub hash2str { Line 4183  sub hash2str {
 sub hashref2str {  sub hashref2str {
   my ($hashref)=@_;    my ($hashref)=@_;
   my $result='__HASH_REF__';    my $result='__HASH_REF__';
   foreach (sort(keys(%$hashref))) {    foreach my $key (sort(keys(%$hashref))) {
     if (ref($_) eq 'ARRAY') {      if (ref($key) eq 'ARRAY') {
       $result.=&arrayref2str($_).'=';        $result.=&arrayref2str($key).'=';
     } elsif (ref($_) eq 'HASH') {      } elsif (ref($key) eq 'HASH') {
       $result.=&hashref2str($_).'=';        $result.=&hashref2str($key).'=';
     } elsif (ref($_)) {      } elsif (ref($key)) {
       $result.='=';        $result.='=';
       #print("Got a ref of ".(ref($_))." skipping.");        #print("Got a ref of ".(ref($key))." skipping.");
     } else {      } else {
  if ($_) {$result.=&escape($_).'=';} else { last; }   if (defined($key)) {$result.=&escape($key).'=';} else { last; }
     }      }
   
     if(ref($hashref->{$_}) eq 'ARRAY') {      if(ref($hashref->{$key}) eq 'ARRAY') {
       $result.=&arrayref2str($hashref->{$_}).'&';        $result.=&arrayref2str($hashref->{$key}).'&';
     } elsif(ref($hashref->{$_}) eq 'HASH') {      } elsif(ref($hashref->{$key}) eq 'HASH') {
       $result.=&hashref2str($hashref->{$_}).'&';        $result.=&hashref2str($hashref->{$key}).'&';
     } elsif(ref($hashref->{$_})) {      } elsif(ref($hashref->{$key})) {
        $result.='&';         $result.='&';
       #print("Got a ref of ".(ref($hashref->{$_}))." skipping.");        #print("Got a ref of ".(ref($hashref->{$key}))." skipping.");
     } else {      } else {
       $result.=&escape($hashref->{$_}).'&';        $result.=&escape($hashref->{$key}).'&';
     }      }
   }    }
   $result=~s/\&$//;    $result=~s/\&$//;
Line 2087  sub tmpreset { Line 4331  sub tmpreset {
   my ($symb,$namespace,$domain,$stuname) = @_;    my ($symb,$namespace,$domain,$stuname) = @_;
   if (!$symb) {    if (!$symb) {
     $symb=&symbread();      $symb=&symbread();
     if (!$symb) { $symb= $ENV{'request.url'}; }      if (!$symb) { $symb= $env{'request.url'}; }
   }    }
   $symb=escape($symb);    $symb=escape($symb);
   
   if (!$namespace) { $namespace=$ENV{'request.state'}; }    if (!$namespace) { $namespace=$env{'request.state'}; }
   $namespace=~s/\//\_/g;    $namespace=~s/\//\_/g;
   $namespace=~s/\W//g;    $namespace=~s/\W//g;
   
   #FIXME needs to do something for /pub resources    if (!$domain) { $domain=$env{'user.domain'}; }
   if (!$domain) { $domain=$ENV{'user.domain'}; }    if (!$stuname) { $stuname=$env{'user.name'}; }
   if (!$stuname) { $stuname=$ENV{'user.name'}; }    if ($domain eq 'public' && $stuname eq 'public') {
   my $path=$perlvar{'lonDaemons'}.'/tmp';        $stuname=$ENV{'REMOTE_ADDR'};
     }
     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',
   &GDBM_WRCREAT(),0640)) {    &GDBM_WRCREAT(),0640)) {
     foreach my $key (keys %hash) {      foreach my $key (keys(%hash)) {
       if ($key=~ /:$symb/) {        if ($key=~ /:$symb/) {
  delete($hash{$key});   delete($hash{$key});
       }        }
Line 2116  sub tmpstore { Line 4362  sub tmpstore {
   
   if (!$symb) {    if (!$symb) {
     $symb=&symbread();      $symb=&symbread();
     if (!$symb) { $symb= $ENV{'request.url'}; }      if (!$symb) { $symb= $env{'request.url'}; }
   }    }
   $symb=escape($symb);    $symb=escape($symb);
   
   if (!$namespace) {    if (!$namespace) {
     # I don't think we would ever want to store this for a course.      # I don't think we would ever want to store this for a course.
     # it seems this will only be used if we don't have a course.      # it seems this will only be used if we don't have a course.
     #$namespace=$ENV{'request.course.id'};      #$namespace=$env{'request.course.id'};
     #if (!$namespace) {      #if (!$namespace) {
       $namespace=$ENV{'request.state'};        $namespace=$env{'request.state'};
     #}      #}
   }    }
   $namespace=~s/\//\_/g;    $namespace=~s/\//\_/g;
   $namespace=~s/\W//g;    $namespace=~s/\W//g;
 #FIXME needs to do something for /pub resources    if (!$domain) { $domain=$env{'user.domain'}; }
   if (!$domain) { $domain=$ENV{'user.domain'}; }    if (!$stuname) { $stuname=$env{'user.name'}; }
   if (!$stuname) { $stuname=$ENV{'user.name'}; }    if ($domain eq 'public' && $stuname eq 'public') {
         $stuname=$ENV{'REMOTE_ADDR'};
     }
   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 2144  sub tmpstore { Line 4392  sub tmpstore {
     my $allkeys='';       my $allkeys=''; 
     foreach my $key (keys(%$storehash)) {      foreach my $key (keys(%$storehash)) {
       $allkeys.=$key.':';        $allkeys.=$key.':';
       $hash{"$version:$symb:$key"}=$$storehash{$key};        $hash{"$version:$symb:$key"}=&freeze_escape($$storehash{$key});
     }      }
     $hash{"$version:$symb:timestamp"}=$now;      $hash{"$version:$symb:timestamp"}=$now;
     $allkeys.='timestamp';      $allkeys.='timestamp';
Line 2166  sub tmprestore { Line 4414  sub tmprestore {
   
   if (!$symb) {    if (!$symb) {
     $symb=&symbread();      $symb=&symbread();
     if (!$symb) { $symb= $ENV{'request.url'}; }      if (!$symb) { $symb= $env{'request.url'}; }
   }    }
   $symb=escape($symb);    $symb=escape($symb);
   
   if (!$namespace) { $namespace=$ENV{'request.state'}; }    if (!$namespace) { $namespace=$env{'request.state'}; }
   #FIXME needs to do something for /pub resources  
   if (!$domain) { $domain=$ENV{'user.domain'}; }  
   if (!$stuname) { $stuname=$ENV{'user.name'}; }  
   
     if (!$domain) { $domain=$env{'user.domain'}; }
     if (!$stuname) { $stuname=$env{'user.name'}; }
     if ($domain eq 'public' && $stuname eq 'public') {
         $stuname=$ENV{'REMOTE_ADDR'};
     }
   my %returnhash;    my %returnhash;
   $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 2192  sub tmprestore { Line 4442  sub tmprestore {
       my $key;        my $key;
       $returnhash{"$scope:keys"}=$vkeys;        $returnhash{"$scope:keys"}=$vkeys;
       foreach $key (@keys) {        foreach $key (@keys) {
  $returnhash{"$scope:$key"}=$hash{"$scope:$symb:$key"};   $returnhash{"$scope:$key"}=&thaw_unescape($hash{"$scope:$symb:$key"});
  $returnhash{"$key"}=$hash{"$scope:$symb:$key"};   $returnhash{"$key"}=&thaw_unescape($hash{"$scope:$symb:$key"});
       }        }
     }      }
     if (!(untie(%hash))) {      if (!(untie(%hash))) {
Line 2216  sub store { Line 4466  sub store {
     $symb=&symbclean($symb);      $symb=&symbclean($symb);
     if (!$symb) { unless ($symb=&symbread()) { return ''; } }      if (!$symb) { unless ($symb=&symbread()) { return ''; } }
   
     if (!$domain) { $domain=$ENV{'user.domain'}; }      if (!$domain) { $domain=$env{'user.domain'}; }
     if (!$stuname) { $stuname=$ENV{'user.name'}; }      if (!$stuname) { $stuname=$env{'user.name'}; }
   
     &devalidate($symb,$stuname,$domain);      &devalidate($symb,$stuname,$domain);
   
     $symb=escape($symb);      $symb=escape($symb);
     if (!$namespace) {       if (!$namespace) { 
        unless ($namespace=$ENV{'request.course.id'}) {          unless ($namespace=$env{'request.course.id'}) { 
           return '';             return ''; 
        }          } 
     }      }
     if (!$home) { $home=$ENV{'user.home'}; }      if (!$home) { $home=$env{'user.home'}; }
   
     $$storehash{'ip'}=$ENV{'REMOTE_ADDR'};      $$storehash{'ip'}=$ENV{'REMOTE_ADDR'};
     $$storehash{'host'}=$perlvar{'lonHostID'};      $$storehash{'host'}=$perlvar{'lonHostID'};
   
     my $namevalue='';      my $namevalue='';
     foreach (keys %$storehash) {      foreach my $key (keys(%$storehash)) {
         $namevalue.=escape($_).'='.escape($$storehash{$_}).'&';          $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
     }      }
     $namevalue=~s/\&$//;      $namevalue=~s/\&$//;
     &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue);      &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue);
Line 2252  sub cstore { Line 4502  sub cstore {
     $symb=&symbclean($symb);      $symb=&symbclean($symb);
     if (!$symb) { unless ($symb=&symbread()) { return ''; } }      if (!$symb) { unless ($symb=&symbread()) { return ''; } }
   
     if (!$domain) { $domain=$ENV{'user.domain'}; }      if (!$domain) { $domain=$env{'user.domain'}; }
     if (!$stuname) { $stuname=$ENV{'user.name'}; }      if (!$stuname) { $stuname=$env{'user.name'}; }
   
     &devalidate($symb,$stuname,$domain);      &devalidate($symb,$stuname,$domain);
   
     $symb=escape($symb);      $symb=escape($symb);
     if (!$namespace) {       if (!$namespace) { 
        unless ($namespace=$ENV{'request.course.id'}) {          unless ($namespace=$env{'request.course.id'}) { 
           return '';             return ''; 
        }          } 
     }      }
     if (!$home) { $home=$ENV{'user.home'}; }      if (!$home) { $home=$env{'user.home'}; }
   
     $$storehash{'ip'}=$ENV{'REMOTE_ADDR'};      $$storehash{'ip'}=$ENV{'REMOTE_ADDR'};
     $$storehash{'host'}=$perlvar{'lonHostID'};      $$storehash{'host'}=$perlvar{'lonHostID'};
   
     my $namevalue='';      my $namevalue='';
     foreach (keys %$storehash) {      foreach my $key (keys(%$storehash)) {
         $namevalue.=escape($_).'='.escape($$storehash{$_}).'&';          $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
     }      }
     $namevalue=~s/\&$//;      $namevalue=~s/\&$//;
     &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue);      &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue);
Line 2292  sub restore { Line 4542  sub restore {
       $symb=&escape(&symbclean($symb));        $symb=&escape(&symbclean($symb));
     }      }
     if (!$namespace) {       if (!$namespace) { 
        unless ($namespace=$ENV{'request.course.id'}) {          unless ($namespace=$env{'request.course.id'}) { 
           return '';             return ''; 
        }          } 
     }      }
     if (!$domain) { $domain=$ENV{'user.domain'}; }      if (!$domain) { $domain=$env{'user.domain'}; }
     if (!$stuname) { $stuname=$ENV{'user.name'}; }      if (!$stuname) { $stuname=$env{'user.name'}; }
     if (!$home) { $home=$ENV{'user.home'}; }      if (!$home) { $home=$env{'user.home'}; }
     my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home");      my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home");
   
     my %returnhash=();      my %returnhash=();
     foreach (split(/\&/,$answer)) {      foreach my $line (split(/\&/,$answer)) {
  my ($name,$value)=split(/\=/,$_);   my ($name,$value)=split(/\=/,$line);
         $returnhash{&unescape($name)}=&unescape($value);          $returnhash{&unescape($name)}=&thaw_unescape($value);
     }      }
     my $version;      my $version;
     for ($version=1;$version<=$returnhash{'version'};$version++) {      for ($version=1;$version<=$returnhash{'version'};$version++) {
        foreach (split(/\:/,$returnhash{$version.':keys'})) {         foreach my $item (split(/\:/,$returnhash{$version.':keys'})) {
           $returnhash{$_}=$returnhash{$version.':'.$_};            $returnhash{$item}=$returnhash{$version.':'.$item};
        }         }
     }      }
     return %returnhash;      return %returnhash;
 }  }
   
 # ---------------------------------------------------------- Course Description  # ---------------------------------------------------------- Course Description
   #
   #  
   
 sub coursedescription {  sub coursedescription {
     my $courseid=shift;      my ($courseid,$args)=@_;
     $courseid=~s/^\///;      $courseid=~s/^\///;
     $courseid=~s/\_/\//g;      $courseid=~s/\_/\//g;
     my ($cdomain,$cnum)=split(/\//,$courseid);      my ($cdomain,$cnum)=split(/\//,$courseid);
Line 2328  sub coursedescription { Line 4580  sub coursedescription {
     # trying and trying and trying to get the course description.      # trying and trying and trying to get the course description.
     my %envhash=();      my %envhash=();
     my %returnhash=();      my %returnhash=();
     $envhash{'course.'.$normalid.'.last_cache'}=time;      
       my $expiretime=600;
       if ($env{'request.course.id'} eq $normalid) {
    $expiretime=120;
       }
   
       my $prefix='course.'.$cdomain.'_'.$cnum.'.';
       if (!$args->{'freshen_cache'}
    && ((time-$env{$prefix.'last_cache'}) < $expiretime) ) {
    foreach my $key (keys(%env)) {
       next if ($key !~ /^\Q$prefix\E(.*)/);
       my ($setting) = $1;
       $returnhash{$setting} = $env{$key};
    }
    return %returnhash;
       }
   
       # get the data again
   
       if (!$args->{'one_time'}) {
    $envhash{'course.'.$normalid.'.last_cache'}=time;
       }
   
     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;
              if (!defined($returnhash{'type'})) {
                  $returnhash{'type'} = 'Course';
              }
            while (my ($name,$value) = each %returnhash) {             while (my ($name,$value) = each %returnhash) {
                $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;
        }         }
     }      }
     &appenv(%envhash);      if (!$args->{'one_time'}) {
    &appenv(\%envhash);
       }
     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 {
     my ($username,$domain)=@_;      my ($username,$domain)=@_;
     my $rolesdump=&reply("dump:$domain:$username:roles",  
  &homeserver($username,$domain));      my %rolesdump = &dump("roles", $domain, $username) or return 0;
     if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return 0; }      my $now = time;
     my $now=time;  
     if ($rolesdump ne '') {      for my $role (@rolesdump{grep { ! /^rolesdef_/ } keys %rolesdump}) {
         foreach (split(/&/,$rolesdump)) {              my ($trole, $tend, $tstart) = split(/_/, $role);
     if ($_!~/^rolesdef\&/) {              if (($trole eq 'dc') || ($trole eq 'su')) {
  my ($area,$role)=split(/=/,$_);                  return 1 unless ($tend && $tend < $now) 
  $area=~s/\_\w\w$//;                      or ($tstart && $tstart > $now);
  my ($trole,$tend,$tstart)=split(/_/,$role);              }
  if (($trole eq 'dc') || ($trole eq 'su')) {  
     my $active=1;  
     if ($tend) {  
  if ($tend<$now) { $active=0; }  
     }  
     if ($tstart) {  
  if ($tstart>$now) { $active=0; }  
     }  
     if ($active) { return 1; }  
  }  
     }  
  }   }
     }  
     return 0;      return 0;
 }  }
   
 # -------------------------------------------------------- Get user privileges  # -------------------------------------------------------- Get user privileges
   
 sub rolesinit {  sub rolesinit {
     my ($domain,$username,$authhost)=@_;      my ($domain, $username) = @_;
     my $rolesdump=reply("dump:$domain:$username:roles",$authhost);      my %userroles = ('user.login.time' => time);
     if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; }      my %rolesdump = &dump("roles", $domain, $username) or return \%userroles;
   
       # firstaccess and timerinterval are related to timed maps/resources. 
       # also, blocking can be triggered by an activating timer
       # it's saved in the user's %env.
       my %firstaccess = &dump('firstaccesstimes', $domain, $username);
       my %timerinterval = &dump('timerinterval', $domain, $username);
       my (%coursetimerstarts, %firstaccchk, %firstaccenv, %coursetimerintervals,
           %timerintchk, %timerintenv);
   
       foreach my $key (keys(%firstaccess)) {
           my ($cid, $rest) = split(/\0/, $key);
           $coursetimerstarts{$cid}{$rest} = $firstaccess{$key};
       }
   
       foreach my $key (keys(%timerinterval)) {
           my ($cid,$rest) = split(/\0/,$key);
           $coursetimerintervals{$cid}{$rest} = $timerinterval{$key};
       }
   
     my %allroles=();      my %allroles=();
     my $now=time;      my %allgroups=();
     my $userroles="user.login.time=$now\n";  
   
     if ($rolesdump ne '') {      for my $area (grep { ! /^rolesdef_/ } keys %rolesdump) {
         foreach (split(/&/,$rolesdump)) {          my $role = $rolesdump{$area};
   if ($_!~/^rolesdef\&/) {          $area =~ s/\_\w\w$//;
             my ($area,$role)=split(/=/,$_);  
             $area=~s/\_\w\w$//;          my ($trole, $tend, $tstart, $group_privs);
             my ($trole,$tend,$tstart)=split(/_/,$role);  
             $userroles.=&set_arearole($trole,$area,$tstart,$tend);          if ($role =~ /^cr/) {
             if (($tend!=0) && ($tend<$now)) { $trole=''; }          # Custom role, defined by a user 
             if (($tstart!=0) && ($tstart>$now)) { $trole=''; }          # e.g., user.role.cr/msu/smith/mynewrole
             if (($area ne '') && ($trole ne '')) {              if ($role =~ m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|) {
  my $spec=$trole.'.'.$area;                  $trole = $1;
  my ($tdummy,$tdomain,$trest)=split(/\//,$area);                  ($tend, $tstart) = split('_', $2);
  if ($trole =~ /^cr\//) {              } else {
                     &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);                  $trole = $role;
  } else {              }
                     &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);          } elsif ($role =~ m|^gr/|) {
  }          # Role of member in a group, defined within a course/community
           # e.g., user.role.gr/msu/04935610a19ee4a5fmsul1/leopards
               ($trole, $tend, $tstart) = split(/_/, $role);
               next if $tstart eq '-1';
               ($trole, $group_privs) = split(/\//, $trole);
               $group_privs = &unescape($group_privs);
           } else {
           # Just a normal role, defined in roles.tab
               ($trole, $tend, $tstart) = split(/_/,$role);
           }
   
           my %new_role = &set_arearole($trole,$area,$tstart,$tend,$domain,
                    $username);
           @userroles{keys(%new_role)} = @new_role{keys(%new_role)};
   
           # role expired or not available yet?
           $trole = '' if ($tend != 0 && $tend < $userroles{'user.login.time'}) or 
               ($tstart != 0 && $tstart > $userroles{'user.login.time'});
   
           next if $area eq '' or $trole eq '';
   
           my $spec = "$trole.$area";
           my ($tdummy, $tdomain, $trest) = split(/\//, $area);
   
           if ($trole =~ /^cr\//) {
           # Custom role, defined by a user
               &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);
           } elsif ($trole eq 'gr') {
           # Role of a member in a group, defined within a course/community
               &group_roleprivs(\%allgroups,$area,$group_privs,$tend,$tstart);
               next;
           } else {
           # Normal role, defined in roles.tab
               &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
           }
   
           my $cid = $tdomain.'_'.$trest;
           unless ($firstaccchk{$cid}) {
               if (ref($coursetimerstarts{$cid}) eq 'HASH') {
                   foreach my $item (keys(%{$coursetimerstarts{$cid}})) {
                       $firstaccenv{'course.'.$cid.'.firstaccess.'.$item} = 
                           $coursetimerstarts{$cid}{$item}; 
                   }
             }              }
           }               $firstaccchk{$cid} = 1;
           }
           unless ($timerintchk{$cid}) {
               if (ref($coursetimerintervals{$cid}) eq 'HASH') {
                   foreach my $item (keys(%{$coursetimerintervals{$cid}})) {
                       $timerintenv{'course.'.$cid.'.timerinterval.'.$item} =
                          $coursetimerintervals{$cid}{$item};
                   }
               }
               $timerintchk{$cid} = 1;
         }          }
         my ($author,$adv) = &set_userprivs(\$userroles,\%allroles);  
         $userroles.='user.adv='.$adv."\n".  
             'user.author='.$author."\n";  
         $ENV{'user.adv'}=$adv;  
     }      }
     return $userroles;    
       @userroles{'user.author', 'user.adv'} = &set_userprivs(\%userroles,
           \%allroles, \%allgroups);
       $env{'user.adv'} = $userroles{'user.adv'};
   
       return (\%userroles,\%firstaccenv,\%timerintenv);
 }  }
   
 sub set_arearole {  sub set_arearole {
     my ($trole,$area,$tstart,$tend,$domain,$username) = @_;      my ($trole,$area,$tstart,$tend,$domain,$username) = @_;
 # log the associated role with the area  # log the associated role with the area
     &userrolelog($trole,$username,$domain,$area,$tstart,$tend);      &userrolelog($trole,$username,$domain,$area,$tstart,$tend);
     return 'user.role.'.$trole.'.'.$area.'='.$tstart.'.'.$tend."\n";      return ('user.role.'.$trole.'.'.$area => $tstart.'.'.$tend);
 }  }
   
 sub custom_roleprivs {  sub custom_roleprivs {
     my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_;      my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_;
     my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);      my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
     my $homsvr=homeserver($rauthor,$rdomain);      my $homsvr=homeserver($rauthor,$rdomain);
     if ($hostname{$homsvr} ne '') {      if (&hostname($homsvr) ne '') {
         my ($rdummy,$roledef)=          my ($rdummy,$roledef)=
             &get('roles',["rolesdef_$rrole"],$rdomain,$rauthor);              &get('roles',["rolesdef_$rrole"],$rdomain,$rauthor);
         if (($rdummy ne 'con_lost') && ($roledef ne '')) {          if (($rdummy ne 'con_lost') && ($roledef ne '')) {
             my ($syspriv,$dompriv,$coursepriv)=split(/\_/,$roledef);              my ($syspriv,$dompriv,$coursepriv)=split(/\_/,$roledef);
             if (defined($syspriv)) {              if (defined($syspriv)) {
                   if ($trest =~ /^$match_community$/) {
                       $syspriv =~ s/bre\&S//; 
                   }
                 $$allroles{'cm./'}.=':'.$syspriv;                  $$allroles{'cm./'}.=':'.$syspriv;
                 $$allroles{$spec.'./'}.=':'.$syspriv;                  $$allroles{$spec.'./'}.=':'.$syspriv;
             }              }
Line 2452  sub custom_roleprivs { Line 4835  sub custom_roleprivs {
     }      }
 }  }
   
   sub group_roleprivs {
       my ($allgroups,$area,$group_privs,$tend,$tstart) = @_;
       my $access = 1;
       my $now = time;
       if (($tend!=0) && ($tend<$now)) { $access = 0; }
       if (($tstart!=0) && ($tstart>$now)) { $access=0; }
       if ($access) {
           my ($course,$group) = ($area =~ m|(/$match_domain/$match_courseid)/([^/]+)$|);
           $$allgroups{$course}{$group} .=':'.$group_privs;
       }
   }
   
 sub standard_roleprivs {  sub standard_roleprivs {
     my ($allroles,$trole,$tdomain,$spec,$trest,$area) = @_;      my ($allroles,$trole,$tdomain,$spec,$trest,$area) = @_;
Line 2472  sub standard_roleprivs { Line 4866  sub standard_roleprivs {
 }  }
   
 sub set_userprivs {  sub set_userprivs {
     my ($userroles,$allroles) = @_;       my ($userroles,$allroles,$allgroups,$groups_roles) = @_; 
     my $author=0;      my $author=0;
     my $adv=0;      my $adv=0;
     foreach (keys %{$allroles}) {      my %grouproles = ();
         my %thesepriv=();      if (keys(%{$allgroups}) > 0) {
         if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; }          my @groupkeys; 
         foreach (split(/:/,$$allroles{$_})) {          foreach my $role (keys(%{$allroles})) {
             if ($_ ne '') {              push(@groupkeys,$role);
                 my ($privilege,$restrictions)=split(/&/,$_);          }
           if (ref($groups_roles) eq 'HASH') {
               foreach my $key (keys(%{$groups_roles})) {
                   unless (grep(/^\Q$key\E$/,@groupkeys)) {
                       push(@groupkeys,$key);
                   }
               }
           }
           if (@groupkeys > 0) {
               foreach my $role (@groupkeys) {
                   my ($trole,$area,$sec,$extendedarea);
                   if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)\.-) {
                       $trole = $1;
                       $area = $2;
                       $sec = $3;
                       $extendedarea = $area.$sec;
                       if (exists($$allgroups{$area})) {
                           foreach my $group (keys(%{$$allgroups{$area}})) {
                               my $spec = $trole.'.'.$extendedarea;
                               $grouproles{$spec.'.'.$area.'/'.$group} = 
                                                   $$allgroups{$area}{$group};
                           }
                       }
                   }
               }
           }
       }
       foreach my $group (keys(%grouproles)) {
           $$allroles{$group} = $grouproles{$group};
       }
       foreach my $role (keys(%{$allroles})) {
           my %thesepriv;
           if (($role=~/^au/) || ($role=~/^ca/) || ($role=~/^aa/)) { $author=1; }
           foreach my $item (split(/:/,$$allroles{$role})) {
               if ($item ne '') {
                   my ($privilege,$restrictions)=split(/&/,$item);
                 if ($restrictions eq '') {                  if ($restrictions eq '') {
                     $thesepriv{$privilege}='F';                      $thesepriv{$privilege}='F';
                 } elsif ($thesepriv{$privilege} ne 'F') {                  } elsif ($thesepriv{$privilege} ne 'F') {
Line 2490  sub set_userprivs { Line 4919  sub set_userprivs {
             }              }
         }          }
         my $thesestr='';          my $thesestr='';
         foreach (keys %thesepriv) { $thesestr.=':'.$_.'&'.$thesepriv{$_}; }          foreach my $priv (sort(keys(%thesepriv))) {
         $$userroles.='user.priv.'.$_.'='.$thesestr."\n";      $thesestr.=':'.$priv.'&'.$thesepriv{$priv};
    }
           $userroles->{'user.priv.'.$role} = $thesestr;
     }      }
     return ($author,$adv);      return ($author,$adv);
 }  }
   
   sub role_status {
       my ($rolekey,$update,$refresh,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_;
       my @pwhere = ();
       if (exists($env{$rolekey}) && $env{$rolekey} ne '') {
           (undef,undef,$$role,@pwhere)=split(/\./,$rolekey);
           unless (!defined($$role) || $$role eq '') {
               $$where=join('.',@pwhere);
               $$trolecode=$$role.'.'.$$where;
               ($$tstart,$$tend)=split(/\./,$env{$rolekey});
               $$tstatus='is';
               if ($$tstart && $$tstart>$update) {
                   $$tstatus='future';
                   if ($$tstart<$now) {
                       if ($$tstart && $$tstart>$refresh) {
                           if (($$where ne '') && ($$role ne '')) {
                               my (%allroles,%allgroups,$group_privs,
                                   %groups_roles,@rolecodes);
                               my %userroles = (
                                   'user.role.'.$$role.'.'.$$where => $$tstart.'.'.$$tend
                               );
                               @rolecodes = ('cm'); 
                               my $spec=$$role.'.'.$$where;
                               my ($tdummy,$tdomain,$trest)=split(/\//,$$where);
                               if ($$role =~ /^cr\//) {
                                   &custom_roleprivs(\%allroles,$$role,$tdomain,$trest,$spec,$$where);
                                   push(@rolecodes,'cr');
                               } elsif ($$role eq 'gr') {
                                   push(@rolecodes,$$role);
                                   my %rolehash = &get('roles',[$$where.'_'.$$role],$env{'user.domain'},
                                                       $env{'user.name'});
                                   my ($trole) = split('_',$rolehash{$$where.'_'.$$role},2);
                                   (undef,my $group_privs) = split(/\//,$trole);
                                   $group_privs = &unescape($group_privs);
                                   &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);
                                   &get_groups_roles($tdomain,$trest,
                                                     \%course_roles,\@rolecodes,
                                                     \%groups_roles);
                               } else {
                                   push(@rolecodes,$$role);
                                   &standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where);
                               }
                               my ($author,$adv)= &set_userprivs(\%userroles,\%allroles,\%allgroups,\%groups_roles);
                               &appenv(\%userroles,\@rolecodes);
                               &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role);
                           }
                       }
                       $$tstatus = 'is';
                   }
               }
               if ($$tend) {
                   if ($$tend<$update) {
                       $$tstatus='expired';
                   } elsif ($$tend<$now) {
                       $$tstatus='will_not';
                   }
               }
           }
       }
   }
   
   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 {
       my ($cdom,$cnum,$update,$refresh,$now,$checkrole,$caller) = @_;
       my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum;
       my $setprivs;
       if ($env{$cckey}) {
           my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend);
           &role_status($cckey,$update,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend);
           unless (($tstatus eq 'is') || ($tstatus eq 'will_not')) {
               &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller);
               $setprivs = 1;
           }
       } else {
           &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller);
           $setprivs = 1;
       }
       return $setprivs;
   }
   
   sub set_adhoc_privileges {
   # role can be cc or ca
       my ($dcdom,$pickedcourse,$role,$caller) = @_;
       my $area = '/'.$dcdom.'/'.$pickedcourse;
       my $spec = $role.'.'.$area;
       my %userroles = &set_arearole($role,$area,'','',$env{'user.domain'},
                                     $env{'user.name'});
       my %ccrole = ();
       &standard_roleprivs(\%ccrole,$role,$dcdom,$spec,$pickedcourse,$area);
       my ($author,$adv)= &set_userprivs(\%userroles,\%ccrole);
       &appenv(\%userroles,[$role,'cm']);
       &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role);
       unless ($caller eq 'constructaccess' && $env{'request.course.id'}) {
           &appenv( {'request.role'        => $spec,
                     'request.role.domain' => $dcdom,
                     'request.course.sec'  => ''
                    }
                  );
           my $tadv=0;
           if (&allowed('adv') eq 'F') { $tadv=1; }
           &appenv({'request.role.adv'    => $tadv});
       }
   }
   
 # --------------------------------------------------------------- get interface  # --------------------------------------------------------------- get interface
   
 sub get {  sub get {
    my ($namespace,$storearr,$udomain,$uname)=@_;     my ($namespace,$storearr,$udomain,$uname)=@_;
    my $items='';     my $items='';
    foreach (@$storearr) {     foreach my $item (@$storearr) {
        $items.=escape($_).'&';         $items.=&escape($item).'&';
    }     }
    $items=~s/\&$//;     $items=~s/\&$//;
    if (!$udomain) { $udomain=$ENV{'user.domain'}; }     if (!$udomain) { $udomain=$env{'user.domain'}; }
    if (!$uname) { $uname=$ENV{'user.name'}; }     if (!$uname) { $uname=$env{'user.name'}; }
    my $uhome=&homeserver($uname,$udomain);     my $uhome=&homeserver($uname,$udomain);
   
    my $rep=&reply("get:$udomain:$uname:$namespace:$items",$uhome);     my $rep=&reply("get:$udomain:$uname:$namespace:$items",$uhome);
Line 2516  sub get { Line 5108  sub get {
    }     }
    my %returnhash=();     my %returnhash=();
    my $i=0;     my $i=0;
    foreach (@$storearr) {     foreach my $item (@$storearr) {
       $returnhash{$_}=&thaw_unescape($pairs[$i]);        $returnhash{$item}=&thaw_unescape($pairs[$i]);
       $i++;        $i++;
    }     }
    return %returnhash;     return %returnhash;
Line 2528  sub get { Line 5120  sub get {
 sub del {  sub del {
    my ($namespace,$storearr,$udomain,$uname)=@_;     my ($namespace,$storearr,$udomain,$uname)=@_;
    my $items='';     my $items='';
    foreach (@$storearr) {     foreach my $item (@$storearr) {
        $items.=escape($_).'&';         $items.=&escape($item).'&';
    }     }
   
    $items=~s/\&$//;     $items=~s/\&$//;
    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);
   
    return &reply("del:$udomain:$uname:$namespace:$items",$uhome);     return &reply("del:$udomain:$uname:$namespace:$items",$uhome);
 }  }
   
 # -------------------------------------------------------------- dump interface  # -------------------------------------------------------------- dump interface
   
   sub unserialize {
       my ($rep, $escapedkeys) = @_;
   
       return {} if $rep =~ /^error/;
   
       my %returnhash=();
    foreach my $item (split /\&/, $rep) {
       my ($key, $value) = split(/=/, $item, 2);
       $key = unescape($key) unless $escapedkeys;
       next if $key =~ /^error: 2 /;
       $returnhash{$key} = Apache::lonnet::thaw_unescape($value);
    }
       #return %returnhash;
       return \%returnhash;
   }        
   
   # see Lond::dump_with_regexp
   # if $escapedkeys hash keys won't get unescaped.
 sub dump {  sub dump {
    my ($namespace,$udomain,$uname,$regexp)=@_;      my ($namespace,$udomain,$uname,$regexp,$range,$escapedkeys)=@_;
    if (!$udomain) { $udomain=$ENV{'user.domain'}; }      if (!$udomain) { $udomain=$env{'user.domain'}; }
    if (!$uname) { $uname=$ENV{'user.name'}; }      if (!$uname) { $uname=$env{'user.name'}; }
    my $uhome=&homeserver($uname,$udomain);      my $uhome=&homeserver($uname,$udomain);
    if ($regexp) {  
        $regexp=&escape($regexp);      my $reply;
    } else {      if (grep { $_ eq $uhome } current_machine_ids()) {
        $regexp='.';          # user is hosted on this machine
    }          $reply = LONCAPA::Lond::dump_with_regexp(join(":", ($udomain,
    my $rep=reply("dump:$udomain:$uname:$namespace:$regexp",$uhome);                      $uname, $namespace, $regexp, $range)), $loncaparevs{$uhome});
    my @pairs=split(/\&/,$rep);          return %{unserialize($reply, $escapedkeys)};
    my %returnhash=();      }
    foreach (@pairs) {      if ($regexp) {
       my ($key,$value)=split(/=/,$_);   $regexp=&escape($regexp);
       $returnhash{unescape($key)}=&thaw_unescape($value);      } else {
    }   $regexp='.';
    return %returnhash;      }
       my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
       my @pairs=split(/\&/,$rep);
       my %returnhash=();
       if (!($rep =~ /^error/ )) {
    foreach my $item (@pairs) {
       my ($key,$value)=split(/=/,$item,2);
           $key = unescape($key) unless $escapedkeys;
           #$key = &unescape($key);
       next if ($key =~ /^error: 2 /);
       $returnhash{$key}=&thaw_unescape($value);
    }
       }
       return %returnhash;
   }
   
   
   # --------------------------------------------------------- dumpstore interface
   
   sub dumpstore {
      my ($namespace,$udomain,$uname,$regexp,$range)=@_;
      # same as dump but keys must be escaped. They may contain colon separated
      # lists of values that may themself contain colons (e.g. symbs).
      return &dump($namespace, $udomain, $uname, $regexp, $range, 1);
 }  }
   
 # -------------------------------------------------------------- keys interface  # -------------------------------------------------------------- keys interface
   
 sub getkeys {  sub getkeys {
    my ($namespace,$udomain,$uname)=@_;     my ($namespace,$udomain,$uname)=@_;
    if (!$udomain) { $udomain=$ENV{'user.domain'}; }     if (!$udomain) { $udomain=$env{'user.domain'}; }
    if (!$uname) { $uname=$ENV{'user.name'}; }     if (!$uname) { $uname=$env{'user.name'}; }
    my $uhome=&homeserver($uname,$udomain);     my $uhome=&homeserver($uname,$udomain);
    my $rep=reply("keys:$udomain:$uname:$namespace",$uhome);     my $rep=reply("keys:$udomain:$uname:$namespace",$uhome);
    my @keyarray=();     my @keyarray=();
    foreach (split(/\&/,$rep)) {     foreach my $key (split(/\&/,$rep)) {
       push (@keyarray,&unescape($_));        next if ($key =~ /^error: 2 /);
         push(@keyarray,&unescape($key));
    }     }
    return @keyarray;     return @keyarray;
 }  }
Line 2579  sub getkeys { Line 5213  sub getkeys {
 # --------------------------------------------------------------- currentdump  # --------------------------------------------------------------- currentdump
 sub currentdump {  sub currentdump {
    my ($courseid,$sdom,$sname)=@_;     my ($courseid,$sdom,$sname)=@_;
    $courseid = $ENV{'request.course.id'} if (! defined($courseid));     $courseid = $env{'request.course.id'} if (! defined($courseid));
    $sdom     = $ENV{'user.domain'}       if (! defined($sdom));     $sdom     = $env{'user.domain'}       if (! defined($sdom));
    $sname    = $ENV{'user.name'}         if (! defined($sname));     $sname    = $env{'user.name'}         if (! defined($sname));
    my $uhome = &homeserver($sname,$sdom);     my $uhome = &homeserver($sname,$sdom);
    my $rep=reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome);     my $rep;
   
      if (grep { $_ eq $uhome } current_machine_ids()) {
          $rep = LONCAPA::Lond::dump_profile_database(join(":", ($sdom, $sname, 
                      $courseid)));
      } else {
          $rep = reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome);
      }
   
    return if ($rep =~ /^(error:|no_such_host)/);     return if ($rep =~ /^(error:|no_such_host)/);
    #     #
    my %returnhash=();     my %returnhash=();
Line 2591  sub currentdump { Line 5233  sub currentdump {
    if ($rep eq "unknown_cmd") {      if ($rep eq "unknown_cmd") { 
        # an old lond will not know currentdump         # an old lond will not know currentdump
        # Do a dump and make it look like a currentdump         # Do a dump and make it look like a currentdump
        my @tmp = &dump($courseid,$sdom,$sname,'.');         my @tmp = &dumpstore($courseid,$sdom,$sname,'.');
        return if ($tmp[0] =~ /^(error:|no_such_host)/);         return if ($tmp[0] =~ /^(error:|no_such_host)/);
        my %hash = @tmp;         my %hash = @tmp;
        @tmp=();         @tmp=();
        %returnhash = %{&convert_dump_to_currentdump(\%hash)};         %returnhash = %{&convert_dump_to_currentdump(\%hash)};
    } else {     } else {
        my @pairs=split(/\&/,$rep);         my @pairs=split(/\&/,$rep);
        foreach (@pairs) {         foreach my $pair (@pairs) {
            my ($key,$value)=split(/=/,$_);             my ($key,$value)=split(/=/,$pair,2);
            my ($symb,$param) = split(/:/,$key);             my ($symb,$param) = split(/:/,$key);
            $returnhash{&unescape($symb)}->{&unescape($param)} =              $returnhash{&unescape($symb)}->{&unescape($param)} = 
                                                         &thaw_unescape($value);                                                          &thaw_unescape($value);
Line 2616  sub convert_dump_to_currentdump{ Line 5258  sub convert_dump_to_currentdump{
     # we might run in to problems with parameter names =~ /^v\./      # we might run in to problems with parameter names =~ /^v\./
     while (my ($key,$value) = each(%hash)) {      while (my ($key,$value) = each(%hash)) {
         my ($v,$symb,$param) = split(/:/,$key);          my ($v,$symb,$param) = split(/:/,$key);
    $symb  = &unescape($symb);
    $param = &unescape($param);
         next if ($v eq 'version' || $symb eq 'keys');          next if ($v eq 'version' || $symb eq 'keys');
         next if (exists($returnhash{$symb}) &&          next if (exists($returnhash{$symb}) &&
                  exists($returnhash{$symb}->{$param}) &&                   exists($returnhash{$symb}->{$param}) &&
Line 2635  sub convert_dump_to_currentdump{ Line 5279  sub convert_dump_to_currentdump{
     return \%returnhash;      return \%returnhash;
 }  }
   
   # ------------------------------------------------------ critical inc interface
   
   sub cinc {
       return &inc(@_,'critical');
   }
   
 # --------------------------------------------------------------- inc interface  # --------------------------------------------------------------- inc interface
   
 sub inc {  sub inc {
     my ($namespace,$store,$udomain,$uname) = @_;      my ($namespace,$store,$udomain,$uname,$critical) = @_;
     if (!$udomain) { $udomain=$ENV{'user.domain'}; }      if (!$udomain) { $udomain=$env{'user.domain'}; }
     if (!$uname) { $uname=$ENV{'user.name'}; }      if (!$uname) { $uname=$env{'user.name'}; }
     my $uhome=&homeserver($uname,$udomain);      my $uhome=&homeserver($uname,$udomain);
     my $items='';      my $items='';
     if (! ref($store)) {      if (! ref($store)) {
Line 2656  sub inc { Line 5306  sub inc {
         }          }
     }      }
     $items=~s/\&$//;      $items=~s/\&$//;
     return &reply("inc:$udomain:$uname:$namespace:$items",$uhome);      if ($critical) {
    return &critical("inc:$udomain:$uname:$namespace:$items",$uhome);
       } else {
    return &reply("inc:$udomain:$uname:$namespace:$items",$uhome);
       }
 }  }
   
 # --------------------------------------------------------------- put interface  # --------------------------------------------------------------- put interface
   
 sub put {  sub put {
    my ($namespace,$storehash,$udomain,$uname)=@_;     my ($namespace,$storehash,$udomain,$uname)=@_;
    if (!$udomain) { $udomain=$ENV{'user.domain'}; }     if (!$udomain) { $udomain=$env{'user.domain'}; }
    if (!$uname) { $uname=$ENV{'user.name'}; }     if (!$uname) { $uname=$env{'user.name'}; }
    my $uhome=&homeserver($uname,$udomain);     my $uhome=&homeserver($uname,$udomain);
    my $items='';     my $items='';
    foreach (keys %$storehash) {     foreach my $item (keys(%$storehash)) {
        $items.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&';         $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
    }     }
    $items=~s/\&$//;     $items=~s/\&$//;
    return &reply("put:$udomain:$uname:$namespace:$items",$uhome);     return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
 }  }
   
 # ---------------------------------------------------------- putstore interface  # ------------------------------------------------------------ newput interface
                                                                                        
 sub putstore {  sub newput {
    my ($namespace,$storehash,$udomain,$uname)=@_;     my ($namespace,$storehash,$udomain,$uname)=@_;
    if (!$udomain) { $udomain=$ENV{'user.domain'}; }     if (!$udomain) { $udomain=$env{'user.domain'}; }
    if (!$uname) { $uname=$ENV{'user.name'}; }     if (!$uname) { $uname=$env{'user.name'}; }
    my $uhome=&homeserver($uname,$udomain);     my $uhome=&homeserver($uname,$udomain);
    my $items='';     my $items='';
    my %allitems = ();     foreach my $key (keys(%$storehash)) {
    foreach (keys %$storehash) {         $items.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
        if ($_ =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) {  
            my $key = $1.':keys:'.$2;  
            $allitems{$key} .= $3.':';  
        }  
        $items.=$_.'='.&escape($$storehash{$_}).'&';  
    }     }
    foreach (keys %allitems) {     $items=~s/\&$//;
        $allitems{$_} =~ s/\:$//;     return &reply("newput:$udomain:$uname:$namespace:$items",$uhome);
        $items.= $_.'='.$allitems{$_}.'&';  }
   
   # ---------------------------------------------------------  putstore interface
   
   sub putstore {
      my ($namespace,$symb,$version,$storehash,$udomain,$uname)=@_;
      if (!$udomain) { $udomain=$env{'user.domain'}; }
      if (!$uname) { $uname=$env{'user.name'}; }
      my $uhome=&homeserver($uname,$udomain);
      my $items='';
      foreach my $key (keys(%$storehash)) {
          $items.= &escape($key).'='.&freeze_escape($storehash->{$key}).'&';
    }     }
    $items=~s/\&$//;     $items=~s/\&$//;
    return &reply("put:$udomain:$uname:$namespace:$items",$uhome);     my $esc_symb=&escape($symb);
      my $esc_v=&escape($version);
      my $reply =
          &reply("putstore:$udomain:$uname:$namespace:$esc_symb:$esc_v:$items",
         $uhome);
      if ($reply eq 'unknown_cmd') {
          # gfall back to way things use to be done
          return &old_putstore($namespace,$symb,$version,$storehash,$udomain,
       $uname);
      }
      return $reply;
   }
   
   sub old_putstore {
       my ($namespace,$symb,$version,$storehash,$udomain,$uname)=@_;
       if (!$udomain) { $udomain=$env{'user.domain'}; }
       if (!$uname) { $uname=$env{'user.name'}; }
       my $uhome=&homeserver($uname,$udomain);
       my %newstorehash;
       foreach my $item (keys(%$storehash)) {
    my $key = $version.':'.&escape($symb).':'.$item;
    $newstorehash{$key} = $storehash->{$item};
       }
       my $items='';
       my %allitems = ();
       foreach my $item (keys(%newstorehash)) {
    if ($item =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) {
       my $key = $1.':keys:'.$2;
       $allitems{$key} .= $3.':';
    }
    $items.=$item.'='.&freeze_escape($newstorehash{$item}).'&';
       }
       foreach my $item (keys(%allitems)) {
    $allitems{$item} =~ s/\:$//;
    $items.= $item.'='.$allitems{$item}.'&';
       }
       $items=~s/\&$//;
       return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
 }  }
   
 # ------------------------------------------------------ critical put interface  # ------------------------------------------------------ critical put interface
   
 sub cput {  sub cput {
    my ($namespace,$storehash,$udomain,$uname)=@_;     my ($namespace,$storehash,$udomain,$uname)=@_;
    if (!$udomain) { $udomain=$ENV{'user.domain'}; }     if (!$udomain) { $udomain=$env{'user.domain'}; }
    if (!$uname) { $uname=$ENV{'user.name'}; }     if (!$uname) { $uname=$env{'user.name'}; }
    my $uhome=&homeserver($uname,$udomain);     my $uhome=&homeserver($uname,$udomain);
    my $items='';     my $items='';
    foreach (keys %$storehash) {     foreach my $item (keys(%$storehash)) {
        $items.=escape($_).'='.&freeze_escape($$storehash{$_}).'&';         $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
    }     }
    $items=~s/\&$//;     $items=~s/\&$//;
    return &critical("put:$udomain:$uname:$namespace:$items",$uhome);     return &critical("put:$udomain:$uname:$namespace:$items",$uhome);
Line 2718  sub cput { Line 5415  sub cput {
 sub eget {  sub eget {
    my ($namespace,$storearr,$udomain,$uname)=@_;     my ($namespace,$storearr,$udomain,$uname)=@_;
    my $items='';     my $items='';
    foreach (@$storearr) {     foreach my $item (@$storearr) {
        $items.=escape($_).'&';         $items.=&escape($item).'&';
    }     }
    $items=~s/\&$//;     $items=~s/\&$//;
    if (!$udomain) { $udomain=$ENV{'user.domain'}; }     if (!$udomain) { $udomain=$env{'user.domain'}; }
    if (!$uname) { $uname=$ENV{'user.name'}; }     if (!$uname) { $uname=$env{'user.name'}; }
    my $uhome=&homeserver($uname,$udomain);     my $uhome=&homeserver($uname,$udomain);
    my $rep=&reply("eget:$udomain:$uname:$namespace:$items",$uhome);     my $rep=&reply("eget:$udomain:$uname:$namespace:$items",$uhome);
    my @pairs=split(/\&/,$rep);     my @pairs=split(/\&/,$rep);
    my %returnhash=();     my %returnhash=();
    my $i=0;     my $i=0;
    foreach (@$storearr) {     foreach my $item (@$storearr) {
       $returnhash{$_}=&thaw_unescape($pairs[$i]);        $returnhash{$item}=&thaw_unescape($pairs[$i]);
       $i++;        $i++;
    }     }
    return %returnhash;     return %returnhash;
 }  }
   
 # ---------------------------------------------- Custom access rule evaluation  # ------------------------------------------------------------ tmpput interface
   sub tmpput {
       my ($storehash,$server,$context)=@_;
       my $items='';
       foreach my $item (keys(%$storehash)) {
    $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
       }
       $items=~s/\&$//;
       if (defined($context)) {
           $items .= ':'.&escape($context);
       }
       return &reply("tmpput:$items",$server);
   }
   
 sub customaccess {  # ------------------------------------------------------------ tmpget interface
     my ($priv,$uri)=@_;  sub tmpget {
     my ($urole,$urealm)=split(/\./,$ENV{'request.role'});      my ($token,$server)=@_;
     $urealm=~s/^\W//;      if (!defined($server)) { $server = $perlvar{'lonHostID'}; }
     my ($udom,$ucrs,$usec)=split(/\//,$urealm);      my $rep=&reply("tmpget:$token",$server);
     my $access=0;      my %returnhash;
     foreach (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) {      foreach my $item (split(/\&/,$rep)) {
  my ($effect,$realm,$role)=split(/\:/,$_);   my ($key,$value)=split(/=/,$item);
         if ($role) {          next if ($key =~ /^error: 2 /);
    if ($role ne $urole) { next; }   $returnhash{&unescape($key)}=&thaw_unescape($value);
         }      }
         foreach (split(/\s*\,\s*/,$realm)) {      return %returnhash;
             my ($tdom,$tcrs,$tsec)=split(/\_/,$_);  }
             if ($tdom) {  
  if ($tdom ne $udom) { next; }  # ------------------------------------------------------------ tmpdel interface
   sub tmpdel {
       my ($token,$server)=@_;
       if (!defined($server)) { $server = $perlvar{'lonHostID'}; }
       return &reply("tmpdel:$token",$server);
   }
   
   # -------------------------------------------------- portfolio access checking
   
   sub portfolio_access {
       my ($requrl) = @_;
       my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl);
       my $result = &get_portfolio_access($udom,$unum,$file_name,$group);
       if ($result) {
           my %setters;
           if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
               my ($startblock,$endblock) =
                   &Apache::loncommon::blockcheck(\%setters,'port',$unum,$udom);
               if ($startblock && $endblock) {
                   return 'B';
               }
           } else {
               my ($startblock,$endblock) =
                   &Apache::loncommon::blockcheck(\%setters,'port');
               if ($startblock && $endblock) {
                   return 'B';
               }
           }
       }
       if ($result eq 'ok') {
          return 'F';
       } elsif ($result =~ /^[^:]+:guest_/) {
          return 'A';
       }
       return '';
   }
   
   sub get_portfolio_access {
       my ($udom,$unum,$file_name,$group,$access_hash) = @_;
   
       if (!ref($access_hash)) {
    my $current_perms = &get_portfile_permissions($udom,$unum);
    my %access_controls = &get_access_controls($current_perms,$group,
      $file_name);
    $access_hash = $access_controls{$file_name};
       }
   
       my ($public,$guest,@domains,@users,@courses,@groups);
       my $now = time;
       if (ref($access_hash) eq 'HASH') {
           foreach my $key (keys(%{$access_hash})) {
               my ($num,$scope,$end,$start) = ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/);
               if ($start > $now) {
                   next;
             }              }
             if ($tcrs) {              if ($end && $end<$now) {
  if ($tcrs ne $ucrs) { next; }                  next;
             }              }
             if ($tsec) {              if ($scope eq 'public') {
  if ($tsec ne $usec) { next; }                  $public = $key;
                   last;
               } elsif ($scope eq 'guest') {
                   $guest = $key;
               } elsif ($scope eq 'domains') {
                   push(@domains,$key);
               } elsif ($scope eq 'users') {
                   push(@users,$key);
               } elsif ($scope eq 'course') {
                   push(@courses,$key);
               } elsif ($scope eq 'group') {
                   push(@groups,$key);
               }
           }
           if ($public) {
               return 'ok';
           }
           if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
               if ($guest) {
                   return $guest;
               }
           } else {
               if (@domains > 0) {
                   foreach my $domkey (@domains) {
                       if (ref($access_hash->{$domkey}{'dom'}) eq 'ARRAY') {
                           if (grep(/^\Q$env{'user.domain'}\E$/,@{$access_hash->{$domkey}{'dom'}})) {
                               return 'ok';
                           }
                       }
                   }
               }
               if (@users > 0) {
                   foreach my $userkey (@users) {
                       if (ref($access_hash->{$userkey}{'users'}) eq 'ARRAY') {
                           foreach my $item (@{$access_hash->{$userkey}{'users'}}) {
                               if (ref($item) eq 'HASH') {
                                   if (($item->{'uname'} eq $env{'user.name'}) &&
                                       ($item->{'udom'} eq $env{'user.domain'})) {
                                       return 'ok';
                                   }
                               }
                           }
                       } 
                   }
               }
               my %roleshash;
               my @courses_and_groups = @courses;
               push(@courses_and_groups,@groups); 
               if (@courses_and_groups > 0) {
                   my (%allgroups,%allroles); 
                   my ($start,$end,$role,$sec,$group);
                   foreach my $envkey (%env) {
                       if ($envkey =~ m-^user\.role\.(gr|cc|co|in|ta|ep|ad|st)\./($match_domain)/($match_courseid)/?([^/]*)$-) {
                           my $cid = $2.'_'.$3; 
                           if ($1 eq 'gr') {
                               $group = $4;
                               $allgroups{$cid}{$group} = $env{$envkey};
                           } else {
                               if ($4 eq '') {
                                   $sec = 'none';
                               } else {
                                   $sec = $4;
                               }
                               $allroles{$cid}{$1}{$sec} = $env{$envkey};
                           }
                       } elsif ($envkey =~ m-^user\.role\./cr/($match_domain/$match_username/\w*)./($match_domain)/($match_courseid)/?([^/]*)$-) {
                           my $cid = $2.'_'.$3;
                           if ($4 eq '') {
                               $sec = 'none';
                           } else {
                               $sec = $4;
                           }
                           $allroles{$cid}{$1}{$sec} = $env{$envkey};
                       }
                   }
                   if (keys(%allroles) == 0) {
                       return;
                   }
                   foreach my $key (@courses_and_groups) {
                       my %content = %{$$access_hash{$key}};
                       my $cnum = $content{'number'};
                       my $cdom = $content{'domain'};
                       my $cid = $cdom.'_'.$cnum;
                       if (!exists($allroles{$cid})) {
                           next;
                       }    
                       foreach my $role_id (keys(%{$content{'roles'}})) {
                           my @sections = @{$content{'roles'}{$role_id}{'section'}};
                           my @groups = @{$content{'roles'}{$role_id}{'group'}};
                           my @status = @{$content{'roles'}{$role_id}{'access'}};
                           my @roles = @{$content{'roles'}{$role_id}{'role'}};
                           foreach my $role (keys(%{$allroles{$cid}})) {
                               if ((grep/^all$/,@roles) || (grep/^\Q$role\E$/,@roles)) {
                                   foreach my $sec (keys(%{$allroles{$cid}{$role}})) {
                                       if (&course_group_datechecker($allroles{$cid}{$role}{$sec},$now,\@status) eq 'ok') {
                                           if (grep/^all$/,@sections) {
                                               return 'ok';
                                           } else {
                                               if (grep/^$sec$/,@sections) {
                                                   return 'ok';
                                               }
                                           }
                                       }
                                   }
                                   if (keys(%{$allgroups{$cid}}) == 0) {
                                       if (grep/^none$/,@groups) {
                                           return 'ok';
                                       }
                                   } else {
                                       if (grep/^all$/,@groups) {
                                           return 'ok';
                                       } 
                                       foreach my $group (keys(%{$allgroups{$cid}})) {
                                           if (grep/^$group$/,@groups) {
                                               return 'ok';
                                           }
                                       }
                                   } 
                               }
                           }
                       }
                   }
               }
               if ($guest) {
                   return $guest;
               }
           }
       }
       return;
   }
   
   sub course_group_datechecker {
       my ($dates,$now,$status) = @_;
       my ($start,$end) = split(/\./,$dates);
       if (!$start && !$end) {
           return 'ok';
       }
       if (grep/^active$/,@{$status}) {
           if (((!$start) || ($start && $start <= $now)) && ((!$end) || ($end && $end >= $now))) {
               return 'ok';
           }
       }
       if (grep/^previous$/,@{$status}) {
           if ($end > $now ) {
               return 'ok';
           }
       }
       if (grep/^future$/,@{$status}) {
           if ($start > $now) {
               return 'ok';
           }
       }
       return; 
   }
   
   sub parse_portfolio_url {
       my ($url) = @_;
   
       my ($type,$udom,$unum,$group,$file_name);
       
       if ($url =~  m-^/*(?:uploaded|editupload)/($match_domain)/($match_username)/portfolio(/.+)$-) {
    $type = 1;
           $udom = $1;
           $unum = $2;
           $file_name = $3;
       } elsif ($url =~ m-^/*(?:uploaded|editupload)/($match_domain)/($match_courseid)/groups/([^/]+)/portfolio/(.+)$-) {
    $type = 2;
           $udom = $1;
           $unum = $2;
           $group = $3;
           $file_name = $3.'/'.$4;
       }
       if (wantarray) {
    return ($type,$udom,$unum,$file_name,$group);
       }
       return $type;
   }
   
   sub is_portfolio_url {
       my ($url) = @_;
       return scalar(&parse_portfolio_url($url));
   }
   
   sub is_portfolio_file {
       my ($file) = @_;
       if (($file =~ /^portfolio/) || ($file =~ /^groups\/\w+\/portfolio/)) {
           return 1;
       }
       return;
   }
   
   sub usertools_access {
       my ($uname,$udom,$tool,$action,$context,$userenvref,$domdefref,$is_advref)=@_;
       my ($access,%tools);
       if ($context eq '') {
           $context = 'tools';
       }
       if ($context eq 'requestcourses') {
           %tools = (
                         official   => 1,
                         unofficial => 1,
                         community  => 1,
                    );
       } elsif ($context eq 'requestauthor') {
           %tools = (
                         requestauthor => 1,
                    );
       } else {
           %tools = (
                         aboutme   => 1,
                         blog      => 1,
                         webdav    => 1,
                         portfolio => 1,
                    );
       }
       return if (!defined($tools{$tool}));
   
       if ((!defined($udom)) || (!defined($uname))) {
           $udom = $env{'user.domain'};
           $uname = $env{'user.name'};
       }
   
       if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
           if ($action ne 'reload') {
               if ($context eq 'requestcourses') {
                   return $env{'environment.canrequest.'.$tool};
               } elsif ($context eq 'requestauthor') {
                   return $env{'environment.canrequest.author'};
               } else {
                   return $env{'environment.availabletools.'.$tool};
               }
           }
       }
   
       my ($toolstatus,$inststatus,$envkey);
       if ($context eq 'requestauthor') {
           $envkey = $context; 
       } else {
           $envkey = $context.'.'.$tool;
       }
   
       if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) &&
            ($action ne 'reload')) {
           $toolstatus = $env{'environment.'.$envkey};
           $inststatus = $env{'environment.inststatus'};
       } else {
           if (ref($userenvref) eq 'HASH') {
               $toolstatus = $userenvref->{$envkey};
               $inststatus = $userenvref->{'inststatus'};
           } else {
               my %userenv = &userenvironment($udom,$uname,$envkey,'inststatus');
               $toolstatus = $userenv{$envkey};
               $inststatus = $userenv{'inststatus'};
           }
       }
   
       if ($toolstatus ne '') {
           if ($toolstatus) {
               $access = 1;
           } else {
               $access = 0;
           }
           return $access;
       }
   
       my ($is_adv,%domdef);
       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 ($is_adv) {
               if ($domdef{$tool}{'_LC_adv'} ne '') {
                   if ($domdef{$tool}{'_LC_adv'}) { 
                       $access = 1;
                   } else {
                       $access = 0;
                   }
                   return $access;
               }
           }
           if ($inststatus ne '') {
               my ($hasaccess,$hasnoaccess);
               foreach my $affiliation (split(/:/,$inststatus)) {
                   if ($domdef{$tool}{$affiliation} ne '') { 
                       if ($domdef{$tool}{$affiliation}) {
                           $hasaccess = 1;
                       } else {
                           $hasnoaccess = 1;
                       }
                   }
               }
               if ($hasaccess || $hasnoaccess) {
                   if ($hasaccess) {
                       $access = 1;
                   } elsif ($hasnoaccess) {
                       $access = 0; 
                   }
                   return $access;
               }
           } else {
               if ($domdef{$tool}{'default'} ne '') {
                   if ($domdef{$tool}{'default'}) {
                       $access = 1;
                   } elsif ($domdef{$tool}{'default'} == 0) {
                       $access = 0;
                   }
                   return $access;
               }
           }
       } else {
           if (($context eq 'tools') && ($tool ne 'webdav')) {
               $access = 1;
           } else {
               $access = 0;
           }
           return $access;
       }
   }
   
   sub is_course_owner {
       my ($cdom,$cnum,$udom,$uname) = @_;
       if (($udom eq '') || ($uname eq '')) {
           $udom = $env{'user.domain'};
           $uname = $env{'user.name'};
       }
       unless (($udom eq '') || ($uname eq '')) {
           if (exists($env{'course.'.$cdom.'_'.$cnum.'.internal.courseowner'})) {
               if ($env{'course.'.$cdom.'_'.$cnum.'.internal.courseowner'} eq $uname.':'.$udom) {
                   return 1;
               } else {
                   my %courseinfo = &Apache::lonnet::coursedescription($cdom.'/'.$cnum);
                   if ($courseinfo{'internal.courseowner'} eq $uname.':'.$udom) {
                       return 1;
                   }
               }
           }
       }
       return;
   }
   
   sub is_advanced_user {
       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 %allroles;
       my ($is_adv,$is_author);
       foreach my $role (keys(%roleshash)) {
           my ($trest,$tdomain,$trole,$sec) = split(/:/,$role);
           my $area = '/'.$tdomain.'/'.$trest;
           if ($sec ne '') {
               $area .= '/'.$sec;
           }
           if (($area ne '') && ($trole ne '')) {
               my $spec=$trole.'.'.$area;
               if ($trole =~ /^cr\//) {
                   &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);
               } elsif ($trole ne 'gr') {
                   &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
               }
               if ($trole eq 'au') {
                   $is_author = 1;
             }              }
             $access=($effect eq 'allow');  
             last;  
         }          }
  if ($realm eq '' && $role eq '') {      }
             $access=($effect eq 'allow');      foreach my $role (keys(%allroles)) {
           last if ($is_adv);
           foreach my $item (split(/:/,$allroles{$role})) {
               if ($item ne '') {
                   my ($privilege,$restrictions)=split(/&/,$item);
                   if ($privilege eq 'adv') {
                       $is_adv = 1;
                       last;
                   }
               }
           }
       }
       if (wantarray) {
           return ($is_adv,$is_author);
       }
       return $is_adv;
   }
   
   sub check_can_request {
       my ($dom,$can_request,$request_domains) = @_;
       my $canreq = 0;
       my ($types,$typename) = &Apache::loncommon::course_types();
       my @options = ('approval','validate','autolimit');
       my $optregex = join('|',@options);
       if ((ref($can_request) eq 'HASH') && (ref($types) eq 'ARRAY')) {
           foreach my $type (@{$types}) {
               if (&usertools_access($env{'user.name'},
                                     $env{'user.domain'},
                                     $type,undef,'requestcourses')) {
                   $canreq ++;
                   if (ref($request_domains) eq 'HASH') {
                       push(@{$request_domains->{$type}},$env{'user.domain'});
                   }
                   if ($dom eq $env{'user.domain'}) {
                       $can_request->{$type} = 1;
                   }
               }
               if ($env{'environment.reqcrsotherdom.'.$type} ne '') {
                   my @curr = split(',',$env{'environment.reqcrsotherdom.'.$type});
                   if (@curr > 0) {
                       foreach my $item (@curr) {
                           if (ref($request_domains) eq 'HASH') {
                               my ($otherdom) = ($item =~ /^($match_domain):($optregex)(=?\d*)$/);
                               if ($otherdom ne '') {
                                   if (ref($request_domains->{$type}) eq 'ARRAY') {
                                       unless (grep(/^\Q$otherdom\E$/,@{$request_domains->{$type}})) {
                                           push(@{$request_domains->{$type}},$otherdom);
                                       }
                                   } else {
                                       push(@{$request_domains->{$type}},$otherdom);
                                   }
                               }
                           }
                       }
                       unless($dom eq $env{'user.domain'}) {
                           $canreq ++;
                           if (grep(/^\Q$dom\E:($optregex)(=?\d*)$/,@curr)) {
                               $can_request->{$type} = 1;
                           }
                       }
                   }
               }
           }
       }
       return $canreq;
   }
   
   # ---------------------------------------------- Custom access rule evaluation
   
   sub customaccess {
       my ($priv,$uri)=@_;
       my ($urole,$urealm)=split(/\./,$env{'request.role'},2);
       my (undef,$udom,$ucrs,$usec)=split(/\//,$urealm);
       $udom = &LONCAPA::clean_domain($udom);
       $ucrs = &LONCAPA::clean_username($ucrs);
       my $access=0;
       foreach my $right (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) {
    my ($effect,$realm,$role,$type)=split(/\:/,$right);
    if ($type eq 'user') {
       foreach my $scope (split(/\s*\,\s*/,$realm)) {
    my ($tdom,$tuname)=split(m{/},$scope);
    if ($tdom) {
       if ($tdom ne $env{'user.domain'}) { next; }
    }
    if ($tuname) {
       if ($tuname ne $env{'user.name'}) { next; }
    }
    $access=($effect eq 'allow');
    last;
       }
    } else {
       if ($role) {
    if ($role ne $urole) { next; }
       }
       foreach my $scope (split(/\s*\,\s*/,$realm)) {
    my ($tdom,$tcrs,$tsec)=split(/\_/,$scope);
    if ($tdom) {
       if ($tdom ne $udom) { next; }
    }
    if ($tcrs) {
       if ($tcrs ne $ucrs) { next; }
    }
    if ($tsec) {
       if ($tsec ne $usec) { next; }
    }
    $access=($effect eq 'allow');
    last;
       }
       if ($realm eq '' && $role eq '') {
    $access=($effect eq 'allow');
       }
  }   }
     }      }
     return $access;      return $access;
Line 2773  sub customaccess { Line 6018  sub customaccess {
 # ------------------------------------------------- Check for a user privilege  # ------------------------------------------------- Check for a user privilege
   
 sub allowed {  sub allowed {
     my ($priv,$uri)=@_;      my ($priv,$uri,$symb,$role)=@_;
       my $ver_orguri=$uri;
     $uri=&deversion($uri);      $uri=&deversion($uri);
     my $orguri=$uri;      my $orguri=$uri;
     $uri=&declutter($uri);      $uri=&declutter($uri);
       
           if ($priv eq 'evb') {
       # Evade communication block restrictions for specified role in a course
     if (defined($ENV{'allowed.'.$priv})) { return $ENV{'allowed.'.$priv}; }          if ($env{'user.priv.'.$role} =~/evb\&([^\:]*)/) {
               return $1;
           } else {
               return;
           }
       }
   
       if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }
 # Free bre access to adm and meta resources  # Free bre access to adm and meta resources
     if (((($uri=~/^adm\//) && ($uri !~ m|/bulletinboard$|))       if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard)$})) 
  || ($uri=~/\.meta$/)) && ($priv eq 'bre')) {   || (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) )) 
    && ($priv eq 'bre')) {
  return 'F';   return 'F';
     }      }
   
 # Free bre access to user's own portfolio contents  # Free bre access to user's own portfolio contents
     my ($space,$domain,$name,$dir)=split('/',$uri);      my ($space,$domain,$name,@dir)=split('/',$uri);
     if (('uploaded' eq $space) && ($ENV{'user.name'} eq $name) &&       if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) && 
  ($ENV{'user.domain'} eq $domain) && ('portfolio' eq $dir)) {   ($env{'user.domain'} eq $domain) && ('portfolio' eq $dir[0])) {
         return 'F';          my %setters;
           my ($startblock,$endblock) = 
               &Apache::loncommon::blockcheck(\%setters,'port');
           if ($startblock && $endblock) {
               return 'B';
           } else {
               return 'F';
           }
       }
   
   # bre access to group portfolio for rgf priv in group, or mdg or vcg in course.
       if (($space=~/^(uploaded|editupload)$/) && ($dir[0] eq 'groups') 
            && ($dir[2] eq 'portfolio') && ($priv eq 'bre')) {
           if (exists($env{'request.course.id'})) {
               my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
               my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
               if (($domain eq $cdom) && ($name eq $cnum)) {
                   my $courseprivid=$env{'request.course.id'};
                   $courseprivid=~s/\_/\//;
                   if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid
                       .'/'.$dir[1]} =~/rgf\&([^\:]*)/) {
                       return $1; 
                   } else {
                       if ($env{'request.course.sec'}) {
                           $courseprivid.='/'.$env{'request.course.sec'};
                       }
                       if ($env{'user.priv.'.$env{'request.role'}.'./'.
                           $courseprivid} =~/(mdg|vcg)\&([^\:]*)/) {
                           return $2;
                       }
                   }
               }
           }
     }      }
   
 # Free bre to public access  # Free bre to public access
   
     if ($priv eq 'bre') {      if ($priv eq 'bre') {
         my $copyright=&metadata($uri,'copyright');          my $copyright=&metadata($uri,'copyright');
  if (($copyright eq 'public') && (!$ENV{'request.course.id'})) {    if (($copyright eq 'public') && (!$env{'request.course.id'})) { 
            return 'F';              return 'F'; 
         }          }
         if ($copyright eq 'priv') {          if ($copyright eq 'priv') {
             $uri=~/([^\/]+)\/([^\/]+)\//;              $uri=~/([^\/]+)\/([^\/]+)\//;
     unless (($ENV{'user.name'} eq $2) && ($ENV{'user.domain'} eq $1)) {      unless (($env{'user.name'} eq $2) && ($env{'user.domain'} eq $1)) {
  return '';   return '';
             }              }
         }          }
         if ($copyright eq 'domain') {          if ($copyright eq 'domain') {
             $uri=~/([^\/]+)\/([^\/]+)\//;              $uri=~/([^\/]+)\/([^\/]+)\//;
     unless (($ENV{'user.domain'} eq $1) ||      unless (($env{'user.domain'} eq $1) ||
                  ($ENV{'course.'.$ENV{'request.course.id'}.'.domain'} eq $1)) {                   ($env{'course.'.$env{'request.course.id'}.'.domain'} eq $1)) {
  return '';   return '';
             }              }
         }          }
         if ($ENV{'request.role'}=~ /li\.\//) {          if ($env{'request.role'}=~ /li\.\//) {
             # Library role, so allow browsing of resources in this domain.              # Library role, so allow browsing of resources in this domain.
             return 'F';              return 'F';
         }          }
Line 2823  sub allowed { Line 6109  sub allowed {
         }          }
     }      }
     # Domain coordinator is trying to create a course      # Domain coordinator is trying to create a course
     if (($priv eq 'ccc') && ($ENV{'request.role'} =~ /^dc\./)) {      if (($priv eq 'ccc') && ($env{'request.role'} =~ /^dc\./)) {
         # uri is the requested domain in this case.          # uri is the requested domain in this case.
         # comparison to 'request.role.domain' shows if the user has selected          # comparison to 'request.role.domain' shows if the user has selected
         # a role of dc for the domain in question.           # a role of dc for the domain in question.
         return 'F' if ($uri eq $ENV{'request.role.domain'});          return 'F' if ($uri eq $env{'request.role.domain'});
     }      }
   
     my $thisallowed='';      my $thisallowed='';
     my $statecond=0;      my $statecond=0;
     my $courseprivid='';      my $courseprivid='';
   
       my $ownaccess;
       # Community Coordinator or Assistant Co-author browsing resource space.
       if (($priv eq 'bro') && ($env{'user.author'})) {
           if ($uri eq '') {
               $ownaccess = 1;
           } else {
               if (($env{'user.domain'} ne '') && ($env{'user.name'} ne '')) {
                   my $udom = $env{'user.domain'};
                   my $uname = $env{'user.name'};
                   if ($uri =~ m{^\Q$udom\E/?$}) {
                       $ownaccess = 1;
                   } elsif ($uri =~ m{^\Q$udom\E/\Q$uname\E/?}) {
                       unless ($uri =~ m{\.\./}) {
                           $ownaccess = 1;
                       }
                   } elsif (($udom ne 'public') && ($uname ne 'public')) {
                       my $now = time;
                       if ($uri =~ m{^([^/]+)/?$}) {
                           my $adom = $1;
                           foreach my $key (keys(%env)) {
                               if ($key =~ m{^user\.role\.(ca|aa)/\Q$adom\E}) {
                                   my ($start,$end) = split('.',$env{$key});
                                   if (($now >= $start) && (!$end || $end < $now)) {
                                       $ownaccess = 1;
                                       last;
                                   }
                               }
                           }
                       } elsif ($uri =~ m{^([^/]+)/([^/]+)/?}) {
                           my $adom = $1;
                           my $aname = $2;
                           foreach my $role ('ca','aa') { 
                               if ($env{"user.role.$role./$adom/$aname"}) {
                                   my ($start,$end) =
                                       split('.',$env{"user.role.$role./$adom/$aname"});
                                   if (($now >= $start) && (!$end || $end < $now)) {
                                       $ownaccess = 1;
                                       last;
                                   }
                               }
                           }
                       }
                   }
               }
           }
       }
   
 # Course  # Course
   
     if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'}=~/\Q$priv\E\&([^\:]*)/) {      if ($env{'user.priv.'.$env{'request.role'}.'./'}=~/\Q$priv\E\&([^\:]*)/) {
        $thisallowed.=$1;          unless (($priv eq 'bro') && (!$ownaccess)) {
               $thisallowed.=$1;
           }
     }      }
   
 # Domain  # Domain
   
     if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.(split(/\//,$uri))[0].'/'}      if ($env{'user.priv.'.$env{'request.role'}.'./'.(split(/\//,$uri))[0].'/'}
        =~/\Q$priv\E\&([^\:]*)/) {         =~/\Q$priv\E\&([^\:]*)/) {
        $thisallowed.=$1;          unless (($priv eq 'bro') && (!$ownaccess)) {
               $thisallowed.=$1;
           }
       }
   
   # User who is not author or co-author might still be able to edit
   # resource of an author in the domain (e.g., if Domain Coordinator).
       if (($priv eq 'eco') && ($thisallowed eq '') && ($env{'request.course.id'}) &&
           (&allowed('mdc',$env{'request.course.id'}))) {
           if ($env{"user.priv.cm./$uri/"}=~/\Q$priv\E\&([^\:]*)/) {
               $thisallowed.=$1;
           }
     }      }
   
 # Course: uri itself is a course  # Course: uri itself is a course
Line 2852  sub allowed { Line 6198  sub allowed {
     $courseuri=~s/\_(\d)/\/$1/;      $courseuri=~s/\_(\d)/\/$1/;
     $courseuri=~s/^([^\/])/\/$1/;      $courseuri=~s/^([^\/])/\/$1/;
   
     if ($ENV{'user.priv.'.$ENV{'request.role'}.'.'.$courseuri}      if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseuri}
        =~/\Q$priv\E\&([^\:]*)/) {         =~/\Q$priv\E\&([^\:]*)/) {
        $thisallowed.=$1;          unless (($priv eq 'bro') && (!$ownaccess)) {
               $thisallowed.=$1;
           }
     }      }
   
 # URI is an uploaded document for this course  # URI is an uploaded document for this course, default permissions don't matter
   # not allowing 'edit' access (editupload) to uploaded course docs
     if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) {      if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) {
  my $refuri=$ENV{'httpref.'.$orguri};   $thisallowed='';
  if ($refuri) {          my ($match)=&is_on_map($uri);
     if ($refuri =~ m|^/adm/|) {          if ($match) {
  $thisallowed='F';              if ($env{'user.priv.'.$env{'request.role'}.'./'}
     }                    =~/\Q$priv\E\&([^\:]*)/) {
  }                  my @blockers = &has_comm_blocking($priv,$symb,$uri);
                   if (@blockers > 0) {
                       $thisallowed = 'B';
                   } else {
                       $thisallowed.=$1;
                   }
               }
           } else {
               my $refuri = $env{'httpref.'.$orguri} || $env{'httpref.'.$ver_orguri};
               if ($refuri) {
                   if ($refuri =~ m|^/adm/|) {
                       $thisallowed='F';
                   } else {
                       $refuri=&declutter($refuri);
                       my ($match) = &is_on_map($refuri);
                       if ($match) {
                           my @blockers = &has_comm_blocking($priv,$symb,$refuri);
                           if (@blockers > 0) {
                               $thisallowed = 'B';
                           } else {
                               $thisallowed='F';
                           }
                       }
                   }
               }
           }
     }      }
   
       if ($priv eq 'bre'
    && $thisallowed ne 'F' 
    && $thisallowed ne '2'
    && &is_portfolio_url($uri)) {
    $thisallowed = &portfolio_access($uri);
       }
       
 # Full access at system, domain or course-wide level? Exit.  # Full access at system, domain or course-wide level? Exit.
   
     if ($thisallowed=~/F/) {      if ($thisallowed=~/F/) {
  return 'F';   return 'F';
     }      }
   
 # If this is generating or modifying users, exit with special codes  # If this is generating or modifying users, exit with special codes
   
     if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:'=~/\:\Q$priv\E\:/) {      if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:caa:'=~/\:\Q$priv\E\:/) {
    if (($priv eq 'cca') || ($priv eq 'caa')) {
       my ($audom,$auname)=split('/',$uri);
   # no author name given, so this just checks on the general right to make a co-author in this domain
       unless ($auname) { return $thisallowed; }
   # an author name is given, so we are about to actually make a co-author for a certain account
       if (($auname ne $env{'user.name'} && $env{'request.role'} !~ /^dc\./) ||
    (($audom ne $env{'user.domain'} && $env{'request.role'} !~ /^dc\./) &&
    ($audom ne $env{'request.role.domain'}))) { return ''; }
    }
  return $thisallowed;   return $thisallowed;
     }      }
 #  #
Line 2885  sub allowed { Line 6273  sub allowed {
 # Course: See if uri or referer is an individual resource that is part of   # Course: See if uri or referer is an individual resource that is part of 
 # the course  # the course
   
     if ($ENV{'request.course.id'}) {      if ($env{'request.course.id'}) {
   
        $courseprivid=$ENV{'request.course.id'};         $courseprivid=$env{'request.course.id'};
        if ($ENV{'request.course.sec'}) {         if ($env{'request.course.sec'}) {
           $courseprivid.='/'.$ENV{'request.course.sec'};            $courseprivid.='/'.$env{'request.course.sec'};
        }         }
        $courseprivid=~s/\_/\//;         $courseprivid=~s/\_/\//;
        my $checkreferer=1;         my $checkreferer=1;
        my ($match,$cond)=&is_on_map($uri);         my ($match,$cond)=&is_on_map($uri);
        if ($match) {         if ($match) {
            $statecond=$cond;             $statecond=$cond;
            if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid}             if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid}
                =~/\Q$priv\E\&([^\:]*)/) {                 =~/\Q$priv\E\&([^\:]*)/) {
                $thisallowed.=$1;                 my $value = $1;
                  if ($priv eq 'bre') {
                      my @blockers = &has_comm_blocking($priv,$symb,$uri);
                      if (@blockers > 0) {
                          $thisallowed = 'B';
                      } else {
                          $thisallowed.=$value;
                      }
                  } else {
                      $thisallowed.=$value;
                  }
                $checkreferer=0;                 $checkreferer=0;
            }             }
        }         }
                 
        if ($checkreferer) {         if ($checkreferer) {
   my $refuri=$ENV{'httpref.'.$orguri};    my $refuri=$env{'httpref.'.$orguri};
             unless ($refuri) {              unless ($refuri) {
                 foreach (keys %ENV) {                  foreach my $key (keys(%env)) {
     if ($_=~/^httpref\..*\*/) {      if ($key=~/^httpref\..*\*/) {
  my $pattern=$_;   my $pattern=$key;
                         $pattern=~s/^httpref\.\/res\///;                          $pattern=~s/^httpref\.\/res\///;
                         $pattern=~s/\*/\[\^\/\]\+/g;                          $pattern=~s/\*/\[\^\/\]\+/g;
                         $pattern=~s/\//\\\//g;                          $pattern=~s/\//\\\//g;
                         if ($orguri=~/$pattern/) {                          if ($orguri=~/$pattern/) {
     $refuri=$ENV{$_};      $refuri=$env{$key};
                         }                          }
                     }                      }
                 }                  }
Line 2924  sub allowed { Line 6322  sub allowed {
           my ($match,$cond)=&is_on_map($refuri);            my ($match,$cond)=&is_on_map($refuri);
             if ($match) {              if ($match) {
               my $refstatecond=$cond;                my $refstatecond=$cond;
               if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid}                if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid}
                   =~/\Q$priv\E\&([^\:]*)/) {                    =~/\Q$priv\E\&([^\:]*)/) {
                   $thisallowed.=$1;                    my $value = $1;
                     if ($priv eq 'bre') {
                         my @blockers = &has_comm_blocking($priv,$symb,$refuri);
                         if (@blockers > 0) {
                             $thisallowed = 'B';
                         } else {
                             $thisallowed.=$value;
                         }
                     } else {
                         $thisallowed.=$value;
                     }
                   $uri=$refuri;                    $uri=$refuri;
                   $statecond=$refstatecond;                    $statecond=$refstatecond;
               }                }
Line 2964  sub allowed { Line 6372  sub allowed {
   
     my $envkey;      my $envkey;
     if ($thisallowed=~/L/) {      if ($thisallowed=~/L/) {
         foreach $envkey (keys %ENV) {          foreach $envkey (keys(%env)) {
            if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) {             if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) {
                my $courseid=$2;                 my $courseid=$2;
                my $roleid=$1.'.'.$2;                 my $roleid=$1.'.'.$2;
                $courseid=~s/^\///;                 $courseid=~s/^\///;
                my $expiretime=600;                 my $expiretime=600;
                if ($ENV{'request.role'} eq $roleid) {                 if ($env{'request.role'} eq $roleid) {
   $expiretime=120;    $expiretime=120;
                }                 }
        my ($cdom,$cnum,$csec)=split(/\//,$courseid);         my ($cdom,$cnum,$csec)=split(/\//,$courseid);
                my $prefix='course.'.$cdom.'_'.$cnum.'.';                 my $prefix='course.'.$cdom.'_'.$cnum.'.';
                if ((time-$ENV{$prefix.'last_cache'})>$expiretime) {                 if ((time-$env{$prefix.'last_cache'})>$expiretime) {
    &coursedescription($courseid);     &coursedescription($courseid,{'freshen_cache' => 1});
                }                 }
                if (($ENV{$prefix.'res.'.$uri.'.lock.sections'}=~/\,\Q$csec\E\,/)                 if (($env{$prefix.'res.'.$uri.'.lock.sections'}=~/\,\Q$csec\E\,/)
                 || ($ENV{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) {                  || ($env{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) {
    if ($ENV{$prefix.'res.'.$uri.'.lock.expire'}>time) {     if ($env{$prefix.'res.'.$uri.'.lock.expire'}>time) {
                        &log($ENV{'user.domain'},$ENV{'user.name'},                         &log($env{'user.domain'},$env{'user.name'},
                             $ENV{'user.home'},                              $env{'user.home'},
                             'Locked by res: '.$priv.' for '.$uri.' due to '.                              'Locked by res: '.$priv.' for '.$uri.' due to '.
                             $cdom.'/'.$cnum.'/'.$csec.' expire '.                              $cdom.'/'.$cnum.'/'.$csec.' expire '.
                             $ENV{$prefix.'priv.'.$priv.'.lock.expire'});                              $env{$prefix.'priv.'.$priv.'.lock.expire'});
        return '';         return '';
                    }                     }
                }                 }
                if (($ENV{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,\Q$csec\E\,/)                 if (($env{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,\Q$csec\E\,/)
                 || ($ENV{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) {                  || ($env{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) {
    if ($ENV{'priv.'.$priv.'.lock.expire'}>time) {     if ($env{'priv.'.$priv.'.lock.expire'}>time) {
                        &log($ENV{'user.domain'},$ENV{'user.name'},                         &log($env{'user.domain'},$env{'user.name'},
                             $ENV{'user.home'},                              $env{'user.home'},
                             'Locked by priv: '.$priv.' for '.$uri.' due to '.                              'Locked by priv: '.$priv.' for '.$uri.' due to '.
                             $cdom.'/'.$cnum.'/'.$csec.' expire '.                              $cdom.'/'.$cnum.'/'.$csec.' expire '.
                             $ENV{$prefix.'priv.'.$priv.'.lock.expire'});                              $env{$prefix.'priv.'.$priv.'.lock.expire'});
        return '';         return '';
                    }                     }
                }                 }
Line 3008  sub allowed { Line 6416  sub allowed {
 # Rest of the restrictions depend on selected course  # Rest of the restrictions depend on selected course
 #  #
   
     unless ($ENV{'request.course.id'}) {      unless ($env{'request.course.id'}) {
        return '1';   if ($thisallowed eq 'A') {
       return 'A';
           } elsif ($thisallowed eq 'B') {
               return 'B';
    } else {
       return '1';
    }
     }      }
   
 #  #
Line 3020  sub allowed { Line 6434  sub allowed {
 # Course preferences  # Course preferences
   
    if ($thisallowed=~/C/) {     if ($thisallowed=~/C/) {
        my $rolecode=(split(/\./,$ENV{'request.role'}))[0];         my $rolecode=(split(/\./,$env{'request.role'}))[0];
        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/) {
            &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},     if (($priv ne 'pch') && ($priv ne 'plc')) { 
                 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.         &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
                 $ENV{'request.course.id'});   'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
    $env{'request.course.id'});
      }
            return '';             return '';
        }         }
   
        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/) {
            &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},     if (($priv ne 'pch') && ($priv ne 'plc')) { 
                 'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.         &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.
                 $ENV{'request.course.id'});   'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.
    $env{'request.course.id'});
      }
            return '';             return '';
        }         }
    }     }
Line 3042  sub allowed { Line 6460  sub allowed {
 # Resource preferences  # Resource preferences
   
    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/) {
   &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},     if (($priv ne 'pch') && ($priv ne 'plc')) { 
                     'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);         &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
           return '';   'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
      }
      return '';
        }         }
    }     }
   
 # Restricted by state or randomout?  # Restricted by state or randomout?
   
    if ($thisallowed=~/X/) {     if ($thisallowed=~/X/) {
       if ($ENV{'acc.randomout'}) {        if ($env{'acc.randomout'}) {
          my $symb=&symbread($uri,1);   if (!$symb) { $symb=&symbread($uri,1); }
          if (($symb) && ($ENV{'acc.randomout'}=~/\&\Q$symb\E\&/)) {            if (($symb) && ($env{'acc.randomout'}=~/\&\Q$symb\E\&/)) { 
             return '';               return ''; 
          }           }
       }        }
Line 3066  sub allowed { Line 6486  sub allowed {
       }        }
    }     }
   
       if ($thisallowed eq 'A') {
    return 'A';
       } elsif ($thisallowed eq 'B') {
           return 'B';
       }
    return 'F';     return 'F';
 }  }
   
   sub get_comm_blocks {
       my ($cdom,$cnum) = @_;
       if ($cdom eq '' || $cnum eq '') {
           return unless ($env{'request.course.id'});
           $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
           $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
       }
       my %commblocks;
       my $hashid=$cdom.'_'.$cnum;
       my ($blocksref,$cached)=&is_cached_new('comm_block',$hashid);
       if ((defined($cached)) && (ref($blocksref) eq 'HASH')) {
           %commblocks = %{$blocksref};
       } else {
           %commblocks = &Apache::lonnet::dump('comm_block',$cdom,$cnum);
           my $cachetime = 600;
           &do_cache_new('comm_block',$hashid,\%commblocks,$cachetime);
       }
       return %commblocks;
   }
   
   sub has_comm_blocking {
       my ($priv,$symb,$uri,$blocks) = @_;
       return unless ($env{'request.course.id'});
       return unless ($priv eq 'bre');
       return if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/);
       my %commblocks;
       if (ref($blocks) eq 'HASH') {
           %commblocks = %{$blocks};
       } else {
           %commblocks = &get_comm_blocks();
       }
       return unless (keys(%commblocks) > 0);
       if (!$symb) { $symb=&symbread($uri,1); }
       my ($map,$resid,undef)=&decode_symb($symb);
       my %tocheck = (
                       maps      => $map,
                       resources => $symb,
                     );
       my @blockers;
       my $now = time;
       my $navmap = Apache::lonnavmaps::navmap->new();
       foreach my $block (keys(%commblocks)) {
           if ($block =~ /^(\d+)____(\d+)$/) {
               my ($start,$end) = ($1,$2);
               if ($start <= $now && $end >= $now) {
                   if (ref($commblocks{$block}{'blocks'}) eq 'HASH') {
                       if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') {
                           if (ref($commblocks{$block}{'blocks'}{'docs'}{'maps'}) eq 'HASH') {
                               if ($commblocks{$block}{'blocks'}{'docs'}{'maps'}{$map}) {
                                   unless (grep(/^\Q$block\E$/,@blockers)) {
                                       push(@blockers,$block);
                                   }
                               }
                           }
                           if (ref($commblocks{$block}{'blocks'}{'docs'}{'resources'}) eq 'HASH') {
                               if ($commblocks{$block}{'blocks'}{'docs'}{'resources'}{$symb}) {
                                   unless (grep(/^\Q$block\E$/,@blockers)) {  
                                       push(@blockers,$block);
                                   }
                               }
                           }
                       }
                   }
               }
           } elsif ($block =~ /^firstaccess____(.+)$/) {
               my $item = $1;
               my @to_test;
               if (ref($commblocks{$block}{'blocks'}) eq 'HASH') {
                   if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') {
                       my $check_interval;
                       if (&check_docs_block($commblocks{$block}{'blocks'}{'docs'},\%tocheck)) {
                           my @interval;
                           my $type = 'map';
                           if ($item eq 'course') {
                               $type = 'course';
                               @interval=&EXT("resource.0.interval");
                           } else {
                               if ($item =~ /___\d+___/) {
                                   $type = 'resource';
                                   @interval=&EXT("resource.0.interval",$item);
                                   if (ref($navmap)) {                        
                                       my $res = $navmap->getBySymb($item); 
                                       push(@to_test,$res);
                                   }
                               } else {
                                   my $mapsymb = &symbread($item,1);
                                   if ($mapsymb) {
                                       if (ref($navmap)) {
                                           my $mapres = $navmap->getBySymb($mapsymb);
                                           @to_test = $mapres->retrieveResources($mapres,undef,0,1);
                                           foreach my $res (@to_test) {
                                               my $symb = $res->symb();
                                               next if ($symb eq $mapsymb);
                                               if ($symb ne '') {
                                                   @interval=&EXT("resource.0.interval",$symb);
                                                   last;
                                               }
                                           }
                                       }
                                   }
                               }
                           }
                           if ($interval[0] =~ /\d+/) {
                               my $first_access;
                               if ($type eq 'resource') {
                                   $first_access=&get_first_access($interval[1],$item);
                               } elsif ($type eq 'map') {
                                   $first_access=&get_first_access($interval[1],undef,$item);
                               } else {
                                   $first_access=&get_first_access($interval[1]);
                               }
                               if ($first_access) {
                                   my $timesup = $first_access+$interval[0];
                                   if ($timesup > $now) {
                                       foreach my $res (@to_test) {
                                           if ($res->is_problem()) {
                                               if ($res->completable()) {
                                                   unless (grep(/^\Q$block\E$/,@blockers)) {
                                                       push(@blockers,$block);
                                                   }
                                                   last;
                                               }
                                           }
                                       }
                                   }
                               }
                           }
                       }
                   }
               }
           }
       }
       return @blockers;
   }
   
   sub check_docs_block {
       my ($docsblock,$tocheck) =@_;
       if ((ref($docsblock) ne 'HASH') || (ref($tocheck) ne 'HASH')) {
           return;
       }
       if (ref($docsblock->{'maps'}) eq 'HASH') {
           if ($tocheck->{'maps'}) {
               if ($docsblock->{'maps'}{$tocheck->{'maps'}}) {
                   return 1;
               }
           }
       }
       if (ref($docsblock->{'resources'}) eq 'HASH') {
           if ($tocheck->{'resources'}) {
               if ($docsblock->{'resources'}{$tocheck->{'resources'}}) {
                   return 1;
               }
           }
       }
       return;
   }
   
   #
   #   Removes the versino from a URI and
   #   splits it in to its filename and path to the filename.
   #   Seems like File::Basename could have done this more clearly.
   #   Parameters:
   #      $uri   - input URI
   #   Returns:
   #     Two element list consisting of 
   #     $pathname  - the URI up to and excluding the trailing /
   #     $filename  - The part of the URI following the last /
   #  NOTE:
   #    Another realization of this is simply:
   #    use File::Basename;
   #    ...
   #    $uri = shift;
   #    $filename = basename($uri);
   #    $path     = dirname($uri);
   #    return ($filename, $path);
   #
   #     The implementation below is probably faster however.
   #
   sub split_uri_for_cond {
       my $uri=&deversion(&declutter(shift));
       my @uriparts=split(/\//,$uri);
       my $filename=pop(@uriparts);
       my $pathname=join('/',@uriparts);
       return ($pathname,$filename);
   }
 # --------------------------------------------------- Is a resource on the map?  # --------------------------------------------------- Is a resource on the map?
   
 sub is_on_map {  sub is_on_map {
     my $uri=&declutter(shift);      my ($pathname,$filename) = &split_uri_for_cond(shift);
     $uri=~s/\.\d+\.(\w+)$/\.$1/;  
     my @uriparts=split(/\//,$uri);  
     my $filename=$uriparts[$#uriparts];  
     my $pathname=$uri;  
     $pathname=~s|/\Q$filename\E$||;  
     $pathname=~s/^adm\/wrapper\///;      
     #Trying to find the conditional for the file      #Trying to find the conditional for the file
     my $match=($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~      my $match=($env{'acc.res.'.$env{'request.course.id'}.'.'.$pathname}=~
        /\&\Q$filename\E\:([\d\|]+)\&/);         /\&\Q$filename\E\:([\d\|]+)\&/);
     if ($match) {      if ($match) {
  return (1,$1);   return (1,$1);
Line 3099  sub get_symb_from_alias { Line 6703  sub get_symb_from_alias {
 # Must be an alias  # Must be an alias
     my $aliassymb='';      my $aliassymb='';
     my %bighash;      my %bighash;
     if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',      if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
                             &GDBM_READER(),0640)) {                              &GDBM_READER(),0640)) {
         my $rid=$bighash{'mapalias_'.$symb};          my $rid=$bighash{'mapalias_'.$symb};
  if ($rid) {   if ($rid) {
Line 3117  sub get_symb_from_alias { Line 6721  sub get_symb_from_alias {
 sub definerole {  sub definerole {
   if (allowed('mcr','/')) {    if (allowed('mcr','/')) {
     my ($rolename,$sysrole,$domrole,$courole)=@_;      my ($rolename,$sysrole,$domrole,$courole)=@_;
     foreach (split(':',$sysrole)) {      foreach my $role (split(':',$sysrole)) {
  my ($crole,$cqual)=split(/\&/,$_);   my ($crole,$cqual)=split(/\&/,$role);
         if ($pr{'cr:s'}!~/\Q$crole\E/) { return "refused:s:$crole"; }          if ($pr{'cr:s'}!~/\Q$crole\E/) { return "refused:s:$crole"; }
         if ($pr{'cr:s'}=~/\Q$crole\E\&/) {          if ($pr{'cr:s'}=~/\Q$crole\E\&/) {
     if ($pr{'cr:s'}!~/\Q$crole\E\&\w*\Q$cqual\E/) {       if ($pr{'cr:s'}!~/\Q$crole\E\&\w*\Q$cqual\E/) { 
Line 3126  sub definerole { Line 6730  sub definerole {
             }              }
         }          }
     }      }
     foreach (split(':',$domrole)) {      foreach my $role (split(':',$domrole)) {
  my ($crole,$cqual)=split(/\&/,$_);   my ($crole,$cqual)=split(/\&/,$role);
         if ($pr{'cr:d'}!~/\Q$crole\E/) { return "refused:d:$crole"; }          if ($pr{'cr:d'}!~/\Q$crole\E/) { return "refused:d:$crole"; }
         if ($pr{'cr:d'}=~/\Q$crole\E\&/) {          if ($pr{'cr:d'}=~/\Q$crole\E\&/) {
     if ($pr{'cr:d'}!~/\Q$crole\W\&\w*\Q$cqual\E/) {       if ($pr{'cr:d'}!~/\Q$crole\W\&\w*\Q$cqual\E/) { 
Line 3135  sub definerole { Line 6739  sub definerole {
             }              }
         }          }
     }      }
     foreach (split(':',$courole)) {      foreach my $role (split(':',$courole)) {
  my ($crole,$cqual)=split(/\&/,$_);   my ($crole,$cqual)=split(/\&/,$role);
         if ($pr{'cr:c'}!~/\Q$crole\E/) { return "refused:c:$crole"; }          if ($pr{'cr:c'}!~/\Q$crole\E/) { return "refused:c:$crole"; }
         if ($pr{'cr:c'}=~/\Q$crole\E\&/) {          if ($pr{'cr:c'}=~/\Q$crole\E\&/) {
     if ($pr{'cr:c'}!~/\Q$crole\E\&\w*\Q$cqual\E/) {       if ($pr{'cr:c'}!~/\Q$crole\E\&\w*\Q$cqual\E/) { 
Line 3144  sub definerole { Line 6748  sub definerole {
             }              }
         }          }
     }      }
     my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:".      my $command="encrypt:rolesput:$env{'user.domain'}:$env{'user.name'}:".
                 "$ENV{'user.domain'}:$ENV{'user.name'}:".                  "$env{'user.domain'}:$env{'user.name'}:".
         "rolesdef_$rolename=".          "rolesdef_$rolename=".
                 escape($sysrole.'_'.$domrole.'_'.$courole);                  escape($sysrole.'_'.$domrole.'_'.$courole);
     return reply($command,$ENV{'user.home'});      return reply($command,$env{'user.home'});
   } else {    } else {
     return 'refused';      return 'refused';
   }    }
Line 3159  sub definerole { Line 6763  sub definerole {
 sub metadata_query {  sub metadata_query {
     my ($query,$custom,$customshow,$server_array)=@_;      my ($query,$custom,$customshow,$server_array)=@_;
     my %rhash;      my %rhash;
       my %libserv = &all_library();
     my @server_list = (defined($server_array) ? @$server_array      my @server_list = (defined($server_array) ? @$server_array
                                               : keys(%libserv) );                                                : keys(%libserv) );
     for my $server (@server_list) {      for my $server (@server_list) {
Line 3182  sub log_query { Line 6787  sub log_query {
     my ($uname,$udom,$query,%filters)=@_;      my ($uname,$udom,$query,%filters)=@_;
     my $uhome=&homeserver($uname,$udom);      my $uhome=&homeserver($uname,$udom);
     if ($uhome eq 'no_host') { return 'error: no_host'; }      if ($uhome eq 'no_host') { return 'error: no_host'; }
     my $uhost=$hostname{$uhome};      my $uhost=&hostname($uhome);
     my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys %filters));      my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys(%filters)));
     my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command,      my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command,
                        $uhome);                         $uhome);
     unless ($queryid=~/^\Q$uhost\E\_/) { return 'error: '.$queryid; }      unless ($queryid=~/^\Q$uhost\E\_/) { return 'error: '.$queryid; }
     return get_query_reply($queryid);      return get_query_reply($queryid);
 }  }
   
   # -------------------------- Update MySQL table for portfolio file
   
   sub update_portfolio_table {
       my ($uname,$udom,$file_name,$query,$group,$action) = @_;
       if ($group ne '') {
           $file_name =~s /^\Q$group\E//;
       }
       my $homeserver = &homeserver($uname,$udom);
       my $queryid=
           &reply("querysend:".$query.':'.&escape($uname.':'.$udom.':'.$group).
                  ':'.&escape($file_name).':'.$action,$homeserver);
       my $reply = &get_query_reply($queryid);
       return $reply;
   }
   
   # -------------------------- Update MySQL allusers table
   
   sub update_allusers_table {
       my ($uname,$udom,$names) = @_;
       my $homeserver = &homeserver($uname,$udom);
       my $queryid=
           &reply('querysend:allusers:'.&escape($uname).':'.&escape($udom).':'.
                  'lastname='.&escape($names->{'lastname'}).'%%'.
                  'firstname='.&escape($names->{'firstname'}).'%%'.
                  'middlename='.&escape($names->{'middlename'}).'%%'.
                  'generation='.&escape($names->{'generation'}).'%%'.
                  'permanentemail='.&escape($names->{'permanentemail'}).'%%'.
                  'id='.&escape($names->{'id'}),$homeserver);
       return;
   }
   
 # ------- Request retrieval of institutional classlists for course(s)  # ------- Request retrieval of institutional classlists for course(s)
   
 sub fetch_enrollment_query {  sub fetch_enrollment_query {
Line 3202  sub fetch_enrollment_query { Line 6838  sub fetch_enrollment_query {
     } else {      } else {
         $homeserver = &homeserver($cnum,$dom);          $homeserver = &homeserver($cnum,$dom);
     }      }
     my $host=$hostname{$homeserver};      my $host=&hostname($homeserver);
     my $cmd = '';      my $cmd = '';
     foreach (keys %{$affiliatesref}) {      foreach my $affiliate (keys(%{$affiliatesref})) {
         $cmd .= $_.'='.join(",",@{$$affiliatesref{$_}}).'%%';          $cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';
     }      }
     $cmd =~ s/%%$//;      $cmd =~ s/%%$//;
     $cmd = &escape($cmd);      $cmd = &escape($cmd);
     my $query = 'fetchenrollment';      my $query = 'fetchenrollment';
     my $queryid=&reply("querysend:".$query.':'.$dom.':'.$ENV{'user.name'}.':'.$cmd,$homeserver);      my $queryid=&reply("querysend:".$query.':'.$dom.':'.$env{'user.name'}.':'.$cmd,$homeserver);
     unless ($queryid=~/^\Q$host\E\_/) {       unless ($queryid=~/^\Q$host\E\_/) { 
         &logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum);           &logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum); 
         return 'error: '.$queryid;          return 'error: '.$queryid;
Line 3222  sub fetch_enrollment_query { Line 6858  sub fetch_enrollment_query {
         $tries ++;          $tries ++;
     }      }
     if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {      if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
         &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$ENV{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);          &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);
     } else {      } else {
         my @responses = split/:/,$reply;          my @responses = split(/:/,$reply);
         if ($homeserver eq $perlvar{'lonHostID'}) {          if ($homeserver eq $perlvar{'lonHostID'}) {
             foreach (@responses) {              foreach my $line (@responses) {
                 my ($key,$value) = split/=/,$_;                  my ($key,$value) = split(/=/,$line,2);
                 $$replyref{$key} = $value;                  $$replyref{$key} = $value;
             }              }
         } else {          } else {
             my $pathname = $perlvar{'lonDaemons'}.'/tmp';              my $pathname = LONCAPA::tempdir();
             foreach (@responses) {              foreach my $line (@responses) {
                 my ($key,$value) = split/=/,$_;                  my ($key,$value) = split(/=/,$line);
                 $$replyref{$key} = $value;                  $$replyref{$key} = $value;
                 if ($value > 0) {                  if ($value > 0) {
                     foreach (@{$$affiliatesref{$key}}) {                      foreach my $item (@{$$affiliatesref{$key}}) {
                         my $filename = $dom.'_'.$key.'_'.$_.'_classlist.xml';                          my $filename = $dom.'_'.$key.'_'.$item.'_classlist.xml';
                         my $destname = $pathname.'/'.$filename;                          my $destname = $pathname.'/'.$filename;
                         my $xml_classlist = &reply("autoretrieve:".$filename,$homeserver);                          my $xml_classlist = &reply("autoretrieve:".$filename,$homeserver);
                         if ($xml_classlist =~ /^error/) {                          if ($xml_classlist =~ /^error/) {
Line 3261  sub fetch_enrollment_query { Line 6897  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;
         if (-e $replyfile.'.end') {          if (-e $replyfile.'.end') {
     if (open(my $fh,$replyfile)) {      if (open(my $fh,$replyfile)) {
                $reply.=<$fh>;   $reply = join('',<$fh>);
                close($fh);   close($fh);
    } else { return 'error: reply_file_error'; }     } else { return 'error: reply_file_error'; }
            return &unescape($reply);             return &unescape($reply);
  }   }
Line 3287  sub courselog_query { Line 6923  sub courselog_query {
 # end: timestamp  # end: timestamp
 #  #
     my (%filters)=@_;      my (%filters)=@_;
     unless ($ENV{'request.course.id'}) { return 'no_course'; }      unless ($env{'request.course.id'}) { return 'no_course'; }
     if ($filters{'url'}) {      if ($filters{'url'}) {
  $filters{'url'}=&symbclean(&declutter($filters{'url'}));   $filters{'url'}=&symbclean(&declutter($filters{'url'}));
         $filters{'url'}=~s/\.(\w+)$/(\\.\\d+)*\\.$1/;          $filters{'url'}=~s/\.(\w+)$/(\\.\\d+)*\\.$1/;
         $filters{'url'}=~s/\.(\w+)\_\_\_/(\\.\\d+)*\\.$1/;          $filters{'url'}=~s/\.(\w+)\_\_\_/(\\.\\d+)*\\.$1/;
     }      }
     my $cname=$ENV{'course.'.$ENV{'request.course.id'}.'.num'};      my $cname=$env{'course.'.$env{'request.course.id'}.'.num'};
     my $cdom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'};      my $cdom=$env{'course.'.$env{'request.course.id'}.'.domain'};
     return &log_query($cname,$cdom,'courselog',%filters);      return &log_query($cname,$cdom,'courselog',%filters);
 }  }
   
 sub userlog_query {  sub userlog_query {
   #
   # possible filters:
   # action: log check role
   # start: timestamp
   # end: timestamp
   #
     my ($uname,$udom,%filters)=@_;      my ($uname,$udom,%filters)=@_;
     return &log_query($uname,$udom,'userlog',%filters);      return &log_query($uname,$udom,'userlog',%filters);
 }  }
Line 3307  sub userlog_query { Line 6949  sub userlog_query {
   
 sub auto_run {  sub auto_run {
     my ($cnum,$cdom) = @_;      my ($cnum,$cdom) = @_;
     my $homeserver = &homeserver($cnum,$cdom);      my $response = 0;
     my $response = &reply('autorun:'.$cdom,$homeserver);      my $settings;
       my %domconfig = &get_dom('configuration',['autoenroll'],$cdom);
       if (ref($domconfig{'autoenroll'}) eq 'HASH') {
           $settings = $domconfig{'autoenroll'};
           if ($settings->{'run'} eq '1') {
               $response = 1;
           }
       } else {
           my $homeserver;
           if (&is_course($cdom,$cnum)) {
               $homeserver = &homeserver($cnum,$cdom);
           } else {
               $homeserver = &domain($cdom,'primary');
           }
           if ($homeserver ne 'no_host') {
               $response = &reply('autorun:'.$cdom,$homeserver);
           }
       }
     return $response;      return $response;
 }  }
                                                                                      
 sub auto_get_sections {  sub auto_get_sections {
     my ($cnum,$cdom,$inst_coursecode) = @_;      my ($cnum,$cdom,$inst_coursecode) = @_;
     my $homeserver = &homeserver($cnum,$cdom);      my $homeserver;
     my @secs = ();      if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) { 
     my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver));          $homeserver = &homeserver($cnum,$cdom);
     unless ($response eq 'refused') {      }
         @secs = split/:/,$response;      if (!defined($homeserver)) { 
           if ($cdom =~ /^$match_domain$/) {
               $homeserver = &domain($cdom,'primary');
           }
       }
       my @secs;
       if (defined($homeserver)) {
           my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver));
           unless ($response eq 'refused') {
               @secs = split(/:/,$response);
           }
     }      }
     return @secs;      return @secs;
 }  }
                                                                                      
 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;
 }  }
                                                                                      
 sub auto_validate_courseID {  sub auto_validate_courseID {
     my ($cnum,$cdom,$inst_course_id) = @_;      my ($cnum,$cdom,$inst_course_id) = @_;
     my $homeserver = &homeserver($cnum,$cdom);      my $homeserver = &homeserver($cnum,$cdom);
     my $response=&unescape(&reply('autovalidatecourse:'.$inst_course_id.':'.$cdom,$homeserver));      my $response=&unescape(&reply('autovalidatecourse:'.$inst_course_id.':'.$cdom,$homeserver));
     return $response;      return $response;
 }  }
                                                                                      
   sub auto_validate_instcode {
       my ($cnum,$cdom,$instcode,$owner) = @_;
       my ($homeserver,$response);
       if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) {
           $homeserver = &homeserver($cnum,$cdom);
       }
       if (!defined($homeserver)) {
           if ($cdom =~ /^$match_domain$/) {
               $homeserver = &domain($cdom,'primary');
           }
       }
       $response=&unescape(&reply('autovalidateinstcode:'.$cdom.':'.
                           &escape($instcode).':'.&escape($owner),$homeserver));
       my ($outcome,$description) = map { &unescape($_); } split('&',$response,2);
       return ($outcome,$description);
   }
   
 sub auto_create_password {  sub auto_create_password {
     my ($cnum,$cdom,$authparam) = @_;      my ($cnum,$cdom,$authparam,$udom) = @_;
     my $homeserver = &homeserver($cnum,$cdom);       my ($homeserver,$response);
     my $create_passwd = 0;      my $create_passwd = 0;
     my $authchk = '';      my $authchk = '';
     my $response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver));      if ($udom =~ /^$match_domain$/) {
     if ($response eq 'refused') {          $homeserver = &domain($udom,'primary');
         $authchk = 'refused';      }
       if ($homeserver eq '') {
           if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) {
               $homeserver = &homeserver($cnum,$cdom);
           }
       }
       if ($homeserver eq '') {
           $authchk = 'nodomain';
     } else {      } else {
         ($authparam,$create_passwd,$authchk) = split/:/,$response;          $response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver));
           if ($response eq 'refused') {
               $authchk = 'refused';
           } else {
               ($authparam,$create_passwd,$authchk) = split(/:/,$response);
           }
     }      }
     return ($authparam,$create_passwd,$authchk);      return ($authparam,$create_passwd,$authchk);
 }  }
   
   sub auto_photo_permission {
       my ($cnum,$cdom,$students) = @_;
       my $homeserver = &homeserver($cnum,$cdom);
       my ($outcome,$perm_reqd,$conditions) = 
    split(/:/,&unescape(&reply('autophotopermission:'.$cdom,$homeserver)),3);
       if ($outcome =~ /^(con_lost|unknown_cmd|no_such_host)$/) {
    return (undef,undef);
       }
       return ($outcome,$perm_reqd,$conditions);
   }
   
   sub auto_checkphotos {
       my ($uname,$udom,$pid) = @_;
       my $homeserver = &homeserver($uname,$udom);
       my ($result,$resulttype);
       my $outcome = &unescape(&reply('autophotocheck:'.&escape($udom).':'.
      &escape($uname).':'.&escape($pid),
      $homeserver));
       if ($outcome =~ /^(con_lost|unknown_cmd|no_such_host)$/) {
    return (undef,undef);
       }
       if ($outcome) {
           ($result,$resulttype) = split(/:/,$outcome);
       } 
       return ($result,$resulttype);
   }
   
   sub auto_photochoice {
       my ($cnum,$cdom) = @_;
       my $homeserver = &homeserver($cnum,$cdom);
       my ($update,$comment) = split(/:/,&unescape(&reply('autophotochoice:'.
          &escape($cdom),
          $homeserver)));
       if ($update =~ /^(con_lost|unknown_cmd|no_such_host)$/) {
    return (undef,undef);
       }
       return ($update,$comment);
   }
   
   sub auto_photoupdate {
       my ($affiliatesref,$dom,$cnum,$photo) = @_;
       my $homeserver = &homeserver($cnum,$dom);
       my $host=&hostname($homeserver);
       my $cmd = '';
       my $maxtries = 1;
       foreach my $affiliate (keys(%{$affiliatesref})) {
           $cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';
       }
       $cmd =~ s/%%$//;
       $cmd = &escape($cmd);
       my $query = 'institutionalphotos';
       my $queryid=&reply("querysend:".$query.':'.$dom.':'.$cnum.':'.$cmd,$homeserver);
       unless ($queryid=~/^\Q$host\E\_/) {
           &logthis('institutionalphotos: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' and course: '.$cnum);
           return 'error: '.$queryid;
       }
       my $reply = &get_query_reply($queryid);
       my $tries = 1;
       while (($reply=~/^timeout/) && ($tries < $maxtries)) {
           $reply = &get_query_reply($queryid);
           $tries ++;
       }
       if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
           &logthis('institutionalphotos error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' course: '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);
       } else {
           my @responses = split(/:/,$reply);
           my $outcome = shift(@responses); 
           foreach my $item (@responses) {
               my ($key,$value) = split(/=/,$item);
               $$photo{$key} = $value;
           }
           return $outcome;
       }
       return 'error';
   }
   
 sub auto_instcode_format {  sub auto_instcode_format {
     my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,$cat_order) = @_;      my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,
    $cat_order) = @_;
     my $courses = '';      my $courses = '';
     my $homeserver;      my @homeservers;
     if ($caller eq 'global') {      if ($caller eq 'global') {
         $homeserver = $perlvar{'lonHostID'};   my %servers = &get_servers($codedom,'library');
    foreach my $tryserver (keys(%servers)) {
       if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
    push(@homeservers,$tryserver);
       }
           }
       } elsif ($caller eq 'requests') {
           if ($codedom =~ /^$match_domain$/) {
               my $chome = &domain($codedom,'primary');
               unless ($chome eq 'no_host') {
                   push(@homeservers,$chome);
               }
           }
     } else {      } else {
         $homeserver = &homeserver($caller,$codedom);          push(@homeservers,&homeserver($caller,$codedom));
     }      }
     my $host=$hostname{$homeserver};      foreach my $code (keys(%{$instcodes})) {
     foreach (keys %{$instcodes}) {          $courses .= &escape($code).'='.&escape($$instcodes{$code}).'&';
         $courses .= &escape($_).'='.&escape($$instcodes{$_}).'&';  
     }      }
     chop($courses);      chop($courses);
     my $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$homeserver);      my $ok_response = 0;
     unless ($response =~ /(con_lost|error|no_such_host|refused)/) {      my $response;
         my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = split/:/,$response;      while (@homeservers > 0 && $ok_response == 0) {
         %{$codes} = &str2hash($codes_str);          my $server = shift(@homeservers); 
         @{$codetitles} = &str2array($codetitles_str);          $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$server);
         %{$cat_titles} = &str2hash($cat_titles_str);          if ($response !~ /(con_lost|error|no_such_host|refused)/) {
         %{$cat_order} = &str2hash($cat_order_str);              my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = 
    split(/:/,$response);
               %{$codes} = (%{$codes},&str2hash($codes_str));
               push(@{$codetitles},&str2array($codetitles_str));
               %{$cat_titles} = (%{$cat_titles},&str2hash($cat_titles_str));
               %{$cat_order} = (%{$cat_order},&str2hash($cat_order_str));
               $ok_response = 1;
           }
       }
       if ($ok_response) {
         return 'ok';          return 'ok';
       } else {
           return $response;
       }
   }
   
   sub auto_instcode_defaults {
       my ($domain,$returnhash,$code_order) = @_;
       my @homeservers;
   
       my %servers = &get_servers($domain,'library');
       foreach my $tryserver (keys(%servers)) {
    if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
       push(@homeservers,$tryserver);
    }
       }
   
       my $response;
       foreach my $server (@homeservers) {
           $response=&reply('autoinstcodedefaults:'.$domain,$server);
           next if ($response =~ /(con_lost|error|no_such_host|refused)/);
   
    foreach my $pair (split(/\&/,$response)) {
       my ($name,$value)=split(/\=/,$pair);
       if ($name eq 'code_order') {
    @{$code_order} = split(/\&/,&unescape($value));
       } else {
    $returnhash->{&unescape($name)}=&unescape($value);
       }
    }
    return 'ok';
       }
   
       return $response;
   }
   
   sub auto_possible_instcodes {
       my ($domain,$codetitles,$cat_titles,$cat_orders,$code_order) = @_;
       unless ((ref($codetitles) eq 'ARRAY') && (ref($cat_titles) eq 'HASH') && 
               (ref($cat_orders) eq 'HASH') && (ref($code_order) eq 'ARRAY')) {
           return;
       }
       my (@homeservers,$uhome);
       if (defined(&domain($domain,'primary'))) {
           $uhome=&domain($domain,'primary');
           push(@homeservers,&domain($domain,'primary'));
       } else {
           my %servers = &get_servers($domain,'library');
           foreach my $tryserver (keys(%servers)) {
               if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
                   push(@homeservers,$tryserver);
               }
           }
       }
       my $response;
       foreach my $server (@homeservers) {
           $response=&reply('autopossibleinstcodes:'.$domain,$server);
           next if ($response =~ /(con_lost|error|no_such_host|refused)/);
           my ($codetitlestr,$codeorderstr,$cat_title,$cat_order) = 
               split(':',$response);
           @{$codetitles} = map { &unescape($_); } (split('&',$codetitlestr));
           @{$code_order} = map { &unescape($_); } (split('&',$codeorderstr));
           foreach my $item (split('&',$cat_title)) {   
               my ($name,$value)=split('=',$item);
               $cat_titles->{&unescape($name)}=&thaw_unescape($value);
           }
           foreach my $item (split('&',$cat_order)) {
               my ($name,$value)=split('=',$item);
               $cat_orders->{&unescape($name)}=&thaw_unescape($value);
           }
           return 'ok';
       }
       return $response;
   }
   
   sub auto_courserequest_checks {
       my ($dom) = @_;
       my ($homeserver,%validations);
       if ($dom =~ /^$match_domain$/) {
           $homeserver = &domain($dom,'primary');
       }
       unless ($homeserver eq 'no_host') {
           my $response=&reply('autocrsreqchecks:'.$dom,$homeserver);
           unless ($response =~ /(con_lost|error|no_such_host|refused)/) {
               my @items = split(/&/,$response);
               foreach my $item (@items) {
                   my ($key,$value) = split('=',$item);
                   $validations{&unescape($key)} = &thaw_unescape($value);
               }
           }
       }
       return %validations; 
   }
   
   sub auto_courserequest_validation {
       my ($dom,$owner,$crstype,$inststatuslist,$instcode,$instseclist) = @_;
       my ($homeserver,$response);
       if ($dom =~ /^$match_domain$/) {
           $homeserver = &domain($dom,'primary');
       }
       unless ($homeserver eq 'no_host') {  
             
           $response=&unescape(&reply('autocrsreqvalidation:'.$dom.':'.&escape($owner).
                                       ':'.&escape($crstype).':'.&escape($inststatuslist).
                                       ':'.&escape($instcode).':'.&escape($instseclist),
                                       $homeserver));
       }
       return $response;
   }
   
   sub auto_validate_class_sec {
       my ($cdom,$cnum,$owners,$inst_class) = @_;
       my $homeserver = &homeserver($cnum,$cdom);
       my $ownerlist;
       if (ref($owners) eq 'ARRAY') {
           $ownerlist = join(',',@{$owners});
       } else {
           $ownerlist = $owners;
     }      }
       my $response=&reply('autovalidateclass_sec:'.$inst_class.':'.
                           &escape($ownerlist).':'.$cdom,$homeserver);
     return $response;      return $response;
 }  }
   
   # ------------------------------------------------------- Course Group routines
   
   sub get_coursegroups {
       my ($cdom,$cnum,$group,$namespace) = @_;
       return(&dump($namespace,$cdom,$cnum,$group));
   }
   
   sub modify_coursegroup {
       my ($cdom,$cnum,$groupsettings) = @_;
       return(&put('coursegroups',$groupsettings,$cdom,$cnum));
   }
   
   sub toggle_coursegroup_status {
       my ($cdom,$cnum,$group,$action) = @_;
       my ($from_namespace,$to_namespace);
       if ($action eq 'delete') {
           $from_namespace = 'coursegroups';
           $to_namespace = 'deleted_groups';
       } else {
           $from_namespace = 'deleted_groups';
           $to_namespace = 'coursegroups';
       }
       my %curr_group = &get_coursegroups($cdom,$cnum,$group,$from_namespace);
       if (my $tmp = &error(%curr_group)) {
           &Apache::lonnet::logthis('Error retrieving group: '.$tmp.' in '.$cnum.':'.$cdom);
           return ('read error',$tmp);
       } else {
           my %savedsettings = %curr_group; 
           my $result = &put($to_namespace,\%savedsettings,$cdom,$cnum);
           my $deloutcome;
           if ($result eq 'ok') {
               $deloutcome = &del($from_namespace,[$group],$cdom,$cnum);
           } else {
               return ('write error',$result);
           }
           if ($deloutcome eq 'ok') {
               return 'ok';
           } else {
               return ('delete error',$deloutcome);
           }
       }
   }
   
   sub modify_group_roles {
       my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs,$selfenroll,$context) = @_;
       my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id;
       my $role = 'gr/'.&escape($userprivs);
       my ($uname,$udom) = split(/:/,$user);
       my $result = &assignrole($udom,$uname,$url,$role,$end,$start,'',$selfenroll,$context);
       if ($result eq 'ok') {
           &devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);
       }
       return $result;
   }
   
   sub modify_coursegroup_membership {
       my ($cdom,$cnum,$membership) = @_;
       my $result = &put('groupmembership',$membership,$cdom,$cnum);
       return $result;
   }
   
   sub get_active_groups {
       my ($udom,$uname,$cdom,$cnum) = @_;
       my $now = time;
       my %groups = ();
       foreach my $key (keys(%env)) {
           if ($key =~ m-user\.role\.gr\./($match_domain)/($match_courseid)/(\w+)$-) {
               my ($start,$end) = split(/\./,$env{$key});
               if (($end!=0) && ($end<$now)) { next; }
               if (($start!=0) && ($start>$now)) { next; }
               if ($1 eq $cdom && $2 eq $cnum) {
                   $groups{$3} = $env{$key} ;
               }
           }
       }
       return %groups;
   }
   
   sub get_group_membership {
       my ($cdom,$cnum,$group) = @_;
       return(&dump('groupmembership',$cdom,$cnum,$group));
   }
   
   sub get_users_groups {
       my ($udom,$uname,$courseid) = @_;
       my @usersgroups;
       my $cachetime=1800;
   
       my $hashid="$udom:$uname:$courseid";
       my ($grouplist,$cached)=&is_cached_new('getgroups',$hashid);
       if (defined($cached)) {
           @usersgroups = split(/:/,$grouplist);
       } else {  
           $grouplist = '';
           my $courseurl = &courseid_to_courseurl($courseid);
           my %roleshash = &dump('roles',$udom,$uname,$courseurl);
           my $access_end = $env{'course.'.$courseid.
                                 '.default_enrollment_end_date'};
           my $now = time;
           foreach my $key (keys(%roleshash)) {
               if ($key =~ /^\Q$courseurl\E\/(\w+)\_gr$/) {
                   my $group = $1;
                   if ($roleshash{$key} =~ /_(\d+)_(\d+)$/) {
                       my $start = $2;
                       my $end = $1;
                       if ($start == -1) { next; } # deleted from group
                       if (($start!=0) && ($start>$now)) { next; }
                       if (($end!=0) && ($end<$now)) {
                           if ($access_end && $access_end < $now) {
                               if ($access_end - $end < 86400) {
                                   push(@usersgroups,$group);
                               }
                           }
                           next;
                       }
                       push(@usersgroups,$group);
                   }
               }
           }
           @usersgroups = &sort_course_groups($courseid,@usersgroups);
           $grouplist = join(':',@usersgroups);
           &do_cache_new('getgroups',$hashid,$grouplist,$cachetime);
       }
       return @usersgroups;
   }
   
   sub devalidate_getgroups_cache {
       my ($udom,$uname,$cdom,$cnum)=@_;
       my $courseid = $cdom.'_'.$cnum;
   
       my $hashid="$udom:$uname:$courseid";
       &devalidate_cache_new('getgroups',$hashid);
   }
   
 # ------------------------------------------------------------------ Plain Text  # ------------------------------------------------------------------ Plain Text
   
 sub plaintext {  sub plaintext {
     my $short=shift;      my ($short,$type,$cid,$forcedefault) = @_;
     return &mt($prp{$short});      if ($short =~ m{^cr/}) {
    return (split('/',$short))[-1];
       }
       if (!defined($cid)) {
           $cid = $env{'request.course.id'};
       }
       my %rolenames = (
                         Course    => 'std',
                         Community => 'alt1',
                       );
       if ($cid ne '') {
           if ($env{'course.'.$cid.'.'.$short.'.plaintext'} ne '') {
               unless ($forcedefault) {
                   my $roletext = $env{'course.'.$cid.'.'.$short.'.plaintext'}; 
                   &Apache::lonlocal::mt_escape(\$roletext);
                   return &Apache::lonlocal::mt($roletext);
               }
           }
       }
       if ((defined($type)) && (defined($rolenames{$type})) &&
           (defined($rolenames{$type})) && 
           (defined($prp{$short}{$rolenames{$type}}))) {
           return &Apache::lonlocal::mt($prp{$short}{$rolenames{$type}});
       } elsif ($cid ne '') {
           my $crstype = $env{'course.'.$cid.'.type'};
           if (($crstype ne '') && (defined($rolenames{$crstype})) &&
               (defined($prp{$short}{$rolenames{$crstype}}))) {
               return &Apache::lonlocal::mt($prp{$short}{$rolenames{$crstype}});
           }
       }
       return &Apache::lonlocal::mt($prp{$short}{'std'});
 }  }
   
 # ----------------------------------------------------------------- Assign Role  # ----------------------------------------------------------------- Assign Role
   
 sub assignrole {  sub assignrole {
     my ($udom,$uname,$url,$role,$end,$start,$deleteflag)=@_;      my ($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll,
           $context)=@_;
     my $mrole;      my $mrole;
     if ($role =~ /^cr\//) {      if ($role =~ /^cr\//) {
         my $cwosec=$url;          my $cwosec=$url;
         $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;          $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
  unless (&allowed('ccr',$cwosec)) {   unless (&allowed('ccr',$cwosec)) {
            &logthis('Refused custom assignrole: '.             my $refused = 1;
              $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.             if ($context eq 'requestcourses') {
     $ENV{'user.name'}.' at '.$ENV{'user.domain'});                 if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '')) {
            return 'refused';                      if ($role =~ m{^cr/($match_domain)/($match_username)/([^/]+)$}) {
                          if (($1 eq $env{'user.domain'}) && ($2 eq $env{'user.name'})) {
                              my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});
                              my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
                              if ($crsenv{'internal.courseowner'} eq
                                  $env{'user.name'}.':'.$env{'user.domain'}) {
                                  $refused = '';
                              }
                          }
                      }
                  }
              }
              if ($refused) {
                  &logthis('Refused custom assignrole: '.
                           $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.
                           ' by '.$env{'user.name'}.' at '.$env{'user.domain'});
                  return 'refused';
              }
         }          }
         $mrole='cr';          $mrole='cr';
       } elsif ($role =~ /^gr\//) {
           my $cwogrp=$url;
           $cwogrp=~s{^/($match_domain)/($match_courseid)/.*}{$1/$2};
           unless (&allowed('mdg',$cwogrp)) {
               &logthis('Refused group assignrole: '.
                 $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
                       $env{'user.name'}.' at '.$env{'user.domain'});
               return 'refused';
           }
           $mrole='gr';
     } else {      } else {
         my $cwosec=$url;          my $cwosec=$url;
         $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;          $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
         unless ((&allowed('c'.$role,$cwosec)) || &allowed('c'.$role,$udom)) {           if (!(&allowed('c'.$role,$cwosec)) && !(&allowed('c'.$role,$udom))) {
            &logthis('Refused assignrole: '.              my $refused;
              $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.              if (($env{'request.course.sec'}  ne '') && ($role eq 'st')) {
     $ENV{'user.name'}.' at '.$ENV{'user.domain'});                  if (!(&allowed('c'.$role,$url))) {
            return 'refused';                       $refused = 1;
                   }
               } else {
                   $refused = 1;
               }
               if ($refused) {
                   my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});
                   if (!$selfenroll && $context eq 'course') {
                       my %crsenv;
                       if ($role eq 'cc' || $role eq 'co') {
                           %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
                           if (($role eq 'cc') && ($cnum !~ /^$match_community$/)) {
                               if ($env{'request.role'} eq 'cc./'.$cdom.'/'.$cnum) {
                                   if ($crsenv{'internal.courseowner'} eq 
                                       $env{'user.name'}.':'.$env{'user.domain'}) {
                                       $refused = '';
                                   }
                               }
                           } elsif (($role eq 'co') && ($cnum =~ /^$match_community$/)) { 
                               if ($env{'request.role'} eq 'co./'.$cdom.'/'.$cnum) {
                                   if ($crsenv{'internal.courseowner'} eq 
                                       $env{'user.name'}.':'.$env{'user.domain'}) {
                                       $refused = '';
                                   }
                               }
                           }
                       }
                   } elsif (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
                       $refused = '';
                   } elsif ($context eq 'requestcourses') {
                       my @possroles = ('st','ta','ep','in','cc','co');
                       if ((grep(/^\Q$role\E$/,@possroles)) && ($env{'user.name'} ne '' && $env{'user.domain'} ne '')) {
                           my $wrongcc;
                           if ($cnum =~ /^$match_community$/) {
                               $wrongcc = 1 if ($role eq 'cc');
                           } else {
                               $wrongcc = 1 if ($role eq 'co');
                           }
                           unless ($wrongcc) {
                               my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
                               if ($crsenv{'internal.courseowner'} eq 
                                    $env{'user.name'}.':'.$env{'user.domain'}) {
                                   $refused = '';
                               }
                           }
                       }
                   } elsif ($context eq 'requestauthor') {
                       if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) && 
                           ($url eq '/'.$udom.'/') && ($role eq 'au')) {
                           if ($env{'environment.requestauthor'} eq 'automatic') {
                               $refused = '';
                           } else {
                               my %domdefaults = &get_domain_defaults($udom);
                               if (ref($domdefaults{'requestauthor'}) eq 'HASH') {
                                   my $checkbystatus;
                                   if ($env{'user.adv'}) { 
                                       my $disposition = $domdefaults{'requestauthor'}{'_LC_adv'};
                                       if ($disposition eq 'automatic') {
                                           $refused = '';
                                       } elsif ($disposition eq '') {
                                           $checkbystatus = 1;
                                       } 
                                   } else {
                                       $checkbystatus = 1;
                                   }
                                   if ($checkbystatus) {
                                       if ($env{'environment.inststatus'}) {
                                           my @inststatuses = split(/,/,$env{'environment.inststatus'});
                                           foreach my $type (@inststatuses) {
                                               if (($type ne '') &&
                                                   ($domdefaults{'requestauthor'}{$type} eq 'automatic')) {
                                                   $refused = '';
                                               }
                                           }
                                       } elsif ($domdefaults{'requestauthor'}{'default'} eq 'automatic') {
                                           $refused = '';
                                       }
                                   }
                               }
                           }
                       }
                   }
                   if ($refused) {
                       &logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.
                                ' '.$role.' '.$end.' '.$start.' by '.
                  $env{'user.name'}.' at '.$env{'user.domain'});
                       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;
     }      }
     my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:".      my $command="encrypt:rolesput:$env{'user.domain'}:$env{'user.name'}:".
                 "$udom:$uname:$url".'_'."$mrole=$role";                  "$udom:$uname:$url".'_'."$mrole=$role";
     if ($end) { $command.='_'.$end; }      if ($end) { $command.='_'.$end; }
     if ($start) {      if ($start) {
Line 3420  sub assignrole { Line 7621  sub assignrole {
            $command.='_0_'.$start;             $command.='_0_'.$start;
         }          }
     }      }
       my $origstart = $start;
       my $origend = $end;
       my $delflag;
 # actually delete  # actually delete
     if ($deleteflag) {      if ($deleteflag) {
  if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) {   if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) {
 # modify command to delete the role  # modify command to delete the role
            $command="encrypt:rolesdel:$ENV{'user.domain'}:$ENV{'user.name'}:".             $command="encrypt:rolesdel:$env{'user.domain'}:$env{'user.name'}:".
                 "$udom:$uname:$url".'_'."$mrole";                  "$udom:$uname:$url".'_'."$mrole";
    &logthis("$ENV{'user.name'} at $ENV{'user.domain'} deletes $mrole in $url for $uname at $udom");      &logthis("$env{'user.name'} at $env{'user.domain'} deletes $mrole in $url for $uname at $udom"); 
 # set start and finish to negative values for userrolelog  # set start and finish to negative values for userrolelog
            $start=-1;             $start=-1;
            $end=-1;             $end=-1;
              $delflag = 1;
         }          }
     }      }
 # send command  # send command
     my $answer=&reply($command,&homeserver($uname,$udom));      my $answer=&reply($command,&homeserver($uname,$udom));
 # log new user role if status is ok  # log new user role if status is ok
     if ($answer eq 'ok') {      if ($answer eq 'ok') {
  &userrolelog($mrole,$uname,$udom,$url,$start,$end);   &userrolelog($role,$uname,$udom,$url,$start,$end);
   # for course roles, perform group memberships changes triggered by role change.
           unless ($role =~ /^gr/) {
               &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend,
                                                $origstart,$selfenroll,$context);
           }
           if (($role eq 'cc') || ($role eq 'in') ||
               ($role eq 'ep') || ($role eq 'ad') ||
               ($role eq 'ta') || ($role eq 'st') ||
               ($role=~/^cr/) || ($role eq 'gr') ||
               ($role eq 'co')) {
               &courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
                              $selfenroll,$context);
           } elsif (($role eq 'li') || ($role eq 'dg') || ($role eq 'sc') ||
                    ($role eq 'au') || ($role eq 'dc')) {
               &domainrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
                              $context);
           } elsif (($role eq 'ca') || ($role eq 'aa')) {
               &coauthorrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
                                $context); 
           }
           if ($role eq 'cc') {
               &autoupdate_coowners($url,$end,$start,$uname,$udom);
           }
     }      }
     return $answer;      return $answer;
 }  }
   
   sub autoupdate_coowners {
       my ($url,$end,$start,$uname,$udom) = @_;
       my ($cdom,$cnum) = ($url =~ m{^/($match_domain)/($match_courseid)});
       if (($cdom ne '') && ($cnum ne '')) {
           my $now = time;
           my %domdesign = &Apache::loncommon::get_domainconf($cdom);
           if ($domdesign{$cdom.'.autoassign.co-owners'}) {
               my %coursehash = &coursedescription($cdom.'_'.$cnum);
               my $instcode = $coursehash{'internal.coursecode'};
               if ($instcode ne '') {
                   if (($start && $start <= $now) && ($end == 0) || ($end > $now)) {
                       unless ($coursehash{'internal.courseowner'} eq $uname.':'.$udom) {
                           my ($delcoowners,@newcoowners,$putresult,$delresult,$coowners);
                           my ($result,$desc) = &auto_validate_instcode($cnum,$cdom,$instcode,$uname.':'.$udom);
                           if ($result eq 'valid') {
                               if ($coursehash{'internal.co-owners'}) {
                                   foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) {
                                       push(@newcoowners,$coowner);
                                   }
                                   unless (grep(/^\Q$uname\E:\Q$udom\E$/,@newcoowners)) {
                                       push(@newcoowners,$uname.':'.$udom);
                                   }
                                   @newcoowners = sort(@newcoowners);
                               } else {
                                   push(@newcoowners,$uname.':'.$udom);
                               }
                           } else {
                               if ($coursehash{'internal.co-owners'}) {
                                   foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) {
                                       unless ($coowner eq $uname.':'.$udom) {
                                           push(@newcoowners,$coowner);
                                       }
                                   }
                                   unless (@newcoowners > 0) {
                                       $delcoowners = 1;
                                       $coowners = '';
                                   }
                               }
                           }
                           if (@newcoowners || $delcoowners) {
                               &store_coowners($cdom,$cnum,$coursehash{'home'},
                                               $delcoowners,@newcoowners);
                           }
                       }
                   }
               }
           }
       }
   }
   
   sub store_coowners {
       my ($cdom,$cnum,$chome,$delcoowners,@newcoowners) = @_;
       my $cid = $cdom.'_'.$cnum;
       my ($coowners,$delresult,$putresult);
       if (@newcoowners) {
           $coowners = join(',',@newcoowners);
           my %coownershash = (
                               'internal.co-owners' => $coowners,
                              );
           $putresult = &put('environment',\%coownershash,$cdom,$cnum);
           if ($putresult eq 'ok') {
               if ($env{'course.'.$cid.'.num'} eq $cnum) {
                   &appenv({'course.'.$cid.'.internal.co-owners' => $coowners});
               }
           }
       }
       if ($delcoowners) {
           $delresult = &Apache::lonnet::del('environment',['internal.co-owners'],$cdom,$cnum);
           if ($delresult eq 'ok') {
               if ($env{'course.'.$cid.'.internal.co-owners'}) {
                   &Apache::lonnet::delenv('course.'.$cid.'.internal.co-owners');
               }
           }
       }
       if (($putresult eq 'ok') || ($delresult eq 'ok')) {
           my %crsinfo =
               &Apache::lonnet::courseiddump($cdom,'.',1,'.','.',$cnum,undef,undef,'.');
           if (ref($crsinfo{$cid}) eq 'HASH') {
               $crsinfo{$cid}{'co-owners'} = \@newcoowners;
               my $cidput = &Apache::lonnet::courseidput($cdom,\%crsinfo,$chome,'notime');
           }
       }
   }
   
 # -------------------------------------------------- Modify user authentication  # -------------------------------------------------- Modify user authentication
 # Overrides without validation  # Overrides without validation
   
Line 3449  sub modifyuserauth { Line 7761  sub modifyuserauth {
     my $uhome=&homeserver($uname,$udom);      my $uhome=&homeserver($uname,$udom);
     unless (&allowed('mau',$udom)) { return 'refused'; }      unless (&allowed('mau',$udom)) { return 'refused'; }
     &logthis('Call to modify user authentication '.$udom.', '.$uname.', '.      &logthis('Call to modify user authentication '.$udom.', '.$uname.', '.
              $umode.' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}.               $umode.' by '.$env{'user.name'}.' at '.$env{'user.domain'}.
              ' in domain '.$ENV{'request.role.domain'});                 ' in domain '.$env{'request.role.domain'});  
     my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'.      my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'.
      &escape($upass),$uhome);       &escape($upass),$uhome);
     &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.home'},      &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},
         'Authentication changed for '.$udom.', '.$uname.', '.$umode.          'Authentication changed for '.$udom.', '.$uname.', '.$umode.
          '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply);           '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply);
     &log($udom,,$uname,$uhome,      &log($udom,,$uname,$uhome,
         'Authentication changed by '.$ENV{'user.domain'}.', '.          'Authentication changed by '.$env{'user.domain'}.', '.
                                      $ENV{'user.name'}.', '.$umode.                                       $env{'user.name'}.', '.$umode.
          '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply);           '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply);
     unless ($reply eq 'ok') {      unless ($reply eq 'ok') {
         &logthis('Authentication mode error: '.$reply);          &logthis('Authentication mode error: '.$reply);
Line 3473  sub modifyuser { Line 7785  sub modifyuser {
     my ($udom,    $uname, $uid,      my ($udom,    $uname, $uid,
         $umode,   $upass, $first,          $umode,   $upass, $first,
         $middle,  $last,  $gene,          $middle,  $last,  $gene,
         $forceid, $desiredhome, $email)=@_;          $forceid, $desiredhome, $email, $inststatus, $candelete)=@_;
     $udom=~s/\W//g;      $udom= &LONCAPA::clean_domain($udom);
     $uname=~s/\W//g;      $uname=&LONCAPA::clean_username($uname);
       my $showcandelete = 'none';
       if (ref($candelete) eq 'ARRAY') {
           if (@{$candelete} > 0) {
               $showcandelete = join(', ',@{$candelete});
           }
       }
     &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.      &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
              $umode.', '.$first.', '.$middle.', '.               $umode.', '.$first.', '.$middle.', '.
      $last.', '.$gene.'(forceid: '.$forceid.')'.       $last.', '.$gene.'(forceid: '.$forceid.'; candelete: '.$showcandelete.')'.
              (defined($desiredhome) ? ' desiredhome = '.$desiredhome :               (defined($desiredhome) ? ' desiredhome = '.$desiredhome :
                                      ' desiredhome not specified').                                        ' desiredhome not specified'). 
              ' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}.               ' by '.$env{'user.name'}.' at '.$env{'user.domain'}.
              ' 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'))) {
         my $unhome='';          my $unhome='';
         if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) {           if (defined($desiredhome) && &host_domain($desiredhome) eq $udom) { 
             $unhome = $desiredhome;              $unhome = $desiredhome;
  } elsif($ENV{'course.'.$ENV{'request.course.id'}.'.domain'} eq $udom) {   } elsif($env{'course.'.$env{'request.course.id'}.'.domain'} eq $udom) {
     $unhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'};      $unhome=$env{'course.'.$env{'request.course.id'}.'.home'};
         } else { # load balancing routine for determining $unhome          } else { # load balancing routine for determining $unhome
             my $tryserver;  
             my $loadm=10000000;              my $loadm=10000000;
             foreach $tryserver (keys %libserv) {      my %servers = &get_servers($udom,'library');
        if ($hostdom{$tryserver} eq $udom) {      foreach my $tryserver (keys(%servers)) {
                   my $answer=reply('load',$tryserver);   my $answer=reply('load',$tryserver);
                   if (($answer=~/\d+/) && ($answer<$loadm)) {   if (($answer=~/\d+/) && ($answer<$loadm)) {
       $loadm=$answer;      $loadm=$answer;
                       $unhome=$tryserver;      $unhome=$tryserver;
                   }   }
        }  
     }      }
         }          }
         if (($unhome eq '') || ($unhome eq 'no_host')) {          if (($unhome eq '') || ($unhome eq 'no_host')) {
Line 3535  sub modifyuser { Line 7855  sub modifyuser {
     }      }
 # -------------------------------------------------------------- Add names, etc  # -------------------------------------------------------------- Add names, etc
     my @tmp=&get('environment',      my @tmp=&get('environment',
    ['firstname','middlename','lastname','generation'],     ['firstname','middlename','lastname','generation','id',
                       '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;
     }      }
 #  #
 # Make sure to not trash student environment if instructor does not bother  # If name, email and/or uid are blank (e.g., because an uploaded file
 # to supply name and email information  # of users did not contain them), do not overwrite existing values
 #  # unless field is in $candelete array ref.  
   #
   
       my @fields = ('firstname','middlename','lastname','generation',
                     'permanentemail','id');
       my %newvalues;
       if (ref($candelete) eq 'ARRAY') {
           foreach my $field (@fields) {
               if (grep(/^\Q$field\E$/,@{$candelete})) {
                   if ($field eq 'firstname') {
                       $names{$field} = $first;
                   } elsif ($field eq 'middlename') {
                       $names{$field} = $middle;
                   } elsif ($field eq 'lastname') {
                       $names{$field} = $last;
                   } elsif ($field eq 'generation') { 
                       $names{$field} = $gene;
                   } elsif ($field eq 'permanentemail') {
                       $names{$field} = $email;
                   } elsif ($field eq 'id') {
                       $names{$field}  = $uid;
                   }
               }
           }
       }
     if ($first)  { $names{'firstname'}  = $first; }      if ($first)  { $names{'firstname'}  = $first; }
     if (defined($middle)) { $names{'middlename'} = $middle; }      if (defined($middle)) { $names{'middlename'} = $middle; }
     if ($last)   { $names{'lastname'}   = $last; }      if ($last)   { $names{'lastname'}   = $last; }
     if (defined($gene))   { $names{'generation'} = $gene; }      if (defined($gene))   { $names{'generation'} = $gene; }
     if ($email)  { $names{'notification'} = $email;      if ($email) {
                    $names{'critnotification'} = $email; }         $email=~s/[^\w\@\.\-\,]//gs;
          if ($email=~/\@/) { $names{'permanentemail'} = $email; }
       }
       if ($uid) { $names{'id'}  = $uid; }
       if (defined($inststatus)) {
           $names{'inststatus'} = '';
           my ($usertypes,$typesorder) = &retrieve_inst_usertypes($udom);
           if (ref($usertypes) eq 'HASH') {
               my @okstatuses; 
               foreach my $item (split(/:/,$inststatus)) {
                   if (defined($usertypes->{$item})) {
                       push(@okstatuses,$item);  
                   }
               }
               if (@okstatuses) {
                   $names{'inststatus'} = join(':', map { &escape($_); } @okstatuses);
               }
           }
       }
       my $logmsg = $udom.', '.$uname.', '.$uid.', '.
                    $umode.', '.$first.', '.$middle.', '.
                    $last.', '.$gene.', '.$email.', '.$inststatus;
       if ($env{'user.name'} ne '' && $env{'user.domain'}) {
           $logmsg .= ' by '.$env{'user.name'}.' at '.$env{'user.domain'};
       } else {
           $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);      my $reply = &put('environment', \%names, $udom,$uname);
     if ($reply ne 'ok') { return 'error: '.$reply; }      if ($reply ne 'ok') { 
     &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.          return 'error: '.$reply;
              $umode.', '.$first.', '.$middle.', '.      }
      $last.', '.$gene.' by '.      if ($names{'permanentemail'} ne $oldnames{'permanentemail'}) {
              $ENV{'user.name'}.' at '.$ENV{'user.domain'});          &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);
     return 'ok';      return 'ok';
 }  }
   
Line 3567  sub modifyuser { Line 7959  sub modifyuser {
   
 sub modifystudent {  sub modifystudent {
     my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,      my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
         $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid)=@_;          $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid,
           $selfenroll,$context,$inststatus)=@_;
     if (!$cid) {      if (!$cid) {
  unless ($cid=$ENV{'request.course.id'}) {   unless ($cid=$env{'request.course.id'}) {
     return 'not_in_class';      return 'not_in_class';
  }   }
     }      }
 # --------------------------------------------------------------- Make the user  # --------------------------------------------------------------- Make the user
     my $reply=&modifyuser      my $reply=&modifyuser
  ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid,   ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid,
          $desiredhome,$email);           $desiredhome,$email,$inststatus);
     unless ($reply eq 'ok') { return $reply; }      unless ($reply eq 'ok') { return $reply; }
     # This will cause &modify_student_enrollment to get the uid from the      # This will cause &modify_student_enrollment to get the uid from the
     # students environment      # students environment
     $uid = undef if (!$forceid);      $uid = undef if (!$forceid);
     $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,      $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,
  $gene,$usec,$end,$start,$type,$locktype,$cid);   $gene,$usec,$end,$start,$type,$locktype,$cid,$selfenroll,$context);
     return $reply;      return $reply;
 }  }
   
 sub modify_student_enrollment {  sub modify_student_enrollment {
     my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid) = @_;      my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid,$selfenroll,$context) = @_;
     my ($cdom,$cnum,$chome);      my ($cdom,$cnum,$chome);
     if (!$cid) {      if (!$cid) {
  unless ($cid=$ENV{'request.course.id'}) {   unless ($cid=$env{'request.course.id'}) {
     return 'not_in_class';      return 'not_in_class';
  }   }
  $cdom=$ENV{'course.'.$cid.'.domain'};   $cdom=$env{'course.'.$cid.'.domain'};
  $cnum=$ENV{'course.'.$cid.'.num'};   $cnum=$env{'course.'.$cid.'.num'};
     } else {      } else {
  ($cdom,$cnum)=split(/_/,$cid);   ($cdom,$cnum)=split(/_/,$cid);
     }      }
     $chome=$ENV{'course.'.$cid.'.home'};      $chome=$env{'course.'.$cid.'.home'};
     if (!$chome) {      if (!$chome) {
  $chome=&homeserver($cnum,$cdom);   $chome=&homeserver($cnum,$cdom);
     }      }
Line 3620  sub modify_student_enrollment { Line 8013  sub modify_student_enrollment {
                        ['firstname','middlename','lastname', 'generation','id']                         ['firstname','middlename','lastname', 'generation','id']
                        ,$udom,$uname);                         ,$udom,$uname);
   
         #foreach (keys(%tmp)) {          #foreach my $key (keys(%tmp)) {
         #    &logthis("key $_ = ".$tmp{$_});          #    &logthis("key $key = ".$tmp{$key});
         #}          #}
         $first  = $tmp{'firstname'}  if (!defined($first)  || $first  eq '');          $first  = $tmp{'firstname'}  if (!defined($first)  || $first  eq '');
         $middle = $tmp{'middlename'} if (!defined($middle) || $middle eq '');          $middle = $tmp{'middlename'} if (!defined($middle) || $middle eq '');
Line 3630  sub modify_student_enrollment { Line 8023  sub modify_student_enrollment {
         $uid    = $tmp{'id'}         if (!defined($uid)    || $uid  eq '');          $uid    = $tmp{'id'}         if (!defined($uid)    || $uid  eq '');
     }      }
     my $fullname = &format_name($first,$middle,$last,$gene,'lastname');      my $fullname = &format_name($first,$middle,$last,$gene,'lastname');
       my $user = "$uname:$udom";
       my %old_entry = &Apache::lonnet::get('classlist',[$user],$cdom,$cnum);
     my $reply=cput('classlist',      my $reply=cput('classlist',
    {"$uname:$udom" =>      {$user => 
  join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) },   join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) },
    $cdom,$cnum);     $cdom,$cnum);
     unless (($reply eq 'ok') || ($reply eq 'delayed')) {      if (($reply eq 'ok') || ($reply eq 'delayed')) {
           &devalidate_getsection_cache($udom,$uname,$cid);
       } else { 
  return 'error: '.$reply;   return 'error: '.$reply;
     }      }
     # Add student role to user      # Add student role to user
Line 3643  sub modify_student_enrollment { Line 8040  sub modify_student_enrollment {
     if ($usec) {      if ($usec) {
  $uurl.='/'.$usec;   $uurl.='/'.$usec;
     }      }
     return &assignrole($udom,$uname,$uurl,'st',$end,$start);      my $result = &assignrole($udom,$uname,$uurl,'st',$end,$start,undef,
                                $selfenroll,$context);
       if ($result ne 'ok') {
           if ($old_entry{$user} ne '') {
               $reply = &cput('classlist',\%old_entry,$cdom,$cnum);
           } else {
               $reply = &del('classlist',[$user],$cdom,$cnum);
           }
       }
       return $result; 
 }  }
   
 sub format_name {  sub format_name {
Line 3677  sub writecoursepref { Line 8083  sub writecoursepref {
  return 'error: no such course';   return 'error: no such course';
     }      }
     my $cstring='';      my $cstring='';
     foreach (keys %prefs) {      foreach my $pref (keys(%prefs)) {
  $cstring.=escape($_).'='.escape($prefs{$_}).'&';   $cstring.=&escape($pref).'='.&escape($prefs{$pref}).'&';
     }      }
     $cstring=~s/\&$//;      $cstring=~s/\&$//;
     return reply('put:'.$cdomain.':'.$cnum.':environment:'.$cstring,$chome);      return reply('put:'.$cdomain.':'.$cnum.':environment:'.$cstring,$chome);
Line 3687  sub writecoursepref { Line 8093  sub writecoursepref {
 # ---------------------------------------------------------- Make/modify course  # ---------------------------------------------------------- Make/modify course
   
 sub createcourse {  sub createcourse {
     my ($udom,$description,$url,$course_server,$nonstandard,$inst_code)=@_;      my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,
           $course_owner,$crstype,$cnum,$context,$category)=@_;
     $url=&declutter($url);      $url=&declutter($url);
     my $cid='';      my $cid='';
     unless (&allowed('ccc',$udom)) {      if ($context eq 'requestcourses') {
           my $can_create = 0;
           my ($ownername,$ownerdom) = split(':',$course_owner);
           if ($udom eq $ownerdom) {
               if (&usertools_access($ownername,$ownerdom,$category,undef,
                                     $context)) {
                   $can_create = 1;
               }
           } else {
               my %userenv = &userenvironment($ownerdom,$ownername,'reqcrsotherdom.'.
                                              $category);
               if ($userenv{'reqcrsotherdom.'.$category} ne '') {
                   my @curr = split(',',$userenv{'reqcrsotherdom.'.$category});
                   if (@curr > 0) {
                       my @options = qw(approval validate autolimit);
                       my $optregex = join('|',@options);
                       if (grep(/^\Q$udom\E:($optregex)(=?\d*)$/,@curr)) {
                           $can_create = 1;
                       }
                   }
               }
           }
           if ($can_create) {
               unless ($ownername eq $env{'user.name'} && $ownerdom eq $env{'user.domain'}) {
                   unless (&allowed('ccc',$udom)) {
                       return 'refused'; 
                   }
               }
           } else {
               return 'refused';
           }
       } elsif (!&allowed('ccc',$udom)) {
         return 'refused';          return 'refused';
     }      }
 # ------------------------------------------------------------------- Create ID  # --------------------------------------------------------------- Get Unique ID
    my $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).      my $uname;
        unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};      if ($cnum =~ /^$match_courseid$/) {
 # ----------------------------------------------- Make sure that does not exist          my $chome=&homeserver($cnum,$udom,'true');
    my $uhome=&homeserver($uname,$udom,'true');          if (($chome eq '') || ($chome eq 'no_host')) {
    unless (($uhome eq '') || ($uhome eq 'no_host')) {              $uname = $cnum;
        $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).          } else {
         unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};              $uname = &generate_coursenum($udom,$crstype);
        $uhome=&homeserver($uname,$udom,'true');                 }
        unless (($uhome eq '') || ($uhome eq 'no_host')) {      } else {
            return 'error: unable to generate unique course-ID';          $uname = &generate_coursenum($udom,$crstype);
        }       }
    }      return $uname if ($uname =~ /^error/);
 # ------------------------------------------------ Check supplied server name  # -------------------------------------------------- Check supplied server name
     $course_server = $ENV{'user.homeserver'} if (! defined($course_server));      if (!defined($course_server)) {
     if (! exists($libserv{$course_server})) {          if (defined(&domain($udom,'primary'))) {
         return 'error:bad server name '.$course_server;              $course_server = &domain($udom,'primary');
           } else {
               $course_server = $env{'user.home'}; 
           }
       }
       my %host_servers =
           &Apache::lonnet::get_servers($udom,'library');
       unless ($host_servers{$course_server}) {
           return 'error: invalid home server for course: '.$course_server;
     }      }
 # ------------------------------------------------------------- Make the course  # ------------------------------------------------------------- Make the course
     my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',      my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',
                       $course_server);                        $course_server);
     unless ($reply eq 'ok') { return 'error: '.$reply; }      unless ($reply eq 'ok') { return 'error: '.$reply; }
     $uhome=&homeserver($uname,$udom,'true');      my $uhome=&homeserver($uname,$udom,'true');
     if (($uhome eq '') || ($uhome eq 'no_host')) {       if (($uhome eq '') || ($uhome eq 'no_host')) { 
  return 'error: no such course';   return 'error: no such course';
     }      }
 # ----------------------------------------------------------------- Course made  # ----------------------------------------------------------------- Course made
 # log existence  # log existence
     &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description).      my $now = time;
                  '='.&escape($inst_code),$uhome);      my $newcourse = {
     &flushcourselogs();                      $udom.'_'.$uname => {
                                        description => $description,
                                        inst_code   => $inst_code,
                                        owner       => $course_owner,
                                        type        => $crstype,
                                        creator     => $env{'user.name'}.':'.
                                                       $env{'user.domain'},
                                        created     => $now,
                                        context     => $context,
                                                   },
                       };
       &courseidput($udom,$newcourse,$uhome,'notime');
 # set toplevel url  # set toplevel url
     my $topurl=$url;      my $topurl=$url;
     unless ($nonstandard) {      unless ($nonstandard) {
 # ------------------------------------------ For standard courses, make top url  # ------------------------------------------ For standard courses, make top url
         my $mapurl=&clutter($url);          my $mapurl=&clutter($url);
         if ($mapurl eq '/res/') { $mapurl=''; }          if ($mapurl eq '/res/') { $mapurl=''; }
         $ENV{'form.initmap'}=(<<ENDINITMAP);          $env{'form.initmap'}=(<<ENDINITMAP);
 <map>  <map>
 <resource id="1" type="start"></resource>  <resource id="1" type="start"></resource>
 <resource id="2" src="$mapurl"></resource>  <resource id="2" src="$mapurl"></resource>
Line 3740  sub createcourse { Line 8197  sub createcourse {
 </map>  </map>
 ENDINITMAP  ENDINITMAP
         $topurl=&declutter(          $topurl=&declutter(
         &finishuserfileupload($uname,$udom,$uhome,'initmap','default.sequence')          &finishuserfileupload($uname,$udom,'initmap','default.sequence')
                           );                            );
     }      }
 # ----------------------------------------------------------- Write preferences  # ----------------------------------------------------------- Write preferences
     &writecoursepref($udom.'_'.$uname,      &writecoursepref($udom.'_'.$uname,
                      ('description' => $description,                       ('description'              => $description,
                       'url'         => $topurl));                        'url'                      => $topurl,
                         'internal.creator'         => $env{'user.name'}.':'.
                                                       $env{'user.domain'},
                         'internal.created'         => $now,
                         'internal.creationcontext' => $context)
                       );
     return '/'.$udom.'/'.$uname;      return '/'.$udom.'/'.$uname;
 }  }
   
   # ------------------------------------------------------------------- Create ID
   sub generate_coursenum {
       my ($udom,$crstype) = @_;
       my $domdesc = &domain($udom);
       return 'error: invalid domain' if ($domdesc eq '');
       my $first;
       if ($crstype eq 'Community') {
           $first = '0';
       } else {
           $first = int(1+rand(9)); 
       } 
       my $uname=$first.
           ('a'..'z','A'..'Z','0'..'9')[int(rand(62))].
           substr($$.time,0,5).unpack("H8",pack("I32",time)).
           unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
   # ----------------------------------------------- Make sure that does not exist
       my $uhome=&homeserver($uname,$udom,'true');
       unless (($uhome eq '') || ($uhome eq 'no_host')) {
           if ($crstype eq 'Community') {
               $first = '0';
           } else {
               $first = int(1+rand(9));
           }
           $uname=$first.
                  ('a'..'z','A'..'Z','0'..'9')[int(rand(62))].
                  substr($$.time,0,5).unpack("H8",pack("I32",time)).
                  unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
           $uhome=&homeserver($uname,$udom,'true');
           unless (($uhome eq '') || ($uhome eq 'no_host')) {
               return 'error: unable to generate unique course-ID';
           }
       }
       return $uname;
   }
   
   sub is_course {
       my ($cdom, $cnum) = scalar(@_) == 1 ? 
            ($_[0] =~ /^($match_domain)_($match_courseid)$/)  :  @_;
   
       return unless $cdom and $cnum;
   
       my %courses = &courseiddump($cdom, '.', 1, '.', '.', $cnum, undef, undef,
           '.');
   
       return unless exists($courses{$cdom.'_'.$cnum});
       return wantarray ? ($cdom, $cnum) : $cdom.'_'.$cnum;
   }
   
   sub store_userdata {
       my ($storehash,$datakey,$namespace,$udom,$uname) = @_;
       my $result;
       if ($datakey ne '') {
           if (ref($storehash) eq 'HASH') {
               if ($udom eq '' || $uname eq '') {
                   $udom = $env{'user.domain'};
                   $uname = $env{'user.name'};
               }
               my $uhome=&homeserver($uname,$udom);
               if (($uhome eq '') || ($uhome eq 'no_host')) {
                   $result = 'error: no_host';
               } else {
                   $storehash->{'ip'} = $ENV{'REMOTE_ADDR'};
                   $storehash->{'host'} = $perlvar{'lonHostID'};
   
                   my $namevalue='';
                   foreach my $key (keys(%{$storehash})) {
                       $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
                   }
                   $namevalue=~s/\&$//;
                   $result =  &reply("store:$udom:$uname:$namespace:$datakey:".
                                     $namevalue,$uhome);
               }
           } else {
               $result = 'error: data to store was not a hash reference'; 
           }
       } else {
           $result= 'error: invalid requestkey'; 
       }
       return $result;
   }
   
 # ---------------------------------------------------------- Assign Custom Role  # ---------------------------------------------------------- Assign Custom Role
   
 sub assigncustomrole {  sub assigncustomrole {
     my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag)=@_;      my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag,$selfenroll,$context)=@_;
     return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename,      return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename,
                        $end,$start,$deleteflag);                         $end,$start,$deleteflag,$selfenroll,$context);
 }  }
   
 # ----------------------------------------------------------------- Revoke Role  # ----------------------------------------------------------------- Revoke Role
   
 sub revokerole {  sub revokerole {
     my ($udom,$uname,$url,$role,$deleteflag)=@_;      my ($udom,$uname,$url,$role,$deleteflag,$selfenroll,$context)=@_;
     my $now=time;      my $now=time;
     return &assignrole($udom,$uname,$url,$role,$now,$deleteflag);      return &assignrole($udom,$uname,$url,$role,$now,undef,$deleteflag,$selfenroll,$context);
 }  }
   
 # ---------------------------------------------------------- Revoke Custom Role  # ---------------------------------------------------------- Revoke Custom Role
   
 sub revokecustomrole {  sub revokecustomrole {
     my ($udom,$uname,$url,$rdom,$rnam,$rolename,$deleteflag)=@_;      my ($udom,$uname,$url,$rdom,$rnam,$rolename,$deleteflag,$selfenroll,$context)=@_;
     my $now=time;      my $now=time;
     return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now,      return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now,
            $deleteflag);             $deleteflag,$selfenroll,$context);
 }  }
   
 # ------------------------------------------------------------ Disk usage  # ------------------------------------------------------------ Disk usage
 sub diskusage {  sub diskusage {
     my ($udom,$uname,$directoryRoot)=@_;      my ($udom,$uname,$directorypath,$getpropath)=@_;
     $directoryRoot =~ s/\/$//;      $directorypath =~ s/\/$//;
     my $listing=&reply('du:'.$directoryRoot,homeserver($uname,$udom));      my $listing=&reply('du2:'.&escape($directorypath).':'
                          .&escape($getpropath).':'.&escape($uname).':'
                          .&escape($udom),homeserver($uname,$udom));
       if ($listing eq 'unknown_cmd') {
           if ($getpropath) {
               $directorypath = &propath($udom,$uname).'/'.$directorypath; 
           }
           $listing = &reply('du:'.$directorypath,homeserver($uname,$udom));
       }
     return $listing;      return $listing;
 }  }
   
 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 = &Apache::lonnet::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);
       if ($tmp=~/^error:/) { undef(%locked); }
       
     if (ref($locked{$file_name}) eq 'ARRAY') {      if (ref($locked{$file_name}) eq 'ARRAY') {
         $is_locked = 'true';          $is_locked = 'false';
           foreach my $entry (@{$locked{$file_name}}) {
              if (ref($entry) eq 'ARRAY') {
                  $is_locked = 'true';
                  if (ref($which) eq 'ARRAY') {
                      push(@{$which},$entry);
                  } else {
                      last;
                  }
              }
          }
     } else {      } else {
         $is_locked = 'false';          $is_locked = 'false';
     }      }
       return $is_locked;
   }
   
   sub declutter_portfile {
       my ($file) = @_;
       $file =~ s{^(/portfolio/|portfolio/)}{/};
       return $file;
 }  }
   
 # ------------------------------------------------------------- Mark as Read Only  # ------------------------------------------------------------- Mark as Read Only
   
 sub mark_as_readonly {  sub mark_as_readonly {
     my ($domain,$user,$files,$what) = @_;      my ($domain,$user,$files,$what) = @_;
     my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user);      my %current_permissions = &dump('file_permissions',$domain,$user);
       my ($tmp)=keys(%current_permissions);
       if ($tmp=~/^error:/) { undef(%current_permissions); }
     foreach my $file (@{$files}) {      foreach my $file (@{$files}) {
    $file = &declutter_portfile($file);
         push(@{$current_permissions{$file}},$what);          push(@{$current_permissions{$file}},$what);
     }      }
     &Apache::lonnet::put('file_permissions',\%current_permissions,$domain,$user);      &put('file_permissions',\%current_permissions,$domain,$user);
     return;      return;
 }  }
   
 #--------------------------------------------------------------Get Marked as Read Only  # ------------------------------------------------------------Save Selected Files
   
   sub save_selected_files {
       my ($user, $path, @files) = @_;
       my $filename = $user."savedfiles";
       my @other_files = &files_not_in_path($user, $path);
       open (OUT, '>'.$tmpdir.$filename);
       foreach my $file (@files) {
           print (OUT $env{'form.currentpath'}.$file."\n");
       }
       foreach my $file (@other_files) {
           print (OUT $file."\n");
       }
       close (OUT);
       return 'ok';
   }
   
   sub clear_selected_files {
       my ($user) = @_;
       my $filename = $user."savedfiles";
       open (OUT, '>'.LONCAPA::tempdir().$filename);
       print (OUT undef);
       close (OUT);
       return ("ok");    
   }
   
   sub files_in_path {
       my ($user, $path) = @_;
       my $filename = $user."savedfiles";
       my %return_files;
       open (IN, '<'.LONCAPA::tempdir().$filename);
       while (my $line_in = <IN>) {
           chomp ($line_in);
           my @paths_and_file = split (m!/!, $line_in);
           my $file_part = pop (@paths_and_file);
           my $path_part = join ('/', @paths_and_file);
           $path_part.='/';
           my $path_and_file = $path_part.$file_part;
           if ($path_part eq $path) {
               $return_files{$file_part}= 'selected';
           }
       }
       close (IN);
       return (\%return_files);
   }
   
   # called in portfolio select mode, to show files selected NOT in current directory
   sub files_not_in_path {
       my ($user, $path) = @_;
       my $filename = $user."savedfiles";
       my @return_files;
       my $path_part;
       open(IN, '<'.LONCAPA::.$filename);
       while (my $line = <IN>) {
           #ok, I know it's clunky, but I want it to work
           my @paths_and_file = split(m|/|, $line);
           my $file_part = pop(@paths_and_file);
           chomp($file_part);
           my $path_part = join('/', @paths_and_file);
           $path_part .= '/';
           my $path_and_file = $path_part.$file_part;
           if ($path_part ne $path) {
               push(@return_files, ($path_and_file));
           }
       }
       close(OUT);
       return (@return_files);
   }
   
   #----------------------------------------------Get portfolio file permissions
   
   sub get_portfile_permissions {
       my ($domain,$user) = @_;
       my %current_permissions = &dump('file_permissions',$domain,$user);
       my ($tmp)=keys(%current_permissions);
       if ($tmp=~/^error:/) { undef(%current_permissions); }
       return \%current_permissions;
   }
   
   #---------------------------------------------Get portfolio file access controls
   
   sub get_access_controls {
       my ($current_permissions,$group,$file) = @_;
       my %access;
       my $real_file = $file;
       $file =~ s/\.meta$//;
       if (defined($file)) {
           if (ref($$current_permissions{$file."\0".'accesscontrol'}) eq 'HASH') {
               foreach my $control (keys(%{$$current_permissions{$file."\0".'accesscontrol'}})) {
                   $access{$real_file}{$control} = $$current_permissions{$file."\0".$control};
               }
           }
       } else {
           foreach my $key (keys(%{$current_permissions})) {
               if ($key =~ /\0accesscontrol$/) {
                   if (defined($group)) {
                       if ($key !~ m-^\Q$group\E/-) {
                           next;
                       }
                   }
                   my ($fullpath) = split(/\0/,$key);
                   if (ref($$current_permissions{$key}) eq 'HASH') {
                       foreach my $control (keys(%{$$current_permissions{$key}})) {
                           $access{$fullpath}{$control}=$$current_permissions{$fullpath."\0".$control};
                       }
                   }
               }
           }
       }
       return %access;
   }
   
   sub modify_access_controls {
       my ($file_name,$changes,$domain,$user)=@_;
       my ($outcome,$deloutcome);
       my %store_permissions;
       my %new_values;
       my %new_control;
       my %translation;
       my @deletions = ();
       my $now = time;
       if (exists($$changes{'activate'})) {
           if (ref($$changes{'activate'}) eq 'HASH') {
               my @newitems = sort(keys(%{$$changes{'activate'}}));
               my $numnew = scalar(@newitems);
               for (my $i=0; $i<$numnew; $i++) {
                   my $newkey = $newitems[$i];
                   my $newid = &Apache::loncommon::get_cgi_id();
                   if ($newkey =~ /^\d+:/) { 
                       $newkey =~ s/^(\d+)/$newid/;
                       $translation{$1} = $newid;
                   } elsif ($newkey =~ /^\d+_\d+_\d+:/) {
                       $newkey =~ s/^(\d+_\d+_\d+)/$newid/;
                       $translation{$1} = $newid;
                   }
                   $new_values{$file_name."\0".$newkey} = 
                                             $$changes{'activate'}{$newitems[$i]};
                   $new_control{$newkey} = $now;
               }
           }
       }
       my %todelete;
       my %changed_items;
       foreach my $action ('delete','update') {
           if (exists($$changes{$action})) {
               if (ref($$changes{$action}) eq 'HASH') {
                   foreach my $key (keys(%{$$changes{$action}})) {
                       my ($itemnum) = ($key =~ /^([^:]+):/);
                       if ($action eq 'delete') { 
                           $todelete{$itemnum} = 1;
                       } else {
                           $changed_items{$itemnum} = $key;
                       }
                   }
               }
           }
       }
       # get lock on access controls for file.
       my $lockhash = {
                     $file_name."\0".'locked_access_records' => $env{'user.name'}.
                                                          ':'.$env{'user.domain'},
                      }; 
       my $tries = 0;
       my $gotlock = &newput('file_permissions',$lockhash,$domain,$user);
      
       while (($gotlock ne 'ok') && $tries <3) {
           $tries ++;
           sleep 1;
           $gotlock = &newput('file_permissions',$lockhash,$domain,$user);
       }
       if ($gotlock eq 'ok') {
           my %curr_permissions = &dump('file_permissions',$domain,$user,$file_name);
           my ($tmp)=keys(%curr_permissions);
           if ($tmp=~/^error:/) { undef(%curr_permissions); }
           if (exists($curr_permissions{$file_name."\0".'accesscontrol'})) {
               my $curr_controls = $curr_permissions{$file_name."\0".'accesscontrol'};
               if (ref($curr_controls) eq 'HASH') {
                   foreach my $control_item (keys(%{$curr_controls})) {
                       my ($itemnum) = ($control_item =~ /^([^:]+):/);
                       if (defined($todelete{$itemnum})) {
                           push(@deletions,$file_name."\0".$control_item);
                       } else {
                           if (defined($changed_items{$itemnum})) {
                               $new_control{$changed_items{$itemnum}} = $now;
                               push(@deletions,$file_name."\0".$control_item);
                               $new_values{$file_name."\0".$changed_items{$itemnum}} = $$changes{'update'}{$changed_items{$itemnum}};
                           } else {
                               $new_control{$control_item} = $$curr_controls{$control_item};
                           }
                       }
                   }
               }
           }
           my ($group);
           if (&is_course($domain,$user)) {
               ($group,my $file) = split(/\//,$file_name,2);
           }
           $deloutcome = &del('file_permissions',\@deletions,$domain,$user);
           $new_values{$file_name."\0".'accesscontrol'} = \%new_control;
           $outcome = &put('file_permissions',\%new_values,$domain,$user);
           #  remove lock
           my @del_lock = ($file_name."\0".'locked_access_records');
           my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user);
           my $sqlresult =
               &update_portfolio_table($user,$domain,$file_name,'portfolio_access',
                                       $group);
       } else {
           $outcome = "error: could not obtain lockfile\n";  
       }
       return ($outcome,$deloutcome,\%new_values,\%translation);
   }
   
   sub make_public_indefinitely {
       my ($requrl) = @_;
       my $now = time;
       my $action = 'activate';
       my $aclnum = 0;
       if (&is_portfolio_url($requrl)) {
           my (undef,$udom,$unum,$file_name,$group) =
               &parse_portfolio_url($requrl);
           my $current_perms = &get_portfile_permissions($udom,$unum);
           my %access_controls = &get_access_controls($current_perms,
                                                      $group,$file_name);
           foreach my $key (keys(%{$access_controls{$file_name}})) {
               my ($num,$scope,$end,$start) = 
                   ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/);
               if ($scope eq 'public') {
                   if ($start <= $now && $end == 0) {
                       $action = 'none';
                   } else {
                       $action = 'update';
                       $aclnum = $num;
                   }
                   last;
               }
           }
           if ($action eq 'none') {
                return 'ok';
           } else {
               my %changes;
               my $newend = 0;
               my $newstart = $now;
               my $newkey = $aclnum.':public_'.$newend.'_'.$newstart;
               $changes{$action}{$newkey} = {
                   type => 'public',
                   time => {
                       start => $newstart,
                       end   => $newend,
                   },
               };
               my ($outcome,$deloutcome,$new_values,$translation) =
                   &modify_access_controls($file_name,\%changes,$udom,$unum);
               return $outcome;
           }
       } else {
           return 'invalid';
       }
   }
   
   #------------------------------------------------------Get Marked as Read Only
   
 sub get_marked_as_readonly {  sub get_marked_as_readonly {
     my ($domain,$user,$what) = @_;      my ($domain,$user,$what,$group) = @_;
     my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user);      my $current_permissions = &get_portfile_permissions($domain,$user);
     my @readonly_files;      my @readonly_files;
     while (my ($file_name,$value) = each(%current_permissions)) {      my $cmp1=$what;
       if (ref($what)) { $cmp1=join('',@{$what}) };
       while (my ($file_name,$value) = each(%{$current_permissions})) {
           if (defined($group)) {
               if ($file_name !~ m-^\Q$group\E/-) {
                   next;
               }
           }
         if (ref($value) eq "ARRAY"){          if (ref($value) eq "ARRAY"){
             foreach my $stored_what (@{$value}) {              foreach my $stored_what (@{$value}) {
                 if ($stored_what eq $what) {                  my $cmp2=$stored_what;
                   if (ref($stored_what) eq 'ARRAY') {
                       $cmp2=join('',@{$stored_what});
                   }
                   if ($cmp1 eq $cmp2) {
                     push(@readonly_files, $file_name);                      push(@readonly_files, $file_name);
                       last;
                 } elsif (!defined($what)) {                  } elsif (!defined($what)) {
                     push(@readonly_files, $file_name);                      push(@readonly_files, $file_name);
                       last;
                 }                  }
             }              }
         }           }
     }      }
     return @readonly_files;      return @readonly_files;
 }  }
   #-----------------------------------------------------------Get Marked as Read Only Hash
   
   sub get_marked_as_readonly_hash {
       my ($current_permissions,$group,$what) = @_;
       my %readonly_files;
       while (my ($file_name,$value) = each(%{$current_permissions})) {
           if (defined($group)) {
               if ($file_name !~ m-^\Q$group\E/-) {
                   next;
               }
           }
           if (ref($value) eq "ARRAY"){
               foreach my $stored_what (@{$value}) {
                   if (ref($stored_what) eq 'ARRAY') {
                       foreach my $lock_descriptor(@{$stored_what}) {
                           if ($lock_descriptor eq 'graded') {
                               $readonly_files{$file_name} = 'graded';
                           } elsif ($lock_descriptor eq 'handback') {
                               $readonly_files{$file_name} = 'handback';
                           } else {
                               if (!exists($readonly_files{$file_name})) {
                                   $readonly_files{$file_name} = 'locked';
                               }
                           }
                       }
                   } 
               }
           } 
       }
       return %readonly_files;
   }
 # ------------------------------------------------------------ Unmark as Read Only  # ------------------------------------------------------------ Unmark as Read Only
   
 sub unmark_as_readonly {  sub unmark_as_readonly {
     # unmarks all files locked by $what       # unmarks $file_name (if $file_name is defined), or all files locked by $what 
     # for portfolio submissions, $what contains $crsid and $symb      # for portfolio submissions, $what contains [$symb,$crsid] 
     my ($domain,$user,$what) = @_;      my ($domain,$user,$what,$file_name,$group) = @_;
     my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user);      $file_name = &declutter_portfile($file_name);
     my @readonly_files = &Apache::lonnet::get_marked_as_readonly($domain,$user,$what);      my $symb_crs = $what;
     foreach my $file(@readonly_files){      if (ref($what)) { $symb_crs=join('',@$what); }
         my $current_locks = $current_permissions{$file};      my %current_permissions = &dump('file_permissions',$domain,$user,$group);
       my ($tmp)=keys(%current_permissions);
       if ($tmp=~/^error:/) { undef(%current_permissions); }
       my @readonly_files = &get_marked_as_readonly($domain,$user,$what,$group);
       foreach my $file (@readonly_files) {
    my $clean_file = &declutter_portfile($file);
    if (defined($file_name) && ($file_name ne $clean_file)) { next; }
    my $current_locks = $current_permissions{$file};
         my @new_locks;          my @new_locks;
         my @del_keys;          my @del_keys;
         if (ref($current_locks) eq "ARRAY"){          if (ref($current_locks) eq "ARRAY"){
             foreach my $locker (@{$current_locks}) {              foreach my $locker (@{$current_locks}) {
                 unless ($locker eq $what) {                  my $compare=$locker;
                     push(@new_locks, $what);                  if (ref($locker) eq 'ARRAY') {
                       $compare=join('',@{$locker});
                       if ($compare ne $symb_crs) {
                           push(@new_locks, $locker);
                       }
                 }                  }
             }              }
             if (@new_locks > 0) {              if (scalar(@new_locks) > 0) {
                 $current_permissions{$file} = \@new_locks;                  $current_permissions{$file} = \@new_locks;
             } else {              } else {
                 push(@del_keys, $file);                  push(@del_keys, $file);
                 &Apache::lonnet::del('file_permissions',\@del_keys, $domain, $user);                  &del('file_permissions',\@del_keys, $domain, $user);
                 delete $current_permissions{$file};                  delete($current_permissions{$file});
             }              }
         }          }
     }      }
     &Apache::lonnet::put('file_permissions',\%current_permissions,$domain,$user);      &put('file_permissions',\%current_permissions,$domain,$user);
     return;      return;
 }  }
   
 # ------------------------------------------------------------ Directory lister  # ------------------------------------------------------------ Directory lister
   
 sub dirlist {  sub dirlist {
     my ($uri,$userdomain,$username,$alternateDirectoryRoot)=@_;      my ($uri,$userdomain,$username,$getpropath,$getuserdir,$alternateRoot)=@_;
   
     $uri=~s/^\///;      $uri=~s/^\///;
     $uri=~s/\/$//;      $uri=~s/\/$//;
     my ($udom, $uname);      my ($udom, $uname);
     (undef,$udom,$uname)=split(/\//,$uri);      if ($getuserdir) {
     if(defined($userdomain)) {  
         $udom = $userdomain;          $udom = $userdomain;
     }  
     if(defined($username)) {  
         $uname = $username;          $uname = $username;
       } else {
           (undef,$udom,$uname)=split(/\//,$uri);
           if(defined($userdomain)) {
               $udom = $userdomain;
           }
           if(defined($username)) {
               $uname = $username;
           }
     }      }
       my ($dirRoot,$listing,@listing_results);
   
     my $dirRoot = $perlvar{'lonDocRoot'};      $dirRoot = $perlvar{'lonDocRoot'};
     if(defined($alternateDirectoryRoot)) {      if (defined($getpropath)) {
         $dirRoot = $alternateDirectoryRoot;          $dirRoot = &propath($udom,$uname);
         $dirRoot =~ s/\/$//;          $dirRoot =~ s/\/$//;
       } elsif (defined($getuserdir)) {
           my $subdir=$uname.'__';
           $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
           $dirRoot = $Apache::lonnet::perlvar{'lonUsersDir'}
                      ."/$udom/$subdir/$uname";
       } elsif (defined($alternateRoot)) {
           $dirRoot = $alternateRoot;
     }      }
   
     if($udom) {      if($udom) {
         if($uname) {          if($uname) {
             my $listing=reply('ls:'.$dirRoot.'/'.$uri,              my $uhome = &homeserver($uname,$udom);
                               homeserver($uname,$udom));              if ($uhome eq 'no_host') {
             return split(/:/,$listing);                  return ([],'no_host');
         } elsif(!defined($alternateDirectoryRoot)) {              }
             my $tryserver;              $listing = &reply('ls3:'.&escape('/'.$uri).':'.$getpropath.':'
             my %allusers=();                                .$getuserdir.':'.&escape($dirRoot)
             foreach $tryserver (keys %libserv) {                                .':'.&escape($uname).':'.&escape($udom),$uhome);
                 if($hostdom{$tryserver} eq $udom) {              if ($listing eq 'unknown_cmd') {
                     my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.                  $listing = &reply('ls2:'.$dirRoot.'/'.$uri,$uhome);
                                       $udom, $tryserver);              } else {
                     if (($listing ne 'no_such_dir') && ($listing ne 'empty')                  @listing_results = map { &unescape($_); } split(/:/,$listing);
                         && ($listing ne 'con_lost')) {              }
                         foreach (split(/:/,$listing)) {              if ($listing eq 'unknown_cmd') {
                             my ($entry,@stat)=split(/&/,$_);                  $listing = &reply('ls:'.$dirRoot.'/'.$uri,$uhome);
                             $allusers{$entry}=1;                  @listing_results = split(/:/,$listing);
                         }              } else {
                     }                  @listing_results = map { &unescape($_); } split(/:/,$listing);
               }
               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) {
               my (%allusers,%listerror);
       my %servers = &get_servers($udom,'library');
        foreach my $tryserver (keys(%servers)) {
                   $listing = &reply('ls3:'.&escape("/res/$udom").':::::'.
                                     &escape($udom),$tryserver);
                   if ($listing eq 'unknown_cmd') {
       $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'.
         $udom, $tryserver);
                   } else {
                       @listing_results = map { &unescape($_); } split(/:/,$listing);
                 }                  }
    if ($listing eq 'unknown_cmd') {
       $listing = &reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.
         $udom, $tryserver);
       @listing_results = split(/:/,$listing);
    } else {
       @listing_results =
    map { &unescape($_); } split(/:/,$listing);
    }
                   if (($listing eq 'no_such_host') || ($listing eq 'con_lost') ||
                       ($listing eq 'rejected') || ($listing eq 'refused') ||
                       ($listing eq 'no_such_dir') || ($listing eq 'empty')) {
                       $listerror{$tryserver} = $listing;
                   } else {
       foreach my $line (@listing_results) {
    my ($entry) = split(/&/,$line,2);
    $allusers{$entry} = 1;
       }
    }
               }
               my @alluserslist=();
               foreach my $user (sort(keys(%allusers))) {
                   push(@alluserslist,$user.'&user');
             }              }
             my $alluserstr='';              return (\@alluserslist);
             foreach (sort keys %allusers) {          } else {
                 $alluserstr.=$_.'&user:';              return ([],'missing username');
             }          }
             $alluserstr=~s/:$//;      } elsif(!defined($getpropath)) {
             return split(/:/,$alluserstr);          my $path = $perlvar{'lonDocRoot'}.'/res/'; 
         } else {          my @all_domains = map { $path.$_.'/&domain'; } (sort(&all_domains()));
             my @emptyResults = ();          return (\@all_domains);
             push(@emptyResults, 'missing user name');      } else {
             return split(':',@emptyResults);          return ([],'missing domain');
         }  
     } elsif(!defined($alternateDirectoryRoot)) {  
         my $tryserver;  
         my %alldom=();  
         foreach $tryserver (keys %libserv) {  
             $alldom{$hostdom{$tryserver}}=1;  
         }  
         my $alldomstr='';  
         foreach (sort keys %alldom) {  
             $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'/&domain:';  
         }  
         $alldomstr=~s/:$//;  
         return split(/:/,$alldomstr);         
     } else {  
         my @emptyResults = ();  
         push(@emptyResults, 'missing domain');  
         return split(':',@emptyResults);  
     }      }
 }  }
   
Line 3938  sub dirlist { Line 8861  sub dirlist {
 # when it was last modified.  It will also return an error of -1  # when it was last modified.  It will also return an error of -1
 # if an error occurs  # if an error occurs
   
 ##  
 ## FIXME: This subroutine assumes its caller knows something about the  
 ## directory structure of the home server for the student ($root).  
 ## Not a good assumption to make.  Since this is for looking up files  
 ## in user directories, the full path should be constructed by lond, not  
 ## whatever machine we request data from.  
 ##  
 sub GetFileTimestamp {  sub GetFileTimestamp {
     my ($studentDomain,$studentName,$filename,$root)=@_;      my ($studentDomain,$studentName,$filename,$getuserdir)=@_;
     $studentDomain=~s/\W//g;      $studentDomain = &LONCAPA::clean_domain($studentDomain);
     $studentName=~s/\W//g;      $studentName   = &LONCAPA::clean_username($studentName);
     my $subdir=$studentName.'__';      my ($fileref,$error) = &dirlist($filename,$studentDomain,$studentName,
     $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;                                      undef,$getuserdir);
     my $proname="$studentDomain/$subdir/$studentName";      if (($error eq 'empty') || ($error eq 'no_such_dir')) {
     $proname .= '/'.$filename;          return -1;
     my ($fileStat) = &Apache::lonnet::dirlist($proname, $studentDomain,       }
                                               $studentName, $root);      if (ref($fileref) eq 'ARRAY') {
     my @stats = split('&', $fileStat);          my @stats = split('&',$fileref->[0]);
     if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {  
         # @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 3964  sub GetFileTimestamp { Line 8879  sub GetFileTimestamp {
     }      }
 }  }
   
   sub stat_file {
       my ($uri) = @_;
       $uri = &clutter_with_no_wrapper($uri);
   
       my ($udom,$uname,$file);
       if ($uri =~ m-^/(uploaded|editupload)/-) {
    ($udom,$uname,$file) =
       ($uri =~ m-/(?:uploaded|editupload)/?($match_domain)/?($match_name)/?(.*)-);
    $file = 'userfiles/'.$file;
       }
       if ($uri =~ m-^/res/-) {
    ($udom,$uname) = 
       ($uri =~ m-/(?:res)/?($match_domain)/?($match_username)/-);
    $file = $uri;
       }
   
       if (!$udom || !$uname || !$file) {
    # unable to handle the uri
    return ();
       }
       my $getpropath;
       if ($file =~ /^userfiles\//) {
           $getpropath = 1;
       }
       my ($listref,$error) = &dirlist($file,$udom,$uname,$getpropath);
       if (($error eq 'empty') || ($error eq 'no_such_dir')) {
           return ();
       } else {
           if (ref($listref) eq 'ARRAY') {
               my @stats = split('&',$listref->[0]);
       shift(@stats); #filename is first
       return @stats;
           }
       }
       return ();
   }
   
 # -------------------------------------------------------- Value of a Condition  # -------------------------------------------------------- Value of a Condition
   
   # gets the value of a specific preevaluated condition
   #    stored in the string  $env{user.state.<cid>}
   # or looks up a condition reference in the bighash and if if hasn't
   # already been evaluated recurses into docondval to get the value of
   # the condition, then memoizing it to 
   #   $env{user.state.<cid>.<condition>}
 sub directcondval {  sub directcondval {
     my $number=shift;      my $number=shift;
     if (!defined($ENV{'user.state.'.$ENV{'request.course.id'}})) {      if (!defined($env{'user.state.'.$env{'request.course.id'}})) {
  &Apache::lonuserstate::evalstate();   &Apache::lonuserstate::evalstate();
     }      }
     if ($ENV{'user.state.'.$ENV{'request.course.id'}}) {      if (exists($env{'user.state.'.$env{'request.course.id'}.".$number"})) {
        return substr($ENV{'user.state.'.$ENV{'request.course.id'}},$number,1);   return $env{'user.state.'.$env{'request.course.id'}.".$number"};
       } elsif ($number =~ /^_/) {
    my $sub_condition;
    if (tie(my %bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
    &GDBM_READER(),0640)) {
       $sub_condition=$bighash{'conditions'.$number};
       untie(%bighash);
    }
    my $value = &docondval($sub_condition);
    &appenv({'user.state.'.$env{'request.course.id'}.".$number" => $value});
    return $value;
       }
       if ($env{'user.state.'.$env{'request.course.id'}}) {
          return substr($env{'user.state.'.$env{'request.course.id'}},$number,1);
     } else {      } else {
        return 2;         return 2;
     }      }
 }  }
   
   # get the collection of conditions for this resource
 sub condval {  sub condval {
     my $condidx=shift;      my $condidx=shift;
     my $result=0;  
     my $allpathcond='';      my $allpathcond='';
     foreach (split(/\|/,$condidx)) {      foreach my $cond (split(/\|/,$condidx)) {
        if (defined($ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_})) {   if (defined($env{'acc.cond.'.$env{'request.course.id'}.'.'.$cond})) {
    $allpathcond.=      $allpathcond.=
                '('.$ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_}.')|';   '('.$env{'acc.cond.'.$env{'request.course.id'}.'.'.$cond}.')|';
        }   }
     }      }
     $allpathcond=~s/\|$//;      $allpathcond=~s/\|$//;
     if ($ENV{'request.course.id'}) {      return &docondval($allpathcond);
        if ($allpathcond) {  }
           my $operand='|';  
   my @stack;  #evaluates an expression of conditions
            foreach ($allpathcond=~/(\d+|\(|\)|\&|\|)/g) {  sub docondval {
               if ($_ eq '(') {      my ($allpathcond) = @_;
                  push @stack,($operand,$result)      my $result=0;
               } elsif ($_ eq ')') {      if ($env{'request.course.id'}
                   my $before=pop @stack;   && defined($allpathcond)) {
   if (pop @stack eq '&') {   my $operand='|';
       $result=$result>$before?$before:$result;   my @stack;
                   } else {   foreach my $chunk ($allpathcond=~/(\d+|_\d+\.\d+|\(|\)|\&|\|)/g) {
                       $result=$result>$before?$result:$before;      if ($chunk eq '(') {
                   }   push @stack,($operand,$result);
               } elsif (($_ eq '&') || ($_ eq '|')) {      } elsif ($chunk eq ')') {
                   $operand=$_;   my $before=pop @stack;
               } else {   if (pop @stack eq '&') {
                   my $new=directcondval($_);      $result=$result>$before?$before:$result;
                   if ($operand eq '&') {   } else {
                      $result=$result>$new?$new:$result;      $result=$result>$before?$result:$before;
                   } else {   }
                      $result=$result>$new?$result:$new;      } elsif (($chunk eq '&') || ($chunk eq '|')) {
                   }   $operand=$chunk;
               }      } else {
           }   my $new=directcondval($chunk);
        }   if ($operand eq '&') {
       $result=$result>$new?$new:$result;
    } else {
       $result=$result>$new?$result:$new;
    }
       }
    }
     }      }
     return $result;      return $result;
 }  }
Line 4024  sub condval { Line 9001  sub condval {
 sub devalidatecourseresdata {  sub devalidatecourseresdata {
     my ($coursenum,$coursedomain)=@_;      my ($coursenum,$coursedomain)=@_;
     my $hashid=$coursenum.':'.$coursedomain;      my $hashid=$coursenum.':'.$coursedomain;
     &devalidate_cache(\%courseresdatacache,$hashid,'courseres');      &devalidate_cache_new('courseres',$hashid);
 }  }
   
   
 # --------------------------------------------------- Course Resourcedata Query  # --------------------------------------------------- Course Resourcedata Query
   #
   #  Parameters:
   #      $coursenum    - Number of the course.
   #      $coursedomain - Domain at which the course was created.
   #  Returns:
   #     A hash of the course parameters along (I think) with timestamps
   #     and version info.
   
 sub courseresdata {  sub get_courseresdata {
     my ($coursenum,$coursedomain,@which)=@_;      my ($coursenum,$coursedomain)=@_;
     my $coursehom=&homeserver($coursenum,$coursedomain);      my $coursehom=&homeserver($coursenum,$coursedomain);
     my $hashid=$coursenum.':'.$coursedomain;      my $hashid=$coursenum.':'.$coursedomain;
     my ($result,$cached)=&is_cached(\%courseresdatacache,$hashid,'courseres');      my ($result,$cached)=&is_cached_new('courseres',$hashid);
       my %dumpreply;
     unless (defined($cached)) {      unless (defined($cached)) {
  my %dumpreply=&dump('resourcedata',$coursedomain,$coursenum);   %dumpreply=&dump('resourcedata',$coursedomain,$coursenum);
  $result=\%dumpreply;   $result=\%dumpreply;
  my ($tmp) = keys(%dumpreply);   my ($tmp) = keys(%dumpreply);
  if ($tmp !~ /^(con_lost|error|no_such_host)/i) {   if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
     &do_cache(\%courseresdatacache,$hashid,$result,'courseres');      &do_cache_new('courseres',$hashid,$result,600);
  } elsif ($tmp =~ /^(con_lost|no_such_host)/) {   } elsif ($tmp =~ /^(con_lost|no_such_host)/) {
     return $tmp;      return $tmp;
  } elsif ($tmp =~ /^(error)/) {   } elsif ($tmp =~ /^(error)/) {
     $result=undef;      $result=undef;
     &do_cache(\%courseresdatacache,$hashid,$result,'courseres');      &do_cache_new('courseres',$hashid,$result,600);
  }   }
     }      }
       return $result;
   }
   
   sub devalidateuserresdata {
       my ($uname,$udom)=@_;
       my $hashid="$udom:$uname";
       &devalidate_cache_new('userres',$hashid);
   }
   
   sub get_userresdata {
       my ($uname,$udom)=@_;
       #most student don\'t have any data set, check if there is some data
       if (&EXT_cache_status($udom,$uname)) { return undef; }
   
       my $hashid="$udom:$uname";
       my ($result,$cached)=&is_cached_new('userres',$hashid);
       if (!defined($cached)) {
    my %resourcedata=&dump('resourcedata',$udom,$uname);
    $result=\%resourcedata;
    &do_cache_new('userres',$hashid,$result,600);
       }
       my ($tmp)=keys(%$result);
       if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) {
    return $result;
       }
       #error 2 occurs when the .db doesn't exist
       if ($tmp!~/error: 2 /) {
    &logthis("<font color=\"blue\">WARNING:".
    " Trying to get resource data for ".
    $uname." at ".$udom.": ".
    $tmp."</font>");
       } elsif ($tmp=~/error: 2 /) {
    #&EXT_cache_set($udom,$uname);
    &do_cache_new('userres',$hashid,undef,600);
    undef($tmp); # not really an error so don't send it back
       }
       return $tmp;
   }
   #----------------------------------------------- resdata - return resource data
   #  Purpose:
   #    Return resource data for either users or for a course.
   #  Parameters:
   #     $name      - Course/user name.
   #     $domain    - Name of the domain the user/course is registered on.
   #     $type      - Type of thing $name is (must be 'course' or 'user'
   #     @which     - Array of names of resources desired.
   #  Returns:
   #     The value of the first reasource in @which that is found in the
   #     resource hash.
   #  Exceptional Conditions:
   #     If the $type passed in is not valid (not the string 'course' or 
   #     'user', an undefined  reference is returned.
   #     If none of the resources are found, an undef is returned
   sub resdata {
       my ($name,$domain,$type,@which)=@_;
       my $result;
       if ($type eq 'course') {
    $result=&get_courseresdata($name,$domain);
       } elsif ($type eq 'user') {
    $result=&get_userresdata($name,$domain);
       }
       if (!ref($result)) { return $result; }    
     foreach my $item (@which) {      foreach my $item (@which) {
  if (defined($result->{$item})) {   if (defined($result->{$item->[0]})) {
     return $result->{$item};      return [$result->{$item->[0]},$item->[1]];
  }   }
     }      }
     return undef;      return undef;
Line 4066  sub clear_EXT_cache_status { Line 9114  sub clear_EXT_cache_status {
 sub EXT_cache_status {  sub EXT_cache_status {
     my ($target_domain,$target_user) = @_;      my ($target_domain,$target_user) = @_;
     my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain;      my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain;
     if (exists($ENV{$cachename}) && ($ENV{$cachename}+600) > time) {      if (exists($env{$cachename}) && ($env{$cachename}+600) > time) {
         # We know already the user has no data          # We know already the user has no data
         return 1;          return 1;
     } else {      } else {
Line 4077  sub EXT_cache_status { Line 9125  sub EXT_cache_status {
 sub EXT_cache_set {  sub EXT_cache_set {
     my ($target_domain,$target_user) = @_;      my ($target_domain,$target_user) = @_;
     my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain;      my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain;
     &appenv($cachename => time);      #&appenv({$cachename => time});
 }  }
   
 # --------------------------------------------------------- Value of a Variable  # --------------------------------------------------------- Value of a Variable
 sub EXT {  sub EXT {
     my ($varname,$symbparm,$udom,$uname,$usection,$recurse)=@_;  
   
       my ($varname,$symbparm,$udom,$uname,$usection,$recurse)=@_;
     unless ($varname) { return ''; }      unless ($varname) { return ''; }
     #get real user name/domain, courseid and symb      #get real user name/domain, courseid and symb
     my $courseid;      my $courseid;
Line 4092  sub EXT { Line 9140  sub EXT {
  $symbparm=&get_symb_from_alias($symbparm);   $symbparm=&get_symb_from_alias($symbparm);
     }      }
     if (!($uname && $udom)) {      if (!($uname && $udom)) {
       (my $cursymb,$courseid,$udom,$uname,$publicuser)=        (my $cursymb,$courseid,$udom,$uname,$publicuser)= &whichuser($symbparm);
   &Apache::lonxml::whichuser($symbparm);  
       if (!$symbparm) { $symbparm=$cursymb; }        if (!$symbparm) { $symbparm=$cursymb; }
     } else {      } else {
  $courseid=$ENV{'request.course.id'};   $courseid=$env{'request.course.id'};
     }      }
     my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);      my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);
     my $rest;      my $rest;
Line 4113  sub EXT { Line 9160  sub EXT {
     if ($realm eq 'user') {      if ($realm eq 'user') {
 # --------------------------------------------------------------- user.resource  # --------------------------------------------------------------- user.resource
  if ($space eq 'resource') {   if ($space eq 'resource') {
     if (defined($Apache::lonhomework::parsing_a_problem)) {      if ( (defined($Apache::lonhomework::parsing_a_problem)
  return $Apache::lonhomework::history{$qualifierrest};    || defined($Apache::lonhomework::parsing_a_task))
    &&
    ($symbparm eq &symbread()) ) {
    # if we are in the middle of processing the resource the
    # get the value we are planning on committing
                   if (defined($Apache::lonhomework::results{$qualifierrest})) {
                       return $Apache::lonhomework::results{$qualifierrest};
                   } else {
                       return $Apache::lonhomework::history{$qualifierrest};
                   }
     } else {      } else {
  my %restored;   my %restored;
  if ($publicuser || $ENV{'request.state'} eq 'construct') {   if ($publicuser || $env{'request.state'} eq 'construct') {
     %restored=&tmprestore($symbparm,$courseid,$udom,$uname);      %restored=&tmprestore($symbparm,$courseid,$udom,$uname);
  } else {   } else {
     %restored=&restore($symbparm,$courseid,$udom,$uname);      %restored=&restore($symbparm,$courseid,$udom,$uname);
Line 4130  sub EXT { Line 9186  sub EXT {
             return &allowed($qualifier,$rest);              return &allowed($qualifier,$rest);
 # ------------------------------------------ user.preferences, user.environment  # ------------------------------------------ user.preferences, user.environment
         } elsif (($space eq 'preferences') || ($space eq 'environment')) {          } elsif (($space eq 'preferences') || ($space eq 'environment')) {
     if (($uname eq $ENV{'user.name'}) &&      if (($uname eq $env{'user.name'}) &&
  ($udom eq $ENV{'user.domain'})) {   ($udom eq $env{'user.domain'})) {
  return $ENV{join('.',('environment',$qualifierrest))};   return $env{join('.',('environment',$qualifierrest))};
     } else {      } else {
  my %returnhash;   my %returnhash;
  if (!$publicuser) {   if (!$publicuser) {
Line 4144  sub EXT { Line 9200  sub EXT {
 # ----------------------------------------------------------------- user.course  # ----------------------------------------------------------------- user.course
         } elsif ($space eq 'course') {          } elsif ($space eq 'course') {
     # FIXME - not supporting calls for a specific user      # FIXME - not supporting calls for a specific user
             return $ENV{join('.',('request.course',$qualifier))};              return $env{join('.',('request.course',$qualifier))};
 # ------------------------------------------------------------------- user.role  # ------------------------------------------------------------------- user.role
         } elsif ($space eq 'role') {          } elsif ($space eq 'role') {
     # FIXME - not supporting calls for a specific user      # FIXME - not supporting calls for a specific user
             my ($role,$where)=split(/\./,$ENV{'request.role'});              my ($role,$where)=split(/\./,$env{'request.role'});
             if ($qualifier eq 'value') {              if ($qualifier eq 'value') {
  return $role;   return $role;
             } elsif ($qualifier eq 'extent') {              } elsif ($qualifier eq 'extent') {
Line 4172  sub EXT { Line 9228  sub EXT {
 # ---------------------------------------------- pull stuff out of query string  # ---------------------------------------------- pull stuff out of query string
         &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'},          &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'},
  [$spacequalifierrest]);   [$spacequalifierrest]);
  return $ENV{'form.'.$spacequalifierrest};    return $env{'form.'.$spacequalifierrest}; 
    } elsif ($realm eq 'request') {     } elsif ($realm eq 'request') {
 # ------------------------------------------------------------- request.browser  # ------------------------------------------------------------- request.browser
         if ($space eq 'browser') {          if ($space eq 'browser') {
     if ($qualifier eq 'textremote') {              return $env{'browser.'.$qualifier};
  if (&mt('textual_remote_display') eq 'on') {  
     return 1;  
  } else {  
     return 0;  
  }  
     } else {  
  return $ENV{'browser.'.$qualifier};  
     }  
 # ------------------------------------------------------------ request.filename  # ------------------------------------------------------------ request.filename
         } else {          } else {
             return $ENV{'request.'.$spacequalifierrest};              return $env{'request.'.$spacequalifierrest};
         }          }
     } elsif ($realm eq 'course') {      } elsif ($realm eq 'course') {
 # ---------------------------------------------------------- course.description  # ---------------------------------------------------------- course.description
         return $ENV{'course.'.$courseid.'.'.$spacequalifierrest};          return $env{'course.'.$courseid.'.'.$spacequalifierrest};
     } elsif ($realm eq 'resource') {      } elsif ($realm eq 'resource') {
   
  my $section;   if (defined($courseid) && $courseid eq $env{'request.course.id'}) {
  if (defined($courseid) && $courseid eq $ENV{'request.course.id'}) {  
     if (!$symbparm) { $symbparm=&symbread(); }      if (!$symbparm) { $symbparm=&symbread(); }
  }   }
   
    if ($space eq 'title') {
       if (!$symbparm) { $symbparm = $env{'request.filename'}; }
       return &gettitle($symbparm);
    }
   
    if ($space eq 'map') {
       my ($map) = &decode_symb($symbparm);
       return &symbread($map);
    }
    if ($space eq 'filename') {
       if ($symbparm) {
    return &clutter((&decode_symb($symbparm))[2]);
       }
       return &hreflocation('',$env{'request.filename'});
    }
   
    my ($section, $group, @groups);
    my ($courselevelm,$courselevel);
  if ($symbparm && defined($courseid) &&    if ($symbparm && defined($courseid) && 
     $courseid eq $ENV{'request.course.id'}) {      $courseid eq $env{'request.course.id'}) {
   
     #print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;      #print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;
   
 # ----------------------------------------------------- Cascading lookup scheme  # ----------------------------------------------------- Cascading lookup scheme
     my $symbp=$symbparm;      my $symbp=$symbparm;
     my $mapp=(&decode_symb($symbp))[0];      my $mapp=&deversion((&decode_symb($symbp))[0]);
   
     my $symbparm=$symbp.'.'.$spacequalifierrest;      my $symbparm=$symbp.'.'.$spacequalifierrest;
     my $mapparm=$mapp.'___(all).'.$spacequalifierrest;      my $mapparm=$mapp.'___(all).'.$spacequalifierrest;
   
     if (($ENV{'user.name'} eq $uname) &&      if (($env{'user.name'} eq $uname) &&
  ($ENV{'user.domain'} eq $udom)) {   ($env{'user.domain'} eq $udom)) {
  $section=$ENV{'request.course.sec'};   $section=$env{'request.course.sec'};
                   @groups = split(/:/,$env{'request.course.groups'});  
                   @groups=&sort_course_groups($courseid,@groups); 
     } else {      } else {
  if (! defined($usection)) {   if (! defined($usection)) {
     $section=&getsection($udom,$uname,$courseid);      $section=&getsection($udom,$uname,$courseid);
  } else {   } else {
     $section = $usection;      $section = $usection;
  }   }
                   @groups = &get_users_groups($udom,$uname,$courseid);
     }      }
   
     my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;      my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
     my $seclevelr=$courseid.'.['.$section.'].'.$symbparm;      my $seclevelr=$courseid.'.['.$section.'].'.$symbparm;
     my $seclevelm=$courseid.'.['.$section.'].'.$mapparm;      my $seclevelm=$courseid.'.['.$section.'].'.$mapparm;
   
     my $courselevel=$courseid.'.'.$spacequalifierrest;      $courselevel=$courseid.'.'.$spacequalifierrest;
     my $courselevelr=$courseid.'.'.$symbparm;      my $courselevelr=$courseid.'.'.$symbparm;
     my $courselevelm=$courseid.'.'.$mapparm;      $courselevelm=$courseid.'.'.$mapparm;
   
 # ----------------------------------------------------------- first, check user  # ----------------------------------------------------------- first, check user
     #most student don\'t have any data set, check if there is some data  
     if (! &EXT_cache_status($udom,$uname)) {  
  my $hashid="$udom:$uname";  
  my ($result,$cached)=&is_cached(\%userresdatacache,$hashid,  
  'userres');  
  if (!defined($cached)) {  
     my %resourcedata=&dump('resourcedata',$udom,$uname);  
     $result=\%resourcedata;  
     &do_cache(\%userresdatacache,$hashid,$result,'userres');  
  }  
  my ($tmp)=keys(%$result);  
  if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) {  
     if ($$result{$courselevelr}) {  
  return $$result{$courselevelr}; }  
     if ($$result{$courselevelm}) {  
  return $$result{$courselevelm}; }  
     if ($$result{$courselevel}) {  
  return $$result{$courselevel}; }  
  } else {  
     #error 2 occurs when the .db doesn't exist  
     if ($tmp!~/error: 2 /) {  
  &logthis("<font color=blue>WARNING:".  
  " Trying to get resource data for ".  
  $uname." at ".$udom.": ".  
  $tmp."</font>");  
     } elsif ($tmp=~/error: 2 /) {  
  &EXT_cache_set($udom,$uname);  
     } elsif ($tmp =~ /^(con_lost|no_such_host)/) {  
  return $tmp;  
     }  
  }  
     }  
   
 # -------------------------------------------------------- second, check course      my $userreply=&resdata($uname,$udom,'user',
          ([$courselevelr,'resource'],
    [$courselevelm,'map'     ],
    [$courselevel, 'course'  ]));
       if (defined($userreply)) { return &get_reply($userreply); }
   
   # ------------------------------------------------ second, check some of course
               my $coursereply;
               if (@groups > 0) {
                   $coursereply = &check_group_parms($courseid,\@groups,$symbparm,
                                          $mapparm,$spacequalifierrest);
                   if (defined($coursereply)) { return &get_reply($coursereply); }
               }
   
     my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'},      $coursereply=&resdata($env{'course.'.$courseid.'.num'},
    $ENV{'course.'.$courseid.'.domain'},    $env{'course.'.$courseid.'.domain'},
    ($seclevelr,$seclevelm,$seclevel,    'course',
     $courselevelr,$courselevelm,    ([$seclevelr,   'resource'],
     $courselevel));     [$seclevelm,   'map'     ],
     if (defined($coursereply)) { return $coursereply; }     [$seclevel,    'course'  ],
      [$courselevelr,'resource']));
       if (defined($coursereply)) { return &get_reply($coursereply); }
   
 # ------------------------------------------------------ third, check map parms  # ------------------------------------------------------ third, check map parms
     my %parmhash=();      my %parmhash=();
     my $thisparm='';      my $thisparm='';
     if (tie(%parmhash,'GDBM_File',      if (tie(%parmhash,'GDBM_File',
     $ENV{'request.course.fn'}.'_parms.db',      $env{'request.course.fn'}.'_parms.db',
     &GDBM_READER(),0640)) {      &GDBM_READER(),0640)) {
  $thisparm=$parmhash{$symbparm};   $thisparm=$parmhash{$symbparm};
  untie(%parmhash);   untie(%parmhash);
     }      }
     if ($thisparm) { return $thisparm; }      if ($thisparm) { return &get_reply([$thisparm,'resource']); }
  }   }
 # --------------------------------------------- last, look in resource metadata  # ------------------------------------------ fourth, look in resource metadata
   
  $spacequalifierrest=~s/\./\_/;   $spacequalifierrest=~s/\./\_/;
  my $filename;   my $filename;
Line 4291  sub EXT { Line 9342  sub EXT {
  if ($symbparm) {   if ($symbparm) {
     $filename=(&decode_symb($symbparm))[2];      $filename=(&decode_symb($symbparm))[2];
  } else {   } else {
     $filename=$ENV{'request.filename'};      $filename=$env{'request.filename'};
  }   }
  my $metadata=&metadata($filename,$spacequalifierrest);   my $metadata=&metadata($filename,$spacequalifierrest);
  if (defined($metadata)) { return $metadata; }   if (defined($metadata)) { return &get_reply([$metadata,'resource']); }
  $metadata=&metadata($filename,'parameter_'.$spacequalifierrest);   $metadata=&metadata($filename,'parameter_'.$spacequalifierrest);
  if (defined($metadata)) { return $metadata; }   if (defined($metadata)) { return &get_reply([$metadata,'resource']); }
   
   # ---------------------------------------------- fourth, look in rest of course
    if ($symbparm && defined($courseid) && 
       $courseid eq $env{'request.course.id'}) {
       my $coursereply=&resdata($env{'course.'.$courseid.'.num'},
        $env{'course.'.$courseid.'.domain'},
        'course',
        ([$courselevelm,'map'   ],
         [$courselevel, 'course']));
       if (defined($coursereply)) { return &get_reply($coursereply); }
    }
 # ------------------------------------------------------------------ Cascade up  # ------------------------------------------------------------------ Cascade up
  unless ($space eq '0') {   unless ($space eq '0') {
     my @parts=split(/_/,$space);      my @parts=split(/_/,$space);
     my $id=pop(@parts);      my $id=pop(@parts);
     my $part=join('_',@parts);      my $part=join('_',@parts);
     if ($part eq '') { $part='0'; }      if ($part eq '') { $part='0'; }
     my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,      my @partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,
  $symbparm,$udom,$uname,$section,1);   $symbparm,$udom,$uname,$section,1);
     if (defined($partgeneral)) { return $partgeneral; }      if (defined($partgeneral[0])) { return &get_reply(\@partgeneral); }
  }   }
  if ($recurse) { return undef; }   if ($recurse) { return undef; }
  my $pack_def=&packages_tab_default($filename,$varname);   my $pack_def=&packages_tab_default($filename,$varname);
  if (defined($pack_def)) { return $pack_def; }   if (defined($pack_def)) { return &get_reply([$pack_def,'resource']); }
   
 # ---------------------------------------------------- Any other user namespace  # ---------------------------------------------------- Any other user namespace
     } elsif ($realm eq 'environment') {      } elsif ($realm eq 'environment') {
 # ----------------------------------------------------------------- environment  # ----------------------------------------------------------------- environment
  if (($uname eq $ENV{'user.name'})&&($udom eq $ENV{'user.domain'})) {   if (($uname eq $env{'user.name'})&&($udom eq $env{'user.domain'})) {
     return $ENV{'environment.'.$spacequalifierrest};      return $env{'environment.'.$spacequalifierrest};
  } else {   } else {
       if ($uname eq 'anonymous' && $udom eq '') {
    return '';
       }
     my %returnhash=&userenvironment($udom,$uname,      my %returnhash=&userenvironment($udom,$uname,
     $spacequalifierrest);      $spacequalifierrest);
     return $returnhash{$spacequalifierrest};      return $returnhash{$spacequalifierrest};
Line 4327  sub EXT { Line 9390  sub EXT {
  if ($space eq 'time') {   if ($space eq 'time') {
     return time;      return time;
         }          }
       } elsif ($realm eq 'server') {
   # ----------------------------------------------------------------- system.time
    if ($space eq 'name') {
       return $ENV{'SERVER_NAME'};
           }
     }      }
     return '';      return '';
 }  }
   
   sub get_reply {
       my ($reply_value) = @_;
       if (ref($reply_value) eq 'ARRAY') {
           if (wantarray) {
       return @$reply_value;
           }
           return $reply_value->[0];
       } else {
           return $reply_value;
       }
   }
   
   sub check_group_parms {
       my ($courseid,$groups,$symbparm,$mapparm,$what) = @_;
       my @groupitems = ();
       my $resultitem;
       my @levels = ([$symbparm,'resource'],[$mapparm,'map'],[$what,'course']);
       foreach my $group (@{$groups}) {
           foreach my $level (@levels) {
                my $item = $courseid.'.['.$group.'].'.$level->[0];
                push(@groupitems,[$item,$level->[1]]);
           }
       }
       my $coursereply = &resdata($env{'course.'.$courseid.'.num'},
                               $env{'course.'.$courseid.'.domain'},
                                        'course',@groupitems);
       return $coursereply;
   }
   
   sub sort_course_groups { # Sort groups based on defined rankings. Default is sort().
       my ($courseid,@groups) = @_;
       @groups = sort(@groups);
       return @groups;
   }
   
 sub packages_tab_default {  sub packages_tab_default {
     my ($uri,$varname)=@_;      my ($uri,$varname)=@_;
     my (undef,$part,$name)=split(/\./,$varname);      my (undef,$part,$name)=split(/\./,$varname);
     my $packages=&metadata($uri,'packages');  
     foreach my $package (split(/,/,$packages)) {      my (@extension,@specifics,$do_default);
       foreach my $package (split(/,/,&metadata($uri,'packages'))) {
  my ($pack_type,$pack_part)=split(/_/,$package,2);   my ($pack_type,$pack_part)=split(/_/,$package,2);
    if ($pack_type eq 'default') {
       $do_default=1;
    } elsif ($pack_type eq 'extension') {
       push(@extension,[$package,$pack_type,$pack_part]);
    } elsif ($pack_part eq $part || $pack_type eq 'part') {
       # only look at packages defaults for packages that this id is
       push(@specifics,[$package,$pack_type,$pack_part]);
    }
       }
       # first look for a package that matches the requested part id
       foreach my $package (@specifics) {
    my (undef,$pack_type,$pack_part)=@{$package};
    next if ($pack_part ne $part);
  if (defined($packagetab{"$pack_type&$name&default"})) {   if (defined($packagetab{"$pack_type&$name&default"})) {
     return $packagetab{"$pack_type&$name&default"};      return $packagetab{"$pack_type&$name&default"};
  }   }
       }
       # look for any possible matching non extension_ package
       foreach my $package (@specifics) {
    my (undef,$pack_type,$pack_part)=@{$package};
    if (defined($packagetab{"$pack_type&$name&default"})) {
       return $packagetab{"$pack_type&$name&default"};
    }
    if ($pack_type eq 'part') { $pack_part='0'; }
  if (defined($packagetab{$pack_type."_".$pack_part."&$name&default"})) {   if (defined($packagetab{$pack_type."_".$pack_part."&$name&default"})) {
     return $packagetab{$pack_type."_".$pack_part."&$name&default"};      return $packagetab{$pack_type."_".$pack_part."&$name&default"};
  }   }
     }      }
       # look for any posible extension_ match
       foreach my $package (@extension) {
    my ($package,$pack_type)=@{$package};
    if (defined($packagetab{"$pack_type&$name&default"})) {
       return $packagetab{"$pack_type&$name&default"};
    }
    if (defined($packagetab{$package."&$name&default"})) {
       return $packagetab{$package."&$name&default"};
    }
       }
       # look for a global default setting
       if ($do_default && defined($packagetab{"default&$name&default"})) {
    return $packagetab{"default&$name&default"};
       }
     return undef;      return undef;
 }  }
   
Line 4365  sub add_prefix_and_part { Line 9504  sub add_prefix_and_part {
   
 # ---------------------------------------------------------------- Get metadata  # ---------------------------------------------------------------- Get metadata
   
   my %metaentry;
   my %importedpartids;
 sub metadata {  sub metadata {
     my ($uri,$what,$liburi,$prefix,$depthcount)=@_;      my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
     $uri=&declutter($uri);      $uri=&declutter($uri);
Line 4372  sub metadata { Line 9513  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 =~ /^~/) ||          ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) {
  ($uri =~ m|home/[^/]+/public_html/|)) {   return undef;
       }
       if (($uri =~ /^priv/ || $uri=~/home\/httpd\/html\/priv/) 
    && &Apache::lonxml::get_state('target') =~ /^(|meta)$/) {
  return undef;   return undef;
     }      }
     my $filename=$uri;      my $filename=$uri;
Line 4384  sub metadata { Line 9528  sub metadata {
 # Everything is cached by the main uri, libraries are never directly cached  # Everything is cached by the main uri, libraries are never directly cached
 #  #
     if (!defined($liburi)) {      if (!defined($liburi)) {
  my ($result,$cached)=&is_cached(\%metacache,$uri,'meta');   my ($result,$cached)=&is_cached_new('meta',$uri);
  if (defined($cached)) { return $result->{':'.$what}; }   if (defined($cached)) { return $result->{':'.$what}; }
     }      }
     {      {
   # Imported parts would go here
           my %importedids=();
           my @origfileimportpartids=();
           my $importedparts=0;
 #  #
 # Is this a recursive call for a library?  # Is this a recursive call for a library?
 #  #
  if (! exists($metacache{$uri})) {  # if (! exists($metacache{$uri})) {
     $metacache{$uri}={};  #    $metacache{$uri}={};
  }  # }
    my $cachetime = 60*60;
         if ($liburi) {          if ($liburi) {
     $liburi=&declutter($liburi);      $liburi=&declutter($liburi);
             $filename=$liburi;              $filename=$liburi;
         } else {          } else {
     &devalidate_cache(\%metacache,$uri,'meta');      &devalidate_cache_new('meta',$uri);
       undef(%metaentry);
  }   }
         my %metathesekeys=();          my %metathesekeys=();
         unless ($filename=~/\.meta$/) { $filename.='.meta'; }          unless ($filename=~/\.meta$/) { $filename.='.meta'; }
  my $metastring;   my $metastring;
  if ($uri !~ m|^uploaded/|) {   if ($uri =~ /^priv/ || $uri=~/home\/httpd\/html\/priv/) {
       my $which = &hreflocation('','/'.($liburi || $uri));
       $metastring = 
    &Apache::lonnet::ssi_body($which,
     ('grade_target' => 'meta'));
       $cachetime = 1; # only want this cached in the child not long term
    } elsif (($uri !~ m -^(editupload)/-) && 
                    ($uri !~ m{^/*uploaded/$match_domain/$match_courseid/docs/})) {
     my $file=&filelocation('',&clutter($filename));      my $file=&filelocation('',&clutter($filename));
     push(@{$metacache{$uri.'.file'}},$file);      #push(@{$metaentry{$uri.'.file'}},$file);
     $metastring=&getfile($file);      $metastring=&getfile($file);
  }   }
         my $parser=HTML::LCParser->new(\$metastring);          my $parser=HTML::LCParser->new(\$metastring);
Line 4422  sub metadata { Line 9579  sub metadata {
     if (defined($token->[2]->{'id'})) {       if (defined($token->[2]->{'id'})) { 
  $keyroot.='_'.$token->[2]->{'id'};    $keyroot.='_'.$token->[2]->{'id'}; 
     }      }
     if ($metacache{$uri}->{':packages'}) {      if ($metaentry{':packages'}) {
  $metacache{$uri}->{':packages'}.=','.$package.$keyroot;   $metaentry{':packages'}.=','.$package.$keyroot;
     } else {      } else {
  $metacache{$uri}->{':packages'}=$package.$keyroot;   $metaentry{':packages'}=$package.$keyroot;
     }      }
     foreach (keys %packagetab) {      foreach my $pack_entry (keys(%packagetab)) {
  my $part=$keyroot;   my $part=$keyroot;
  $part=~s/^\_//;   $part=~s/^\_//;
  if ($_=~/^\Q$package\E\&/ ||    if ($pack_entry=~/^\Q$package\E\&/ || 
     $_=~/^\Q$package\E_0\&/) {      $pack_entry=~/^\Q$package\E_0\&/) {
     my ($pack,$name,$subp)=split(/\&/,$_);      my ($pack,$name,$subp)=split(/\&/,$pack_entry);
     # ignore package.tab specified default values      # ignore package.tab specified default values
                             # here &package_tab_default() will fetch those                              # here &package_tab_default() will fetch those
     if ($subp eq 'default') { next; }      if ($subp eq 'default') { next; }
     my $value=$packagetab{$_};      my $value=$packagetab{$pack_entry};
     my $unikey;      my $unikey;
     if ($pack =~ /_0$/) {      if ($pack =~ /_0$/) {
  $unikey='parameter_0_'.$name;   $unikey='parameter_0_'.$name;
Line 4447  sub metadata { Line 9604  sub metadata {
     if ($subp eq 'display') {      if ($subp eq 'display') {
  $value.=' [Part: '.$part.']';   $value.=' [Part: '.$part.']';
     }      }
     $metacache{$uri}->{':'.$unikey.'.part'}=$part;      $metaentry{':'.$unikey.'.part'}=$part;
     $metathesekeys{$unikey}=1;      $metathesekeys{$unikey}=1;
     unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) {      unless (defined($metaentry{':'.$unikey.'.'.$subp})) {
  $metacache{$uri}->{':'.$unikey.'.'.$subp}=$value;   $metaentry{':'.$unikey.'.'.$subp}=$value;
     }      }
     if (defined($metacache{$uri}->{':'.$unikey.'.default'})) {      if (defined($metaentry{':'.$unikey.'.default'})) {
  $metacache{$uri}->{':'.$unikey}=   $metaentry{':'.$unikey}=
     $metacache{$uri}->{':'.$unikey.'.default'};      $metaentry{':'.$unikey.'.default'};
     }      }
  }   }
     }      }
Line 4463  sub metadata { Line 9620  sub metadata {
 # This is not a package - some other kind of start tag  # This is not a package - some other kind of start tag
 #  #
     my $entry=$token->[1];      my $entry=$token->[1];
     my $unikey;      my $unikey='';
     if ($entry eq 'import') {  
  $unikey='';  
     } else {  
  $unikey=$entry;  
     }  
     $unikey.=&add_prefix_and_part($prefix,$token->[2]->{'part'});  
   
     if (defined($token->[2]->{'id'})) {   
  $unikey.='_'.$token->[2]->{'id'};   
     }  
   
     if ($entry eq 'import') {      if ($entry eq 'import') {
 #  #
 # Importing a library here  # Importing a library here
 #  #
                           my $location=$parser->get_text('/import');
                           my $dir=$filename;
                           $dir=~s|[^/]*$||;
                           $location=&filelocation($dir,$location);
                          
                           my $importmode=$token->[2]->{'importmode'};
                           if ($importmode eq 'problem') {
   # Import as problem/response
                              $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});
                           } elsif ($importmode eq 'part') {
   # Import as part(s)
                              $importedparts=1;
   # We need to get the original file and the imported file to get the part order correct
   # Good news: we do not need to worry about nested libraries, since parts cannot be nested
   # Load and inspect original file
                              if ($#origfileimportpartids<0) {
                                 undef(%importedpartids);
                                 my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri);
                                 my $origfile=&getfile($origfilelocation);
                                 @origfileimportpartids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
                              }
   
   # Load and inspect imported file
                              my $impfile=&getfile($location);
                              my @impfilepartids=($impfile=~/<part[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
                              if ($#impfilepartids>=0) {
   # This problem had parts
                                  $importedpartids{$token->[2]->{'id'}}=join(',',@impfilepartids);
                              } else {
   # Importing by turning a single problem into a problem part
   # It gets the import-tags ID as part-ID
                                  $unikey=&add_prefix_and_part($prefix,$token->[2]->{'id'});
                                  $importedpartids{$token->[2]->{'id'}}=$token->[2]->{'id'};
                              }
                           } else {
   # Normal import
                              $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});
                              if (defined($token->[2]->{'id'})) {
                                 $unikey.='_'.$token->[2]->{'id'};
                              }
                           }
   
  if ($depthcount<20) {   if ($depthcount<20) {
     my $location=$parser->get_text('/import');      my $metadata = 
     my $dir=$filename;   &metadata($uri,'keys', $location,$unikey,
     $dir=~s|[^/]*$||;    $depthcount+1);
     $location=&filelocation($dir,$location);      foreach my $meta (split(',',$metadata)) {
     foreach (sort(split(/\,/,&metadata($uri,'keys',   $metaentry{':'.$meta}=$metaentry{':'.$meta};
        $location,$unikey,   $metathesekeys{$meta}=1;
        $depthcount+1)))) {  
  $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_};  
  $metathesekeys{$_}=1;  
     }      }
  }  
     } else {   
   
                           }
       } else {
   #
   # Not importing, some other kind of non-package, non-library start tag
   # 
                           $unikey=$entry.&add_prefix_and_part($prefix,$token->[2]->{'part'});
                           if (defined($token->[2]->{'id'})) {
                               $unikey.='_'.$token->[2]->{'id'};
                           }
  if (defined($token->[2]->{'name'})) {    if (defined($token->[2]->{'name'})) { 
     $unikey.='_'.$token->[2]->{'name'};       $unikey.='_'.$token->[2]->{'name'}; 
  }   }
  $metathesekeys{$unikey}=1;   $metathesekeys{$unikey}=1;
  foreach (@{$token->[3]}) {   foreach my $param (@{$token->[3]}) {
     $metacache{$uri}->{':'.$unikey.'.'.$_}=$token->[2]->{$_};      $metaentry{':'.$unikey.'.'.$param} =
    $token->[2]->{$param};
  }   }
  my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));   my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));
  my $default=$metacache{$uri}->{':'.$unikey.'.default'};   my $default=$metaentry{':'.$unikey.'.default'};
  if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) {   if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) {
  # only ws inside the tag, and not in default, so use default   # only ws inside the tag, and not in default, so use default
  # as value   # as value
     $metacache{$uri}->{':'.$unikey}=$default;      $metaentry{':'.$unikey}=$default;
    } elsif ( $internaltext =~ /\S/ ) {
     # something interesting inside the tag
       $metaentry{':'.$unikey}=$internaltext;
  } else {   } else {
   # either something interesting inside the tag or default    # no interesting values, don't set a default
                   # uninteresting  
     $metacache{$uri}->{':'.$unikey}=$internaltext;  
  }   }
 # end of not-a-package not-a-library import  # end of not-a-package not-a-library import
     }      }
Line 4519  sub metadata { Line 9714  sub metadata {
     }      }
  }   }
  my ($extension) = ($uri =~ /\.(\w+)$/);   my ($extension) = ($uri =~ /\.(\w+)$/);
  foreach my $key (sort(keys(%packagetab))) {   $extension = lc($extension);
     #&logthis("extsion1 $extension $key !!");   if ($extension eq 'htm') { $extension='html'; }
   
    foreach my $key (keys(%packagetab)) {
     #no specific packages #how's our extension      #no specific packages #how's our extension
     if ($key!~/^extension_\Q$extension\E&/) { next; }      if ($key!~/^extension_\Q$extension\E&/) { next; }
     &metadata_create_package_def($uri,$key,'extension_'.$extension,      &metadata_create_package_def($uri,$key,'extension_'.$extension,
  \%metathesekeys);   \%metathesekeys);
  }   }
  if (!exists($metacache{$uri}->{':packages'})) {  
     foreach my $key (sort(keys(%packagetab))) {   if (!exists($metaentry{':packages'})
       || $packagetab{"import_defaults&extension_$extension"}) {
       foreach my $key (keys(%packagetab)) {
  #no specific packages well let's get default then   #no specific packages well let's get default then
  if ($key!~/^default&/) { next; }   if ($key!~/^default&/) { next; }
  &metadata_create_package_def($uri,$key,'default',   &metadata_create_package_def($uri,$key,'default',
Line 4535  sub metadata { Line 9734  sub metadata {
     }      }
  }   }
 # are there custom rights to evaluate  # are there custom rights to evaluate
  if ($metacache{$uri}->{':copyright'} eq 'custom') {   if ($metaentry{':copyright'} eq 'custom') {
   
     #      #
     # Importing a rights file here      # Importing a rights file here
     #      #
     unless ($depthcount) {      unless ($depthcount) {
  my $location=$metacache{$uri}->{':customdistributionfile'};   my $location=$metaentry{':customdistributionfile'};
  my $dir=$filename;   my $dir=$filename;
  $dir=~s|[^/]*$||;   $dir=~s|[^/]*$||;
  $location=&filelocation($dir,$location);   $location=&filelocation($dir,$location);
  foreach (sort(split(/\,/,&metadata($uri,'keys',   my $rights_metadata =
    $location,'_rights',      &metadata($uri,'keys',$location,'_rights',
    $depthcount+1)))) {        $depthcount+1);
     $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_};   foreach my $rights (split(',',$rights_metadata)) {
     $metathesekeys{$_}=1;      #$metaentry{':'.$rights}=$metacache{$uri}->{':'.$rights};
       $metathesekeys{$rights}=1;
  }   }
     }      }
  }   }
  $metacache{$uri}->{':keys'}=join(',',keys %metathesekeys);   # uniqifiy package listing
  &metadata_generate_part0(\%metathesekeys,$metacache{$uri},$uri);   my %seen;
  $metacache{$uri}->{':allpossiblekeys'}=join(',',keys %metathesekeys);   my @uniq_packages =
  &do_cache(\%metacache,$uri,$metacache{$uri},'meta');      grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'}));
    $metaentry{':packages'} = join(',',@uniq_packages);
   
           if ($importedparts) {
   # We had imported parts and need to rebuild partorder
              $metaentry{':partorder'}='';
              $metathesekeys{'partorder'}=1;
              for (my $index=0;$index<$#origfileimportpartids;$index+=2) {
                  if ($origfileimportpartids[$index] eq 'part') {
   # original part, part of the problem
                     $metaentry{':partorder'}.=','.$origfileimportpartids[$index+1];
                  } else {
   # we have imported parts at this position
                     $metaentry{':partorder'}.=','.$importedpartids{$origfileimportpartids[$index+1]};
                  }
              }
              $metaentry{':partorder'}=~s/^\,//;
           }
   
    $metaentry{':keys'} = join(',',keys(%metathesekeys));
    &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
    $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);
    &do_cache_new('meta',$uri,\%metaentry,$cachetime);
 # this is the end of "was not already recently cached  # this is the end of "was not already recently cached
     }      }
     return $metacache{$uri}->{':'.$what};      return $metaentry{':'.$what};
 }  }
   
 sub metadata_create_package_def {  sub metadata_create_package_def {
Line 4567  sub metadata_create_package_def { Line 9789  sub metadata_create_package_def {
     my ($pack,$name,$subp)=split(/\&/,$key);      my ($pack,$name,$subp)=split(/\&/,$key);
     if ($subp eq 'default') { next; }      if ($subp eq 'default') { next; }
           
     if (defined($metacache{$uri}->{':packages'})) {      if (defined($metaentry{':packages'})) {
  $metacache{$uri}->{':packages'}.=','.$package;   $metaentry{':packages'}.=','.$package;
     } else {      } else {
  $metacache{$uri}->{':packages'}=$package;   $metaentry{':packages'}=$package;
     }      }
     my $value=$packagetab{$key};      my $value=$packagetab{$key};
     my $unikey;      my $unikey;
     $unikey='parameter_0_'.$name;      $unikey='parameter_0_'.$name;
     $metacache{$uri}->{':'.$unikey.'.part'}=0;      $metaentry{':'.$unikey.'.part'}=0;
     $$metathesekeys{$unikey}=1;      $$metathesekeys{$unikey}=1;
     unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) {      unless (defined($metaentry{':'.$unikey.'.'.$subp})) {
  $metacache{$uri}->{':'.$unikey.'.'.$subp}=$value;   $metaentry{':'.$unikey.'.'.$subp}=$value;
     }      }
     if (defined($metacache{$uri}->{':'.$unikey.'.default'})) {      if (defined($metaentry{':'.$unikey.'.default'})) {
  $metacache{$uri}->{':'.$unikey}=   $metaentry{':'.$unikey}=
     $metacache{$uri}->{':'.$unikey.'.default'};      $metaentry{':'.$unikey.'.default'};
     }      }
 }  }
   
 sub metadata_generate_part0 {  sub metadata_generate_part0 {
     my ($metadata,$metacache,$uri) = @_;      my ($metadata,$metacache,$uri) = @_;
     my %allnames;      my %allnames;
     foreach my $metakey (sort keys %$metadata) {      foreach my $metakey (keys(%$metadata)) {
  if ($metakey=~/^parameter\_(.*)/) {   if ($metakey=~/^parameter\_(.*)/) {
   my $part=$$metacache{':'.$metakey.'.part'};    my $part=$$metacache{':'.$metakey.'.part'};
   my $name=$$metacache{':'.$metakey.'.name'};    my $name=$$metacache{':'.$metakey.'.name'};
Line 4608  sub metadata_generate_part0 { Line 9830  sub metadata_generate_part0 {
    '.type'};     '.type'};
       my $olddis=$$metacache{':parameter_'.$allnames{$name}.'_'.$name.        my $olddis=$$metacache{':parameter_'.$allnames{$name}.'_'.$name.
      '.display'};       '.display'};
       my $expr='\\[Part: '.$allnames{$name}.'\\]';        my $expr='[Part: '.$allnames{$name}.']';
       $olddis=~s/\Q$expr\E/\[Part: 0\]/;        $olddis=~s/\Q$expr\E/\[Part: 0\]/;
       $$metacache{"$key.display"}=$olddis;        $$metacache{"$key.display"}=$olddis;
     }      }
 }  }
   
   # ------------------------------------------------------ Devalidate title cache
   
   sub devalidate_title_cache {
       my ($url)=@_;
       if (!$env{'request.course.id'}) { return; }
       my $symb=&symbread($url);
       if (!$symb) { return; }
       my $key=$env{'request.course.id'}."\0".$symb;
       &devalidate_cache_new('title',$key);
   }
   
   # ------------------------------------------------- Get the title of a course
   
   sub current_course_title {
       return $env{ 'course.' . $env{'request.course.id'} . '.description' };
   }
 # ------------------------------------------------- Get the title of a resource  # ------------------------------------------------- Get the title of a resource
   
 sub gettitle {  sub gettitle {
     my $urlsymb=shift;      my $urlsymb=shift;
     my $symb=&symbread($urlsymb);      my $symb=&symbread($urlsymb);
     if ($symb) {      if ($symb) {
  my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600);   my $key=$env{'request.course.id'}."\0".$symb;
  if (defined($cached)) { return $result; }   my ($result,$cached)=&is_cached_new('title',$key);
    if (defined($cached)) { 
       return $result;
    }
  my ($map,$resid,$url)=&decode_symb($symb);   my ($map,$resid,$url)=&decode_symb($symb);
  my $title='';   my $title='';
  my %bighash;   if (!$map && $resid == 0 && $url =~/default\.sequence$/) {
  if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',      $title = $env{'course.'.$env{'request.course.id'}.'.description'};
  &GDBM_READER(),0640)) {   } else {
     my $mapid=$bighash{'map_pc_'.&clutter($map)};      if (tie(my %bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
     $title=$bighash{'title_'.$mapid.'.'.$resid};      &GDBM_READER(),0640)) {
     untie %bighash;   my $mapid=$bighash{'map_pc_'.&clutter($map)};
    $title=$bighash{'title_'.$mapid.'.'.$resid};
    untie(%bighash);
       }
  }   }
  $title=~s/\&colon\;/\:/gs;   $title=~s/\&colon\;/\:/gs;
  if ($title) {   if ($title) {
     return &do_cache(\%titlecache,$symb,$title,'title');  # Remember both $symb and $title for dynamic metadata
               $accesshash{$symb.'___crstitle'}=$title;
               $accesshash{&declutter($map).'___'.&declutter($url).'___usage'}=time;
   # Cache this title and then return it
       return &do_cache_new('title',$key,$title,600);
  }   }
  $urlsymb=$url;   $urlsymb=$url;
     }      }
Line 4641  sub gettitle { Line 9889  sub gettitle {
     if (!$title) { $title=(split('/',$urlsymb))[-1]; }          if (!$title) { $title=(split('/',$urlsymb))[-1]; }    
     return $title;      return $title;
 }  }
       
   sub get_slot {
       my ($which,$cnum,$cdom)=@_;
       if (!$cnum || !$cdom) {
    (undef,my $courseid)=&whichuser();
    $cdom=$env{'course.'.$courseid.'.domain'};
    $cnum=$env{'course.'.$courseid.'.num'};
       }
       my $key=join("\0",'slots',$cdom,$cnum,$which);
       my %slotinfo;
       if (exists($remembered{$key})) {
    $slotinfo{$which} = $remembered{$key};
       } else {
    %slotinfo=&get('slots',[$which],$cdom,$cnum);
    &Apache::lonhomework::showhash(%slotinfo);
    my ($tmp)=keys(%slotinfo);
    if ($tmp=~/^error:/) { return (); }
    $remembered{$key} = $slotinfo{$which};
       }
       if (ref($slotinfo{$which}) eq 'HASH') {
    return %{$slotinfo{$which}};
       }
       return $slotinfo{$which};
   }
   
   sub get_reservable_slots {
       my ($cnum,$cdom,$uname,$udom) = @_;
       my $now = time;
       my $reservable_info;
       my $key=join("\0",'reservableslots',$cdom,$cnum,$uname,$udom);
       if (exists($remembered{$key})) {
           $reservable_info = $remembered{$key};
       } else {
           my %resv;
           ($resv{'now_order'},$resv{'now'},$resv{'future_order'},$resv{'future'}) =
           &Apache::loncommon::get_future_slots($cnum,$cdom,$now);
           $reservable_info = \%resv;
           $remembered{$key} = $reservable_info;
       }
       return $reservable_info;
   }
   
   sub get_course_slots {
       my ($cnum,$cdom) = @_;
       my $hashid=$cnum.':'.$cdom;
       my ($result,$cached) = &Apache::lonnet::is_cached_new('allslots',$hashid);
       if (defined($cached)) {
           if (ref($result) eq 'HASH') {
               return %{$result};
           }
       } else {
           my %slots=&Apache::lonnet::dump('slots',$cdom,$cnum);
           my ($tmp) = keys(%slots);
           if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
               &Apache::lonnet::do_cache_new('allslots',$hashid,\%slots,600);
               return %slots;
           }
       }
       return;
   }
   
   sub devalidate_slots_cache {
       my ($cnum,$cdom)=@_;
       my $hashid=$cnum.':'.$cdom;
       &devalidate_cache_new('allslots',$hashid);
   }
   
   sub get_coursechange {
       my ($cdom,$cnum) = @_;
       if ($cdom eq '' || $cnum eq '') {
           return unless ($env{'request.course.id'});
           $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
           $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
       }
       my $hashid=$cdom.'_'.$cnum;
       my ($change,$cached)=&is_cached_new('crschange',$hashid);
       if ((defined($cached)) && ($change ne '')) {
           return $change;
       } else {
           my %crshash;
           %crshash = &get('environment',['internal.contentchange'],$cdom,$cnum);
           if ($crshash{'internal.contentchange'} eq '') {
               $change = $env{'course.'.$cdom.'_'.$cnum.'.internal.created'};
               if ($change eq '') {
                   %crshash = &get('environment',['internal.created'],$cdom,$cnum);
                   $change = $crshash{'internal.created'};
               }
           } else {
               $change = $crshash{'internal.contentchange'};
           }
           my $cachetime = 600;
           &do_cache_new('crschange',$hashid,$change,$cachetime);
       }
       return $change;
   }
   
   sub devalidate_coursechange_cache {
       my ($cnum,$cdom)=@_;
       my $hashid=$cnum.':'.$cdom;
       &devalidate_cache_new('crschange',$hashid);
   }
   
 # ------------------------------------------------- Update symbolic store links  # ------------------------------------------------- Update symbolic store links
   
 sub symblist {  sub symblist {
     my ($mapname,%newhash)=@_;      my ($mapname,%newhash)=@_;
     $mapname=&deversion(&declutter($mapname));      $mapname=&deversion(&declutter($mapname));
     my %hash;      my %hash;
     if (($ENV{'request.course.fn'}) && (%newhash)) {      if (($env{'request.course.fn'}) && (%newhash)) {
         if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',          if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
                       &GDBM_WRCREAT(),0640)) {                        &GDBM_WRCREAT(),0640)) {
     foreach (keys %newhash) {      foreach my $url (keys(%newhash)) {
                 $hash{declutter($_)}=$mapname.'___'.&deversion($newhash{$_});   next if ($url eq 'last_known'
    && $env{'form.no_update_last_known'});
    $hash{declutter($url)}=&encode_symb($mapname,
       $newhash{$url}->[1],
       $newhash{$url}->[0]);
             }              }
             if (untie(%hash)) {              if (untie(%hash)) {
  return 'ok';   return 'ok';
Line 4667  sub symblist { Line 10020  sub symblist {
 sub symbverify {  sub symbverify {
     my ($symb,$thisurl)=@_;      my ($symb,$thisurl)=@_;
     my $thisfn=$thisurl;      my $thisfn=$thisurl;
 # wrapper not part of symbs  
     $thisfn=~s/^\/adm\/wrapper//;  
     $thisfn=&declutter($thisfn);      $thisfn=&declutter($thisfn);
 # direct jump to resource in page or to a sequence - will construct own symbs  # direct jump to resource in page or to a sequence - will construct own symbs
     if ($thisfn=~/\.(page|sequence)$/) { return 1; }      if ($thisfn=~/\.(page|sequence)$/) { return 1; }
Line 4684  sub symbverify { Line 10035  sub symbverify {
     my %bighash;      my %bighash;
     my $okay=0;      my $okay=0;
   
     if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',      if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
                             &GDBM_READER(),0640)) {                              &GDBM_READER(),0640)) {
           if (($thisurl =~ m{^/adm/wrapper/ext/}) || ($thisurl =~ m{^ext/})) {
               $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)
     foreach (split(/\,/,$ids)) {      foreach my $id (split(/\,/,$ids)) {
                my ($mapid,$resid)=split(/\./,$_);         my ($mapid,$resid)=split(/\./,$id);
                  if ($thisfn =~ m{^/adm/wrapper/ext/}) {
                      $symb =~ s/\?.+$//;
                  }
                if (                 if (
   &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)    &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)
    eq $symb) {      eq $symb) { 
                   $okay=1;      if (($env{'request.role.adv'}) ||
                }         ($bighash{'encrypted_'.$id} eq $env{'request.enc'}) ||
                          ($thisurl eq '/adm/navmaps')) {
          $okay=1; 
      }
          }
    }     }
         }          }
  untie(%bighash);   untie(%bighash);
Line 4710  sub symbverify { Line 10072  sub symbverify {
   
 sub symbclean {  sub symbclean {
     my $symb=shift;      my $symb=shift;
       if ($symb=~m|^/enc/|) { $symb=&Apache::lonenc::unencrypted($symb); }
 # remove version from map  # remove version from map
     $symb=~s/\.(\d+)\.(\w+)\_\_\_/\.$2\_\_\_/;      $symb=~s/\.(\d+)\.(\w+)\_\_\_/\.$2\_\_\_/;
   
Line 4720  sub symbclean { Line 10082  sub symbclean {
 # remove wrapper  # remove wrapper
   
     $symb=~s/(\_\_\_\d+\_\_\_)adm\/wrapper\/(res\/)*/$1/;      $symb=~s/(\_\_\_\d+\_\_\_)adm\/wrapper\/(res\/)*/$1/;
       $symb=~s/(\_\_\_\d+\_\_\_)adm\/coursedocs\/showdoc\/(res\/)*/$1/;
     return $symb;      return $symb;
 }  }
   
Line 4731  sub encode_symb { Line 10094  sub encode_symb {
 }  }
   
 sub decode_symb {  sub decode_symb {
     my ($map,$resid,$url)=split(/\_\_\_/,shift);      my $symb=shift;
       if ($symb=~m|^/enc/|) { $symb=&Apache::lonenc::unencrypted($symb); }
       my ($map,$resid,$url)=split(/___/,$symb);
     return (&fixversion($map),$resid,&fixversion($url));      return (&fixversion($map),$resid,&fixversion($url));
 }  }
   
 sub fixversion {  sub fixversion {
     my $fn=shift;      my $fn=shift;
     if ($fn=~/^(adm|uploaded|public)/) { return $fn; }      if ($fn=~/^(adm|uploaded|editupload|public)/) { return $fn; }
     my %bighash;      my %bighash;
     my $uri=&clutter($fn);      my $uri=&clutter($fn);
     my $key=$ENV{'request.course.id'}.'_'.$uri;      my $key=$env{'request.course.id'}.'_'.$uri;
 # is this cached?  # is this cached?
     my ($result,$cached)=&is_cached(\%courseresversioncache,$key,      my ($result,$cached)=&is_cached_new('courseresversion',$key);
     'courseresversion',600);  
     if (defined($cached)) { return $result; }      if (defined($cached)) { return $result; }
 # unfortunately not cached, or expired  # unfortunately not cached, or expired
     if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',      if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
     &GDBM_READER(),0640)) {      &GDBM_READER(),0640)) {
   if ($bighash{'version_'.$uri}) {    if ($bighash{'version_'.$uri}) {
      my $version=$bighash{'version_'.$uri};       my $version=$bighash{'version_'.$uri};
Line 4757  sub fixversion { Line 10121  sub fixversion {
   }    }
   untie %bighash;    untie %bighash;
     }      }
     return &do_cache      return &do_cache_new('courseresversion',$key,&declutter($uri),600);
  (\%courseresversioncache,$key,&declutter($uri),'courseresversion');  
 }  }
   
 sub deversion {  sub deversion {
Line 4772  sub deversion { Line 10135  sub deversion {
 sub symbread {  sub symbread {
     my ($thisfn,$donotrecurse)=@_;      my ($thisfn,$donotrecurse)=@_;
     my $cache_str='request.symbread.cached.'.$thisfn;      my $cache_str='request.symbread.cached.'.$thisfn;
     if (defined($ENV{$cache_str})) { return $ENV{$cache_str}; }      if (defined($env{$cache_str})) {
           if (($thisfn) || ($env{$cache_str} ne '')) {
               return $env{$cache_str};
           }
       }
 # no filename provided? try from environment  # no filename provided? try from environment
     unless ($thisfn) {      unless ($thisfn) {
         if ($ENV{'request.symb'}) {          if ($env{'request.symb'}) {
     return $ENV{$cache_str}=&symbclean($ENV{'request.symb'});      return $env{$cache_str}=&symbclean($env{'request.symb'});
  }   }
  $thisfn=$ENV{'request.filename'};   $thisfn=$env{'request.filename'};
     }      }
       if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }
 # is that filename actually a symb? Verify, clean, and return  # is that filename actually a symb? Verify, clean, and return
     if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) {      if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) {
  if (&symbverify($thisfn,$1)) {   if (&symbverify($thisfn,$1)) {
     return $ENV{$cache_str}=&symbclean($thisfn);      return $env{$cache_str}=&symbclean($thisfn);
  }   }
     }      }
     $thisfn=declutter($thisfn);      $thisfn=declutter($thisfn);
     my %hash;      my %hash;
     my %bighash;      my %bighash;
     my $syval='';      my $syval='';
     if (($ENV{'request.course.fn'}) && ($thisfn)) {      if (($env{'request.course.fn'}) && ($thisfn)) {
         my $targetfn = $thisfn;          my $targetfn = $thisfn;
         if ( ($thisfn =~ m/^uploaded\//) && ($thisfn !~ m/\.(page|sequence)$/) ) {          if ( ($thisfn =~ m/^(uploaded|editupload)\//) && ($thisfn !~ m/\.(page|sequence)$/) ) {
             $targetfn = 'adm/wrapper/'.$thisfn;              $targetfn = 'adm/wrapper/'.$thisfn;
         }          }
         if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',   if ($targetfn =~ m|^adm/wrapper/(ext/.*)|) {
       $targetfn=$1;
    }
           if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
                       &GDBM_READER(),0640)) {                        &GDBM_READER(),0640)) {
     $syval=$hash{$targetfn};      $syval=$hash{$targetfn};
             untie(%hash);              untie(%hash);
         }          }
 # ---------------------------------------------------------- There was an entry  # ---------------------------------------------------------- There was an entry
         if ($syval) {          if ($syval) {
            unless ($syval=~/\_\d+$/) {      #unless ($syval=~/\_\d+$/) {
        unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) {   #unless ($env{'form.request.prefix'}=~/\.(\d+)\_$/) {
                   &appenv('request.ambiguous' => $thisfn);      #&appenv({'request.ambiguous' => $thisfn});
   return $ENV{$cache_str}='';      #return $env{$cache_str}='';
                }       #}    
                $syval.=$1;   #$syval.=$1;
    }      #}
         } else {          } else {
 # ------------------------------------------------------- Was not in symb table  # ------------------------------------------------------- Was not in symb table
            if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',             if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
                             &GDBM_READER(),0640)) {                              &GDBM_READER(),0640)) {
 # ---------------------------------------------- Get ID(s) for current resource  # ---------------------------------------------- Get ID(s) for current resource
               my $ids=$bighash{'ids_'.&clutter($thisfn)};                my $ids=$bighash{'ids_'.&clutter($thisfn)};
Line 4828  sub symbread { Line 10199  sub symbread {
                  if ($#possibilities==0) {                   if ($#possibilities==0) {
 # ----------------------------------------------- There is only one possibility  # ----------------------------------------------- There is only one possibility
      my ($mapid,$resid)=split(/\./,$ids);       my ($mapid,$resid)=split(/\./,$ids);
                      $syval=declutter($bighash{'map_id_'.$mapid}).'___'.$resid;       $syval=&encode_symb($bighash{'map_id_'.$mapid},
       $resid,$thisfn);
                  } elsif (!$donotrecurse) {                   } elsif (!$donotrecurse) {
 # ------------------------------------------ There is more than one possibility  # ------------------------------------------ There is more than one possibility
                      my $realpossible=0;                       my $realpossible=0;
                      foreach (@possibilities) {                       foreach my $id (@possibilities) {
  my $file=$bighash{'src_'.$_};   my $file=$bighash{'src_'.$id};
                          if (&allowed('bre',$file)) {                           if (&allowed('bre',$file)) {
              my ($mapid,$resid)=split(/\./,$_);               my ($mapid,$resid)=split(/\./,$id);
                             if ($bighash{'map_type_'.$mapid} ne 'page') {                              if ($bighash{'map_type_'.$mapid} ne 'page') {
  $realpossible++;   $realpossible++;
                                 $syval=declutter($bighash{'map_id_'.$mapid}).                                  $syval=&encode_symb($bighash{'map_id_'.$mapid},
                                        '___'.$resid;      $resid,$thisfn);
                             }                              }
  }   }
                      }                       }
Line 4852  sub symbread { Line 10224  sub symbread {
            }             }
         }          }
         if ($syval) {          if ($syval) {
     return $ENV{$cache_str}=&symbclean($syval.'___'.$thisfn);      return $env{$cache_str}=$syval;
         }          }
     }      }
     &appenv('request.ambiguous' => $thisfn);      &appenv({'request.ambiguous' => $thisfn});
     return $ENV{$cache_str}='';      return $env{$cache_str}='';
 }  }
   
 # ---------------------------------------------------------- Return random seed  # ---------------------------------------------------------- Return random seed
Line 4890  sub numval2 { Line 10262  sub numval2 {
     return int($total);      return int($total);
 }  }
   
   sub numval3 {
       use integer;
       my $txt=shift;
       $txt=~tr/A-J/0-9/;
       $txt=~tr/a-j/0-9/;
       $txt=~tr/K-T/0-9/;
       $txt=~tr/k-t/0-9/;
       $txt=~tr/U-Z/0-5/;
       $txt=~tr/u-z/0-5/;
       $txt=~s/\D//g;
       my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt);
       my $total;
       foreach my $val (@txts) { $total+=$val; }
       if ($_64bit) { $total=(($total<<32)>>32); }
       return $total;
   }
   
   sub digest {
       my ($data)=@_;
       my $digest=&Digest::MD5::md5($data);
       my ($a,$b,$c,$d)=unpack("iiii",$digest);
       my ($e,$f);
       {
           use integer;
           $e=($a+$b);
           $f=($c+$d);
           if ($_64bit) {
               $e=(($e<<32)>>32);
               $f=(($f<<32)>>32);
           }
       }
       if (wantarray) {
    return ($e,$f);
       } else {
    my $g;
    {
       use integer;
       $g=($e+$f);
       if ($_64bit) {
    $g=(($g<<32)>>32);
       }
    }
    return $g;
       }
   }
   
 sub latest_rnd_algorithm_id {  sub latest_rnd_algorithm_id {
     return '64bit3';      return '64bit5';
 }  }
   
 sub get_rand_alg {  sub get_rand_alg {
     my ($courseid)=@_;      my ($courseid)=@_;
     if (!$courseid) { $courseid=(&Apache::lonxml::whichuser())[1]; }      if (!$courseid) { $courseid=(&whichuser())[1]; }
     if ($courseid) {      if ($courseid) {
  return $ENV{"course.$courseid.rndseed"};   return $env{"course.$courseid.rndseed"};
     }      }
     return &latest_rnd_algorithm_id();      return &latest_rnd_algorithm_id();
 }  }
Line 4910  sub validCODE { Line 10328  sub validCODE {
 }  }
   
 sub getCODE {  sub getCODE {
     if (&validCODE($ENV{'form.CODE'})) { return $ENV{'form.CODE'}; }      if (&validCODE($env{'form.CODE'})) { return $env{'form.CODE'}; }
     if (defined($Apache::lonhomework::parsing_a_problem) &&      if ( (defined($Apache::lonhomework::parsing_a_problem) ||
  &validCODE($Apache::lonhomework::history{'resource.CODE'})) {    defined($Apache::lonhomework::parsing_a_task) ) &&
    &validCODE($Apache::lonhomework::history{'resource.CODE'})) {
  return $Apache::lonhomework::history{'resource.CODE'};   return $Apache::lonhomework::history{'resource.CODE'};
     }      }
     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)=&Apache::lonxml::whichuser();      if (!defined($symb)) {
     if (!$symb) {  
  unless ($symb=$wsymb) { return time; }   unless ($symb=$wsymb) { return time; }
     }      }
     if (!$courseid) { $courseid=$wcourseid; }      if (!defined $courseid) { 
     if (!$domain) { $domain=$wdomain; }   $courseid=$wcourseid; 
     if (!$username) { $username=$wusername }      }
     my $which=&get_rand_alg();      if (!defined $domain) { $domain=$wdomain; }
       if (!defined $username) { $username=$wusername }
   
       my $which;
       if (defined($cenv->{'rndseed'})) {
    $which = $cenv->{'rndseed'};
       } else {
    $which =&get_rand_alg($courseid);
       }
     if (defined(&getCODE())) {      if (defined(&getCODE())) {
  return &rndseed_CODE_64bit($symb,$courseid,$domain,$username);  
    if ($which eq '64bit5') {
       return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username);
    } elsif ($which eq '64bit4') {
       return &rndseed_CODE_64bit4($symb,$courseid,$domain,$username);
    } else {
       return &rndseed_CODE_64bit($symb,$courseid,$domain,$username);
    }
       } elsif ($which eq '64bit5') {
    return &rndseed_64bit5($symb,$courseid,$domain,$username);
       } elsif ($which eq '64bit4') {
    return &rndseed_64bit4($symb,$courseid,$domain,$username);
     } elsif ($which eq '64bit3') {      } elsif ($which eq '64bit3') {
  return &rndseed_64bit3($symb,$courseid,$domain,$username);   return &rndseed_64bit3($symb,$courseid,$domain,$username);
     } elsif ($which eq '64bit2') {      } elsif ($which eq '64bit2') {
Line 4952  sub rndseed_32bit { Line 10406  sub rndseed_32bit {
  my $domainseed=unpack("%32C*",$domain) << 7;   my $domainseed=unpack("%32C*",$domain) << 7;
  my $courseseed=unpack("%32C*",$courseid);   my $courseseed=unpack("%32C*",$courseid);
  my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;   my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;
  #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");   #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
  #&Apache::lonxml::debug("rndseed :$num:$symb");   #&logthis("rndseed :$num:$symb");
  if ($_64bit) { $num=(($num<<32)>>32); }   if ($_64bit) { $num=(($num<<32)>>32); }
  return $num;   return $num;
     }      }
Line 4973  sub rndseed_64bit { Line 10427  sub rndseed_64bit {
   
  my $num1=$symbchck+$symbseed+$namechck;   my $num1=$symbchck+$symbseed+$namechck;
  my $num2=$nameseed+$domainseed+$courseseed;   my $num2=$nameseed+$domainseed+$courseseed;
  #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");   #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
  #&Apache::lonxml::debug("rndseed :$num:$symb");   #&logthis("rndseed :$num:$symb");
  if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }  
  if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }   if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
  return "$num1,$num2";   return "$num1,$num2";
     }      }
Line 4997  sub rndseed_64bit2 { Line 10450  sub rndseed_64bit2 {
   
  my $num1=$symbchck+$symbseed+$namechck;   my $num1=$symbchck+$symbseed+$namechck;
  my $num2=$nameseed+$domainseed+$courseseed;   my $num2=$nameseed+$domainseed+$courseseed;
  #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");   #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
  #&Apache::lonxml::debug("rndseed :$num:$symb");   #&logthis("rndseed :$num:$symb");
    if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
  return "$num1,$num2";   return "$num1,$num2";
     }      }
 }  }
Line 5019  sub rndseed_64bit3 { Line 10473  sub rndseed_64bit3 {
   
  my $num1=$symbchck+$symbseed+$namechck;   my $num1=$symbchck+$symbseed+$namechck;
  my $num2=$nameseed+$domainseed+$courseseed;   my $num2=$nameseed+$domainseed+$courseseed;
  #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");   #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
  #&Apache::lonxml::debug("rndseed :$num1:$num2:$_64bit");   #&logthis("rndseed :$num1:$num2:$_64bit");
  if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }   if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
   
  return "$num1:$num2";   return "$num1:$num2";
     }      }
 }  }
   
   sub rndseed_64bit4 {
       my ($symb,$courseid,$domain,$username)=@_;
       {
    use integer;
    # strings need to be an even # of cahracters long, it it is odd the
           # last characters gets thrown away
    my $symbchck=unpack("%32S*",$symb.' ') << 21;
    my $symbseed=numval3($symb) << 10;
    my $namechck=unpack("%32S*",$username.' ');
   
    my $nameseed=numval3($username) << 21;
    my $domainseed=unpack("%32S*",$domain.' ') << 10;
    my $courseseed=unpack("%32S*",$courseid.' ');
   
    my $num1=$symbchck+$symbseed+$namechck;
    my $num2=$nameseed+$domainseed+$courseseed;
    #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
    #&logthis("rndseed :$num1:$num2:$_64bit");
    if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
   
    return "$num1:$num2";
       }
   }
   
   sub rndseed_64bit5 {
       my ($symb,$courseid,$domain,$username)=@_;
       my ($num1,$num2)=&digest("$symb,$courseid,$domain,$username");
       return "$num1:$num2";
   }
   
 sub rndseed_CODE_64bit {  sub rndseed_CODE_64bit {
     my ($symb,$courseid,$domain,$username)=@_;      my ($symb,$courseid,$domain,$username)=@_;
     {      {
Line 5038  sub rndseed_CODE_64bit { Line 10522  sub rndseed_CODE_64bit {
  my $courseseed=unpack("%32S*",$courseid.' ');   my $courseseed=unpack("%32S*",$courseid.' ');
  my $num1=$symbseed+$CODEchck;   my $num1=$symbseed+$CODEchck;
  my $num2=$CODEseed+$courseseed+$symbchck;   my $num2=$CODEseed+$courseseed+$symbchck;
  #&Apache::lonxml::debug("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck");   #&logthis("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck");
  #&Apache::lonxml::debug("rndseed :$num1:$num2:$symb");   #&logthis("rndseed :$num1:$num2:$symb");
  if ($_64bit) { $num1=(($num1<<32)>>32); }   if ($_64bit) { $num1=(($num1<<32)>>32); }
  if ($_64bit) { $num2=(($num2<<32)>>32); }   if ($_64bit) { $num2=(($num2<<32)>>32); }
  return "$num1:$num2";   return "$num1:$num2";
     }      }
 }  }
   
   sub rndseed_CODE_64bit4 {
       my ($symb,$courseid,$domain,$username)=@_;
       {
    use integer;
    my $symbchck=unpack("%32S*",$symb.' ') << 16;
    my $symbseed=numval3($symb);
    my $CODEchck=unpack("%32S*",&getCODE().' ') << 16;
    my $CODEseed=numval3(&getCODE());
    my $courseseed=unpack("%32S*",$courseid.' ');
    my $num1=$symbseed+$CODEchck;
    my $num2=$CODEseed+$courseseed+$symbchck;
    #&logthis("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck");
    #&logthis("rndseed :$num1:$num2:$symb");
    if ($_64bit) { $num1=(($num1<<32)>>32); }
    if ($_64bit) { $num2=(($num2<<32)>>32); }
    return "$num1:$num2";
       }
   }
   
   sub rndseed_CODE_64bit5 {
       my ($symb,$courseid,$domain,$username)=@_;
       my $code = &getCODE();
       my ($num1,$num2)=&digest("$symb,$courseid,$code");
       return "$num1:$num2";
   }
   
 sub setup_random_from_rndseed {  sub setup_random_from_rndseed {
     my ($rndseed)=@_;      my ($rndseed)=@_;
     if ($rndseed =~/([,:])/) {      if ($rndseed =~/([,:])/) {
Line 5057  sub setup_random_from_rndseed { Line 10567  sub setup_random_from_rndseed {
 }  }
   
 sub latest_receipt_algorithm_id {  sub latest_receipt_algorithm_id {
     return 'receipt2';      return 'receipt3';
 }  }
   
 sub recunique {  sub recunique {
     my $fucourseid=shift;      my $fucourseid=shift;
     my $unique;      my $unique;
     if ($ENV{"course.$fucourseid.receiptalg"} eq 'receipt2') {      if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' ||
  $unique=$ENV{"course.$fucourseid.internal.encseed"};   $env{"course.$fucourseid.receiptalg"} eq 'receipt3' ) {
    $unique=$env{"course.$fucourseid.internal.encseed"};
     } else {      } else {
  $unique=$perlvar{'lonReceipt'};   $unique=$perlvar{'lonReceipt'};
     }      }
Line 5074  sub recunique { Line 10585  sub recunique {
 sub recprefix {  sub recprefix {
     my $fucourseid=shift;      my $fucourseid=shift;
     my $prefix;      my $prefix;
     if ($ENV{"course.$fucourseid.receiptalg"} eq 'receipt2') {      if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2'||
  $prefix=$ENV{"course.$fucourseid.internal.encpref"};   $env{"course.$fucourseid.receiptalg"} eq 'receipt3' ) {
    $prefix=$env{"course.$fucourseid.internal.encpref"};
     } else {      } else {
  $prefix=$perlvar{'lonHostID'};   $prefix=$perlvar{'lonHostID'};
     }      }
Line 5084  sub recprefix { Line 10596  sub recprefix {
   
 sub ireceipt {  sub ireceipt {
     my ($funame,$fudom,$fucourseid,$fusymb,$part)=@_;      my ($funame,$fudom,$fucourseid,$fusymb,$part)=@_;
   
       my $return =&recprefix($fucourseid).'-';
   
       if ($env{"course.$fucourseid.receiptalg"} eq 'receipt3' ||
    $env{'request.state'} eq 'construct') {
    $return .= (&digest("$funame,$fudom,$fucourseid,$fusymb,$part")%10000);
    return $return;
       }
   
     my $cuname=unpack("%32C*",$funame);      my $cuname=unpack("%32C*",$funame);
     my $cudom=unpack("%32C*",$fudom);      my $cudom=unpack("%32C*",$fudom);
     my $cucourseid=unpack("%32C*",$fucourseid);      my $cucourseid=unpack("%32C*",$fucourseid);
     my $cusymb=unpack("%32C*",$fusymb);      my $cusymb=unpack("%32C*",$fusymb);
     my $cunique=&recunique($fucourseid);      my $cunique=&recunique($fucourseid);
     my $cpart=unpack("%32S*",$part);      my $cpart=unpack("%32S*",$part);
     my $return =&recprefix($fucourseid).'-';      if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') {
     if ($ENV{"course.$fucourseid.receiptalg"} eq 'receipt2' ||  
  $ENV{'request.state'} eq 'construct') {   #&logthis("doing receipt2  using parts $cpart, uname $cuname and udom $cudom gets  ".($cpart%$cuname)." and ".($cpart%$cudom));
  &Apache::lonxml::debug("doing receipt2  using parts $cpart, uname $cuname and udom $cudom gets  ".($cpart%$cuname).  
        " and ".($cpart%$cudom));  
                 
  $return.= ($cunique%$cuname+   $return.= ($cunique%$cuname+
    $cunique%$cudom+     $cunique%$cudom+
Line 5117  sub ireceipt { Line 10636  sub ireceipt {
   
 sub receipt {  sub receipt {
     my ($part)=@_;      my ($part)=@_;
     my ($symb,$courseid,$domain,$name) = &Apache::lonxml::whichuser();      my ($symb,$courseid,$domain,$name) = &whichuser();
     return &ireceipt($name,$domain,$courseid,$symb,$part);      return &ireceipt($name,$domain,$courseid,$symb,$part);
 }  }
   
   sub whichuser {
       my ($passedsymb)=@_;
       my ($symb,$courseid,$domain,$name,$publicuser);
       if (defined($env{'form.grade_symb'})) {
    my ($tmp_courseid)=&get_env_multiple('form.grade_courseid');
    my $allowed=&allowed('vgr',$tmp_courseid);
    if (!$allowed &&
       exists($env{'request.course.sec'}) &&
       $env{'request.course.sec'} !~ /^\s*$/) {
       $allowed=&allowed('vgr',$tmp_courseid.
         '/'.$env{'request.course.sec'});
    }
    if ($allowed) {
       ($symb)=&get_env_multiple('form.grade_symb');
       $courseid=$tmp_courseid;
       ($domain)=&get_env_multiple('form.grade_domain');
       ($name)=&get_env_multiple('form.grade_username');
       return ($symb,$courseid,$domain,$name,$publicuser);
    }
       }
       if (!$passedsymb) {
    $symb=&symbread();
       } else {
    $symb=$passedsymb;
       }
       $courseid=$env{'request.course.id'};
       $domain=$env{'user.domain'};
       $name=$env{'user.name'};
       if ($name eq 'public' && $domain eq 'public') {
    if (!defined($env{'form.username'})) {
       $env{'form.username'}.=time.rand(10000000);
    }
    $name.=$env{'form.username'};
       }
       return ($symb,$courseid,$domain,$name,$publicuser);
   
   }
   
 # ------------------------------------------------------------ Serves up a file  # ------------------------------------------------------------ Serves up a file
 # returns either the contents of the file or   # returns either the contents of the file or 
 # -1 if the file doesn't exist  # -1 if the file doesn't exist
Line 5133  sub receipt { Line 10690  sub receipt {
   
 sub getfile {  sub getfile {
     my ($file) = @_;      my ($file) = @_;
       if ($file =~ m -^/*(uploaded|editupload)/-) { $file=&filelocation("",$file); }
     if ($file =~ m|^/*uploaded/|) { $file=&filelocation("",$file); }  
     &repcopy($file);      &repcopy($file);
     return &readfile($file);      return &readfile($file);
 }  }
   
 sub repcopy_userfile {  sub repcopy_userfile {
     my ($file)=@_;      my ($file)=@_;
       my $londocroot = $perlvar{'lonDocRoot'};
     if ($file =~ m|^/*uploaded/|) { $file=&filelocation("",$file); }      if ($file =~ m{^/*(uploaded|editupload)/}) { $file=&filelocation("",$file); }
     if ($file =~ m|^/home/httpd/html/lonUsers/|) { return OK; }      if ($file =~ m{^\Q/home/httpd/lonUsers/\E}) { return 'ok'; }
   
     my ($cdom,$cnum,$filename) =       my ($cdom,$cnum,$filename) = 
  ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+([^/]+)/+([^/]+)/+(.*)|);   ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_name)/+(.*)|);
     my ($info,$rtncode);  
     my $uri="/uploaded/$cdom/$cnum/$filename";      my $uri="/uploaded/$cdom/$cnum/$filename";
     if (-e "$file") {      if (-e "$file") {
   # we already have a local copy, check it out
  my @fileinfo = stat($file);   my @fileinfo = stat($file);
    my $rtncode;
    my $info;
  my $lwpresp = &getuploaded('HEAD',$uri,$cdom,$cnum,\$info,\$rtncode);   my $lwpresp = &getuploaded('HEAD',$uri,$cdom,$cnum,\$info,\$rtncode);
  if ($lwpresp ne 'ok') {   if ($lwpresp ne 'ok') {
   # there is no such file anymore, even though we had a local copy
     if ($rtncode eq '404') {      if ($rtncode eq '404') {
  unlink($file);   unlink($file);
     }      }
     #my $ua=new LWP::UserAgent;  
     #my $request=new HTTP::Request('GET',&tokenwrapper($uri));  
     #my $response=$ua->request($request);  
     #if ($response->is_success()) {  
  # return $response->content;  
  #    } else {  
  # return -1;  
  #    }  
     return -1;      return -1;
  }   }
  if ($info < $fileinfo[9]) {   if ($info < $fileinfo[9]) {
     return OK;  # nice, the file we have is up-to-date, just say okay
  }      return 'ok';
  $info = '';   } else {
  $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);  # the file is outdated, get rid of it
  if ($lwpresp ne 'ok') {      unlink($file);
     return -1;  
  }  
     } else {  
  my $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);  
  if ($lwpresp ne 'ok') {  
     my $ua=new LWP::UserAgent;  
     my $request=new HTTP::Request('GET',&tokenwrapper($uri));  
     my $response=$ua->request($request);  
     if ($response->is_success()) {  
  $info=$response->content;  
     } else {  
  return -1;  
     }  
  }  
  my @parts = ($cdom,$cnum);   
  if ($filename =~ m|^(.+)/[^/]+$|) {  
     push @parts, split(/\//,$1);  
  }   }
  my $path = $perlvar{'lonDocRoot'}.'/userfiles';      }
  foreach my $part (@parts) {  # one way or the other, at this point, we don't have the file
     $path .= '/'.$part;  # construct the correct path for the file
     if (!-e $path) {      my @parts = ($cdom,$cnum); 
  mkdir($path,0770);      if ($filename =~ m|^(.+)/[^/]+$|) {
     }   push @parts, split(/\//,$1);
       }
       my $path = $perlvar{'lonDocRoot'}.'/userfiles';
       foreach my $part (@parts) {
    $path .= '/'.$part;
    if (!-e $path) {
       mkdir($path,0770);
  }   }
     }      }
     open(FILE,">$file");  # now the path exists for sure
     print FILE $info;  # get a user agent
     close(FILE);      my $ua=new LWP::UserAgent;
     return OK;      my $transferfile=$file.'.in.transfer';
   # FIXME: this should flock
       if (-e $transferfile) { return 'ok'; }
       my $request;
       $uri=~s/^\///;
       my $homeserver = &homeserver($cnum,$cdom);
       my $protocol = $protocol{$homeserver};
       $protocol = 'http' if ($protocol ne 'https');
       $request=new HTTP::Request('GET',$protocol.'://'.&hostname($homeserver).'/raw/'.$uri);
       my $response=$ua->request($request,$transferfile);
   # did it work?
       if ($response->is_error()) {
    unlink($transferfile);
    &logthis("Userfile repcopy failed for $uri");
    return -1;
       }
   # worked, rename the transfer file
       rename($transferfile,$file);
       return 'ok';
 }  }
   
 sub tokenwrapper {  sub tokenwrapper {
     my $uri=shift;      my $uri=shift;
     $uri=~s|^http\://([^/]+)||;      $uri=~s|^https?\://([^/]+)||;
     $uri=~s|^/||;      $uri=~s|^/||;
     $ENV{'user.environment'}=~/\/([^\/]+)\.id/;      $env{'user.environment'}=~/\/([^\/]+)\.id/;
     my $token=$1;      my $token=$1;
     my (undef,$udom,$uname,$file)=split('/',$uri,4);      my (undef,$udom,$uname,$file)=split('/',$uri,4);
     if ($udom && $uname && $file) {      if ($udom && $uname && $file) {
  $file=~s|(\?\.*)*$||;   $file=~s|(\?\.*)*$||;
         &appenv("userfile.$udom/$uname/$file" => $ENV{'request.course.id'});          &appenv({"userfile.$udom/$uname/$file" => $env{'request.course.id'}});
         return 'http://'.$hostname{ &homeserver($uname,$udom)}.'/'.$uri.          my $homeserver = &homeserver($uname,$udom);
           my $protocol = $protocol{$homeserver};
           $protocol = 'http' if ($protocol ne 'https');
           return $protocol.'://'.&hostname($homeserver).'/'.$uri.
                (($uri=~/\?/)?'&':'?').'token='.$token.                 (($uri=~/\?/)?'&':'?').'token='.$token.
                                '&tokenissued='.$perlvar{'lonHostID'};                                 '&tokenissued='.$perlvar{'lonHostID'};
     } else {      } else {
Line 5222  sub tokenwrapper { Line 10782  sub tokenwrapper {
     }      }
 }  }
   
   # call with reqtype HEAD: get last modification time
   # call with reqtype GET: get the file contents
   # Do not call this with reqtype GET for large files! It loads everything into memory
   #
 sub getuploaded {  sub getuploaded {
     my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;      my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
     $uri=~s/^\///;      $uri=~s/^\///;
     $uri = 'http://'.$hostname{ &homeserver($cnum,$cdom)}.'/raw/'.$uri;      my $homeserver = &homeserver($cnum,$cdom);
       my $protocol = $protocol{$homeserver};
       $protocol = 'http' if ($protocol ne 'https');
       $uri = $protocol.'://'.&hostname($homeserver).'/raw/'.$uri;
     my $ua=new LWP::UserAgent;      my $ua=new LWP::UserAgent;
     my $request=new HTTP::Request($reqtype,$uri);      my $request=new HTTP::Request($reqtype,$uri);
     my $response=$ua->request($request);      my $response=$ua->request($request);
Line 5247  sub readfile { Line 10814  sub readfile {
     my $fh;      my $fh;
     open($fh,"<$file");      open($fh,"<$file");
     my $a='';      my $a='';
     while (<$fh>) { $a .=$_; }      while (my $line = <$fh>) { $a .= $line; }
     return $a;      return $a;
 }  }
   
 sub filelocation {  sub filelocation {
   my ($dir,$file) = @_;      my ($dir,$file) = @_;
   my $location;      my $location;
   $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces      $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces
   if ($file=~m:^/~:) { # is a contruction space reference  
     $location = $file;      if ($file =~ m-^/adm/-) {
     $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;   $file=~s-^/adm/wrapper/-/-;
   } elsif ($file=~/^\/*uploaded/) { # is an uploaded file   $file=~s-^/adm/coursedocs/showdoc/-/-;
       my ($udom,$uname,$filename)=      }
   ($file=~m|^/+uploaded/+([^/]+)/+([^/]+)/+(.*)$|);  
       my $home=&homeserver($uname,$udom);      if ($file =~ m-^\Q$Apache::lonnet::perlvar{'lonTabDir'}\E/-) {
       my $is_me=0;          $location = $file;
       my @ids=&current_machine_ids();      } elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file
       foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }          my ($udom,$uname,$filename)=
       if ($is_me) {       ($file=~m -^/+(?:uploaded|editupload)/+($match_domain)/+($match_name)/+(.*)$-);
   $location=&Apache::loncommon::propath($udom,$uname).          my $home=&homeserver($uname,$udom);
       '/userfiles/'.$filename;          my $is_me=0;
       } else {          my @ids=&current_machine_ids();
   $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.          foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }
       $udom.'/'.$uname.'/'.$filename;          if ($is_me) {
       }       $location=propath($udom,$uname).'/userfiles/'.$filename;
   } else {          } else {
     $file=~s/^\Q$perlvar{'lonDocRoot'}\E//;     $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.
     $file=~s:^/res/:/:;         $udom.'/'.$uname.'/'.$filename;
     if ( !( $file =~ m:^/:) ) {          }
       $location = $dir. '/'.$file;      } elsif ($file =~ m-^/adm/-) {
    $location = $perlvar{'lonDocRoot'}.'/'.$file;
     } else {      } else {
       $location = '/home/httpd/html/res'.$file;          $file=~s/^\Q$perlvar{'lonDocRoot'}\E//;
           $file=~s:^/(res|priv)/:/:;
           my $space=$1;
           if ( !( $file =~ m:^/:) ) {
               $location = $dir. '/'.$file;
           } else {
               $location = $perlvar{'lonDocRoot'}.'/'.$space.$file;
           }
     }      }
   }      $location=~s://+:/:g; # remove duplicate /
   $location=~s://+:/:g; # remove duplicate /      while ($location=~m{/\.\./}) {
   while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..   if ($location =~ m{/[^/]+/\.\./}) {
   while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./      $location=~ s{/[^/]+/\.\./}{/}g;
   return $location;   } else {
       $location=~ s{/\.\./}{/}g;
    }
       } #remove dir/..
       while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./
       return $location;
 }  }
   
 sub hreflocation {  sub hreflocation {
     my ($dir,$file)=@_;      my ($dir,$file)=@_;
     unless (($file=~m-^http://-i) || ($file=~m-^/-)) {      unless (($file=~m-^https?\://-i) || ($file=~m-^/-)) {
  my $finalpath=filelocation($dir,$file);   $file=filelocation($dir,$file);
  $finalpath=~s-^/home/httpd/html--;      } elsif ($file=~m-^/adm/-) {
  $finalpath=~s-^/home/(\w+)/public_html/-/~$1/-;   $file=~s-^/adm/wrapper/-/-;
  return $finalpath;   $file=~s-^/adm/coursedocs/showdoc/-/-;
     } elsif ($file=~m-^/home-) {      }
  $file=~s-^/home/httpd/html--;      if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) {
  $file=~s-^/home/(\w+)/public_html/-/~$1/-;   $file=~s-^\Q$perlvar{'lonDocRoot'}\E--;
  return $file;      } elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) {
    $file=~s{^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/}
           {/uploaded/$1/$2/}x;
       }
       if ($file=~ m{^/userfiles/}) {
    $file =~ s{^/userfiles/}{/uploaded/};
     }      }
     return $file;      return $file;
 }  }
   
   
   
   
   
 sub current_machine_domains {  sub current_machine_domains {
     my $hostname=$hostname{$perlvar{'lonHostID'}};      return &machine_domains(&hostname($perlvar{'lonHostID'}));
   }
   
   sub machine_domains {
       my ($hostname) = @_;
     my @domains;      my @domains;
       my %hostname = &all_hostnames();
     while( my($id, $name) = each(%hostname)) {      while( my($id, $name) = each(%hostname)) {
 # &logthis("-$id-$name-$hostname-");  # &logthis("-$id-$name-$hostname-");
  if ($hostname eq $name) {   if ($hostname eq $name) {
     push(@domains,$hostdom{$id});      push(@domains,&host_domain($id));
  }   }
     }      }
     return @domains;      return @domains;
 }  }
   
 sub current_machine_ids {  sub current_machine_ids {
     my $hostname=$hostname{$perlvar{'lonHostID'}};      return &machine_ids(&hostname($perlvar{'lonHostID'}));
   }
   
   sub machine_ids {
       my ($hostname) = @_;
       $hostname ||= &hostname($perlvar{'lonHostID'});
     my @ids;      my @ids;
     while( my($id, $name) = each(%hostname)) {      my %name_to_host = &all_names();
 # &logthis("-$id-$name-$hostname-");      if (ref($name_to_host{$hostname}) eq 'ARRAY') {
  if ($hostname eq $name) {   return @{ $name_to_host{$hostname} };
     push(@ids,$id);  
  }  
     }      }
     return @ids;      return;
   }
   
   sub additional_machine_domains {
       my @domains;
       open(my $fh,"<$perlvar{'lonTabDir'}/expected_domains.tab");
       while( my $line = <$fh>) {
           $line =~ s/\s//g;
           push(@domains,$line);
       }
       return @domains;
   }
   
   sub default_login_domain {
       my $domain = $perlvar{'lonDefDomain'};
       my $testdomain=(split(/\./,$ENV{'HTTP_HOST'}))[0];
       foreach my $posdom (&current_machine_domains(),
                           &additional_machine_domains()) {
           if (lc($posdom) eq lc($testdomain)) {
               $domain=$posdom;
               last;
           }
       }
       return $domain;
 }  }
   
 # ------------------------------------------------------------- Declutters URLs  # ------------------------------------------------------------- Declutters URLs
   
 sub declutter {  sub declutter {
     my $thisfn=shift;      my $thisfn=shift;
       if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }
     $thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//;      $thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//;
     $thisfn=~s/^\///;      $thisfn=~s/^\///;
       $thisfn=~s|^adm/wrapper/||;
       $thisfn=~s|^adm/coursedocs/showdoc/||;
     $thisfn=~s/^res\///;      $thisfn=~s/^res\///;
     $thisfn=~s/\?.+$//;      $thisfn=~s/^priv\///;
       unless (($thisfn =~ /^ext/) || ($thisfn =~ /\.(page|sequence)___\d+___ext/)) {
           $thisfn=~s/\?.+$//;
       }
     return $thisfn;      return $thisfn;
 }  }
   
Line 5341  sub declutter { Line 10967  sub declutter {
   
 sub clutter {  sub clutter {
     my $thisfn='/'.&declutter(shift);      my $thisfn='/'.&declutter(shift);
     unless ($thisfn=~/^\/(uploaded|adm|userfiles|ext|raw|priv|public)\//) {       if ($thisfn !~ m{^/(uploaded|editupload|adm|userfiles|ext|raw|priv|public)/}
    || $thisfn =~ m{^/adm/(includes|pages)} ) { 
        $thisfn='/res'.$thisfn;          $thisfn='/res'.$thisfn; 
     }      }
       if ($thisfn !~m|^/adm|) {
    if ($thisfn =~ m|^/ext/|) {
       $thisfn='/adm/wrapper'.$thisfn;
    } else {
       my ($ext) = ($thisfn =~ /\.(\w+)$/);
       my $embstyle=&Apache::loncommon::fileembstyle($ext);
       if ($embstyle eq 'ssi'
    || ($embstyle eq 'hdn')
    || ($embstyle eq 'rat')
    || ($embstyle eq 'prv')
    || ($embstyle eq 'ign')) {
    #do nothing with these
       } elsif (($embstyle eq 'img') 
    || ($embstyle eq 'emb')
    || ($embstyle eq 'wrp')) {
    $thisfn='/adm/wrapper'.$thisfn;
       } elsif ($embstyle eq 'unk'
        && $thisfn!~/\.(sequence|page)$/) {
    $thisfn='/adm/coursedocs/showdoc'.$thisfn;
       } else {
   # &logthis("Got a blank emb style");
       }
    }
       }
     return $thisfn;      return $thisfn;
 }  }
   
   sub clutter_with_no_wrapper {
       my $uri = &clutter(shift);
       if ($uri =~ m-^/adm/-) {
    $uri =~ s-^/adm/wrapper/-/-;
    $uri =~ s-^/adm/coursedocs/showdoc/-/-;
       }
       return $uri;
   }
   
 sub freeze_escape {  sub freeze_escape {
     my ($value)=@_;      my ($value)=@_;
     if (ref($value)) {      if (ref($value)) {
Line 5356  sub freeze_escape { Line 11016  sub freeze_escape {
     return &escape($value);      return &escape($value);
 }  }
   
 # -------------------------------------------------------- Escape Special Chars  
   
 sub escape {  
     my $str=shift;  
     $str =~ s/(\W)/"%".unpack('H2',$1)/eg;  
     return $str;  
 }  
   
 # ----------------------------------------------------- Un-Escape Special Chars  
   
 sub unescape {  
     my $str=shift;  
     $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;  
     return $str;  
 }  
   
 sub thaw_unescape {  sub thaw_unescape {
     my ($value)=@_;      my ($value)=@_;
Line 5382  sub thaw_unescape { Line 11027  sub thaw_unescape {
     return &unescape($value);      return &unescape($value);
 }  }
   
 sub mod_perl_version {  
     if (defined($perlvar{'MODPERL2'})) {  
  return 2;  
     }  
     return 1;  
 }  
   
 sub correct_line_ends {  sub correct_line_ends {
     my ($result)=@_;      my ($result)=@_;
     $$result =~s/\r\n/\n/mg;      $$result =~s/\r\n/\n/mg;
Line 5399  sub correct_line_ends { Line 11037  sub correct_line_ends {
 sub goodbye {  sub goodbye {
    &logthis("Starting Shut down");     &logthis("Starting Shut down");
 #not converted to using infrastruture and probably shouldn't be  #not converted to using infrastruture and probably shouldn't be
    &logthis(sprintf("%-20s is %s",'%badServerCache',scalar(%badServerCache)));     &logthis(sprintf("%-20s is %s",'%badServerCache',length(&nfreeze(\%badServerCache))));
 #converted  #converted
    &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));  #   &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));
    &logthis(sprintf("%-20s is %s",'%homecache',scalar(%homecache)));     &logthis(sprintf("%-20s is %s",'%homecache',length(&nfreeze(\%homecache))));
    &logthis(sprintf("%-20s is %s",'%titlecache',scalar(%titlecache)));  #   &logthis(sprintf("%-20s is %s",'%titlecache',length(&nfreeze(\%titlecache))));
    &logthis(sprintf("%-20s is %s",'%courseresdatacache',scalar(%courseresdatacache)));  #   &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&nfreeze(\%courseresdatacache))));
 #1.1 only  #1.1 only
    &logthis(sprintf("%-20s is %s",'%userresdatacache',scalar(%userresdatacache)));  #   &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&nfreeze(\%userresdatacache))));
    &logthis(sprintf("%-20s is %s",'%getsectioncache',scalar(%getsectioncache)));  #   &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&nfreeze(\%getsectioncache))));
    &logthis(sprintf("%-20s is %s",'%courseresversioncache',scalar(%courseresversioncache)));  #   &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&nfreeze(\%courseresversioncache))));
    &logthis(sprintf("%-20s is %s",'%resversioncache',scalar(%resversioncache)));  #   &logthis(sprintf("%-20s is %s",'%resversioncache',length(&nfreeze(\%resversioncache))));
      &logthis(sprintf("%-20s is %s",'%remembered',length(&nfreeze(\%remembered))));
      &logthis(sprintf("%-20s is %s",'kicks',$kicks));
      &logthis(sprintf("%-20s is %s",'hits',$hits));
    &flushcourselogs();     &flushcourselogs();
    &logthis("Shutting down");     &logthis("Shutting down");
    return DONE;  
 }  }
   
 BEGIN {  sub get_dns {
 # ----------------------------------- Read loncapa.conf and loncapa_apache.conf      my ($url,$func,$ignore_cache) = @_;
     unless ($readit) {      if (!$ignore_cache) {
 {   my ($content,$cached)=
     open(my $config,"</etc/httpd/conf/loncapa.conf");      &Apache::lonnet::is_cached_new('dns',$url);
    if ($cached) {
       &$func($content);
       return;
    }
       }
   
     while (my $configline=<$config>) {      my %alldns;
         if ($configline=~/\S/ && $configline =~ /^[^\#]*PerlSetVar/) {      open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
    my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);      foreach my $dns (<$config>) {
            chomp($varvalue);   next if ($dns !~ /^\^(\S*)/x);
            $perlvar{$varname}=$varvalue;          my $line = $1;
         }          my ($host,$protocol) = split(/:/,$line);
           if ($protocol ne 'https') {
               $protocol = 'http';
           }
    $alldns{$host} = $protocol;
       }
       while (%alldns) {
    my ($dns) = keys(%alldns);
    my $ua=new LWP::UserAgent;
           $ua->timeout(30);
    my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");
    my $response=$ua->request($request);
           delete($alldns{$dns});
    next if ($response->is_error());
    my @content = split("\n",$response->content);
    &Apache::lonnet::do_cache_new('dns',$url,\@content,30*24*60*60);
    &$func(\@content);
    return;
     }      }
     close($config);      close($config);
       my $which = (split('/',$url))[3];
       &logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n");
       open($config,"<$perlvar{'lonTabDir'}/dns_$which.tab");
       my @content = <$config>;
       &$func(\@content);
       return;
 }  }
   # ------------------------------------------------------------ Read domain file
 {  {
     open(my $config,"</etc/httpd/conf/loncapa_apache.conf");      my $loaded;
       my %domain;
   
     while (my $configline=<$config>) {      sub parse_domain_tab {
         if ($configline =~ /^[^\#]*PerlSetVar/) {   my ($lines) = @_;
    my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);   foreach my $line (@$lines) {
            chomp($varvalue);      next if ($line =~ /^(\#|\s*$ )/x);
            $perlvar{$varname}=$varvalue;  
         }      chomp($line);
       my ($name,@elements) = split(/:/,$line,9);
       my %this_domain;
       foreach my $field ('description', 'auth_def', 'auth_arg_def',
          'lang_def', 'city', 'longi', 'lati',
          'primary') {
    $this_domain{$field} = shift(@elements);
       }
       $domain{$name} = \%this_domain;
    }
     }      }
     close($config);  
 }  
   
 # ------------------------------------------------------------ Read domain file      sub reset_domain_info {
 {   undef($loaded);
     %domaindescription = ();   undef(%domain);
     %domain_auth_def = ();      }
     %domain_auth_arg_def = ();  
     my $fh;  
     if (open($fh,"<".$Apache::lonnet::perlvar{'lonTabDir'}.'/domain.tab')) {  
        while (<$fh>) {  
            next if (/^(\#|\s*$)/);  
 #           next if /^\#/;  
            chomp;  
            my ($domain, $domain_description, $def_auth, $def_auth_arg,  
        $def_lang, $city, $longi, $lati) = split(/:/,$_);  
    $domain_auth_def{$domain}=$def_auth;  
            $domain_auth_arg_def{$domain}=$def_auth_arg;  
    $domaindescription{$domain}=$domain_description;  
    $domain_lang_def{$domain}=$def_lang;  
    $domain_city{$domain}=$city;  
    $domain_longi{$domain}=$longi;  
    $domain_lati{$domain}=$lati;  
   
  #         &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}");      sub load_domain_tab {
 #          &logthis("Domain.tab: $domain ".$domaindescription{$domain} );   my ($ignore_cache) = @_;
    &get_dns('/adm/dns/domain',\&parse_domain_tab,$ignore_cache);
    my $fh;
    if (open($fh,"<".$perlvar{'lonTabDir'}.'/domain.tab')) {
       my @lines = <$fh>;
       &parse_domain_tab(\@lines);
  }   }
    close($fh);
    $loaded = 1;
       }
   
       sub domain {
    &load_domain_tab() if (!$loaded);
   
    my ($name,$what) = @_;
    return if ( !exists($domain{$name}) );
   
    if (!$what) {
       return $domain{$name}{'description'};
    }
    return $domain{$name}{$what};
       }
   
       sub domain_info {
           &load_domain_tab() if (!$loaded);
           return %domain;
     }      }
     close ($fh);  
 }  }
   
   
 # ------------------------------------------------------------- Read hosts file  # ------------------------------------------------------------- Read hosts file
 {  {
     open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");      my %hostname;
       my %hostdom;
       my %libserv;
       my $loaded;
       my %name_to_host;
       my %internetdom;
       my %LC_dns_serv;
   
       sub parse_hosts_tab {
    my ($file) = @_;
    foreach my $configline (@$file) {
       next if ($configline =~ /^(\#|\s*$ )/x);
               chomp($configline);
       if ($configline =~ /^\^/) {
                   if ($configline =~ /^\^([\w.\-]+)/) {
                       $LC_dns_serv{$1} = 1;
                   }
                   next;
               }
       my ($id,$domain,$role,$name,$protocol,$intdom)=split(/:/,$configline);
       $name=~s/\s//g;
       if ($id && $domain && $role && $name) {
    $hostname{$id}=$name;
    push(@{$name_to_host{$name}}, $id);
    $hostdom{$id}=$domain;
    if ($role eq 'library') { $libserv{$id}=$name; }
                   if (defined($protocol)) {
                       if ($protocol eq 'https') {
                           $protocol{$id} = $protocol;
                       } else {
                           $protocol{$id} = 'http'; 
                       }
                   } else {
                       $protocol{$id} = 'http';
                   }
                   if (defined($intdom)) {
                       $internetdom{$id} = $intdom;
                   }
       }
    }
       }
       
       sub reset_hosts_info {
    &purge_remembered();
    &reset_domain_info();
    &reset_hosts_ip_info();
    undef(%name_to_host);
    undef(%hostname);
    undef(%hostdom);
    undef(%libserv);
    undef($loaded);
       }
   
     while (my $configline=<$config>) {      sub load_hosts_tab {
        next if ($configline =~ /^(\#|\s*$)/);   my ($ignore_cache) = @_;
        chomp($configline);   &get_dns('/adm/dns/hosts',\&parse_hosts_tab,$ignore_cache);
        my ($id,$domain,$role,$name,$ip,$domdescr)=split(/:/,$configline);   open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
        if ($id && $domain && $role && $name && $ip) {   my @config = <$config>;
  $hostname{$id}=$name;   &parse_hosts_tab(\@config);
  $hostdom{$id}=$domain;   close($config);
  $hostip{$id}=$ip;   $loaded=1;
  $iphost{$ip}=$id;  
  if ($role eq 'library') { $libserv{$id}=$name; }  
        }  
     }      }
     close($config);  
       sub hostname {
    &load_hosts_tab() if (!$loaded);
   
    my ($lonid) = @_;
    return $hostname{$lonid};
       }
   
       sub all_hostnames {
    &load_hosts_tab() if (!$loaded);
   
    return %hostname;
       }
   
       sub all_names {
    &load_hosts_tab() if (!$loaded);
   
    return %name_to_host;
       }
   
       sub all_host_domain {
           &load_hosts_tab() if (!$loaded);
           return %hostdom;
       }
   
       sub is_library {
    &load_hosts_tab() if (!$loaded);
   
    return exists($libserv{$_[0]});
       }
   
       sub all_library {
    &load_hosts_tab() if (!$loaded);
   
    return %libserv;
       }
   
       sub unique_library {
    #2x reverse removes all hostnames that appear more than once
           my %unique = reverse &all_library();
           return reverse %unique;
       }
   
       sub get_servers {
    &load_hosts_tab() if (!$loaded);
   
    my ($domain,$type) = @_;
    my %possible_hosts = ($type eq 'library') ? %libserv
                                             : %hostname;
    my %result;
    if (ref($domain) eq 'ARRAY') {
       while ( my ($host,$hostname) = each(%possible_hosts)) {
    if (grep(/^\Q$hostdom{$host}\E$/,@$domain)) {
       $result{$host} = $hostname;
    }
       }
    } else {
       while ( my ($host,$hostname) = each(%possible_hosts)) {
    if ($hostdom{$host} eq $domain) {
       $result{$host} = $hostname;
    }
       }
    }
    return %result;
       }
   
       sub get_unique_servers {
           my %unique = reverse &get_servers(@_);
    return reverse %unique;
       }
   
       sub host_domain {
    &load_hosts_tab() if (!$loaded);
   
    my ($lonid) = @_;
    return $hostdom{$lonid};
       }
   
       sub all_domains {
    &load_hosts_tab() if (!$loaded);
   
    my %seen;
    my @uniq = grep(!$seen{$_}++, values(%hostdom));
    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});
       }
   
 }  }
   
   { 
       my %iphost;
       my %name_to_ip;
       my %lonid_to_ip;
   
       sub get_hosts_from_ip {
    my ($ip) = @_;
    my %iphosts = &get_iphost();
    if (ref($iphosts{$ip})) {
       return @{$iphosts{$ip}};
    }
    return;
       }
       
       sub reset_hosts_ip_info {
    undef(%iphost);
    undef(%name_to_ip);
    undef(%lonid_to_ip);
       }
   
       sub get_host_ip {
    my ($lonid) = @_;
    if (exists($lonid_to_ip{$lonid})) {
       return $lonid_to_ip{$lonid};
    }
    my $name=&hostname($lonid);
       my $ip = gethostbyname($name);
    return if (!$ip || length($ip) ne 4);
    $ip=inet_ntoa($ip);
    $name_to_ip{$name}   = $ip;
    $lonid_to_ip{$lonid} = $ip;
    return $ip;
       }
       
       sub get_iphost {
    my ($ignore_cache) = @_;
   
    if (!$ignore_cache) {
       if (%iphost) {
    return %iphost;
       }
       my ($ip_info,$cached)=
    &Apache::lonnet::is_cached_new('iphost','iphost');
       if ($cached) {
    %iphost      = %{$ip_info->[0]};
    %name_to_ip  = %{$ip_info->[1]};
    %lonid_to_ip = %{$ip_info->[2]};
    return %iphost;
       }
    }
   
    # get yesterday's info for fallback
    my %old_name_to_ip;
    my ($ip_info,$cached)=
       &Apache::lonnet::is_cached_new('iphost','iphost');
    if ($cached) {
       %old_name_to_ip = %{$ip_info->[1]};
    }
   
    my %name_to_host = &all_names();
    foreach my $name (keys(%name_to_host)) {
       my $ip;
       if (!exists($name_to_ip{$name})) {
    $ip = gethostbyname($name);
    if (!$ip || length($ip) ne 4) {
       if (defined($old_name_to_ip{$name})) {
    $ip = $old_name_to_ip{$name};
    &logthis("Can't find $name defaulting to old $ip");
       } else {
    &logthis("Name $name no IP found");
    next;
       }
    } else {
       $ip=inet_ntoa($ip);
    }
    $name_to_ip{$name} = $ip;
       } else {
    $ip = $name_to_ip{$name};
       }
       foreach my $id (@{ $name_to_host{$name} }) {
    $lonid_to_ip{$id} = $ip;
       }
       push(@{$iphost{$ip}},@{$name_to_host{$name}});
    }
    &Apache::lonnet::do_cache_new('iphost','iphost',
         [\%iphost,\%name_to_ip,\%lonid_to_ip],
         48*60*60);
   
    return %iphost;
       }
   
       #
       #  Given a DNS returns the loncapa host name for that DNS 
       # 
       sub host_from_dns {
           my ($dns) = @_;
           my @hosts;
           my $ip;
   
           if (exists($name_to_ip{$dns})) {
               $ip = $name_to_ip{$dns};
           }
           if (!$ip) {
               $ip = gethostbyname($dns); # Initial translation to IP is in net order.
               if (length($ip) == 4) { 
           $ip   = &IO::Socket::inet_ntoa($ip);
               }
           }
           if ($ip) {
       @hosts = get_hosts_from_ip($ip);
       return $hosts[0];
           }
           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 {
   
   # ----------------------------------- Read loncapa.conf and loncapa_apache.conf
       unless ($readit) {
   {
       my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf');
       %perlvar = (%perlvar,%{$configvars});
   }
   
   
 # ------------------------------------------------------ Read spare server file  # ------------------------------------------------------ Read spare server file
 {  {
     open(my $config,"<$perlvar{'lonTabDir'}/spare.tab");      open(my $config,"<$perlvar{'lonTabDir'}/spare.tab");
Line 5498  BEGIN { Line 11491  BEGIN {
     while (my $configline=<$config>) {      while (my $configline=<$config>) {
        chomp($configline);         chomp($configline);
        if ($configline) {         if ($configline) {
           $spareid{$configline}=1;     my ($host,$type) = split(':',$configline,2);
      if (!defined($type) || $type eq '') { $type = 'default' };
      push(@{ $spareid{$type} }, $host);
        }         }
     }      }
     close($config);      close($config);
Line 5524  BEGIN { Line 11519  BEGIN {
     while (my $configline=<$config>) {      while (my $configline=<$config>) {
  chomp($configline);   chomp($configline);
  if ($configline) {   if ($configline) {
     my ($short,$plain)=split(/:/,$configline);      my ($short,@plain)=split(/:/,$configline);
     if ($plain ne '') { $prp{$short}=$plain; }              %{$prp{$short}} = ();
       if (@plain > 0) {
                   $prp{$short}{'std'} = $plain[0];
                   for (my $i=1; $i<@plain; $i++) {
                       $prp{$short}{'alt'.$i} = $plain[$i];  
                   }
               }
  }   }
     }      }
     close($config);      close($config);
Line 5548  BEGIN { Line 11549  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();
   
 }  }
   
 %metacache=();  $memcache=new Cache::Memcached({'servers'           => ['127.0.0.1:11211'],
    'compress_threshold'=> 20_000,
            });
   
 $processmarker='_'.time.'_'.$perlvar{'lonHostID'};  $processmarker='_'.time.'_'.$perlvar{'lonHostID'};
 $dumpcount=0;  $dumpcount=0;
   $locknum=0;
   
 &logtouch();  &logtouch();
 &logthis('<font color=yellow>INFO: Read configuration</font>');  &logthis('<font color="yellow">INFO: Read configuration</font>');
 $readit=1;  $readit=1;
     {      {
  use integer;   use integer;
  my $test=(2**32)+1;   my $test=(2**32)+1;
  if ($test != 0) { $_64bit=1; }   if ($test != 0) { $_64bit=1; } else { $_64bit=0; }
  &logthis(" Detected 64bit platform ($_64bit)");   &logthis(" Detected 64bit platform ($_64bit)");
     }      }
 }  }
Line 5725  when the connection is brought back up Line 11792  when the connection is brought back up
 =item * B<con_failed>: unable to contact remote host and unable to save message  =item * B<con_failed>: unable to contact remote host and unable to save message
 for later delivery  for later delivery
   
 =item * B<error:>: an error a occured, a description of the error follows the :  =item * B<error:>: an error a occurred, a description of the error follows the :
   
 =item * B<no_such_host>: unable to fund a host associated with the user/domain  =item * B<no_such_host>: unable to fund a host associated with the user/domain
 that was requested  that was requested
Line 5740  that was requested Line 11807  that was requested
   
 =item *   =item * 
 X<appenv()>  X<appenv()>
 B<appenv(%hash)>: the value of %hash is written to  B<appenv($hashref,$rolesarrayref)>: the value of %{$hashref} is written to
 the user envirnoment file, and will be restored for each access this  the user envirnoment file, and will be restored for each access this
 user makes during this session, also modifies the %ENV for the current  user makes during this session, also modifies the %env for the current
 process  process. Optional rolesarrayref - if defined contains a reference to an array
   of roles which are exempt from the restriction on modifying user.role entries 
   in the user's environment.db and in %env.    
   
 =item *  =item *
 X<delenv()>  X<delenv()>
 B<delenv($regexp)>: removes all items from the session  B<delenv($delthis,$regexp)>: removes all items from the session
 environment file that matches the regular expression in $regexp. The  environment file that begin with $delthis. If the 
 values are also delted from the current processes %ENV.  optional second arg - $regexp - is true, $delthis is treated as a 
   regular expression, otherwise \Q$delthis\E is used. 
   The values are also deleted from the current processes %env.
   
   =item * get_env_multiple($name) 
   
   gets $name from the %env hash, it seemlessly handles the cases where multiple
   values may be defined and end up as an array ref.
   
   returns an array of values
   
 =back  =back
   
Line 5764  authentication scheme Line 11842  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 5792  B<idput($udom,%ids)>: store away a list Line 11875  B<idput($udom,%ids)>: store away a list
   
 =item *  =item *
 X<rolesinit()>  X<rolesinit()>
 B<rolesinit($udom,$username,$authhost)>: get user privileges  B<rolesinit($udom,$username)>: get user privileges.
   returns user role, first access and timer interval hashes
   
   =item *
   X<privileged()>
   B<privileged($username,$domain)>: returns a true if user has a
   privileged and active role (i.e. su or dc), false otherwise.
   
 =item *  =item *
 X<getsection()>  X<getsection()>
Line 5805  X<userenvironment()> Line 11894  X<userenvironment()>
 B<userenvironment($udom,$uname,@what)>: gets the values of the keys  B<userenvironment($udom,$uname,@what)>: gets the values of the keys
 passed in @what from the requested user's environment, returns a hash  passed in @what from the requested user's environment, returns a hash
   
   =item * 
   X<userlog_query()>
   B<userlog_query($uname,$udom,%filters)>: retrieves data from a user's
   activity.log file. %filters defines filters applied when parsing the
   log file. These can be start or end timestamps, or the type of action
   - log to look for Login or Logout events, check for Checkin or
   Checkout, role for role selection. The response is in the form
   timestamp1:hostid1:event1&timestamp2:hostid2:event2 where events are
   escaped strings of the action recorded in the activity.log file.
   
 =back  =back
   
 =head2 User Roles  =head2 User Roles
Line 5813  passed in @what from the requested user' Line 11912  passed in @what from the requested user'
   
 =item *  =item *
   
 allowed($priv,$uri) : check for a user privilege; returns codes for allowed  allowed($priv,$uri,$symb,$role) : check for a user privilege; returns codes for allowed actions
 actions  
  F: full access   F: full access
  U,I,K: authentication modes (cxx only)   U,I,K: authentication modes (cxx only)
  '': forbidden   '': forbidden
  1: user needs to choose course   1: user needs to choose course
  2: browse allowed   2: browse allowed
    A: passphrase authentication needed
   
 =item *  =item *
   
Line 5829  and course level Line 11928  and course level
   
 =item *  =item *
   
 plaintext($short) : return value in %prp hash (rolesplain.tab); plain text  plaintext($short,$type,$cid,$forcedefault) : return value in %prp hash 
 explanation of a user role term  (rolesplain.tab); plain text explanation of a user role term.
   $type is Course (default) or Community.
   If $forcedefault evaluates to true, text returned will be default 
   text for $type. Otherwise, if this is a course, the text returned 
   will be a custom name for the role (if defined in the course's 
   environment).  If no custom name is defined the default is returned.
      
   =item *
   
   get_my_roles($uname,$udom,$context,$types,$roles,$roledoms,$withsec) :
   All arguments are optional. Returns a hash of a roles, either for
   co-author/assistant author roles for a user's Construction Space
   (default), or if $context is 'userroles', roles for the user himself,
   In the hash, keys are set to colon-separated $uname,$udom,$role, and
   (optionally) if $withsec is true, a fourth colon-separated item - $section.
   For each key, value is set to colon-separated start and end times for
   the role.  If no username and domain are specified, will default to
   current user/domain. Types, roles, and roledoms are references to arrays
   of role statuses (active, future or previous), roles 
   (e.g., cc,in, st etc.) and domains of the roles which can be used
   to restrict the list of roles reported. If no array ref is 
   provided for types, will default to return only active roles.
   
 =back  =back
   
Line 5840  explanation of a user role term Line 11960  explanation of a user role term
   
 =item *  =item *
   
 assignrole($udom,$uname,$url,$role,$end,$start) : assign role; give a role to a  assignrole($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll,$context) : assign role; give a role to a
 user for the level given by URL.  Optional start and end dates (leave empty  user for the level given by URL.  Optional start and end dates (leave empty
 string or zero for "no date")  string or zero for "no date")
   
Line 5857  modifyuserauth($udom,$uname,$umode,$upas Line 11977  modifyuserauth($udom,$uname,$umode,$upas
   
 =item *  =item *
   
 modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene) :   modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last, $gene,
 modify user             $forceid,$desiredhome,$email,$inststatus,$candelete) :
   
   will update user information (firstname,middlename,lastname,generation,
   permanentemail), and if forceid is true, student/employee ID also.
   A user's institutional affiliation(s) can also be updated.
   User information fields will not be overwritten with empty entries 
   unless the field is included in the $candelete array reference.
   This array is included when a single user is modified via "Manage Users",
   or when Autoupdate.pl is run by cron in a domain.
   
 =item *  =item *
   
 modifystudent  modifystudent
   
 modify a students enrollment and identification information.  modify a student's enrollment and identification information.
 The course id is resolved based on the current users environment.    The course id is resolved based on the current users environment.  
 This means the envoking user must be a course coordinator or otherwise  This means the envoking user must be a course coordinator or otherwise
 associated with a course.  associated with a course.
Line 5876  Inputs: Line 12004  Inputs:
   
 =over 4  =over 4
   
 =item B<$udom> Students loncapa domain  =item B<$udom> Student's loncapa domain
   
 =item B<$uname> Students loncapa login name  =item B<$uname> Student's loncapa login name
   
 =item B<$uid> Students id/student number  =item B<$uid> Student/Employee ID
   
 =item B<$umode> Students authentication mode  =item B<$umode> Student's authentication mode
   
 =item B<$upass> Students password  =item B<$upass> Student's password
   
 =item B<$first> Students first name  =item B<$first> Student's first name
   
 =item B<$middle> Students middle name  =item B<$middle> Student's middle name
   
 =item B<$last> Students last name  =item B<$last> Student's last name
   
 =item B<$gene> Students generation  =item B<$gene> Student's generation
   
 =item B<$usec> Students section in course  =item B<$usec> Student's section in course
   
 =item B<$end> Unix time of the roles expiration  =item B<$end> Unix time of the roles expiration
   
Line 5904  Inputs: Line 12032  Inputs:
   
 =item B<$desiredhome> server to use as home server for student  =item B<$desiredhome> server to use as home server for student
   
   =item B<$email> Student's permanent e-mail address
   
   =item B<$type> Type of enrollment (auto or manual)
   
   =item B<$locktype> boolean - enrollment type locked to prevent Autoenroll.pl changing manual to auto    
   
   =item B<$cid> courseID - needed if a course role is assigned by a user whose current role is DC
   
   =item B<$selfenroll> boolean - 1 if user role change occurred via self-enrollment
   
   =item B<$context> role change context (shown in User Management Logs display in a course)
   
   =item B<$inststatus> institutional status of user - : separated string of escaped status types  
   
 =back  =back
   
 =item *  =item *
Line 5937  Inputs: Line 12079  Inputs:
   
 =item $start  =item $start
   
   =item $type
   
   =item $locktype
   
   =item $cid
   
   =item $selfenroll
   
   =item $context
   
 =back  =back
   
   
Line 5962  revokecustomrole($udom,$uname,$url,$role Line 12114  revokecustomrole($udom,$uname,$url,$role
   
 =item *  =item *
   
 coursedescription($courseid) : course description  coursedescription($courseid,$options) : returns a hash of information about the
   specified course id, including all environment settings for the
   course, the description of the course will be in the hash under the
   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 *
   
 courseresdata($coursenum,$coursedomain,@which) : request for current  resdata($name,$domain,$type,@which) : request for current parameter
 parameter setting for a specific course, @what should be a list of  setting for a specific $type, where $type is either 'course' or 'user',
 parameters to ask about. This routine caches answers for 5 minutes.  @what should be a list of parameters to ask about. This routine caches
   answers for 5 minutes.
   
   =item *
   
   get_courseresdata($courseid, $domain) : dump the entire course resource
   data base, returning a hash that is keyed by the resource name and has
   values that are the resource value.  I believe that the timestamps and
   versions are also returned.
   
   
 =back  =back
   
Line 5983  database) for a course Line 12168  database) for a course
   
 =item *  =item *
   
 createcourse($udom,$description,$url) : make/modify course  createcourse($udom,$description,$url,$course_server,$nonstandard,$inst_code,$course_owner,$crstype,$cnum) : make course
   
   =item *
   
   generate_coursenum($udom,$crstype) : get a unique (unused) course number in domain $udom for course type $crstype (Course or Community).
   
   =item *
   
   is_course($courseid), is_course($cdom, $cnum)
   
   Accepts either a combined $courseid (in the form of domain_courseid) or the
   two component version $cdom, $cnum. It checks if the specified course exists.
   
   Returns:
       undef if the course doesn't exist, otherwise
       in scalar context the combined courseid.
       in list context the two components of the course identifier, domain and 
       courseid.    
   
 =back  =back
   
Line 5999  subscribe($fname) : subscribe to a resou Line 12201  subscribe($fname) : subscribe to a resou
   
 repcopy($filename) : subscribes to the requested file, and attempts to  repcopy($filename) : subscribes to the requested file, and attempts to
 replicate from the owning library server, Might return  replicate from the owning library server, Might return
 HTTP_SERVICE_UNAVAILABLE, HTTP_NOT_FOUND, FORBIDDEN, OK, or  'unavailable', 'not_found', 'forbidden', 'ok', or
 HTTP_BAD_REQUEST, also attempts to grab the metadata for the  'bad_request', also attempts to grab the metadata for the
 resource. Expects the local filesystem pathname  resource. Expects the local filesystem pathname
 (/home/httpd/html/res/....)  (/home/httpd/html/res/....)
   
Line 6054  returns the data handle Line 12256  returns the data handle
 =item *  =item *
   
 symbverify($symb,$thisfn) : verifies that $symb actually exists and is  symbverify($symb,$thisfn) : verifies that $symb actually exists and is
 a possible symb for the URL in $thisfn, returns a 1 on success, 0 on  a possible symb for the URL in $thisfn, and if is an encryypted
 failure, user must be in a course, as it assumes the existance of the  resource that the user accessed using /enc/ returns a 1 on success, 0
 course initi hash, and uses $ENV('request.course.id'}  on failure, user must be in a course, as it assumes the existance of
   the course initial hash, and uses $env('request.course.id'}
   
   
 =item *  =item *
Line 6087  unfakeable, receipt Line 12290  unfakeable, receipt
   
 =item *  =item *
   
 receipt() : API to ireceipt working off of ENV values; given out to users  receipt() : API to ireceipt working off of env values; given out to users
   
 =item *  =item *
   
Line 6121  forcing spreadsheet to reevaluate the re Line 12324  forcing spreadsheet to reevaluate the re
 store($storehash,$symb,$namespace,$udom,$uname) : stores hash permanently  store($storehash,$symb,$namespace,$udom,$uname) : stores hash permanently
 for this url; hashref needs to be given and should be a \%hashname; the  for this url; hashref needs to be given and should be a \%hashname; the
 remaining args aren't required and if they aren't passed or are '' they will  remaining args aren't required and if they aren't passed or are '' they will
 be derived from the ENV  be derived from the env
   
 =item *  =item *
   
Line 6135  all args are optional Line 12338  all args are optional
   
 =item *  =item *
   
   dumpstore($namespace,$udom,$uname,$regexp,$range) : 
   dumps the complete (or key matching regexp) namespace into a hash
   ($udom, $uname, $regexp, $range are optional) for a namespace that is
   normally &store()ed into
   
   $range should be either an integer '100' (give me the first 100
                                              matching records)
                 or be  two integers sperated by a - with no spaces
                    '30-50' (give me the 30th through the 50th matching
                             records)
   
   
   =item *
   
   putstore($namespace,$symb,$version,$storehash,$udomain,$uname) :
   replaces a &store() version of data with a replacement set of data
   for a particular resource in a namespace passed in the $storehash hash 
   reference
   
   =item *
   
 tmpstore($storehash,$symb,$namespace,$udom,$uname) : storage that  tmpstore($storehash,$symb,$namespace,$udom,$uname) : storage that
 works very similar to store/cstore, but all data is stored in a  works very similar to store/cstore, but all data is stored in a
 temporary location and can be reset using tmpreset, $storehash should  temporary location and can be reset using tmpreset, $storehash should
Line 6164  namesp ($udom and $uname are optional) Line 12388  namesp ($udom and $uname are optional)
   
 =item *  =item *
   
 dump($namespace,$udom,$uname,$regexp) :   dump($namespace,$udom,$uname,$regexp,$range) : 
 dumps the complete (or key matching regexp) namespace into a hash  dumps the complete (or key matching regexp) namespace into a hash
 ($udom, $uname and $regexp are optional)  ($udom, $uname, $regexp, $range are optional)
   
   $range should be either an integer '100' (give me the first 100
                                              matching records)
                 or be  two integers sperated by a - with no spaces
                    '30-50' (give me the 30th through the 50th matching
                             records)
 =item *  =item *
   
 inc($namespace,$store,$udom,$uname) : increments $store in $namespace.  inc($namespace,$store,$udom,$uname) : increments $store in $namespace.
Line 6183  put($namespace,$storehash,$udom,$uname) Line 12412  put($namespace,$storehash,$udom,$uname)
   
 =item *  =item *
   
 putstore($namespace,$storehash,$udomain,$uname) : stores hash in namesp  cput($namespace,$storehash,$udom,$uname) : critical put
 keys used in storehash include version information (e.g., 1:$symb:message etc.) as  ($udom and $uname are optional)
 used in records written by &store and retrieved by &restore.  This function   
 was created for use in editing discussion posts, without incrementing the  
 version number included in the key for a particular post. The colon   
 separated list of attribute names (e.g., the value associated with the key   
 1:keys:$symb) is also generated and passed in the ampersand separated   
 items sent to lonnet::reply().    
   
 =item *  =item *
   
 cput($namespace,$storehash,$udom,$uname) : critical put  newput($namespace,$storehash,$udom,$uname) :
 ($udom and $uname are optional)  
   Attempts to store the items in the $storehash, but only if they don't
   currently exist, if this succeeds you can be certain that you have 
   successfully created a new key value pair in the $namespace db.
   
   
   Args:
    $namespace: name of database to store values to
    $storehash: hashref to store to the db
    $udom: (optional) domain of user containing the db
    $uname: (optional) name of user caontaining the db
   
   Returns:
    'ok' -> succeeded in storing all keys of $storehash
    'key_exists: <key>' -> failed to anything out of $storehash, as at
                           least <key> already existed in the db (other
                           requested keys may also already exist)
    'error: <msg>' -> unable to tie the DB or other error occurred
    'con_lost' -> unable to contact request server
    'refused' -> action was not allowed by remote machine
   
   
 =item *  =item *
   
Line 6208  reference filled in from namesp (encrypt Line 12451  reference filled in from namesp (encrypt
 log($udom,$name,$home,$message) : write to permanent log for user; use  log($udom,$name,$home,$message) : write to permanent log for user; use
 critical subroutine  critical subroutine
   
   =item *
   
   get_dom($namespace,$storearr,$udom,$uhome) : returns hash with keys from
   array reference filled in from namespace found in domain level on either
   specified domain server ($uhome) or primary domain server ($udom and $uhome are optional).
   
   =item *
   
   put_dom($namespace,$storehash,$udom,$uhome) :  stores hash in namespace at 
   domain level either on specified domain server ($uhome) or primary domain 
   server ($udom and $uhome are optional)
   
   =item * 
   
   get_domain_defaults($target_domain) : returns hash with defaults for
   authentication and language in the domain. Keys are: auth_def, auth_arg_def,
   lang_def; corresponsing values are authentication type (internal, krb4, krb5,
   or localauth), initial password or a kerberos realm, language (e.g., en-us).
   Values are retrieved from cache (if current), or from domain's configuration.db
   (if available), or lastly from values in lonTabs/dns_domain,tab, 
   or lonTabs/domain.tab. 
   
   %domdefaults = &get_auth_defaults($target_domain);
   
 =back  =back
   
 =head2 Network Status Functions  =head2 Network Status Functions
Line 6216  critical subroutine Line 12483  critical subroutine
   
 =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 *
   
 spareserver() : find server with least workload from spare.tab  spareserver() : find server with least workload from spare.tab
   
   
   =item *
   
   host_from_dns($dns) : Returns the loncapa hostname corresponding to a DNS name or undef
   if there is no corresponding loncapa host.
   
 =back  =back
   
   
 =head2 Apache Request  =head2 Apache Request
   
 =over 4  =over 4
Line 6271  splitting on '&', supports elements that Line 12620  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 6291  logperm() : append a permanent message t Line 12641  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 6323  getfile($file,$caller) : two cases - req Line 12674  getfile($file,$caller) : two cases - req
    - returns the entire contents of a file or -1;      - returns the entire contents of a file or -1; 
    it properly subscribes to and replicates the file if neccessary.     it properly subscribes to and replicates the file if neccessary.
   
   
   =item *
   
   stat_file($url) : $url is expected to be a /res/ or /uploaded/ style file
                     reference
   
   returns either a stat() list of data about the file or an empty list
   if the file doesn't exist or couldn't find out about it (connection
   problems or user unknown)
   
 =item *  =item *
   
 filelocation($dir,$file) : returns file system location of a file  filelocation($dir,$file) : returns file system location of a file
Line 6341  declutter() : declutters URLs (remove do Line 12702  declutter() : declutters URLs (remove do
   
 =back  =back
   
   =head2 Usererfile file routines (/uploaded*)
   
   =over 4
   
   =item *
   
   userfileupload(): main rotine for putting a file in a user or course's
                     filespace, arguments are,
   
    formname - required - this is the name of the element in $env where the
              filename, and the contents of the file to create/modifed exist
              the filename is in $env{'form.'.$formname.'.filename'} and the
              contents of the file is located in $env{'form.'.$formname}
    context - if coursedoc, store the file in the course of the active role
                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/
            if undefined, it will be placed in "unknown"
   
    (This routine calls clean_filename() to remove any dangerous
    characters from the filename, and then calls finuserfileupload() to
    complete the transaction)
   
    returns either the url of the uploaded file (/uploaded/....) if successful
    and /adm/notfound.html if unsuccessful
   
   =item *
   
   clean_filename(): routine for cleaing a filename up for storage in
                    userfile space, argument is:
   
    filename - proposed filename
   
   returns: the new clean filename
   
   =item *
   
   finishuserfileupload(): routine that creates and sends the file to
   userspace, probably shouldn't be called directly
   
     docuname: username or courseid of destination for the file
     docudom: domain of user/course of destination for the file
     formname: same as for userfileupload()
     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
    and /adm/notfound.html if unsuccessful (or an error message if context 
    was 'overwrite').
    
   
   =item *
   
   renameuserfile(): renames an existing userfile to a new name
   
     Args:
      docuname: username or courseid of destination for the file
      docudom: domain of user/course of destination for the file
      old: current file name (including any subdirs under userfiles)
      new: desired file name (including any subdirs under userfiles)
   
   =item *
   
   mkdiruserfile(): creates a directory is a userfiles dir
   
     Args:
      docuname: username or courseid of destination for the file
      docudom: domain of user/course of destination for the file
      dir: dir to create (including any subdirs under userfiles)
   
   =item *
   
   removeuserfile(): removes a file that exists in userfiles
   
     Args:
      docuname: username or courseid of destination for the file
      docudom: domain of user/course of destination for the file
      fname: filname to delete (including any subdirs under userfiles)
   
   =item *
   
   removeuploadedurl(): convience function for removeuserfile()
   
     Args:
      url:  a full /uploaded/... url to delete
   
   =item * 
   
   get_portfile_permissions():
     Args:
       domain: domain of user or course contain the portfolio files
       user: name of user or num of course contain the portfolio files
     Returns:
       hashref of a dump of the proper file_permissions.db
      
   
   =item * 
   
   get_access_controls():
   
   Args:
     current_permissions: the hash ref returned from get_portfile_permissions()
     group: (optional) the group you want the files associated with
     file: (optional) the file you want access info on
   
   Returns:
       a hash (keys are file names) of hashes containing
           keys are: path to file/file_name\0uniqueID:scope_end_start (see below)
           values are XML containing access control settings (see below) 
   
   Internal notes:
   
    access controls are stored in file_permissions.db as key=value pairs.
       key -> path to file/file_name\0uniqueID:scope_end_start
           where scope -> public,guest,course,group,domains or users.
                 end -> UNIX time for end of access (0 -> no end date)
                 start -> UNIX time for start of access
   
       value -> XML description of access control
              <scope type=""> (type =1 of: public,guest,course,group,domains,users">
               <start></start>
               <end></end>
   
               <password></password>  for scope type = guest
   
               <domain></domain>     for scope type = course or group
               <number></number>
               <roles id="">
                <role></role>
                <access></access>
                <section></section>
                <group></group>
               </roles>
   
               <dom></dom>         for scope type = domains
   
               <users>             for scope type = users
                <user>
                 <uname></uname>
                 <udom></udom>
                </user>
               </users>
              </scope> 
                 
    Access data is also aggregated for each file in an additional key=value pair:
    key -> path to file/file_name\0accesscontrol 
    value -> reference to hash
             hash contains key = value pairs
             where key = uniqueID:scope_end_start
                   value = UNIX time record was last updated
   
             Used to improve speed of look-ups of access controls for each file.  
    
    Locks on files (resulting from submission of portfolio file to a homework problem stored in array of arrays.
   
   modify_access_controls():
   
   Modifies access controls for a portfolio file
   Args
   1. file name
   2. reference to hash of required changes,
   3. domain
   4. username
     where domain,username are the domain of the portfolio owner 
     (either a user or a course) 
   
   Returns:
   1. result of additions or updates ('ok' or 'error', with error message). 
   2. result of deletions ('ok' or 'error', with error message).
   3. reference to hash of any new or updated access controls.
   4. reference to hash used to map incoming IDs to uniqueIDs assigned to control.
      key = integer (inbound ID)
      value = uniqueID  
   
   =back
   
 =head2 HTTP Helper Routines  =head2 HTTP Helper Routines
   
 =over 4  =over 4
Line 6417  symblist($mapname,%newhash) : update sym Line 12965  symblist($mapname,%newhash) : update sym
 =back  =back
   
 =cut  =cut
   
Removed from v.1.567  
changed lines
  Added in v.1.1189

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