[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.732 and 1.1172.2.52

version 1.732, 2006/04/26 15:47:38 version 1.1172.2.52, 2014/06/25 18:44:10
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 %badServerCache %iphost %spareid %hostdom   
    %libserv %pr %prp $memcache %packagetab   
    %courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount   
    %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf  
    %domaindescription %domain_auth_def %domain_auth_arg_def   
    %domain_lang_def %domain_city %domain_longi %domain_lati %domain_primary  
    $tmpdir $_64bit %env);  
   
 use IO::Socket;  Apache::lonnet.pm
 use GDBM_File;  
 use HTML::LCParser;  
 use HTML::Parser;  
 use Fcntl qw(:flock);  
 use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze);  
 use Time::HiRes qw( gettimeofday tv_interval );  
 use Cache::Memcached;  
 use Digest::MD5;  
   
 my $readit;  =head1 SYNOPSIS
 my $max_connection_retries = 10;     # Or some such value.  
   
 require Exporter;  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.
   
 our @ISA = qw (Exporter);  This is part of the LearningOnline Network with CAPA project
 our @EXPORT = qw(%env);  described at http://www.lon-capa.org.
   
 =pod  
   
 =head1 Package Variables  =head1 Package Variables
   
Line 83  delayed. Line 68  delayed.
   
 =cut  =cut
   
   package Apache::lonnet;
   
   use strict;
   use LWP::UserAgent();
   use HTTP::Date;
   use Image::Magick;
   
   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;
   
 # --------------------------------------------------------------------- Logging  use File::Copy;
   
   my $readit;
   my $max_connection_retries = 10;     # Or some such value.
   
   require Exporter;
   
   our @ISA = qw (Exporter);
   our @EXPORT = qw(%env);
   
   # ------------------------------------ Logging (parameters, docs, slots, roles)
 {  {
     my $logid;      my $logid;
     sub instructor_log {      sub write_log {
  my ($hash_name,$storehash,$delflag,$uname,$udom)=@_;   my ($context,$hash_name,$storehash,$delflag,$uname,$udom,$cnum,$cdom)=@_;
  $logid++;          if ($context eq 'course') {
  my $id=time().'00000'.$$.'00000'.$logid;              if (($cnum eq '') || ($cdom eq '')) {
  return &Apache::lonnet::put('nohist_'.$hash_name,                  $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
     { $id => {                  $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
  'exe_uname' => $env{'user.name'},              }
  'exe_udom'  => $env{'user.domain'},          }
  'exe_time'  => time(),   $logid ++;
  'exe_ip'    => $ENV{'REMOTE_ADDR'},          my $now = time();
  'delflag'   => $delflag,   my $id=$now.'00000'.$$.'00000'.$logid;
  'logentry'  => $storehash,          my $logentry = {
  'uname'     => $uname,                           $id => {
  'udom'      => $udom,                                    'exe_uname' => $env{'user.name'},
     }                                    'exe_udom'  => $env{'user.domain'},
   },                                    'exe_time'  => $now,
     $env{'course.'.$env{'request.course.id'}.'.domain'},                                    'exe_ip'    => $ENV{'REMOTE_ADDR'},
     $env{'course.'.$env{'request.course.id'}.'.num'}                                    'delflag'   => $delflag,
     );                                    'logentry'  => $storehash,
                                     'uname'     => $uname,
                                     'udom'      => $udom,
                                   }
                          };
           return &put('nohist_'.$hash_name,$logentry,$cdom,$cnum);
     }      }
 }  }
   
Line 125  sub logthis { Line 155  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 143  sub logperm { Line 174  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,$cachekeys) = @_;
       my $items;
       return unless (ref($cachekeys) eq 'ARRAY');
       my $cachestr = join('&',@{$cachekeys});
       return &reply('devalidatecache:'.&escape($cachestr),$lonhost);
   }
   
 # -------------------------------------------------- Non-critical communication  # -------------------------------------------------- Non-critical communication
 sub subreply {  sub subreply {
     my ($cmd,$server)=@_;      my ($cmd,$server)=@_;
     my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$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 167  sub subreply { Line 383  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) {
Line 186  sub subreply { Line 404  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=~/^refused/) || ($answer=~/^rejected/)) {      if (($answer=~/^refused/) || ($answer=~/^rejected/)) {
        &logthis("<font color=\"blue\">WARNING:".         &logthis("<font color=\"blue\">WARNING:".
Line 198  sub reply { Line 416  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 208  sub reconlonc { Line 443  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 228  sub reconlonc { Line 457  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';
Line 278  sub critical { Line 507  sub critical {
     return $answer;      return $answer;
 }  }
   
 # ------------------------------------------- Transfer profile into environment  # ------------------------------------------- check if return value is an error
   
 sub transfer_profile_to_env {  sub error {
       my ($result) = @_;
       if ($result =~ /^(con_lost|no_such_host|error: (\d+) (.*))/) {
    if ($2 == 2) { return undef; }
    return $1;
       }
       return undef;
   }
   
   sub convert_and_load_session_env {
     my ($lonidsdir,$handle)=@_;      my ($lonidsdir,$handle)=@_;
       my @profile;
       {
    my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");
    if (!$opened) {
       return 0;
    }
    flock($idf,LOCK_SH);
    @profile=<$idf>;
    close($idf);
       }
       my %temp_env;
       foreach my $line (@profile) {
    if ($line !~ m/=/) {
       return 0;
    }
    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)) {      if (!defined($lonidsdir)) {
  $lonidsdir = $perlvar{'lonIDsDir'};   $lonidsdir = $perlvar{'lonIDsDir'};
     }      }
Line 289  sub transfer_profile_to_env { Line 562  sub transfer_profile_to_env {
         ($handle) = ($env{'user.environment'} =~m|/([^/]+)\.id$| );          ($handle) = ($env{'user.environment'} =~m|/([^/]+)\.id$| );
     }      }
   
     my @profile;      my $convert;
     {      {
  open(my $idf,"$lonidsdir/$handle.id");      my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");
    if (!$opened) {
       return;
    }
  flock($idf,LOCK_SH);   flock($idf,LOCK_SH);
  @profile=<$idf>;   if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",
  close($idf);   &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 $envi;  
     my %Remove;      my %remove;
     for ($envi=0;$envi<=$#profile;$envi++) {      while ( my $envname = each(%env) ) {
  chomp($profile[$envi]);  
  my ($envname,$envvalue)=split(/=/,$profile[$envi],2);  
  $envname=&unescape($envname);  
  $envvalue=&unescape($envvalue);  
  $env{$envname} = $envvalue;  
         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";      $env{'user.environment'} = "$lonidsdir/$handle.id";
     foreach my $expired_key (keys(%Remove)) {      $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,$userhashref) = @_;
     my %newenv=@_;      my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));
     foreach my $key (keys(%newenv)) {      if ($name eq '') {
  if (($newenv{$key}=~/^user\.role/) || ($newenv{$key}=~/^user\.priv/)) {          $name = 'lonID';
             &logthis("<font color=\"blue\">WARNING: ".      }
                 "Attempt to modify environment ".$key." to ".$newenv{$key}      my $lonid=$cookies{$name};
                 .'</font>');      return undef if (!$lonid);
     delete($newenv{$key});  
         } else {      my $handle=&LONCAPA::clean_handle($lonid->value);
             $env{$key}=$newenv{$key};      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: '.$!;  
     }      }
   
     my @oldenv;      if (ref($userhashref) eq 'HASH') {
     {          $userhashref->{'name'} = $disk_env{'user.name'};
  my $fh;          $userhashref->{'domain'} = $disk_env{'user.domain'};
  unless (open($fh,"$env{'user.environment'}")) {      }
     return 'error: '.$!;  
  }      return $handle;
  @oldenv=<$fh>;  }
  close($fh);  
   sub timed_flock {
       my ($file,$lock_type) = @_;
       my $failed=0;
       eval {
    local $SIG{__DIE__}='DEFAULT';
    local $SIG{ALRM}=sub {
       $failed=1;
       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],2);  
     $name=&unescape($name);  sub appenv {
     $value=&unescape($value);      my ($newenv,$roles) = @_;
     unless (defined($newenv{$name})) {      if (ref($newenv) eq 'HASH') {
  $newenv{$name}=$value;          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 =~ m{^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 &escape($newname).'='.&escape($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) = @_;
     if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {      if (($delthis=~/^user\.role/) || ($delthis=~/^user\.priv/)) {
         &logthis("<font color=\"blue\">WARNING: ".          my $refused = 1;
                 "Attempt to delete from environment ".$delthis);          if (ref($roles) eq 'ARRAY') {
         return 'error';              my ($type,$role) = ($delthis =~ /^user\.(role|priv)\.([^.]+)\./);
     }              if (grep(/^\Q$role\E$/,@{$roles})) {
     my @oldenv;                  $refused = 0;
     {              }
  my $fh;          }
  unless (open($fh,"$env{'user.environment'}")) {          if ($refused) {
     return 'error';              &logthis("<font color=\"blue\">WARNING: ".
  }                       "Attempt to delete from environment ".$delthis);
  unless (flock($fh,LOCK_SH)) {              return 'error';
     &logthis("<font color=\"blue\">WARNING: ".          }
      'Could not obtain shared lock in delenv: '.$!);  
     close($fh);  
     return 'error: '.$!;  
  }  
  @oldenv=<$fh>;  
  close($fh);  
     }      }
     {      my $opened = open(my $env_file,'+<',$env{'user.environment'});
  my $fh;      if ($opened
  unless (open($fh,">$env{'user.environment'}")) {   && &timed_flock($env_file,LOCK_EX)
     return 'error';   &&
  }   tie(my %disk_env,'GDBM_File',$env{'user.environment'},
  unless (flock($fh,LOCK_EX)) {      (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
     &logthis("<font color=\"blue\">WARNING: ".   foreach my $key (keys(%disk_env)) {
      'Could not obtain exclusive lock in delenv: '.$!);      if ($regexp) {
     close($fh);                  if ($key=~/^$delthis/) {
     return 'error: '.$!;                      delete($env{$key});
  }                      delete($disk_env{$key});
  foreach my $cur_key (@oldenv) {                  } 
     my $unescaped_cur_key = &unescape($cur_key);  
     if ($unescaped_cur_key=~/^$delthis/) {   
                 my ($key) = split('=',$cur_key,2);  
  $key = &unescape($key);  
                 delete($env{$key});  
             } else {              } else {
                 print $fh $cur_key;                   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 436  sub userload { Line 809  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 451  sub userload { Line 825  sub userload {
     return $userloadpercent;      return $userloadpercent;
 }  }
   
 # ------------------------------------------ Fight off request when overloaded  
   
 sub overloaderror {  
     my ($r,$checkserver)=@_;  
     unless ($checkserver) { $checkserver=$perlvar{'lonHostID'}; }  
     my $loadavg;  
     if ($checkserver eq $perlvar{'lonHostID'}) {  
        open(my $loadfile,'/proc/loadavg');  
        $loadavg=<$loadfile>;  
        $loadavg =~ s/\s.*//g;  
        $loadavg = 100*$loadavg/$perlvar{'lonLoadLim'};  
        close($loadfile);  
     } else {  
        $loadavg=&reply('load',$checkserver);  
     }  
     my $overload=$loadavg-100;  
     if ($overload>0) {  
  $r->err_headers_out->{'Retry-After'}=$overload;  
         $r->log_error('Overload of '.$overload.' on '.$checkserver);  
         return 413;  
     }      
     return '';  
 }  
   
 # ------------------------------ Find server with least workload from spare.tab  # ------------------------------ Find server with least workload from spare.tab
   
 sub spareserver {  sub spareserver {
     my ($loadpercent,$userloadpercent,$want_server_name) = @_;      my ($loadpercent,$userloadpercent,$want_server_name,$udom) = @_;
     my $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, $required) = @_;
   
       if ($required) {
           my ($reqdmajor,$reqdminor) = ($required =~ /^(\d+)\.(\d+)$/);
           my $remoterev = &get_server_loncaparev(undef,$try_server);
           my ($major,$minor) = ($remoterev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/);
           if (($major eq '' && $minor eq '') ||
               (($reqdmajor > $major) || (($reqdmajor == $major) && ($reqdminor > $minor)))) {
               return ($spare_server,$lowest_load);
           }
       }
   
       my $loadans     = &reply('load',    $try_server);
       my $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)) {  
     if ($want_server_name) {  
  $spareserver=$tryserver;  
     } else {  
  $spareserver="http://$hostname{$tryserver}";  
     }  
     $lowestserver=$answer;  
  }   }
       } else {
    $load = $userloadans;
       }
   
       if (($load =~ /\d/) && ($load < $lowest_load)) {
    $spare_server = $try_server;
    $lowest_load  = $load;
       }
       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,$required,$skiploadbal) = @_;
       my %domconfhash = &Apache::loncommon::get_domainconf($udom);
       my %servers = &get_servers($udom);
       my $lowest_load = 30000;
       my ($login_host,$hostname,$portal_path,$isredirect,$balancers);
       if ($skiploadbal) {
           ($balancers,my $cached)=&is_cached_new('loadbalancing',$udom);
           unless (defined($cached)) {
               my $cachetime = 60*60*24;
               my %domconfig =
                   &Apache::lonnet::get_dom('configuration',['loadbalancing'],$udom);
               if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
                   $balancers = &do_cache_new('loadbalancing',$udom,$domconfig{'loadbalancing'},
                                              $cachetime);
               }
           }
       }
       foreach my $lonhost (keys(%servers)) {
           my $loginvia;
           if ($skiploadbal) {
               if (ref($balancers) eq 'HASH') {
                   next if (exists($balancers->{$lonhost}));
               }
           }
           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, $required);
                   if ($login_host eq $server) {
                       $portal_path = $path;
                       $isredirect = 1;
                   }
               } else {
                   ($login_host, $lowest_load) =
                       &compare_server_load($lonhost, $login_host, $lowest_load, $required);
                   if ($login_host eq $lonhost) {
                       $portal_path = '';
                       $isredirect = ''; 
                   }
               }
           } else {
               ($login_host, $lowest_load) =
                   &compare_server_load($lonhost, $login_host, $lowest_load, $required);
           }
       }
       if ($login_host ne '') {
           $hostname = &hostname($login_host);
     }      }
     return $spareserver;      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 545  sub changepass { Line 1041  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 568  sub queryauthenticate { Line 1067  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 589  sub authenticate { Line 1108  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,$currtargets,$currrules,$dom_in_use,$homeintdom,
           $rule_in_effect,$offloadto,$otherserver);
       my $lonhost = $perlvar{'lonHostID'};
       my @hosts = &current_machine_ids();
       my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
       my $uintdom = &Apache::lonnet::internet_dom($uprimary_id);
       my $intdom = &Apache::lonnet::internet_dom($lonhost);
       my $serverhomedom = &host_domain($lonhost);
   
       my $cachetime = 60*60*24;
   
       if (($uintdom ne '') && ($uintdom eq $intdom)) {
           $dom_in_use = $udom;
           $homeintdom = 1;
       } else {
           $dom_in_use = $serverhomedom;
       }
       my ($result,$cached)=&is_cached_new('loadbalancing',$dom_in_use);
       unless (defined($cached)) {
           my %domconfig =
               &Apache::lonnet::get_dom('configuration',['loadbalancing'],$dom_in_use);
           if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
               $result = &do_cache_new('loadbalancing',$dom_in_use,$domconfig{'loadbalancing'},$cachetime);
           }
       }
       if (ref($result) eq 'HASH') {
           ($is_balancer,$currtargets,$currrules) =
               &check_balancer_result($result,@hosts);
           if ($is_balancer) {
               if (ref($currrules) eq 'HASH') {
                   if ($homeintdom) {
                       if ($uname ne '') {
                           if (($currrules->{'_LC_adv'} ne '') || ($currrules->{'_LC_author'} ne '')) {
                               my ($is_adv,$is_author) = &is_advanced_user($udom,$uname);
                               if (($currrules->{'_LC_author'} ne '') && ($is_author)) {
                                   $rule_in_effect = $currrules->{'_LC_author'};
                               } elsif (($currrules->{'_LC_adv'} ne '') && ($is_adv)) {
                                   $rule_in_effect = $currrules->{'_LC_adv'}
                               }
                           }
                           if ($rule_in_effect eq '') {
                               my %userenv = &userenvironment($udom,$uname,'inststatus');
                               if ($userenv{'inststatus'} ne '') {
                                   my @statuses = map { &unescape($_); } split(/:/,$userenv{'inststatus'});
                                   my ($othertitle,$usertypes,$types) =
                                       &Apache::loncommon::sorted_inst_types($udom);
                                   if (ref($types) eq 'ARRAY') {
                                       foreach my $type (@{$types}) {
                                           if (grep(/^\Q$type\E$/,@statuses)) {
                                               if (exists($currrules->{$type})) {
                                                   $rule_in_effect = $currrules->{$type};
                                               }
                                           }
                                       }
                                   }
                               } else {
                                   if (exists($currrules->{'default'})) {
                                       $rule_in_effect = $currrules->{'default'};
                                   }
                               }
                           }
                       } else {
                           if (exists($currrules->{'default'})) {
                               $rule_in_effect = $currrules->{'default'};
                           }
                       }
                   } else {
                       if ($currrules->{'_LC_external'} ne '') {
                           $rule_in_effect = $currrules->{'_LC_external'};
                       }
                   }
                   $offloadto = &get_loadbalancer_targets($rule_in_effect,$currtargets,
                                                          $uname,$udom);
               }
           }
       } elsif (($homeintdom) && ($udom ne $serverhomedom)) {
           ($result,$cached)=&is_cached_new('loadbalancing',$serverhomedom);
           unless (defined($cached)) {
               my %domconfig =
                   &Apache::lonnet::get_dom('configuration',['loadbalancing'],$serverhomedom);
               if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
                   $result = &do_cache_new('loadbalancing',$dom_in_use,$domconfig{'loadbalancing'},$cachetime);
               }
           }
           if (ref($result) eq 'HASH') {
               ($is_balancer,$currtargets,$currrules) =
                   &check_balancer_result($result,@hosts);
               if ($is_balancer) {
                   if (ref($currrules) eq 'HASH') {
                       if ($currrules->{'_LC_internetdom'} ne '') {
                           $rule_in_effect = $currrules->{'_LC_internetdom'};
                       }
                   }
                   $offloadto = &get_loadbalancer_targets($rule_in_effect,$currtargets,
                                                          $uname,$udom);
               }
           } else {
               if ($perlvar{'lonBalancer'} eq 'yes') {
                   $is_balancer = 1;
                   $offloadto = &this_host_spares($dom_in_use);
               }
           }
       } else {
           if ($perlvar{'lonBalancer'} eq 'yes') {
               $is_balancer = 1;
               $offloadto = &this_host_spares($dom_in_use);
           }
       }
       if ($is_balancer) {
           my $lowest_load = 30000;
           if (ref($offloadto) eq 'HASH') {
               if (ref($offloadto->{'primary'}) eq 'ARRAY') {
                   foreach my $try_server (@{$offloadto->{'primary'}}) {
                       ($otherserver,$lowest_load) =
                           &compare_server_load($try_server,$otherserver,$lowest_load);
                   }
               }
               my $found_server = ($otherserver ne '' && $lowest_load < 100);
   
               if (!$found_server) {
                   if (ref($offloadto->{'default'}) eq 'ARRAY') {
                       foreach my $try_server (@{$offloadto->{'default'}}) {
                           ($otherserver,$lowest_load) =
                               &compare_server_load($try_server,$otherserver,$lowest_load);
                       }
                   }
               }
           } elsif (ref($offloadto) eq 'ARRAY') {
               if (@{$offloadto} == 1) {
                   $otherserver = $offloadto->[0];
               } elsif (@{$offloadto} > 1) {
                   foreach my $try_server (@{$offloadto}) {
                       ($otherserver,$lowest_load) =
                           &compare_server_load($try_server,$otherserver,$lowest_load);
                   }
               }
           }
           if (($otherserver ne '') && (grep(/^\Q$otherserver\E$/,@hosts))) {
               $is_balancer = 0;
               if ($uname ne '' && $udom ne '') {
                   if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) {
   
                       &appenv({'user.loadbalexempt'     => $lonhost,
                                'user.loadbalcheck.time' => time});
                   }
               }
           }
       }
       return ($is_balancer,$otherserver);
   }
   
   sub check_balancer_result {
       my ($result,@hosts) = @_;
       my ($is_balancer,$currtargets,$currrules);
       if (ref($result) eq 'HASH') {
           if ($result->{'lonhost'} ne '') {
               my $currbalancer = $result->{'lonhost'};
               if (grep(/^\Q$currbalancer\E$/,@hosts)) {
                   $is_balancer = 1;
                   $currtargets = $result->{'targets'};
                   $currrules = $result->{'rules'};
               }
           } else {
               foreach my $key (keys(%{$result})) {
                   if (($key ne '') && (grep(/^\Q$key\E$/,@hosts)) &&
                       (ref($result->{$key}) eq 'HASH')) {
                       $is_balancer = 1;
                       $currrules = $result->{$key}{'rules'};
                       $currtargets = $result->{$key}{'targets'};
                       last;
                   }
               }
           }
       }
       return ($is_balancer,$currtargets,$currrules);
   }
   
   sub get_loadbalancer_targets {
       my ($rule_in_effect,$currtargets,$uname,$udom) = @_;
       my $offloadto;
       if ($rule_in_effect eq 'none') {
           return [$perlvar{'lonHostID'}];
       } elsif ($rule_in_effect eq '') {
           $offloadto = $currtargets;
       } else {
           if ($rule_in_effect eq 'homeserver') {
               my $homeserver = &homeserver($uname,$udom);
               if ($homeserver ne 'no_host') {
                   $offloadto = [$homeserver];
               }
           } elsif ($rule_in_effect eq 'externalbalancer') {
               my %domconfig =
                   &Apache::lonnet::get_dom('configuration',['loadbalancing'],$udom);
               if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
                   if ($domconfig{'loadbalancing'}{'lonhost'} ne '') {
                       if (&hostname($domconfig{'loadbalancing'}{'lonhost'}) ne '') {
                           $offloadto = [$domconfig{'loadbalancing'}{'lonhost'}];
                       }
                   }
               } else {
                   my %servers = &internet_dom_servers($udom);
                   my ($remotebalancer,$remotetargets) = &get_lonbalancer_config(\%servers);
                   if (&hostname($remotebalancer) ne '') {
                       $offloadto = [$remotebalancer];
                   }
               }
           } elsif (&hostname($rule_in_effect) ne '') {
               $offloadto = [$rule_in_effect];
           }
       }
       return $offloadto;
   }
   
   sub internet_dom_servers {
       my ($dom) = @_;
       my (%uniqservers,%servers);
       my $primaryserver = &hostname(&domain($dom,'primary'));
       my @machinedoms = &machine_domains($primaryserver);
       foreach my $mdom (@machinedoms) {
           my %currservers = %servers;
           my %server = &get_servers($mdom);
           %servers = (%currservers,%server);
       }
       my %by_hostname;
       foreach my $id (keys(%servers)) {
           push(@{$by_hostname{$servers{$id}}},$id);
       }
       foreach my $hostname (sort(keys(%by_hostname))) {
           if (@{$by_hostname{$hostname}} > 1) {
               my $match = 0;
               foreach my $id (@{$by_hostname{$hostname}}) {
                   if (&host_domain($id) eq $dom) {
                       $uniqservers{$id} = $hostname;
                       $match = 1;
                   }
               }
               unless ($match) {
                   $uniqservers{$by_hostname{$hostname}[0]} = $hostname;
               }
           } else {
               $uniqservers{$by_hostname{$hostname}[0]} = $hostname;
           }
       }
       return %uniqservers;
   }
   
 # ---------------------- Find the homebase for a user from domain's lib servers  # ---------------------- Find the homebase for a user from domain's lib servers
   
 my %homecache;  my %homecache;
Line 597  sub homeserver { Line 1525  sub homeserver {
     my $index="$uname:$udom";      my $index="$uname:$udom";
   
     if (exists($homecache{$index})) { return $homecache{$index}; }      if (exists($homecache{$index})) { return $homecache{$index}; }
     my $tryserver;  
     foreach $tryserver (keys %libserv) {      my %servers = &get_servers($udom,'library');
       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 $homecache{$index}=$tryserver;      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 619  sub idget { Line 1548  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 645  sub idget { Line 1572  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 656  sub idrget { Line 1583  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 {
                   $servers{$uhom}=$id.'='.$esc_unam;
               }
           }
       }
       foreach my $server (keys(%servers)) {
           &critical('idput:'.$udom.':'.$servers{$server},$server);
       }
   }
   
   # ---------------------------------------- Delete unwanted IDs from ids.db file
   
   sub iddel {
       my ($udom,$idshashref,$uhome)=@_;
       my %result=();
       unless (ref($idshashref) eq 'HASH') {
           return %result;
       }
       my %servers=();
       while (my ($id,$uname) = each(%{$idshashref})) {
           my $uhom;
           if ($uhome) {
               $uhom = $uhome;
           } else {
               $uhom=&homeserver($uname,$udom);
           }
           if ($uhom ne 'no_host') {
               if ($servers{$uhom}) {
                   $servers{$uhom}.='&'.&escape($id);
             } else {              } else {
                 $servers{$uhom}=$id.'='.$unam;                  $servers{$uhom}=&escape($id);
             }              }
         }          }
     }      }
     foreach (keys %servers) {      foreach my $server (keys(%servers)) {
         &critical('idput:'.$udom.':'.$servers{$_},$_);          $result{$server} = &critical('iddel:'.$udom.':'.$servers{$server},$uhome);
     }      }
       return %result;
   }
   
   # ------------------------------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");
       }
   }
   
   # --------------------- 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')) {
           return ($domdefs{'inststatustypes'},$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("retrieve_inst_usertypes 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("retrieve_inst_usertypes 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,$ignore_cache) = @_;
       return if (($domain eq '') || ($domain eq 'public'));
       my $cachetime = 60*60*24;
       unless ($ignore_cache) {
           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','selfenrollment',
                                     'coursecategories'],$domain);
       my @coursetypes = ('official','unofficial','community','textbook');
       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{'quotas'}{'authorquota'}) eq 'HASH') {
               $domdefaults{'authorquota'} = $domconfig{'quotas'}{'authorquota'};
           }
       }
       if (ref($domconfig{'requestcourses'}) eq 'HASH') {
           foreach my $item ('official','unofficial','community','textbook') {
               $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','inststatusguest') {
               $domdefaults{$item} = $domconfig{'inststatus'}{$item};
           }
       }
       if (ref($domconfig{'coursedefaults'}) eq 'HASH') {
           foreach my $type (@coursetypes) {
               if (ref($domconfig{'coursedefaults'}{'coursecredits'}) eq 'HASH') {
                   unless ($type eq 'community') {
                       $domdefaults{$type.'credits'} = $domconfig{'coursedefaults'}{'coursecredits'}{$type};
                   }
               }
               if (ref($domconfig{'coursedefaults'}{'uploadquota'}) eq 'HASH') {
                   $domdefaults{$type.'quota'} = $domconfig{'coursedefaults'}{'uploadquota'}{$type};
               }
           }
       }
       if (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'};
           }
       }
       if (ref($domconfig{'selfenrollment'}) eq 'HASH') {
           if (ref($domconfig{'selfenrollment'}{'admin'}) eq 'HASH') {
               my @settings = ('types','registered','enroll_dates','access_dates','section',
                               'approval','limit');
               foreach my $type (@coursetypes) {
                   if (ref($domconfig{'selfenrollment'}{'admin'}{$type}) eq 'HASH') {
                       my @mgrdc = ();
                       foreach my $item (@settings) {
                           if ($domconfig{'selfenrollment'}{'admin'}{$type}{$item} eq '0') {
                               push(@mgrdc,$item);
                           }
                       }
                       if (@mgrdc) {
                           $domdefaults{$type.'selfenrolladmdc'} = join(',',@mgrdc);
                       }
                   }
               }
           }
           if (ref($domconfig{'selfenrollment'}{'default'}) eq 'HASH') {
               foreach my $type (@coursetypes) {
                   if (ref($domconfig{'selfenrollment'}{'default'}{$type}) eq 'HASH') {
                       foreach my $item (keys(%{$domconfig{'selfenrollment'}{'default'}{$type}})) {
                           $domdefaults{$type.'selfenroll'.$item} = $domconfig{'selfenrollment'}{'default'}{$type}{$item};
                       }
                   }
               }
           }
       }
       if (ref($domconfig{'coursecategories'}) eq 'HASH') {
           $domdefaults{'catauth'} = 'std';
           $domdefaults{'catunauth'} = 'std';
           if ($domconfig{'coursecategories'}{'auth'}) {
               $domdefaults{'catauth'} = $domconfig{'coursecategories'}{'auth'};
           }
           if ($domconfig{'coursecategories'}{'unauth'}) {
               $domdefaults{'catunauth'} = $domconfig{'coursecategories'}{'unauth'};
           }
       }
       &do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);
       return %domdefaults;
 }  }
   
 # --------------------------------------------------- Assign a key to a student  # --------------------------------------------------- Assign a key to a student
Line 707  sub assign_access_key { Line 2161  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 808  sub validate_access_key { Line 2262  sub validate_access_key {
 # ------------------------------------- Find the section of student in a course  # ------------------------------------- Find the section of student in a course
 sub devalidate_getsection_cache {  sub devalidate_getsection_cache {
     my ($udom,$unam,$courseid)=@_;      my ($udom,$unam,$courseid)=@_;
     $courseid=~s/\_/\//g;  
     $courseid=~s/^(\w)/\/$1/;  
     my $hashid="$udom:$unam:$courseid";      my $hashid="$udom:$unam:$courseid";
     &devalidate_cache_new('getsection',$hashid);      &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)=@_;
     my $cachetime=1800;      my $cachetime=1800;
     $courseid=~s/\_/\//g;  
     $courseid=~s/^(\w)/\/$1/;  
   
     my $hashid="$udom:$unam:$courseid";      my $hashid="$udom:$unam:$courseid";
     my ($result,$cached)=&is_cached_new('getsection',$hashid);      my ($result,$cached)=&is_cached_new('getsection',$hashid);
Line 839  sub getsection { Line 2308  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 877  sub save_cache { Line 2345  sub save_cache {
     &purge_remembered();      &purge_remembered();
     #&Apache::loncommon::validate_page();      #&Apache::loncommon::validate_page();
     undef(%env);      undef(%env);
       undef($env_loaded);
 }  }
   
 my $to_remember=-1;  my $to_remember=-1;
Line 884  my %remembered; Line 2353  my %remembered;
 my %accessed;  my %accessed;
 my $kicks=0;  my $kicks=0;
 my $hits=0;  my $hits=0;
   sub make_key {
       my ($name,$id) = @_;
       if (length($id) > 65 
    && length(&escape($id)) > 200) {
    $id=length($id).':'.&Digest::MD5::md5_hex($id);
       }
       return &escape($name.':'.$id);
   }
   
 sub devalidate_cache_new {  sub devalidate_cache_new {
     my ($name,$id,$debug) = @_;      my ($name,$id,$debug) = @_;
     if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); }      if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); }
     $id=&escape($name.':'.$id);      $id=&make_key($name,$id);
     $memcache->delete($id);      $memcache->delete($id);
     delete($remembered{$id});      delete($remembered{$id});
     delete($accessed{$id});      delete($accessed{$id});
Line 895  sub devalidate_cache_new { Line 2373  sub devalidate_cache_new {
   
 sub is_cached_new {  sub is_cached_new {
     my ($name,$id,$debug) = @_;      my ($name,$id,$debug) = @_;
     $id=&escape($name.':'.$id);      $id=&make_key($name,$id);
     if (exists($remembered{$id})) {      if (exists($remembered{$id})) {
  if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); }   if ($debug) { &Apache::lonnet::logthis("Early return $id of $remembered{$id} "); }
  $accessed{$id}=[&gettimeofday()];   $accessed{$id}=[&gettimeofday()];
  $hits++;   $hits++;
  return ($remembered{$id},1);   return ($remembered{$id},1);
Line 918  sub is_cached_new { Line 2396  sub is_cached_new {
   
 sub do_cache_new {  sub do_cache_new {
     my ($name,$id,$value,$time,$debug) = @_;      my ($name,$id,$value,$time,$debug) = @_;
     $id=&escape($name.':'.$id);      $id=&make_key($name,$id);
     my $setvalue=$value;      my $setvalue=$value;
     if (!defined($setvalue)) {      if (!defined($setvalue)) {
  $setvalue='__undef__';   $setvalue='__undef__';
Line 927  sub do_cache_new { Line 2405  sub do_cache_new {
  $time=600;   $time=600;
     }      }
     if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); }      if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); }
     $memcache->set($id,$setvalue,$time);      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      # need to make a copy of $value
     #&make_room($id,$value,$debug);      &make_room($id,$value,$debug);
     return $value;      return $value;
 }  }
   
 sub make_room {  sub make_room {
     my ($id,$value,$debug)=@_;      my ($id,$value,$debug)=@_;
     $remembered{$id}=$value;  
       $remembered{$id}= (ref($value)) ? &Storable::dclone($value)
                                       : $value;
     if ($to_remember<0) { return; }      if ($to_remember<0) { return; }
     $accessed{$id}=[&gettimeofday()];      $accessed{$id}=[&gettimeofday()];
     if (scalar(keys(%remembered)) <= $to_remember) { return; }      if (scalar(keys(%remembered)) <= $to_remember) { return; }
Line 964  sub purge_remembered { Line 2448  sub purge_remembered {
   
 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;
 }  }
Line 1041  sub chatsend { Line 2535  sub chatsend {
   
 sub getversion {  sub getversion {
     my $fname=&clutter(shift);      my $fname=&clutter(shift);
     unless ($fname=~/^\/res\//) { return -1; }      unless ($fname=~m{^(/adm/wrapper|)/res/}) { return -1; }
     return &currentversion(&filelocation('',$fname));      return &currentversion(&filelocation('',$fname));
 }  }
   
 sub currentversion {  sub currentversion {
     my $fname=shift;      my $fname=shift;
     my ($result,$cached)=&is_cached_new('resversion',$fname);  
     if (defined($cached)) { return $result; }  
     my $author=$fname;      my $author=$fname;
     $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;      $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
     my ($udom,$uname)=split(/\//,$author);      my ($udom,$uname)=split(/\//,$author);
     my $home=homeserver($uname,$udom);      my $home=&homeserver($uname,$udom);
     if ($home eq 'no_host') {       if ($home eq 'no_host') { 
         return -1;           return -1; 
     }      }
     my $answer=reply("currentversion:$fname",$home);      my $answer=&reply("currentversion:$fname",$home);
     if (($answer eq 'con_lost') || ($answer eq 'rejected')) {      if (($answer eq 'con_lost') || ($answer eq 'rejected')) {
  return -1;   return -1;
     }      }
     return &do_cache_new('resversion',$fname,$answer,600);      return $answer;
   }
   
   #
   # Return special version number of resource if set by override, empty otherwise
   #
   sub usedversion {
       my $fname=shift;
       unless ($fname) { $fname=$env{'request.uri'}; }
       my ($urlversion)=($fname=~/\.(\d+)\.\w+$/);
       if ($urlversion) { return $urlversion; }
       return '';
 }  }
   
 # ----------------------------- Subscribe to a resource, return URL if possible  # ----------------------------- Subscribe to a resource, return URL if possible
Line 1088  sub subscribe { Line 2591  sub subscribe {
 sub repcopy {  sub repcopy {
     my $filename=shift;      my $filename=shift;
     $filename=~s/\/+/\//g;      $filename=~s/\/+/\//g;
     if ($filename=~m|^/home/httpd/html/adm/|) { return 'ok'; }      my $londocroot = $perlvar{'lonDocRoot'};
     if ($filename=~m|^/home/httpd/html/lonUsers/|) { return 'ok'; }      if ($filename=~m{^\Q$londocroot/adm/\E}) { return 'ok'; }
     if ($filename=~m|^/home/httpd/html/userfiles/| or      if ($filename=~m{^\Q/home/httpd/lonUsers/\E}) { return 'ok'; }
  $filename=~m -^/*(uploaded|editupload)/-) {       if ($filename=~m{^\Q$londocroot/userfiles/\E} or
    $filename=~m{^/*(uploaded|editupload)/}) {
  return &repcopy_userfile($filename);   return &repcopy_userfile($filename);
     }      }
     $filename=~s/[\n\r]//g;      $filename=~s/[\n\r]//g;
     my $transname="$filename.in.transfer";      my $transname="$filename.in.transfer";
   # FIXME: this should flock
     if ((-e $filename) || (-e $transname)) { return 'ok'; }      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/) {
Line 1117  sub repcopy { Line 2622  sub repcopy {
         unless ($home eq $perlvar{'lonHostID'}) {          unless ($home eq $perlvar{'lonHostID'}) {
            my @parts=split(/\//,$filename);             my @parts=split(/\//,$filename);
            my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";             my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";
            if ($path ne "$perlvar{'lonDocRoot'}/res") {             if ($path ne "$londocroot/res") {
                &logthis("Malconfiguration for replication: $filename");                 &logthis("Malconfiguration for replication: $filename");
        return 'bad_request';         return 'bad_request';
            }             }
Line 1160  sub ssi_body { Line 2665  sub ssi_body {
     if (! exists($form{'LONCAPA_INTERNAL_no_discussion'})) {      if (! exists($form{'LONCAPA_INTERNAL_no_discussion'})) {
         $form{'LONCAPA_INTERNAL_no_discussion'}='true';          $form{'LONCAPA_INTERNAL_no_discussion'}='true';
     }      }
     my $output=($filelink=~/^http\:/?&externalssi($filelink):      my $output='';
                                      &ssi($filelink,%form));      my $response;
     $output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+// END LON-CAPA Internal\s*(-->)?\s||gs;      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;      $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);
       if (wantarray) {
     return $response->content;   return ($response->content, $response);
       } else {
    return $response->content;
       }
 }  }
   
 sub externalssi {  sub externalssi {
Line 1198  sub externalssi { Line 2734  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 1211  sub allowuploaded { Line 2751  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);
   }
   
   #
   # Determine if the current user should be able to edit a particular resource,
   # when viewing in course context.
   # (a) When viewing resource used to determine if "Edit" item is included in
   #     Functions.
   # (b) When displaying folder contents in course editor, used to determine if
   #     "Edit" link will be displayed alongside resource.
   #
   #  input: six args -- filename (decluttered), course number, course domain,
   #                   url, symb (if registered) and group (if this is a group
   #                   item -- e.g., bulletin board, group page etc.).
   #  output: array of five scalars --
   #          $cfile -- url for file editing if editable on current server
   #          $home -- homeserver of resource (i.e., for author if published,
   #                                           or course if uploaded.).
   #          $switchserver --  1 if server switch will be needed.
   #          $forceedit -- 1 if icon/link should be to go to edit mode
   #          $forceview -- 1 if icon/link should be to go to view mode
   #
   
   sub can_edit_resource {
       my ($file,$cnum,$cdom,$resurl,$symb,$group) = @_;
       my ($cfile,$home,$switchserver,$forceedit,$forceview,$uploaded,$incourse);
   #
   # For aboutme pages user can only edit his/her own.
   #
       if ($resurl =~ m{^/?adm/($match_domain)/($match_username)/aboutme$}) {
           my ($sdom,$sname) = ($1,$2);
           if (($sdom eq $env{'user.domain'}) && ($sname eq $env{'user.name'})) {
               $home = $env{'user.home'};
               $cfile = $resurl;
               if ($env{'form.forceedit'}) {
                   $forceview = 1;
               } else {
                   $forceedit = 1;
               }
               return ($cfile,$home,$switchserver,$forceedit,$forceview);
           } else {
               return;
           }
       }
   
       if ($env{'request.course.id'}) {
           my $crsedit = &Apache::lonnet::allowed('mdc',$env{'request.course.id'});
           if ($group ne '') {
   # if this is a group homepage or group bulletin board, check group privs
               my $allowed = 0;
               if ($resurl =~ m{^/?adm/$cdom/$cnum/$group/smppg$}) {
                   if ((&allowed('mdg',$env{'request.course.id'}.
                                 ($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:''))) ||
                           (&allowed('mgh',$env{'request.course.id'}.'/'.$group)) || $crsedit) {
                       $allowed = 1;
                   }
               } elsif ($resurl =~ m{^/?adm/$cdom/$cnum/\d+/bulletinboard$}) {
                   if ((&allowed('mdg',$env{'request.course.id'}.($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:''))) ||
                           (&allowed('cgb',$env{'request.course.id'}.'/'.$group)) || $crsedit) {
                       $allowed = 1;
                   }
               }
               if ($allowed) {
                   $home=&homeserver($cnum,$cdom);
                   if ($env{'form.forceedit'}) {
                       $forceview = 1;
                   } else {
                       $forceedit = 1;
                   }
                   $cfile = $resurl;
               } else {
                   return;
               }
           } else {
               if ($resurl =~ m{^/?adm/viewclasslist$}) {
                   unless (&Apache::lonnet::allowed('opa',$env{'request.course.id'})) {
                       return;
                   }
               } elsif (!$crsedit) {
   #
   # No edit allowed where CC has switched to student role.
   #
                   return;
               }
           }
       }
   
       if ($file ne '') {
           if (($cnum =~ /$match_courseid/) && ($cdom =~ /$match_domain/)) {
               if (&is_course_upload($file,$cnum,$cdom)) {
                   $uploaded = 1;
                   $incourse = 1;
                   if ($file =~/\.(htm|html|css|js|txt)$/) {
                       $cfile = &hreflocation('',$file);
                       if ($env{'form.forceedit'}) {
                           $forceview = 1;
                       } else {
                           $forceedit = 1;
                       }
                   }
               } elsif ($resurl =~ m{^/public/$cdom/$cnum/syllabus}) {
                   $incourse = 1;
                   if ($env{'form.forceedit'}) {
                       $forceview = 1;
                   } else {
                       $forceedit = 1;
                   }
                   $cfile = $resurl;
               } elsif (($resurl ne '') && (&is_on_map($resurl))) {
                   if ($resurl =~ m{^/adm/$match_domain/$match_username/\d+/smppg|bulletinboard$}) {
                       $incourse = 1;
                       if ($env{'form.forceedit'}) {
                           $forceview = 1;
                       } else {
                           $forceedit = 1;
                       }
                       $cfile = $resurl;
                   } elsif ($resurl eq '/res/lib/templates/simpleproblem.problem') {
                       $incourse = 1;
                       $cfile = $resurl.'/smpedit';
                   } elsif ($resurl =~ m{^/adm/wrapper/ext/}) {
                       $incourse = 1;
                       if ($env{'form.forceedit'}) {
                           $forceview = 1;
                       } else {
                           $forceedit = 1;
                       }
                       $cfile = $resurl;
                   } elsif ($resurl =~ m{^/?adm/viewclasslist$}) {
                       $incourse = 1;
                       if ($env{'form.forceedit'}) {
                           $forceview = 1;
                       } else {
                           $forceedit = 1;
                       }
                       $cfile = ($resurl =~ m{^/} ? $resurl : "/$resurl");
                   }
               } elsif ($resurl eq '/res/lib/templates/simpleproblem.problem/smpedit') {
                   my $template = '/res/lib/templates/simpleproblem.problem';
                   if (&is_on_map($template)) {
                       $incourse = 1;
                       $forceview = 1;
                       $cfile = $template;
                   }
               } elsif (($resurl =~ m{^/adm/wrapper/ext/}) && ($env{'form.folderpath'} =~ /^supplemental/)) {
                       $incourse = 1;
                       if ($env{'form.forceedit'}) {
                           $forceview = 1;
                       } else {
                           $forceedit = 1;
                       }
                       $cfile = $resurl;
               } elsif (($resurl eq '/adm/extresedit') && ($symb || $env{'form.folderpath'})) {
                   $incourse = 1;
                   $forceview = 1;
                   if ($symb) {
                       my ($map,$id,$res)=&decode_symb($symb);
                       $env{'request.symb'} = $symb;
                       $cfile = &clutter($res);
                   } else {
                       $cfile = $env{'form.suppurl'};
                       $cfile =~ s{^http://}{};
                       $cfile = '/adm/wrapper/ext/'.$cfile;
                   }
               } elsif ($resurl =~ m{^/?adm/viewclasslist$}) {
                   if ($env{'form.forceedit'}) {
                       $forceview = 1;
                   } else {
                       $forceedit = 1;
                   }
                   $cfile = ($resurl =~ m{^/} ? $resurl : "/$resurl");
               }
           }
           if ($uploaded || $incourse) {
               $home=&homeserver($cnum,$cdom);
           } elsif ($file !~ m{/$}) {
               $file=~s{^(priv/$match_domain/$match_username)}{/$1};
               $file=~s{^($match_domain/$match_username)}{/priv/$1};
               # Check that the user has permission to edit this resource
               my $setpriv = 1;
               my ($cfuname,$cfudom)=&constructaccess($file,$setpriv);
               if (defined($cfudom)) {
                   $home=&homeserver($cfuname,$cfudom);
                   $cfile=$file;
               }
           }
           if (($cfile ne '') && (!$incourse || $uploaded) &&
               (($home ne '') && ($home ne 'no_host'))) {
               my @ids=&current_machine_ids();
               unless (grep(/^\Q$home\E$/,@ids)) {
                   $switchserver=1;
               }
           }
       }
       return ($cfile,$home,$switchserver,$forceedit,$forceview);
   }
   
   sub is_course_upload {
       my ($file,$cnum,$cdom) = @_;
       my $uploadpath = &LONCAPA::propath($cdom,$cnum);
       $uploadpath =~ s{^\/}{};
       if (($file =~ m{^\Q$uploadpath\E/userfiles/(docs|supplemental)/}) ||
           ($file =~ m{^userfiles/\Q$cdom\E/\Q$cnum\E/(docs|supplemental)/})) {
           return 1;
       }
       return;
   }
   
   sub in_course {
       my ($udom,$uname,$cdom,$cnum,$type,$hideprivileged) = @_;
       if ($hideprivileged) {
           my $skipuser;
           my %coursehash = &coursedescription($cdom.'_'.$cnum);
           my @possdoms = ($cdom);
           if ($coursehash{'checkforpriv'}) {
               push(@possdoms,split(/,/,$coursehash{'checkforpriv'}));
           }
           if (&privileged($uname,$udom,\@possdoms)) {
               $skipuser = 1;
               if ($coursehash{'nothideprivileged'}) {
                   foreach my $item (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
                       my $user;
                       if ($item =~ /:/) {
                           $user = $item;
                       } else {
                           $user = join(':',split(/[\@]/,$item));
                       }
                       if ($user eq $uname.':'.$udom) {
                           undef($skipuser);
                           last;
                       }
                   }
               }
               if ($skipuser) {
                   return 0;
               }
           }
       }
       $type ||= 'any';
       if (!defined($cdom) || !defined($cnum)) {
           my $cid  = $env{'request.course.id'};
           $cdom = $env{'course.'.$cid.'.domain'};
           $cnum = $env{'course.'.$cid.'.num'};
       }
       my $typesref;
       if (($type eq 'any') || ($type eq 'all')) {
           $typesref = ['active','previous','future'];
       } elsif ($type eq 'previous' || $type eq 'future') {
           $typesref = [$type];
       }
       my %roles = &get_my_roles($uname,$udom,'userroles',
                                 $typesref,undef,[$cdom]);
       my ($tmp) = keys(%roles);
       return 0 if ($tmp =~ /^(con_lost|error|no_such_host)/i);
       my @course_roles = grep(/^\Q$cnum\E:\Q$cdom\E:/, keys(%roles));
       if (@course_roles > 0) {
           return 1;
       }
       return 0;
 }  }
   
 # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course  # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course
Line 1219  sub allowuploaded { Line 3017  sub allowuploaded {
 #        path to file, source of file, instruction to parse file for objects,  #        path to file, source of file, instruction to parse file for objects,
 #        ref to hash for embedded objects,  #        ref to hash for embedded objects,
 #        ref to hash for codebase of java objects.  #        ref to hash for codebase of java objects.
   #        reference to scalar to accommodate mime type determined
   #          from File::MMagic if $parser = parse.
 #  #
 # output: url to file (if action was uploaddoc),   # output: url to file (if action was uploaddoc), 
 #         ok if successful, or diagnostic message otherwise (if action was propagate or copy)  #         ok if successful, or diagnostic message otherwise (if action was propagate or copy)
Line 1245  sub allowuploaded { Line 3045  sub allowuploaded {
 #  #
   
 sub process_coursefile {  sub process_coursefile {
     my ($action,$docuname,$docudom,$file,$source,$parser,$allfiles,$codebase)=@_;      my ($action,$docuname,$docudom,$file,$source,$parser,$allfiles,$codebase,
           $mimetype)=@_;
     my $fetchresult;      my $fetchresult;
     my $home=&homeserver($docuname,$docudom);      my $home=&homeserver($docuname,$docudom);
     if ($action eq 'propagate') {      if ($action eq 'propagate') {
Line 1272  sub process_coursefile { Line 3073  sub process_coursefile {
             print $fh $env{'form.'.$source};              print $fh $env{'form.'.$source};
             close($fh);              close($fh);
             if ($parser eq 'parse') {              if ($parser eq 'parse') {
                 my $parse_result = &extract_embedded_items($filepath,$fname,$allfiles,$codebase);                  my $mm = new File::MMagic;
                 unless ($parse_result eq 'ok') {                  my $type = $mm->checktype_filename($filepath.'/'.$fname);
                     &logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result);                  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,
                                  $home);                                   $home);
Line 1335  sub store_edited_file { Line 3143  sub store_edited_file {
 }  }
   
 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  # --------------- Take an uploaded file and put it into the userfiles directory
 # input: $formname - the contents of the file are in $env{"form.$formname"}  # input: $formname - the contents of the file are in $env{"form.$formname"}
 #                    the desired filenam is in $env{"form.$formname.filename"}  #                    the desired filename is in $env{"form.$formname.filename"}
 #        $coursedoc - if true up to the current course  #        $context - possible values: coursedoc, existingfile, overwrite, 
 #                     if false  #                                    canceloverwrite, or ''. 
   #                   if 'coursedoc': upload to the current course
   #                   if 'existingfile': write file to tmp/overwrites directory 
   #                   if 'canceloverwrite': delete file written to tmp/overwrites directory
   #                   $context is passed as argument to &finishuserfileupload
 #        $subdir - directory in userfile to store the file into  #        $subdir - directory in userfile to store the file into
 #        $parser, $allfiles, $codebase - unknown  #        $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>   # output: url of file in userspace, or error: <message> 
 #             or /adm/notfound.html if failure to upload occurse  #             or /adm/notfound.html if failure to upload occurse
   
   
 sub userfileupload {  sub userfileupload {
     my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname,$destudom)=@_;      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 1384  sub userfileupload { Line 3281  sub userfileupload {
         open(my $fh,'>'.$fullpath.'/'.$fname);          open(my $fh,'>'.$fullpath.'/'.$fname);
         print $fh $env{'form.'.$formname};          print $fh $env{'form.'.$formname};
         close($fh);          close($fh);
         return $fullpath.'/'.$fname;           if ($context eq 'existingfile') {
               my @info = stat($fullpath.'/'.$fname);
               return ($fullpath.'/'.$fname,$info[9]);
           } else {
               return $fullpath.'/'.$fname;
           }
     }      }
           if ($subdir eq 'scantron') {
 # Create the directory if not present          $fname = 'scantron_orig_'.$fname;
     $fname="$subdir/$fname";      } else {
     if ($coursedoc) {          $fname="$subdir/$fname";
       }
       if ($context eq 'coursedoc') {
  my $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};   my $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
  my $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};   my $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
         if ($env{'form.folder'} =~ m/^(default|supplemental)/) {          if ($env{'form.folder'} =~ m/^(default|supplemental)/) {
             return &finishuserfileupload($docuname,$docudom,              return &finishuserfileupload($docuname,$docudom,
  $formname,$fname,$parser,$allfiles,   $formname,$fname,$parser,$allfiles,
  $codebase);   $codebase,$thumbwidth,$thumbheight,
                                            $resizewidth,$resizeheight,$context,$mimetype);
         } else {          } else {
             $fname=$env{'form.folder'}.'/'.$fname;              if ($env{'form.folder'}) {
                   $fname=$env{'form.folder'}.'/'.$fname;
               }
             return &process_coursefile('uploaddoc',$docuname,$docudom,              return &process_coursefile('uploaddoc',$docuname,$docudom,
        $fname,$formname,$parser,         $fname,$formname,$parser,
        $allfiles,$codebase);         $allfiles,$codebase,$mimetype);
         }          }
     } elsif (defined($destuname)) {      } elsif (defined($destuname)) {
         my $docuname=$destuname;          my $docuname=$destuname;
         my $docudom=$destudom;          my $docudom=$destudom;
  return &finishuserfileupload($docuname,$docudom,$formname,   return &finishuserfileupload($docuname,$docudom,$formname,$fname,
      $fname,$parser,$allfiles,$codebase);       $parser,$allfiles,$codebase,
                                                $thumbwidth,$thumbheight,
                                        $resizewidth,$resizeheight,$context,$mimetype);
     } else {      } else {
         my $docuname=$env{'user.name'};          my $docuname=$env{'user.name'};
         my $docudom=$env{'user.domain'};          my $docudom=$env{'user.domain'};
         if (exists($env{'form.group'})) {          if ((exists($env{'form.group'})) || ($context eq 'syllabus')) {
             $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};              $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
             $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};              $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
         }          }
  return &finishuserfileupload($docuname,$docudom,$formname,   return &finishuserfileupload($docuname,$docudom,$formname,$fname,
      $fname,$parser,$allfiles,$codebase);       $parser,$allfiles,$codebase,
                                        $thumbwidth,$thumbheight,
                                        $resizewidth,$resizeheight,$context,$mimetype);
     }      }
 }  }
   
 sub finishuserfileupload {  sub finishuserfileupload {
     my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase) = @_;      my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase,
           $thumbwidth,$thumbheight,$resizewidth,$resizeheight,$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 1438  sub finishuserfileupload { Line 3350  sub finishuserfileupload {
     mkdir($filepath,0777);      mkdir($filepath,0777);
         }          }
     }      }
   
 # Save the file  # Save the file
     {      {
  if (!open(FH,'>'.$filepath.'/'.$file)) {   if (!open(FH,'>'.$filepath.'/'.$file)) {
Line 1445  sub finishuserfileupload { Line 3358  sub finishuserfileupload {
     print STDERR ('Failed to create '.$filepath.'/'.$file."\n");      print STDERR ('Failed to create '.$filepath.'/'.$file."\n");
     return '/adm/notfound.html';      return '/adm/notfound.html';
  }   }
  if (!print FH ($env{'form.'.$formname})) {          if ($context eq 'overwrite') {
               my $source =  LONCAPA::tempdir().'/overwrites/'.$docudom.'/'.$docuname.'/'.$fname;
               my $target = $filepath.'/'.$file;
               if (-e $source) {
                   my @info = stat($source);
                   if ($info[9] eq $env{'form.timestamp'}) {   
                       unless (&File::Copy::move($source,$target)) {
                           &logthis('Failed to overwrite '.$filepath.'/'.$file);
                           return "Moving from $source failed";
                       }
                   } else {
                       return "Temporary file: $source had unexpected date/time for last modification";
                   }
               } else {
                   return "Temporary file: $source missing";
               }
           } elsif (!print FH ($env{'form.'.$formname})) {
     &logthis('Failed to write to '.$filepath.'/'.$file);      &logthis('Failed to write to '.$filepath.'/'.$file);
     print STDERR ('Failed to write to '.$filepath.'/'.$file."\n");      print STDERR ('Failed to write to '.$filepath.'/'.$file."\n");
     return '/adm/notfound.html';      return '/adm/notfound.html';
  }   }
  close(FH);   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 ($parser eq 'parse') {
         my $parse_result = &extract_embedded_items($filepath,$file,$allfiles,          if ((ref($mimetype)) && ($$mimetype eq 'text/html')) {
    $codebase);              my $parse_result = &extract_embedded_items($filepath.'/'.$file,
         unless ($parse_result eq 'ok') {                                                         $allfiles,$codebase);
             &logthis('Failed to parse '.$filepath.$file.              unless ($parse_result eq 'ok') {
      ' for embedded media: '.$parse_result);                   &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 $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 1472  sub finishuserfileupload { Line 3436  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 {  sub extract_embedded_items {
     my ($filepath,$file,$allfiles,$codebase,$content) = @_;      my ($fullpath,$allfiles,$codebase,$content) = @_;
     my @state = ();      my @state = ();
       my (%lastids,%related,%shockwave,%flashvars);
     my %javafiles = (      my %javafiles = (
                       codebase => '',                        codebase => '',
                       code => '',                        code => '',
Line 1491  sub extract_embedded_items { Line 3456  sub extract_embedded_items {
     if ($content) {      if ($content) {
         $p = HTML::LCParser->new($content);          $p = HTML::LCParser->new($content);
     } else {      } else {
         $p = HTML::LCParser->new($filepath.'/'.$file);          $p = HTML::LCParser->new($fullpath);
     }      }
     while (my $t=$p->get_token()) {      while (my $t=$p->get_token()) {
  if ($t->[0] eq 'S') {   if ($t->[0] eq 'S') {
     my ($tagname, $attr) = ($t->[1],$t->[2]);      my ($tagname, $attr) = ($t->[1],$t->[2]);
     push (@state, $tagname);      push(@state, $tagname);
             if (lc($tagname) eq 'allow') {              if (lc($tagname) eq 'allow') {
                 &add_filetype($allfiles,$attr->{'src'},'src');                  &add_filetype($allfiles,$attr->{'src'},'src');
             }              }
     if (lc($tagname) eq 'img') {      if (lc($tagname) eq 'img') {
  &add_filetype($allfiles,$attr->{'src'},'src');   &add_filetype($allfiles,$attr->{'src'},'src');
     }      }
       if (lc($tagname) eq 'a') {
                   unless (($attr->{'href'} =~ /^#/) || ($attr->{'href'} eq '')) {
       &add_filetype($allfiles,$attr->{'href'},'href');
                   }
       }
             if (lc($tagname) eq 'script') {              if (lc($tagname) eq 'script') {
                   my $src;
                 if ($attr->{'archive'} =~ /\.jar$/i) {                  if ($attr->{'archive'} =~ /\.jar$/i) {
                     &add_filetype($allfiles,$attr->{'archive'},'archive');                      &add_filetype($allfiles,$attr->{'archive'},'archive');
                 } else {                  } else {
                     &add_filetype($allfiles,$attr->{'src'},'src');                      if ($attr->{'src'} ne '') {
                           $src = $attr->{'src'};
                           &add_filetype($allfiles,$src,'src');
                       }
                   }
                   my $text = $p->get_trimmed_text();
                   if ($text =~ /\Qswfobject.registerObject(\E([^\)]+)\)/) {
                       my @swfargs = split(/,/,$1);
                       foreach my $item (@swfargs) {
                           $item =~ s/["']//g;
                           $item =~ s/^\s+//;
                           $item =~ s/\s+$//;
                       }
                       if (($swfargs[0] ne'') && ($swfargs[2] ne '')) {
                           if (ref($related{$swfargs[0]}) eq 'ARRAY') {
                               push(@{$related{$swfargs[0]}},$swfargs[2]);
                           } else {
                               $related{$swfargs[0]} = [$swfargs[2]];
                           }
                       }
                 }                  }
             }              }
             if (lc($tagname) eq 'link') {              if (lc($tagname) eq 'link') {
Line 1520  sub extract_embedded_items { Line 3510  sub extract_embedded_items {
  foreach my $item (keys(%javafiles)) {   foreach my $item (keys(%javafiles)) {
     $javafiles{$item} = '';      $javafiles{$item} = '';
  }   }
                   if ((lc($tagname) eq 'object') && (lc($state[-2]) ne 'object')) {
                       $lastids{lc($tagname)} = $attr->{'id'};
                   }
     }      }
     if (lc($state[-2]) eq 'object' && lc($tagname) eq 'param') {      if (lc($state[-2]) eq 'object' && lc($tagname) eq 'param') {
  my $name = lc($attr->{'name'});   my $name = lc($attr->{'name'});
Line 1529  sub extract_embedded_items { Line 3522  sub extract_embedded_items {
  last;   last;
     }      }
  }   }
                   my $pathfrom;
  foreach my $item (keys(%mediafiles)) {   foreach my $item (keys(%mediafiles)) {
     if ($name eq $item) {      if ($name eq $item) {
  &add_filetype($allfiles, $attr->{'value'}, 'value');                          $pathfrom = $attr->{'value'};
                           $shockwave{$lastids{lc($state[-2])}} = $pathfrom;
    &add_filetype($allfiles,$pathfrom,$name);
  last;   last;
     }      }
  }   }
                   if ($name eq 'flashvars') {
                       $flashvars{$lastids{lc($state[-2])}} = $attr->{'value'};
                   }
                   if ($pathfrom ne '') {
                       &embedded_dependency($allfiles,\%related,$lastids{lc($state[-2])},
                                            $pathfrom);
                   }
     }      }
     if (lc($tagname) eq 'embed' || lc($tagname) eq 'applet') {      if (lc($tagname) eq 'embed' || lc($tagname) eq 'applet') {
  foreach my $item (keys(%javafiles)) {   foreach my $item (keys(%javafiles)) {
Line 1549  sub extract_embedded_items { Line 3552  sub extract_embedded_items {
  last;   last;
     }      }
  }   }
                   if (lc($tagname) eq 'embed') {
                       if (($attr->{'name'} ne '') && ($attr->{'src'} ne '')) {
                           &embedded_dependency($allfiles,\%related,$attr->{'name'},
                                                $attr->{'src'});
                       }
                   }
     }      }
               if (lc($tagname) eq 'iframe') {
                   my $src = $attr->{'src'} ;
                   if (($src ne '') && ($src !~ m{^(/|https?://)})) {
                       &add_filetype($allfiles,$src,'src');
                   } elsif ($src =~ m{^/}) {
                       if ($env{'request.course.id'}) {
                           my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
                           my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
                           my $url = &hreflocation('',$fullpath);
                           if ($url =~ m{^/uploaded/$cdom/$cnum/docs/(\w+/\d+)/}) {
                               my $relpath = $1;
                               if ($src =~ m{^/uploaded/$cdom/$cnum/docs/\Q$relpath\E/(.+)$}) {
                                   &add_filetype($allfiles,$1,'src');
                               }
                           }
                       }
                   }
               }
               if ($t->[4] =~ m{/>$}) {
                   pop(@state);
               }
  } elsif ($t->[0] eq 'E') {   } elsif ($t->[0] eq 'E') {
     my ($tagname) = ($t->[1]);      my ($tagname) = ($t->[1]);
     if ($javafiles{'codebase'} ne '') {      if ($javafiles{'codebase'} ne '') {
Line 1569  sub extract_embedded_items { Line 3599  sub extract_embedded_items {
     pop @state;      pop @state;
  }   }
     }      }
       foreach my $id (sort(keys(%flashvars))) {
           if ($shockwave{$id} ne '') {
               my @pairs = split(/\&/,$flashvars{$id});
               foreach my $pair (@pairs) {
                   my ($key,$value) = split(/\=/,$pair);
                   if ($key eq 'thumb') {
                       &add_filetype($allfiles,$value,$key);
                   } elsif ($key eq 'content') {
                       my ($path) = ($shockwave{$id} =~ m{^(.+/)[^/]+$});
                       my ($ext) = ($value =~ /\.([^.]+)$/);
                       if ($ext ne '') {
                           &add_filetype($allfiles,$path.$value,$ext);
                       }
                   }
               }
           }
       }
     return 'ok';      return 'ok';
 }  }
   
Line 1583  sub add_filetype { Line 3630  sub add_filetype {
     }      }
 }  }
   
   sub embedded_dependency {
       my ($allfiles,$related,$identifier,$pathfrom) = @_;
       if ((ref($allfiles) eq 'HASH') && (ref($related) eq 'HASH')) {
           if (($identifier ne '') &&
               (ref($related->{$identifier}) eq 'ARRAY') &&
               ($pathfrom ne '')) {
               my ($path) = ($pathfrom =~ m{^(.+/)[^/]+$});
               foreach my $dep (@{$related->{$identifier}}) {
                   &add_filetype($allfiles,$path.$dep,'object');
               }
           }
       }
       return;
   }
   
 sub removeuploadedurl {  sub removeuploadedurl {
     my ($url)=@_;      my ($url)=@_;
     my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);      my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);    
     return &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 1604  sub mkdiruserfile { Line 3679  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 1631  sub flushcourselogs { Line 3721  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 1645  sub flushcourselogs { Line 3734  sub flushcourselogs {
                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}).':'.&escape($courseownerbuf{$crsid});              'type'        => $coursetypebuf{$crsid},
         } else {              'owner'       => $courseownerbuf{$crsid},
            $courseidbuffer{$coursehombuf{$crsid}}=          };
  &escape($crsid).'='.&escape($coursedescrbuf{$crsid}).  
                          ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$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 1669  sub flushcourselogs { Line 3757  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'};
Line 1682  sub flushcourselogs { Line 3771  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 1701  sub flushcourselogs { Line 3785  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 1715  sub flushcourselogs { Line 3798  sub flushcourselogs {
 # Reverse lookup of domain roles (dc, ad, li, sc, au)  # Reverse lookup of domain roles (dc, ad, li, sc, au)
 #  #
     my %domrolebuffer = ();      my %domrolebuffer = ();
     foreach my $entry (keys %domainrolehash) {      foreach my $entry (keys(%domainrolehash)) {
         my ($role,$uname,$udom,$runame,$rudom,$rsec)=split/:/,$entry;          my ($role,$uname,$udom,$runame,$rudom,$rsec)=split(/:/,$entry);
         if ($domrolebuffer{$rudom}) {          if ($domrolebuffer{$rudom}) {
             $domrolebuffer{$rudom}.='&'.&escape($entry).              $domrolebuffer{$rudom}.='&'.&escape($entry).
                       '='.&escape($domainrolehash{$entry});                        '='.&escape($domainrolehash{$entry});
Line 1727  sub flushcourselogs { Line 3810  sub flushcourselogs {
         delete $domainrolehash{$entry};          delete $domainrolehash{$entry};
     }      }
     foreach my $dom (keys(%domrolebuffer)) {      foreach my $dom (keys(%domrolebuffer)) {
         foreach my $tryserver (keys %libserv) {   my %servers = &get_servers($dom,'library');
             if ($hostdom{$tryserver} eq $dom) {   foreach my $tryserver (keys(%servers)) {
                 unless (&reply('domroleput:'.$dom.':'.      unless (&reply('domroleput:'.$dom.':'.
                   $domrolebuffer{$dom},$tryserver) eq 'ok') {     $domrolebuffer{$dom},$tryserver) eq 'ok') {
                     &logthis('Put of domain roles failed for '.$dom.' and  '.$tryserver);   &logthis('Put of domain roles failed for '.$dom.' and  '.$tryserver);
                 }      }
             }  
         }          }
     }      }
     $dumpcount++;      $dumpcount++;
Line 1755  sub courselog { Line 3837  sub courselog {
        $env{'course.'.$env{'request.course.id'}.'.internal.coursecode'};         $env{'course.'.$env{'request.course.id'}.'.internal.coursecode'};
     $courseownerbuf{$env{'request.course.id'}}=      $courseownerbuf{$env{'request.course.id'}}=
        $env{'course.'.$env{'request.course.id'}.'.internal.courseowner'};         $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'}}) {      if (defined $courselogs{$env{'request.course.id'}}) {
  $courselogs{$env{'request.course.id'}}.='&'.$what;   $courselogs{$env{'request.course.id'}}.='&'.$what;
     } else {      } else {
Line 1769  sub courseacclog { Line 3853  sub courseacclog {
     my $fnsymb=shift;      my $fnsymb=shift;
     unless ($env{'request.course.id'}) { return ''; }      unless ($env{'request.course.id'}) { return ''; }
     my $what=$fnsymb.':'.$env{'user.name'}.':'.$env{'user.domain'};      my $what=$fnsymb.':'.$env{'user.name'}.':'.$env{'user.domain'};
     if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|task|page)$/) {      if ($fnsymb=~/$LONCAPA::assess_re/) {
         $what.=':POST';          $what.=':POST';
         # FIXME: Probably ought to escape things....          # FIXME: Probably ought to escape things....
  foreach (keys %env) {   foreach my $key (keys(%env)) {
             if ($_=~/^form\.(.*)/) {              if ($key=~/^form\.(.*)/) {
  $what.=':'.$1.'='.$env{$_};                  my $formitem = $1;
                   if ($formitem =~ /^HWFILE(?:SIZE|TOOBIG)/) {
                       $what.=':'.$formitem.'='.$env{$key};
                   } elsif ($formitem !~ /^HWFILE(?:[^.]+)$/) {
                       $what.=':'.$formitem.'='.$env{$key};
                   }
             }              }
         }          }
     } elsif ($fnsymb =~ m:^/adm/searchcat:) {      } elsif ($fnsymb =~ m:^/adm/searchcat:) {
Line 1796  sub countacc { Line 3885  sub countacc {
     my $url=&declutter(shift);      my $url=&declutter(shift);
     return if (! defined($url) || $url eq '');      return if (! defined($url) || $url eq '');
     unless ($env{'request.course.id'}) { return ''; }      unless ($env{'request.course.id'}) { return ''; }
   #
   # Mark that this url was used in this course
   #
     $accesshash{$env{'request.course.id'}.'___'.$url.'___course'}=1;      $accesshash{$env{'request.course.id'}.'___'.$url.'___course'}=1;
   #
   # Increase the access count for this resource in this child process
   #
     my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count';      my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count';
     $accesshash{$key}++;      $accesshash{$key}++;
 }  }
Line 1808  sub linklog { Line 3903  sub linklog {
     $accesshash{$from.'___'.$to.'___comefrom'}=1;      $accesshash{$from.'___'.$to.'___comefrom'}=1;
     $accesshash{$to.'___'.$from.'___goto'}=1;      $accesshash{$to.'___'.$from.'___goto'}=1;
 }  }
   
   sub statslog {
       my ($symb,$part,$users,$av_attempts,$degdiff)=@_;
       if ($users<2) { return; }
       my %dynstore=&LONCAPA::lonmetadata::dynamic_metadata_storage({
               'course'       => $env{'request.course.id'},
               'sections'     => '"all"',
               'num_students' => $users,
               'part'         => $part,
               'symb'         => $symb,
               'mean_tries'   => $av_attempts,
               'deg_of_diff'  => $degdiff});
       foreach my $key (keys(%dynstore)) {
           $accesshash{$key}=$dynstore{$key};
       }
   }
       
 sub userrolelog {  sub userrolelog {
     my ($trole,$username,$domain,$area,$tstart,$tend)=@_;      my ($trole,$username,$domain,$area,$tstart,$tend)=@_;
     if (($trole=~/^ca/) || ($trole=~/^aa/) ||      if ( $trole =~ /^(ca|aa|in|cc|ep|cr|ta|co)/ ) {
         ($trole=~/^in/) || ($trole=~/^cc/) ||  
         ($trole=~/^ep/) || ($trole=~/^cr/) ||  
         ($trole=~/^ta/)) {  
        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 (($trole=~/^dc/) || ($trole=~/^ad/) ||      if ($env{'request.role'} =~ /dc\./ && $trole =~ /^(au|in|cc|ep|cr|ta|co)/) {
         ($trole=~/^li/) || ($trole=~/^li/) ||         $userrolehash
         ($trole=~/^au/) || ($trole=~/^dg/) ||           {$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'}
         ($trole=~/^sc/)) {                      =$tend.':'.$tstart;
       }
       if ($trole =~ /^(dc|ad|li|au|dg|sc)/ ) {
        my (undef,$rudom,$runame,$rsec)=split(/\//,$area);         my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
        $domainrolehash         $domainrolehash
          {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}           {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
Line 1831  sub userrolelog { Line 3941  sub userrolelog {
     }      }
 }  }
   
   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 @possdoms = ($coursehash{'domain'});
       if ($coursehash{'checkforpriv'}) {
           push(@possdoms,split(/,/,$coursehash{'checkforpriv'}));
     }      }
     my %returnhash=();      my %returnhash=();
     my %dumphash=      my %dumphash=
             &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});              &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});
     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 ($username eq '' || $domain eq '') { next; }   if ($username eq '' || $domain eq '') { next; }
  if ((&privileged($username,$domain)) &&           if ((&privileged($username,$domain,\@possdoms)) &&
     (!$nothide{$username.':'.$domain})) { next; }              (!$nothide{$username.':'.$domain})) { next; }
  if ($role eq 'cr') { next; }   if ($role eq 'cr') { next; }
         my $key=&plaintext($role);          if ($codes) {
  if ($role =~ /^cr/) {              if ($section) { $role .= ':'.$section; }
     $key=(split('/',$role))[3];              if ($returnhash{$role}) {
  }                  $returnhash{$role}.=','.$username.':'.$domain;
         if ($section) { $key.=' (Sec/Grp '.$section.')'; }              } else {
         if ($returnhash{$key}) {                  $returnhash{$role}=$username.':'.$domain;
     $returnhash{$key}.=','.$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);
             &dump('nohist_userroles',$udom,$uname);      if ($context eq 'userroles') {
           %dumphash = &dump('roles',$udom,$uname);
       } else {
           %dumphash = &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) {
               my @privroles = ('dc','su');
               if ($context eq 'userroles') {
                   next if (grep(/^\Q$role\E$/,@privroles));
               } else {
                   my $possdoms = [$domain];
                   if (ref($roledoms) eq 'ARRAY') {
                      push(@{$possdoms},@{$roledoms});
                   }
                   if (&privileged($username,$domain,$possdoms,\@privroles)) {
                       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 1892  sub get_my_roles { Line 4166  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 1901  sub getannounce { Line 4175  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 1920  sub getannounce { Line 4194  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,$instcodefilter,$ownerfilter,$coursefilter,$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)) ) {          $hasuniquecode)=@_;
     if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) {      my $as_hash = 1;
         foreach (      my %returnhash;
                  split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'.      if (!$domfilter) { $domfilter=''; }
        $sincefilter.':'.&escape($descfilter).':'.      my %libserv = &all_library();
                                &escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter),      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, $hasuniquecode)));
                   } 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.':'.$hasuniquecode,
                                $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 1947  sub courseiddump { Line 4296  sub courseiddump {
     return %returnhash;      return %returnhash;
 }  }
   
   sub courselastaccess {
       my ($cdom,$cnum,$hostidref) = @_;
       my %returnhash;
       if ($cdom && $cnum) {
           my $chome = &homeserver($cnum,$cdom);
           if ($chome ne 'no_host') {
               my $rep = &reply('courselastaccess:'.$cdom.':'.$cnum,$chome);
               &extract_lastaccess(\%returnhash,$rep);
           }
       } else {
           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 extract_lastaccess {
       my ($returnhash,$rep) = @_;
       if (ref($returnhash) eq 'HASH') {
           unless ($rep eq 'unknown_command' || $rep eq 'no_such_host' || 
                   $rep eq 'con_lost' || $rep eq 'rejected' || $rep eq 'refused' ||
                    $rep eq '') {
               my @pairs=split(/\&/,$rep);
               foreach my $item (@pairs) {
                   my ($key,$value)=split(/\=/,$item,2);
                   $key = &unescape($key);
                   next if ($key =~ /^error: 2 /);
                   $returnhash->{$key} = &thaw_unescape($value);
               }
           }
       }
       return;
   }
   
 # ---------------------------------------------------------- DC e-mail  # ---------------------------------------------------------- DC e-mail
   
 sub dcmailput {  sub dcmailput {
     my ($domain,$msgid,$message,$server)=@_;      my ($domain,$msgid,$message,$server)=@_;
     my $status = &Apache::lonnet::critical(      my $status = &Apache::lonnet::critical(
        'dcmailput:'.$domain.':'.&Apache::lonnet::escape($msgid).'='.         'dcmailput:'.$domain.':'.&escape($msgid).'='.
        &Apache::lonnet::escape($message),$server);         &escape($message),$server);
     return $status;      return $status;
 }  }
   
 sub dcmaildump {  sub dcmaildump {
     my ($dom,$startdate,$enddate,$senders) = @_;      my ($dom,$startdate,$enddate,$senders) = @_;
     my %returnhash=();      my %returnhash=();
     if (exists($domain_primary{$dom})) {  
       if (defined(&domain($dom,'primary'))) {
         my $cmd='dcmaildump:'.$dom.':'.&escape($startdate).':'.          my $cmd='dcmaildump:'.$dom.':'.&escape($startdate).':'.
                                                          &escape($enddate).':';                                                           &escape($enddate).':';
  my @esc_senders=map { &escape($_)} @$senders;   my @esc_senders=map { &escape($_)} @$senders;
  $cmd.=&escape(join('&',@esc_senders));   $cmd.=&escape(join('&',@esc_senders));
  foreach (split(/\&/,&reply($cmd,$domain_primary{$dom}))) {   foreach my $line (split(/\&/,&reply($cmd,&domain($dom,'primary')))) {
             my ($key,$value) = split(/\=/,$_);              my ($key,$value) = split(/\=/,$line,2);
             if (($key) && ($value)) {              if (($key) && ($value)) {
                 $returnhash{&unescape($key)} = &unescape($value);                  $returnhash{&unescape($key)} = &unescape($value);
             }              }
Line 1978  sub dcmaildump { Line 4371  sub dcmaildump {
   
 sub get_domain_roles {  sub get_domain_roles {
     my ($dom,$roles,$startdate,$enddate)=@_;      my ($dom,$roles,$startdate,$enddate)=@_;
     if (undef($startdate) || $startdate eq '') {      if ((!defined($startdate)) || ($startdate eq '')) {
         $startdate = '.';          $startdate = '.';
     }      }
     if (undef($enddate) || $enddate eq '') {      if ((!defined($enddate)) || ($enddate eq '')) {
         $enddate = '.';          $enddate = '.';
     }      }
     my $rolelist = join(':',@{$roles});      my $rolelist;
       if (ref($roles) eq 'ARRAY') {
           $rolelist = join('&',@{$roles});
       }
     my %personnel = ();      my %personnel = ();
     foreach my $tryserver (keys(%libserv)) {  
         if ($hostdom{$tryserver} eq $dom) {      my %servers = &get_servers($dom,'library');
             %{$personnel{$tryserver}}=();      foreach my $tryserver (keys(%servers)) {
             foreach (   %{$personnel{$tryserver}}=();
                 split(/\&/,&reply('domrolesdump:'.$dom.':'.   foreach my $line (split(/\&/,&reply('domrolesdump:'.$dom.':'.
                    &escape($startdate).':'.&escape($enddate).':'.      &escape($startdate).':'.
                    &escape($rolelist), $tryserver))) {      &escape($enddate).':'.
                 my($key,$value) = split(/\=/,$_);      &escape($rolelist), $tryserver))) {
                 if (($key) && ($value)) {      my ($key,$value) = split(/\=/,$line,2);
                     $personnel{$tryserver}{&unescape($key)} = &unescape($value);      if (($key) && ($value)) {
                 }   $personnel{$tryserver}{&unescape($key)} = &unescape($value);
             }      }
         }   }
     }      }
     return %personnel;      return %personnel;
 }  }
   
 # ----------------------------------------------------------- Check out an item  # ----------------------------------------------------------- Interval timing 
   
   {
   # Caches needed for speedup of navmaps
   # We don't want to cache this for very long at all (5 seconds at most)
   # 
   # The user for whom we cache
   my $cachedkey='';
   # The cached times for this user
   my %cachedtimes=();
   # When this was last done
   my $cachedtime=();
   
   sub load_all_first_access {
       my ($uname,$udom)=@_;
       if (($cachedkey eq $uname.':'.$udom) &&
           (abs($cachedtime-time)<5) && (!$env{'form.markaccess'})) {
           return;
       }
       $cachedtime=time;
       $cachedkey=$uname.':'.$udom;
       %cachedtimes=&dump('firstaccesstimes',$udom,$uname);
   }
   
 sub get_first_access {  sub get_first_access {
     my ($type,$argsymb)=@_;      my ($type,$argsymb,$argmap)=@_;
     my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();      my ($symb,$courseid,$udom,$uname)=&whichuser();
     if ($argsymb) { $symb=$argsymb; }      if ($argsymb) { $symb=$argsymb; }
     my ($map,$id,$res)=&decode_symb($symb);      my ($map,$id,$res)=&decode_symb($symb);
     if ($type eq 'map') {      if ($argmap) { $map = $argmap; }
       if ($type eq 'course') {
    $res='course';
       } elsif ($type eq 'map') {
  $res=&symbread($map);   $res=&symbread($map);
     } else {      } else {
  $res=$symb;   $res=$symb;
     }      }
     my %times=&get('firstaccesstimes',["$courseid\0$res"],$udom,$uname);      &load_all_first_access($uname,$udom);
     return $times{"$courseid\0$res"};      return $cachedtimes{"$courseid\0$res"};
 }  }
   
 sub set_first_access {  sub set_first_access {
     my ($type)=@_;      my ($type,$interval)=@_;
     my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();      my ($symb,$courseid,$udom,$uname)=&whichuser();
     my ($map,$id,$res)=&decode_symb($symb);      my ($map,$id,$res)=&decode_symb($symb);
     if ($type eq 'map') {      if ($type eq 'course') {
    $res='course';
       } elsif ($type eq 'map') {
  $res=&symbread($map);   $res=&symbread($map);
     } else {      } else {
  $res=$symb;   $res=$symb;
     }      }
     my $firstaccess=&get_first_access($type,$symb);      $cachedkey='';
       my $firstaccess=&get_first_access($type,$symb,$map);
     if (!$firstaccess) {      if (!$firstaccess) {
  return &put('firstaccesstimes',{"$courseid\0$res"=>time},$udom,$uname);          my $start = time;
    my $putres = &put('firstaccesstimes',{"$courseid\0$res"=>$start},
                             $udom,$uname);
           if ($putres eq 'ok') {
               &put('timerinterval',{"$courseid\0$res"=>$interval},
                    $udom,$uname); 
               &appenv(
                        {
                           'course.'.$courseid.'.firstaccess.'.$res   => $start,
                           'course.'.$courseid.'.timerinterval.'.$res => $interval,
                        }
                     );
           }
           return $putres;
     }      }
     return 'already_set';      return 'already_set';
 }  }
   }
   
 sub checkout {  sub checkout {
     my ($symb,$tuname,$tudom,$tcrsid)=@_;      my ($symb,$tuname,$tudom,$tcrsid)=@_;
Line 2045  sub checkout { Line 4483  sub checkout {
                  $tudom.'&'.                   $tudom.'&'.
                  $tcrsid.'&'.                   $tcrsid.'&'.
                  $symb.'&'.                   $symb.'&'.
  $now.'&'.$ENV{'REMOTE_ADDR'});                   $now.'&'.$ENV{'REMOTE_ADDR'});
     my $token=&reply('tmpput:'.$infostr,$lonhost);      my $token=&reply('tmpput:'.$infostr,$lonhost);
     if ($token=~/^error\:/) {       if ($token=~/^error\:/) {
         &logthis("<font color=\"blue\">WARNING: ".          &logthis("<font color=\"blue\">WARNING: ".
                 "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.                  "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.
                  "</font>");                   "</font>");
         return '';           return '';
     }      }
   
     $token=~s/^(\d+)\_.*\_(\d+)$/$1\*$2\*$lonhost/;      $token=~s/^(\d+)\_.*\_(\d+)$/$1\*$2\*$lonhost/;
Line 2067  sub checkout { Line 4505  sub checkout {
         &logthis("<font color=\"blue\">WARNING: ".          &logthis("<font color=\"blue\">WARNING: ".
                 "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.                  "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.
                  "</font>");                   "</font>");
     }          }
   
     if (&log($tudom,$tuname,&homeserver($tuname,$tudom),      if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
                          &escape('Checkout '.$infostr.' - '.                           &escape('Checkout '.$infostr.' - '.
                                                  $token)) ne 'ok') {                                                   $token)) ne 'ok') {
  return '';          return '';
     } else {      } else {
         &logthis("<font color=\"blue\">WARNING: ".          &logthis("<font color=\"blue\">WARNING: ".
                 "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.                  "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.
Line 2088  sub checkin { Line 4526  sub checkin {
     my $now=time;      my $now=time;
     my ($ta,$tb,$lonhost)=split(/\*/,$token);      my ($ta,$tb,$lonhost)=split(/\*/,$token);
     $lonhost=~tr/A-Z/a-z/;      $lonhost=~tr/A-Z/a-z/;
     my $dtoken=$ta.'_'.$hostname{$lonhost}.'_'.$tb;      my $dtoken=$ta.'_'.&hostname($lonhost).'_'.$tb;
     $dtoken=~s/\W/\_/g;      $dtoken=~s/\W/\_/g;
     my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=      my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
                  split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));                   split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));
Line 2097  sub checkin { Line 4535  sub checkin {
         &logthis('Check in '.$token.' ('.$dtoken.') failed');          &logthis('Check in '.$token.' ('.$dtoken.') failed');
         return '';          return '';
     }      }
       
     unless (&allowed('mgr',$tcrsid)) {      unless (&allowed('mgr',$tcrsid)) {
         &logthis('Check in '.$token.' ('.$dtoken.') unauthorized: '.          &logthis('Check in '.$token.' ('.$dtoken.') unauthorized: '.
                  $env{'user.name'}.' - '.$env{'user.domain'});                   $env{'user.name'}.' - '.$env{'user.domain'});
Line 2110  sub checkin { Line 4548  sub checkin {
   
     unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {      unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
        return '';         return '';
     }          }
   
     if (&log($tudom,$tuname,&homeserver($tuname,$tudom),      if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
                          &escape('Checkin - '.$token)) ne 'ok') {                           &escape('Checkin - '.$token)) ne 'ok') {
  return '';          return '';
     }      }
   
     return ($symb,$tuname,$tudom,$tcrsid);          return ($symb,$tuname,$tudom,$tcrsid);
 }  }
   
 # --------------------------------------------- Set Expire Date for Spreadsheet  # --------------------------------------------- Set Expire Date for Spreadsheet
Line 2215  sub hash2str { Line 4653  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 2376  sub tmpreset { Line 4814  sub tmpreset {
   if ($domain eq 'public' && $stuname eq 'public') {    if ($domain eq 'public' && $stuname eq 'public') {
       $stuname=$ENV{'REMOTE_ADDR'};        $stuname=$ENV{'REMOTE_ADDR'};
   }    }
   my $path=$perlvar{'lonDaemons'}.'/tmp';    my $path=LONCAPA::tempdir();
   my %hash;    my %hash;
   if (tie(%hash,'GDBM_File',    if (tie(%hash,'GDBM_File',
   $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',    $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
   &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 2415  sub tmpstore { Line 4853  sub tmpstore {
   }    }
   my $now=time;    my $now=time;
   my %hash;    my %hash;
   my $path=$perlvar{'lonDaemons'}.'/tmp';    my $path=LONCAPA::tempdir();
   if (tie(%hash,'GDBM_File',    if (tie(%hash,'GDBM_File',
   $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',    $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
   &GDBM_WRCREAT(),0640)) {    &GDBM_WRCREAT(),0640)) {
Line 2461  sub tmprestore { Line 4899  sub tmprestore {
   $namespace=~s/\//\_/g;    $namespace=~s/\//\_/g;
   $namespace=~s/\W//g;    $namespace=~s/\W//g;
   my %hash;    my %hash;
   my $path=$perlvar{'lonDaemons'}.'/tmp';    my $path=LONCAPA::tempdir();
   if (tie(%hash,'GDBM_File',    if (tie(%hash,'GDBM_File',
   $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',    $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
   &GDBM_READER(),0640)) {    &GDBM_READER(),0640)) {
Line 2515  sub store { Line 4953  sub store {
     $$storehash{'host'}=$perlvar{'lonHostID'};      $$storehash{'host'}=$perlvar{'lonHostID'};
   
     my $namevalue='';      my $namevalue='';
     foreach (keys %$storehash) {      foreach my $key (keys(%$storehash)) {
         $namevalue.=&escape($_).'='.&freeze_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 2551  sub cstore { Line 4989  sub cstore {
     $$storehash{'host'}=$perlvar{'lonHostID'};      $$storehash{'host'}=$perlvar{'lonHostID'};
   
     my $namevalue='';      my $namevalue='';
     foreach (keys %$storehash) {      foreach my $key (keys(%$storehash)) {
         $namevalue.=&escape($_).'='.&freeze_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 2569  sub restore { Line 5007  sub restore {
     if ($stuname) { $home=&homeserver($stuname,$domain); }      if ($stuname) { $home=&homeserver($stuname,$domain); }
   
     if (!$symb) {      if (!$symb) {
       unless ($symb=escape(&symbread())) { return ''; }          return if ($namespace eq 'courserequests');
           unless ($symb=escape(&symbread())) { return ''; }
     } else {      } else {
       $symb=&escape(&symbclean($symb));          unless ($namespace eq 'courserequests') {
               $symb=&escape(&symbclean($symb));
           }
     }      }
     if (!$namespace) {       if (!$namespace) { 
        unless ($namespace=$env{'request.course.id'}) {          unless ($namespace=$env{'request.course.id'}) { 
Line 2584  sub restore { Line 5025  sub restore {
     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)}=&thaw_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,$args)=@_;      my ($courseid,$args)=@_;
Line 2627  sub coursedescription { Line 5070  sub coursedescription {
  return %returnhash;   return %returnhash;
     }      }
   
     # get the data agin      # get the data again
   
     if (!$args->{'one_time'}) {      if (!$args->{'one_time'}) {
  $envhash{'course.'.$normalid.'.last_cache'}=time;   $envhash{'course.'.$normalid.'.last_cache'}=time;
     }      }
   
     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;
        }         }
     }      }
     if (!$args->{'one_time'}) {      if (!$args->{'one_time'}) {
  &appenv(%envhash);   &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,$possdomains,$possroles)=@_;
     my $rolesdump=&reply("dump:$domain:$username:roles",      my $now = time;
  &homeserver($username,$domain));      my $roles;
     if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return 0; }      if (ref($possroles) eq 'ARRAY') {
     my $now=time;          $roles = $possroles;
     if ($rolesdump ne '') {      } else {
         foreach (split(/&/,$rolesdump)) {          $roles = ['dc','su'];
     if ($_!~/^rolesdef_/) {      }
  my ($area,$role)=split(/=/,$_);      if (ref($possdomains) eq 'ARRAY') {
  $area=~s/\_\w\w$//;          my %privileged = &privileged_by_domain($possdomains,$roles);
  my ($trole,$tend,$tstart)=split(/_/,$role);          foreach my $dom (@{$possdomains}) {
  if (($trole eq 'dc') || ($trole eq 'su')) {              if (($username =~ /^$match_username$/) && ($domain =~ /^$match_domain$/) &&
     my $active=1;                  (ref($privileged{$dom}) eq 'HASH')) {
     if ($tend) {                  foreach my $role (@{$roles}) {
  if ($tend<$now) { $active=0; }                      if (ref($privileged{$dom}{$role}) eq 'HASH') {
     }                          if (exists($privileged{$dom}{$role}{$username.':'.$domain})) {
     if ($tstart) {                              my ($end,$start) = split(/:/,$privileged{$dom}{$role}{$username.':'.$domain});
  if ($tstart>$now) { $active=0; }                              return 1 unless (($end && $end < $now) ||
     }                                               ($start && $start > $now));
     if ($active) { return 1; }                          }
  }                      }
     }                  }
  }              }
           }
       } else {
           my %rolesdump = &dump("roles", $domain, $username) or return 0;
           my $now = time;
   
           for my $role (@rolesdump{grep { ! /^rolesdef_/ } keys %rolesdump}) {
               my ($trole, $tend, $tstart) = split(/_/, $role);
               if (grep(/^\Q$trole\E$/,@{$roles})) {
                   return 1 unless ($tend && $tend < $now)
                           or ($tstart && $tstart > $now);
               }
           }
     }      }
     return 0;      return 0;
 }  }
   
   sub privileged_by_domain {
       my ($domains,$roles) = @_;
       my %privileged = ();
       my $cachetime = 60*60*24;
       my $now = time;
       unless ((ref($domains) eq 'ARRAY') && (ref($roles) eq 'ARRAY')) {
           return %privileged;
       }
       foreach my $dom (@{$domains}) {
           next if (ref($privileged{$dom}) eq 'HASH');
           my $needroles;
           foreach my $role (@{$roles}) {
               my ($result,$cached)=&is_cached_new('priv_'.$role,$dom);
               if (defined($cached)) {
                   if (ref($result) eq 'HASH') {
                       $privileged{$dom}{$role} = $result;
                   }
               } else {
                   $needroles = 1;
               }
           }
           if ($needroles) {
               my %dompersonnel = &get_domain_roles($dom,$roles);
               $privileged{$dom} = {};
               foreach my $server (keys(%dompersonnel)) {
                   if (ref($dompersonnel{$server}) eq 'HASH') {
                       foreach my $item (keys(%{$dompersonnel{$server}})) {
                           my ($trole,$uname,$udom,$rest) = split(/:/,$item,4);
                           my ($end,$start) = split(/:/,$dompersonnel{$server}{$item});
                           next if ($end && $end < $now);
                           $privileged{$dom}{$trole}{$uname.':'.$udom} =
                               $dompersonnel{$server}{$item};
                       }
                   }
               }
               if (ref($privileged{$dom}) eq 'HASH') {
                   foreach my $role (@{$roles}) {
                       if (ref($privileged{$dom}{$role}) eq 'HASH') {
                           &do_cache_new('priv_'.$role,$dom,$privileged{$dom}{$role},$cachetime);
                       } else {
                           my %hash = ();
                           &do_cache_new('priv_'.$role,$dom,\%hash,$cachetime);
                       }
                   }
               }
           }
       }
       return %privileged;
   }
   
 # -------------------------------------------------------- Get user privileges  # -------------------------------------------------------- Get user privileges
   
 sub rolesinit {  sub rolesinit {
     my ($domain,$username,$authhost)=@_;      my ($domain, $username) = @_;
     my $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 %allgroups=();         my %allgroups=();
     my $now=time;  
     my $userroles="user.login.time=$now\n";  
     my $group_privs;  
   
     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,$group_privs);  
     if ($role=~/^cr/) {           if ($role =~ /^cr/) {
  if ($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|) {          # Custom role, defined by a user 
     ($trole,my $trest)=($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|);          # e.g., user.role.cr/msu/smith/mynewrole
     ($tend,$tstart)=split('_',$trest);              if ($role =~ m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|) {
  } else {                  $trole = $1;
     $trole=$role;                  ($tend, $tstart) = split('_', $2);
  }              } else {
             } elsif ($role =~ m|^gr/|) {                  $trole = $role;
                 ($trole,$tend,$tstart) = split(/_/,$role);  
                 ($trole,$group_privs) = split(/\//,$trole);  
                 $group_privs = &unescape($group_privs);  
     } else {  
  ($trole,$tend,$tstart)=split(/_/,$role);  
     }  
             $userroles.=&set_arearole($trole,$area,$tstart,$tend,$domain,$username);  
             if (($tend!=0) && ($tend<$now)) { $trole=''; }  
             if (($tstart!=0) && ($tstart>$now)) { $trole=''; }  
             if (($area ne '') && ($trole ne '')) {  
  my $spec=$trole.'.'.$area;  
  my ($tdummy,$tdomain,$trest)=split(/\//,$area);  
  if ($trole =~ /^cr\//) {  
                     &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);  
                 } elsif ($trole eq 'gr') {  
                     &group_roleprivs(\%allgroups,$area,$group_privs,$tend,$tstart);  
  } else {  
                     &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);  
  }  
             }              }
           }          } elsif ($role =~ m|^gr/|) {
           # Role of member in a group, defined within a course/community
           # e.g., user.role.gr/msu/04935610a19ee4a5fmsul1/leopards
               ($trole, $tend, $tstart) = split(/_/, $role);
               next if $tstart eq '-1';
               ($trole, $group_privs) = split(/\//, $trole);
               $group_privs = &unescape($group_privs);
           } else {
           # Just a normal role, defined in roles.tab
               ($trole, $tend, $tstart) = split(/_/,$role);
           }
   
           my %new_role = &set_arearole($trole,$area,$tstart,$tend,$domain,
                    $username);
           @userroles{keys(%new_role)} = @new_role{keys(%new_role)};
   
           # role expired or not available yet?
           $trole = '' if ($tend != 0 && $tend < $userroles{'user.login.time'}) or 
               ($tstart != 0 && $tstart > $userroles{'user.login.time'});
   
           next if $area eq '' or $trole eq '';
   
           my $spec = "$trole.$area";
           my ($tdummy, $tdomain, $trest) = split(/\//, $area);
   
           if ($trole =~ /^cr\//) {
           # Custom role, defined by a user
               &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);
           } elsif ($trole eq 'gr') {
           # Role of a member in a group, defined within a course/community
               &group_roleprivs(\%allgroups,$area,$group_privs,$tend,$tstart);
               next;
           } else {
           # Normal role, defined in roles.tab
               &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
           }
   
           my $cid = $tdomain.'_'.$trest;
           unless ($firstaccchk{$cid}) {
               if (ref($coursetimerstarts{$cid}) eq 'HASH') {
                   foreach my $item (keys(%{$coursetimerstarts{$cid}})) {
                       $firstaccenv{'course.'.$cid.'.firstaccess.'.$item} = 
                           $coursetimerstarts{$cid}{$item}; 
                   }
               }
               $firstaccchk{$cid} = 1;
           }
           unless ($timerintchk{$cid}) {
               if (ref($coursetimerintervals{$cid}) eq 'HASH') {
                   foreach my $item (keys(%{$coursetimerintervals{$cid}})) {
                       $timerintenv{'course.'.$cid.'.timerinterval.'.$item} =
                          $coursetimerintervals{$cid}{$item};
                   }
               }
               $timerintchk{$cid} = 1;
         }          }
         my ($author,$adv) = &set_userprivs(\$userroles,\%allroles,\%allgroups);  
         $userroles.='user.adv='.$adv."\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,$nolog) = @_;
       unless ($nolog) {
 # log the associated role with the area  # log the associated role with the area
     &userrolelog($trole,$username,$domain,$area,$tstart,$tend);          &userrolelog($trole,$username,$domain,$area,$tstart,$tend);
     return 'user.role.'.$trole.'.'.$area.'='.$tstart.'.'.$tend."\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 2781  sub group_roleprivs { Line 5390  sub group_roleprivs {
     if (($tend!=0) && ($tend<$now)) { $access = 0; }      if (($tend!=0) && ($tend<$now)) { $access = 0; }
     if (($tstart!=0) && ($tstart>$now)) { $access=0; }      if (($tstart!=0) && ($tstart>$now)) { $access=0; }
     if ($access) {      if ($access) {
         my ($course,$group) = ($area =~ m|(/\w+/\w+)/([^/]+)$|);          my ($course,$group) = ($area =~ m|(/$match_domain/$match_courseid)/([^/]+)$|);
         $$allgroups{$course}{$group} .=':'.$group_privs;          $$allgroups{$course}{$group} .=':'.$group_privs;
     }      }
 }  }
Line 2805  sub standard_roleprivs { Line 5414  sub standard_roleprivs {
 }  }
   
 sub set_userprivs {  sub set_userprivs {
     my ($userroles,$allroles,$allgroups) = @_;       my ($userroles,$allroles,$allgroups,$groups_roles) = @_; 
     my $author=0;      my $author=0;
     my $adv=0;      my $adv=0;
     my %grouproles = ();      my %grouproles = ();
     if (keys(%{$allgroups}) > 0) {      if (keys(%{$allgroups}) > 0) {
         foreach my $role (keys %{$allroles}) {          my @groupkeys; 
             my ($trole,$area,$sec,$extendedarea);          foreach my $role (keys(%{$allroles})) {
             if ($role =~ m|^(\w+)\.(/\w+/\w+)(/?\w*)|) {              push(@groupkeys,$role);
                 $trole = $1;          }
                 $area = $2;          if (ref($groups_roles) eq 'HASH') {
                 $sec = $3;              foreach my $key (keys(%{$groups_roles})) {
                 $extendedarea = $area.$sec;                  unless (grep(/^\Q$key\E$/,@groupkeys)) {
                 if (exists($$allgroups{$area})) {                      push(@groupkeys,$key);
                     foreach my $group (keys(%{$$allgroups{$area}})) {                  }
                         my $spec = $trole.'.'.$extendedarea;              }
                         $grouproles{$spec.'.'.$area.'/'.$group} =           }
           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};                                                  $$allgroups{$area}{$group};
                           }
                     }                      }
                 }                  }
             }              }
         }          }
     }      }
     foreach (keys(%grouproles)) {      foreach my $group (keys(%grouproles)) {
         $$allroles{$_} = $grouproles{$_};          $$allroles{$group} = $grouproles{$group};
     }      }
     foreach (keys %{$allroles}) {      foreach my $role (keys(%{$allroles})) {
         my %thesepriv=();          my %thesepriv;
         if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; }          if (($role=~/^au/) || ($role=~/^ca/) || ($role=~/^aa/)) { $author=1; }
         foreach (split(/:/,$$allroles{$_})) {          foreach my $item (split(/:/,$$allroles{$role})) {
             if ($_ ne '') {              if ($item ne '') {
                 my ($privilege,$restrictions)=split(/&/,$_);                  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 2845  sub set_userprivs { Line 5467  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) = @_;
       if (exists($env{$rolekey}) && $env{$rolekey} ne '') {
           my ($one,$two) = split(m{\./},$rolekey,2);
           (undef,undef,$$role) = split(/\./,$one,3);
           unless (!defined($$role) || $$role eq '') {
               $$where = '/'.$two;
               $$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'},1);
       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'}; }
Line 2871  sub get { Line 5656  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 2883  sub get { Line 5668  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} = &thaw_unescape($value);
       }
       return \%returnhash;
   }
   
   # see Lond::dump_with_regexp
   # if $escapedkeys hash keys won't get unescaped.
 sub dump {  sub dump {
    my ($namespace,$udomain,$uname,$regexp,$range)=@_;      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:$range",$uhome);                      $uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'});
    my @pairs=split(/\&/,$rep);          return %{&unserialize($reply, $escapedkeys)};
    my %returnhash=();      }
    foreach (@pairs) {      if ($regexp) {
       my ($key,$value)=split(/=/,$_,2);   $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);
       next if ($key =~ /^error: 2 /);
       $returnhash{$key}=&thaw_unescape($value);
    }
       }
       return %returnhash;
 }  }
   
   
 # --------------------------------------------------------- dumpstore interface  # --------------------------------------------------------- dumpstore interface
   
 sub dumpstore {  sub dumpstore {
    my ($namespace,$udomain,$uname,$regexp,$range)=@_;     my ($namespace,$udomain,$uname,$regexp,$range)=@_;
    return &dump($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
Line 2932  sub getkeys { Line 5749  sub getkeys {
    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 2945  sub currentdump { Line 5763  sub currentdump {
    $sdom     = $env{'user.domain'}       if (! defined($sdom));     $sdom     = $env{'user.domain'}       if (! defined($sdom));
    $sname    = $env{'user.name'}         if (! defined($sname));     $sname    = $env{'user.name'}         if (! defined($sname));
    my $uhome = &homeserver($sname,$sdom);     my $uhome = &homeserver($sname,$sdom);
    my $rep=reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome);     my $rep;
   
      if (grep { $_ eq $uhome } current_machine_ids()) {
          $rep = LONCAPA::Lond::dump_profile_database(join(":", ($sdom, $sname,
                      $courseid)));
      } else {
          $rep = reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome);
      }
   
    return if ($rep =~ /^(error:|no_such_host)/);     return if ($rep =~ /^(error:|no_such_host)/);
    #     #
    my %returnhash=();     my %returnhash=();
Line 2953  sub currentdump { Line 5779  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 2978  sub convert_dump_to_currentdump{ Line 5804  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 3039  sub put { Line 5867  sub put {
    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);
Line 3092  sub old_putstore { Line 5920  sub old_putstore {
     if (!$uname) { $uname=$env{'user.name'}; }      if (!$uname) { $uname=$env{'user.name'}; }
     my $uhome=&homeserver($uname,$udomain);      my $uhome=&homeserver($uname,$udomain);
     my %newstorehash;      my %newstorehash;
     foreach (keys %$storehash) {      foreach my $item (keys(%$storehash)) {
  my $key = $version.':'.&escape($symb).':'.$_;   my $key = $version.':'.&escape($symb).':'.$item;
  $newstorehash{$key} = $storehash->{$_};   $newstorehash{$key} = $storehash->{$item};
     }      }
     my $items='';      my $items='';
     my %allitems = ();      my %allitems = ();
     foreach (keys %newstorehash) {      foreach my $item (keys(%newstorehash)) {
  if ($_ =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) {   if ($item =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) {
     my $key = $1.':keys:'.$2;      my $key = $1.':keys:'.$2;
     $allitems{$key} .= $3.':';      $allitems{$key} .= $3.':';
  }   }
  $items.=$_.'='.&freeze_escape($newstorehash{$_}).'&';   $items.=$item.'='.&freeze_escape($newstorehash{$item}).'&';
     }      }
     foreach (keys %allitems) {      foreach my $item (keys(%allitems)) {
  $allitems{$_} =~ s/\:$//;   $allitems{$item} =~ s/\:$//;
  $items.= $_.'='.$allitems{$_}.'&';   $items.= $item.'='.$allitems{$item}.'&';
     }      }
     $items=~s/\&$//;      $items=~s/\&$//;
     return &reply("put:$udomain:$uname:$namespace:$items",$uhome);      return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
Line 3121  sub cput { Line 5949  sub cput {
    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 3133  sub cput { Line 5961  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'}; }
Line 3144  sub eget { Line 5972  sub eget {
    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;
Line 3153  sub eget { Line 5981  sub eget {
   
 # ------------------------------------------------------------ tmpput interface  # ------------------------------------------------------------ tmpput interface
 sub tmpput {  sub tmpput {
     my ($storehash,$server)=@_;      my ($storehash,$server,$context)=@_;
     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/\&$//;
       if (defined($context)) {
           $items .= ':'.&escape($context);
       }
     return &reply("tmpput:$items",$server);      return &reply("tmpput:$items",$server);
 }  }
   
Line 3170  sub tmpget { Line 6001  sub tmpget {
     my %returnhash;      my %returnhash;
     foreach my $item (split(/\&/,$rep)) {      foreach my $item (split(/\&/,$rep)) {
  my ($key,$value)=split(/=/,$item);   my ($key,$value)=split(/=/,$item);
           next if ($key =~ /^error: 2 /);
  $returnhash{&unescape($key)}=&thaw_unescape($value);   $returnhash{&unescape($key)}=&thaw_unescape($value);
     }      }
     return %returnhash;      return %returnhash;
 }  }
   
 # ------------------------------------------------------------ tmpget interface  # ------------------------------------------------------------ tmpdel interface
 sub tmpdel {  sub tmpdel {
     my ($token,$server)=@_;      my ($token,$server)=@_;
     if (!defined($server)) { $server = $perlvar{'lonHostID'}; }      if (!defined($server)) { $server = $perlvar{'lonHostID'}; }
     return &reply("tmpdel:$token",$server);      return &reply("tmpdel:$token",$server);
 }  }
   
 # ---------------------------------------------- Custom access rule evaluation  # ------------------------------------------------------------ get_timebased_id
   
 sub customaccess {  sub get_timebased_id {
     my ($priv,$uri)=@_;      my ($prefix,$keyid,$namespace,$cdom,$cnum,$idtype,$who,$locktries,
     my ($urole,$urealm)=split(/\./,$env{'request.role'});          $maxtries) = @_;
     $urealm=~s/^\W//;      my ($newid,$error,$dellock);
     my ($udom,$ucrs,$usec)=split(/\//,$urealm);      unless (($prefix =~ /^\w+$/) && ($keyid =~ /^\w+$/) && ($namespace ne '')) {
     my $access=0;          return ('','ok','invalid call to get suffix');
     foreach (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) {      }
  my ($effect,$realm,$role)=split(/\:/,$_);  
         if ($role) {  # set defaults for any optional args for which values were not supplied
    if ($role ne $urole) { next; }      if ($who eq '') {
         }          $who = $env{'user.name'}.':'.$env{'user.domain'};
         foreach (split(/\s*\,\s*/,$realm)) {      }
             my ($tdom,$tcrs,$tsec)=split(/\_/,$_);      if (!$locktries) {
             if ($tdom) {          $locktries = 3;
  if ($tdom ne $udom) { next; }      }
       if (!$maxtries) {
           $maxtries = 10;
       }
   
       if (($cdom eq '') || ($cnum eq '')) {
           if ($env{'request.course.id'}) {
               $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
               $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
           }
           if (($cdom eq '') || ($cnum eq '')) {
               return ('','ok','call to get suffix not in course context');
           }
       }
   
   # construct locking item
       my $lockhash = {
                         $prefix."\0".'locked_'.$keyid => $who,
                      };
       my $tries = 0;
   
   # attempt to get lock on nohist_$namespace file
       my $gotlock = &Apache::lonnet::newput('nohist_'.$namespace,$lockhash,$cdom,$cnum);
       while (($gotlock ne 'ok') && $tries <$locktries) {
           $tries ++;
           sleep 1;
           $gotlock = &Apache::lonnet::newput('nohist_'.$namespace,$lockhash,$cdom,$cnum);
       }
   
   # attempt to get unique identifier, based on current timestamp
       if ($gotlock eq 'ok') {
           my %inuse = &Apache::lonnet::dump('nohist_'.$namespace,$cdom,$cnum,$prefix);
           my $id = time;
           $newid = $id;
           my $idtries = 0;
           while (exists($inuse{$prefix."\0".$newid}) && $idtries < $maxtries) {
               if ($idtype eq 'concat') {
                   $newid = $id.$idtries;
               } else {
                   $newid ++;
             }              }
             if ($tcrs) {              $idtries ++;
  if ($tcrs ne $ucrs) { next; }          }
           if (!exists($inuse{$prefix."\0".$newid})) {
               my %new_item =  (
                                 $prefix."\0".$newid => $who,
                               );
               my $putresult = &Apache::lonnet::put('nohist_'.$namespace,\%new_item,
                                                    $cdom,$cnum);
               if ($putresult ne 'ok') {
                   undef($newid);
                   $error = 'error saving new item: '.$putresult;
             }              }
             if ($tsec) {          } else {
  if ($tsec ne $usec) { next; }               $error = ('error: no unique suffix available for the new item ');
           }
   #  remove lock
           my @del_lock = ($prefix."\0".'locked_'.$keyid);
           $dellock = &Apache::lonnet::del('nohist_'.$namespace,\@del_lock,$cdom,$cnum);
       } else {
           $error = "error: could not obtain lockfile\n";
           $dellock = 'ok';
       }
       return ($newid,$dellock,$error);
   }
   
   # -------------------------------------------------- portfolio access checking
   
   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';
             }              }
             $access=($effect eq 'allow');          } else {
             last;              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 ($end && $end<$now) {
                   next;
               }
               if ($scope eq 'public') {
                   $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,
                         textbook   => 1,
                    );
       } elsif ($context eq 'requestauthor') {
           %tools = (
                         requestauthor => 1,
                    );
       } else {
           %tools = (
                         aboutme   => 1,
                         blog      => 1,
                         webdav    => 1,
                         portfolio => 1,
                    );
       }
       return if (!defined($tools{$tool}));
   
       if (($udom eq '') || ($uname eq '')) {
           $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;
         }          }
  if ($realm eq '' && $role eq '') {          return $access;
             $access=($effect eq 'allow');      }
   
       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;
               }
           }
       }
       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 3219  sub customaccess { Line 6647  sub customaccess {
 # ------------------------------------------------- Check for a user privilege  # ------------------------------------------------- Check for a user privilege
   
 sub allowed {  sub allowed {
     my ($priv,$uri,$symb)=@_;      my ($priv,$uri,$symb,$role)=@_;
     my $ver_orguri=$uri;      my $ver_orguri=$uri;
     $uri=&deversion($uri);      $uri=&deversion($uri);
     my $orguri=$uri;      my $orguri=$uri;
     $uri=&declutter($uri);      $uri=&declutter($uri);
       
       if ($priv eq 'evb') {
   # Evade communication block restrictions for specified role in a course
           if ($env{'user.priv.'.$role} =~/evb\&([^\:]*)/) {
               return $1;
           } else {
               return;
           }
       }
   
     if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }      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';
     }      }
   
Line 3236  sub allowed { Line 6674  sub allowed {
     my ($space,$domain,$name,@dir)=split('/',$uri);      my ($space,$domain,$name,@dir)=split('/',$uri);
     if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) &&       if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) && 
  ($env{'user.domain'} eq $domain) && ('portfolio' eq $dir[0])) {   ($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 if user has rgf priv for this group and course.  # bre access to group portfolio for rgf priv in group, or mdg or vcg in course.
     if (($space=~/^(uploaded|editupload)$/) && ($dir[0] eq 'groups')       if (($space=~/^(uploaded|editupload)$/) && ($dir[0] eq 'groups') 
          && ($dir[2] eq 'portfolio') && ($priv eq 'bre')) {           && ($dir[2] eq 'portfolio') && ($priv eq 'bre')) {
         if (exists($env{'request.course.id'})) {          if (exists($env{'request.course.id'})) {
Line 3251  sub allowed { Line 6696  sub allowed {
                 if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid                  if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid
                     .'/'.$dir[1]} =~/rgf\&([^\:]*)/) {                      .'/'.$dir[1]} =~/rgf\&([^\:]*)/) {
                     return $1;                       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;
                       }
                 }                  }
             }              }
         }          }
Line 3296  sub allowed { Line 6749  sub allowed {
     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 3316  sub allowed { Line 6829  sub allowed {
   
     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;
           }
 # Group: uri itself is a group  
     my $groupuri=$uri;  
     $groupuri=~s/^([^\/])/\/$1/;  
     if ($env{'user.priv.'.$env{'request.role'}.'.'.$groupuri}  
        =~/\Q$priv\E\&([^\:]*)/) {  
        $thisallowed.=$1;  
     }      }
   
 # URI is an uploaded document for this course, default permissions don't matter  # URI is an uploaded document for this course, default permissions don't matter
Line 3335  sub allowed { Line 6842  sub allowed {
         if ($match) {          if ($match) {
             if ($env{'user.priv.'.$env{'request.role'}.'./'}              if ($env{'user.priv.'.$env{'request.role'}.'./'}
                   =~/\Q$priv\E\&([^\:]*)/) {                    =~/\Q$priv\E\&([^\:]*)/) {
                 $thisallowed.=$1;                  my @blockers = &has_comm_blocking($priv,$symb,$uri);
                   if (@blockers > 0) {
                       $thisallowed = 'B';
                   } else {
                       $thisallowed.=$1;
                   }
             }              }
         } else {          } else {
             my $refuri = $env{'httpref.'.$orguri} || $env{'httpref.'.$ver_orguri};              my $refuri = $env{'httpref.'.$orguri} || $env{'httpref.'.$ver_orguri};
Line 3346  sub allowed { Line 6858  sub allowed {
                     $refuri=&declutter($refuri);                      $refuri=&declutter($refuri);
                     my ($match) = &is_on_map($refuri);                      my ($match) = &is_on_map($refuri);
                     if ($match) {                      if ($match) {
                         $thisallowed='F';                          my @blockers = &has_comm_blocking($priv,$symb,$refuri);
                           if (@blockers > 0) {
                               $thisallowed = 'B';
                           } else {
                               $thisallowed='F';
                           }
                     }                      }
                 }                  }
             }              }
         }          }
     }      }
   
       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';
     }      }
Line 3392  sub allowed { Line 6915  sub allowed {
            $statecond=$cond;             $statecond=$cond;
            if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid}             if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid}
                =~/\Q$priv\E\&([^\:]*)/) {                 =~/\Q$priv\E\&([^\:]*)/) {
                $thisallowed.=$1;                 my $value = $1;
                  if ($priv eq 'bre') {
                      my @blockers = &has_comm_blocking($priv,$symb,$uri);
                      if (@blockers > 0) {
                          $thisallowed = 'B';
                      } else {
                          $thisallowed.=$value;
                      }
                  } else {
                      $thisallowed.=$value;
                  }
                $checkreferer=0;                 $checkreferer=0;
            }             }
        }         }
Line 3400  sub allowed { Line 6933  sub allowed {
        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 3420  sub allowed { Line 6953  sub allowed {
               my $refstatecond=$cond;                my $refstatecond=$cond;
               if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid}                if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid}
                   =~/\Q$priv\E\&([^\:]*)/) {                    =~/\Q$priv\E\&([^\:]*)/) {
                   $thisallowed.=$1;                    my $value = $1;
                     if ($priv eq 'bre') {
                         my @blockers = &has_comm_blocking($priv,$symb,$refuri);
                         if (@blockers > 0) {
                             $thisallowed = 'B';
                         } else {
                             $thisallowed.=$value;
                         }
                     } else {
                         $thisallowed.=$value;
                     }
                   $uri=$refuri;                    $uri=$refuri;
                   $statecond=$refstatecond;                    $statecond=$refstatecond;
               }                }
Line 3458  sub allowed { Line 7001  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;
Line 3503  sub allowed { Line 7046  sub allowed {
 #  #
   
     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 3518  sub allowed { Line 7067  sub allowed {
        my $unamedom=$env{'user.name'}.':'.$env{'user.domain'};         my $unamedom=$env{'user.name'}.':'.$env{'user.domain'};
        if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'}         if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'}
    =~/\Q$rolecode\E/) {     =~/\Q$rolecode\E/) {
    if ($priv ne 'pch') {      if (($priv ne 'pch') && ($priv ne 'plc')) { 
        &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.         &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
  'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.   'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
  $env{'request.course.id'});   $env{'request.course.id'});
Line 3528  sub allowed { Line 7077  sub allowed {
   
        if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'}         if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'}
    =~/\Q$unamedom\E/) {     =~/\Q$unamedom\E/) {
    if ($priv ne 'pch') {      if (($priv ne 'pch') && ($priv ne 'plc')) { 
        &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.         &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.
  'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.   'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.
  $env{'request.course.id'});   $env{'request.course.id'});
Line 3542  sub allowed { Line 7091  sub allowed {
    if ($thisallowed=~/R/) {     if ($thisallowed=~/R/) {
        my $rolecode=(split(/\./,$env{'request.role'}))[0];         my $rolecode=(split(/\./,$env{'request.role'}))[0];
        if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) {         if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) {
    if ($priv ne 'pch') {      if (($priv ne 'pch') && ($priv ne 'plc')) { 
        &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.         &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
  'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);   'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
    }     }
Line 3566  sub allowed { Line 7115  sub allowed {
       }        }
    }     }
   
       if ($thisallowed eq 'A') {
    return 'A';
       } elsif ($thisallowed eq 'B') {
           return 'B';
       }
    return 'F';     return 'F';
 }  }
   
   # ------------------------------------------- Check construction space access
   
   sub constructaccess {
       my ($url,$setpriv)=@_;
   
   # We do not allow editing of previous versions of files
       if ($url=~/\.(\d+)\.(\w+)$/) { return ''; }
   
   # Get username and domain from URL
       my ($ownername,$ownerdomain,$ownerhome);
   
       ($ownerdomain,$ownername) =
           ($url=~ m{^(?:\Q$perlvar{'lonDocRoot'}\E|)/priv/($match_domain)/($match_username)/});
   
   # The URL does not really point to any authorspace, forget it
       unless (($ownername) && ($ownerdomain)) { return ''; }
   
   # Now we need to see if the user has access to the authorspace of
   # $ownername at $ownerdomain
   
       if (($ownername eq $env{'user.name'}) && ($ownerdomain eq $env{'user.domain'})) {
   # Real author for this?
          $ownerhome = $env{'user.home'};
          if (exists($env{'user.priv.au./'.$ownerdomain.'/./'})) {
             return ($ownername,$ownerdomain,$ownerhome);
          }
       } else {
   # Co-author for this?
           if (exists($env{'user.priv.ca./'.$ownerdomain.'/'.$ownername.'./'}) ||
               exists($env{'user.priv.aa./'.$ownerdomain.'/'.$ownername.'./'}) ) {
               $ownerhome = &homeserver($ownername,$ownerdomain);
               return ($ownername,$ownerdomain,$ownerhome);
           }
       }
   
   # We don't have any access right now. If we are not possibly going to do anything about this,
   # we might as well leave
      unless ($setpriv) { return ''; }
   
   # Backdoor access?
       my $allowed=&allowed('eco',$ownerdomain);
   # Nope
       unless ($allowed) { return ''; }
   # Looks like we may have access, but could be locked by the owner of the construction space
       if ($allowed eq 'U') {
           my %blocked=&get('environment',['domcoord.author'],
                            $ownerdomain,$ownername);
   # Is blocked by owner
           if ($blocked{'domcoord.author'} eq 'blocked') { return ''; }
       }
       if (($allowed eq 'F') || ($allowed eq 'U')) {
   # Grant temporary access
           my $then=$env{'user.login.time'};
           my $update=$env{'user.update.time'};
           if (!$update) { $update = $then; }
           my $refresh=$env{'user.refresh.time'};
           if (!$refresh) { $refresh = $update; }
           my $now = time;
           &check_adhoc_privs($ownerdomain,$ownername,$update,$refresh,
                              $now,'ca','constructaccess');
           $ownerhome = &homeserver($ownername,$ownerdomain);
           return($ownername,$ownerdomain,$ownerhome);
       }
   # No business here
       return '';
   }
   
   sub get_comm_blocks {
       my ($cdom,$cnum) = @_;
       if ($cdom eq '' || $cnum eq '') {
           return unless ($env{'request.course.id'});
           $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
           $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
       }
       my %commblocks;
       my $hashid=$cdom.'_'.$cnum;
       my ($blocksref,$cached)=&is_cached_new('comm_block',$hashid);
       if ((defined($cached)) && (ref($blocksref) eq 'HASH')) {
           %commblocks = %{$blocksref};
       } else {
           %commblocks = &Apache::lonnet::dump('comm_block',$cdom,$cnum);
           my $cachetime = 600;
           &do_cache_new('comm_block',$hashid,\%commblocks,$cachetime);
       }
       return %commblocks;
   }
   
   sub has_comm_blocking {
       my ($priv,$symb,$uri,$blocks) = @_;
       return unless ($env{'request.course.id'});
       return unless ($priv eq 'bre');
       return if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/);
       my %commblocks;
       if (ref($blocks) eq 'HASH') {
           %commblocks = %{$blocks};
       } else {
           %commblocks = &get_comm_blocks();
       }
       return unless (keys(%commblocks) > 0);
       if (!$symb) { $symb=&symbread($uri,1); }
       my ($map,$resid,undef)=&decode_symb($symb);
       my %tocheck = (
                       maps      => $map,
                       resources => $symb,
                     );
       my @blockers;
       my $now = time;
       my $navmap = Apache::lonnavmaps::navmap->new();
       foreach my $block (keys(%commblocks)) {
           if ($block =~ /^(\d+)____(\d+)$/) {
               my ($start,$end) = ($1,$2);
               if ($start <= $now && $end >= $now) {
                   if (ref($commblocks{$block}{'blocks'}) eq 'HASH') {
                       if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') {
                           if (ref($commblocks{$block}{'blocks'}{'docs'}{'maps'}) eq 'HASH') {
                               if ($commblocks{$block}{'blocks'}{'docs'}{'maps'}{$map}) {
                                   unless (grep(/^\Q$block\E$/,@blockers)) {
                                       push(@blockers,$block);
                                   }
                               }
                           }
                           if (ref($commblocks{$block}{'blocks'}{'docs'}{'resources'}) eq 'HASH') {
                               if ($commblocks{$block}{'blocks'}{'docs'}{'resources'}{$symb}) {
                                   unless (grep(/^\Q$block\E$/,@blockers)) {  
                                       push(@blockers,$block);
                                   }
                               }
                           }
                       }
                   }
               }
           } elsif ($block =~ /^firstaccess____(.+)$/) {
               my $item = $1;
               my @to_test;
               if (ref($commblocks{$block}{'blocks'}) eq 'HASH') {
                   if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') {
                       my $check_interval;
                       if (&check_docs_block($commblocks{$block}{'blocks'}{'docs'},\%tocheck)) {
                           my @interval;
                           my $type = 'map';
                           if ($item eq 'course') {
                               $type = 'course';
                               @interval=&EXT("resource.0.interval");
                           } else {
                               if ($item =~ /___\d+___/) {
                                   $type = 'resource';
                                   @interval=&EXT("resource.0.interval",$item);
                                   if (ref($navmap)) {                        
                                       my $res = $navmap->getBySymb($item); 
                                       push(@to_test,$res);
                                   }
                               } else {
                                   my $mapsymb = &symbread($item,1);
                                   if ($mapsymb) {
                                       if (ref($navmap)) {
                                           my $mapres = $navmap->getBySymb($mapsymb);
                                           @to_test = $mapres->retrieveResources($mapres,undef,0,1);
                                           foreach my $res (@to_test) {
                                               my $symb = $res->symb();
                                               next if ($symb eq $mapsymb);
                                               if ($symb ne '') {
                                                   @interval=&EXT("resource.0.interval",$symb);
                                                   last;
                                               }
                                           }
                                       }
                                   }
                               }
                           }
                           if ($interval[0] =~ /\d+/) {
                               my $first_access;
                               if ($type eq 'resource') {
                                   $first_access=&get_first_access($interval[1],$item);
                               } elsif ($type eq 'map') {
                                   $first_access=&get_first_access($interval[1],undef,$item);
                               } else {
                                   $first_access=&get_first_access($interval[1]);
                               }
                               if ($first_access) {
                                   my $timesup = $first_access+$interval[0];
                                   if ($timesup > $now) {
                                       foreach my $res (@to_test) {
                                           if ($res->is_problem()) {
                                               if ($res->completable()) {
                                                   unless (grep(/^\Q$block\E$/,@blockers)) {
                                                       push(@blockers,$block);
                                                   }
                                                   last;
                                               }
                                           }
                                       }
                                   }
                               }
                           }
                       }
                   }
               }
           }
       }
       return @blockers;
   }
   
   sub check_docs_block {
       my ($docsblock,$tocheck) =@_;
       if ((ref($docsblock) ne 'HASH') || (ref($tocheck) ne 'HASH')) {
           return;
       }
       if (ref($docsblock->{'maps'}) eq 'HASH') {
           if ($tocheck->{'maps'}) {
               if ($docsblock->{'maps'}{$tocheck->{'maps'}}) {
                   return 1;
               }
           }
       }
       if (ref($docsblock->{'resources'}) eq 'HASH') {
           if ($tocheck->{'resources'}) {
               if ($docsblock->{'resources'}{$tocheck->{'resources'}}) {
                   return 1;
               }
           }
       }
       return;
   }
   
   #
   #   Removes the versino from a URI and
   #   splits it in to its filename and path to the filename.
   #   Seems like File::Basename could have done this more clearly.
   #   Parameters:
   #      $uri   - input URI
   #   Returns:
   #     Two element list consisting of 
   #     $pathname  - the URI up to and excluding the trailing /
   #     $filename  - The part of the URI following the last /
   #  NOTE:
   #    Another realization of this is simply:
   #    use File::Basename;
   #    ...
   #    $uri = shift;
   #    $filename = basename($uri);
   #    $path     = dirname($uri);
   #    return ($filename, $path);
   #
   #     The implementation below is probably faster however.
   #
 sub split_uri_for_cond {  sub split_uri_for_cond {
     my $uri=&deversion(&declutter(shift));      my $uri=&deversion(&declutter(shift));
     my @uriparts=split(/\//,$uri);      my @uriparts=split(/\//,$uri);
Line 3618  sub get_symb_from_alias { Line 7417  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 3627  sub definerole { Line 7426  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 3636  sub definerole { Line 7435  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 3658  sub definerole { Line 7457  sub definerole {
 # ---------------- Make a metadata query against the network of library servers  # ---------------- Make a metadata query against the network of library servers
   
 sub metadata_query {  sub metadata_query {
     my ($query,$custom,$customshow,$server_array)=@_;      my ($query,$custom,$customshow,$server_array,$domains_hash)=@_;
     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) {
           my $domains = '';
           if (ref($domains_hash) eq 'HASH') {
               $domains = $domains_hash->{$server};    
           }
  unless ($custom or $customshow) {   unless ($custom or $customshow) {
     my $reply=&reply("querysend:".&escape($query),$server);      my $reply=&reply("querysend:".&escape($query).':::'.&escape($domains),$server);
     $rhash{$server}=$reply;      $rhash{$server}=$reply;
  }   }
  else {   else {
     my $reply=&reply("querysend:".&escape($query).':'.      my $reply=&reply("querysend:".&escape($query).':'.
      &escape($custom).':'.&escape($customshow),       &escape($custom).':'.&escape($customshow).':'.&escape($domains),
      $server);       $server);
     $rhash{$server}=$reply;      $rhash{$server}=$reply;
  }   }
Line 3683  sub log_query { Line 7487  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 3703  sub fetch_enrollment_query { Line 7538  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);
Line 3725  sub fetch_enrollment_query { Line 7560  sub fetch_enrollment_query {
     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 3762  sub fetch_enrollment_query { Line 7597  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 3800  sub courselog_query { Line 7635  sub courselog_query {
 }  }
   
 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 3808  sub userlog_query { Line 7649  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,$defaultcredits) = map { &unescape($_); } split('&',$response,3);
       return ($outcome,$description,$defaultcredits);
   }
   
 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);
 }  }
Line 3894  sub auto_photochoice { Line 7791  sub auto_photochoice {
 sub auto_photoupdate {  sub auto_photoupdate {
     my ($affiliatesref,$dom,$cnum,$photo) = @_;      my ($affiliatesref,$dom,$cnum,$photo) = @_;
     my $homeserver = &homeserver($cnum,$dom);      my $homeserver = &homeserver($cnum,$dom);
     my $host=$hostname{$homeserver};      my $host=&hostname($homeserver);
     my $cmd = '';      my $cmd = '';
     my $maxtries = 1;      my $maxtries = 1;
     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);
Line 3929  sub auto_photoupdate { Line 7826  sub auto_photoupdate {
 }  }
   
 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') {
         foreach my $tryserver (keys %libserv) {   my %servers = &get_servers($codedom,'library');
             if ($hostdom{$tryserver} eq $codedom) {   foreach my $tryserver (keys(%servers)) {
                 $homeserver = $tryserver;      if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
                 last;   push(@homeservers,$tryserver);
             }      }
         }          }
         if (($env{'user.name'}) && ($env{'user.domain'} eq $codedom)) {      } elsif ($caller eq 'requests') {
             $homeserver = &homeserver($env{'user.name'},$codedom);          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));
     }      }
     foreach (keys %{$instcodes}) {      foreach my $code (keys(%{$instcodes})) {
         $courses .= &escape($_).'='.&escape($$instcodes{$_}).'&';          $courses .= &escape($code).'='.&escape($$instcodes{$code}).'&';
     }      }
     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';
       } 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 'ok';
     }      }
     return $response;      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,$custominfo) = @_;
       my ($homeserver,$response);
       if ($dom =~ /^$match_domain$/) {
           $homeserver = &domain($dom,'primary');
       }
       unless ($homeserver eq 'no_host') {
           my $customdata;
           if (ref($custominfo) eq 'HASH') {
               $customdata = &freeze_escape($custominfo);
           }
           $response=&unescape(&reply('autocrsreqvalidation:'.$dom.':'.&escape($owner).
                                       ':'.&escape($crstype).':'.&escape($inststatuslist).
                                       ':'.&escape($instcode).':'.&escape($instseclist).':'.
                                       $customdata,$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;
   }
   
   sub auto_crsreq_update {
       my ($cdom,$cnum,$crstype,$action,$ownername,$ownerdomain,$fullname,$title,
           $code,$accessstart,$accessend,$inbound) = @_;
       my ($homeserver,%crsreqresponse);
       if ($cdom =~ /^$match_domain$/) {
           $homeserver = &domain($cdom,'primary');
       }
       unless (($homeserver eq 'no_host') || ($homeserver eq '')) {
           my $info;
           if (ref($inbound) eq 'HASH') {
               $info = &freeze_escape($inbound);
           }
           my $response=&reply('autocrsrequpdate:'.$cdom.':'.$cnum.':'.&escape($crstype).
                               ':'.&escape($action).':'.&escape($ownername).':'.
                               &escape($ownerdomain).':'.&escape($fullname).':'.
                               &escape($title).':'.&escape($code).':'.
                               &escape($accessstart).':'.&escape($accessend).':'.$info,$homeserver);
           unless ($response =~ /(con_lost|error|no_such_host|refused)/) {
               my @items = split(/&/,$response);
               foreach my $item (@items) {
                   my ($key,$value) = split('=',$item);
                   $crsreqresponse{&unescape($key)} = &thaw_unescape($value);
               }
           }
       }
       return \%crsreqresponse;
   }
   
 # ------------------------------------------------------- Course Group routines  # ------------------------------------------------------- Course Group routines
   
 sub get_coursegroups {  sub get_coursegroups {
     my ($cdom,$cnum,$group) = @_;      my ($cdom,$cnum,$group,$namespace) = @_;
     return(&dump('coursegroups',$cdom,$cnum,$group));      return(&dump($namespace,$cdom,$cnum,$group));
 }  }
   
 sub modify_coursegroup {  sub modify_coursegroup {
Line 3973  sub modify_coursegroup { Line 8034  sub modify_coursegroup {
     return(&put('coursegroups',$groupsettings,$cdom,$cnum));      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 {  sub modify_group_roles {
     my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs) = @_;      my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs,$selfenroll,$context) = @_;
     my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id;      my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id;
     my $role = 'gr/'.&escape($userprivs);      my $role = 'gr/'.&escape($userprivs);
     my ($uname,$udom) = split(/:/,$user);      my ($uname,$udom) = split(/:/,$user);
     my $result = &assignrole($udom,$uname,$url,$role,$end,$start);      my $result = &assignrole($udom,$uname,$url,$role,$end,$start,'',$selfenroll,$context);
     if ($result eq 'ok') {      if ($result eq 'ok') {
         &devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);          &devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);
     }      }
   
     return $result;      return $result;
 }  }
   
Line 3997  sub get_active_groups { Line 8088  sub get_active_groups {
     my $now = time;      my $now = time;
     my %groups = ();      my %groups = ();
     foreach my $key (keys(%env)) {      foreach my $key (keys(%env)) {
         if ($key =~ m-user\.role\.gr\./([^/]+)/([^/]+)/(\w+)$-) {          if ($key =~ m-user\.role\.gr\./($match_domain)/($match_courseid)/(\w+)$-) {
             my ($start,$end) = split(/\./,$env{$key});              my ($start,$end) = split(/\./,$env{$key});
             if (($end!=0) && ($end<$now)) { next; }              if (($end!=0) && ($end<$now)) { next; }
             if (($start!=0) && ($start>$now)) { next; }              if (($start!=0) && ($start>$now)) { next; }
Line 4016  sub get_group_membership { Line 8107  sub get_group_membership {
   
 sub get_users_groups {  sub get_users_groups {
     my ($udom,$uname,$courseid) = @_;      my ($udom,$uname,$courseid) = @_;
       my @usersgroups;
     my $cachetime=1800;      my $cachetime=1800;
     $courseid=~s/\_/\//g;  
     $courseid=~s/^(\w)/\/$1/;  
   
     my $hashid="$udom:$uname:$courseid";      my $hashid="$udom:$uname:$courseid";
     my ($result,$cached)=&is_cached_new('getgroups',$hashid);      my ($grouplist,$cached)=&is_cached_new('getgroups',$hashid);
     if (defined($cached)) { return $result; }      if (defined($cached)) {
           @usersgroups = split(/:/,$grouplist);
     my %roleshash = &dump('roles',$udom,$uname,$courseid);      } else {  
     my ($tmp) = keys(%roleshash);          $grouplist = '';
     if ($tmp=~/^error:/) {          my $courseurl = &courseid_to_courseurl($courseid);
         &logthis('Error retrieving roles: '.$tmp.' for '.$uname.':'.$udom);          my %roleshash = &dump('roles',$udom,$uname,$courseurl);
         return '';          my $access_end = $env{'course.'.$courseid.
     } else {                                '.default_enrollment_end_date'};
         my $grouplist;          my $now = time;
         foreach my $key (keys %roleshash) {          foreach my $key (keys(%roleshash)) {
             if ($key =~ /^\Q$courseid\E\/(\w+)\_gr$/) {              if ($key =~ /^\Q$courseurl\E\/(\w+)\_gr$/) {
                 unless ($roleshash{$key} =~ /_\d+_\-1$/) {   # deleted membership                  my $group = $1;
                     $grouplist .= $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);
                 }                  }
             }              }
         }          }
         $grouplist =~ s/:$//;          @usersgroups = &sort_course_groups($courseid,@usersgroups);
         return &do_cache_new('getgroups',$hashid,$grouplist,$cachetime);          $grouplist = join(':',@usersgroups);
           &do_cache_new('getgroups',$hashid,$grouplist,$cachetime);
     }      }
       return @usersgroups;
 }  }
   
 sub devalidate_getgroups_cache {  sub devalidate_getgroups_cache {
     my ($udom,$uname,$cdom,$cnum)=@_;      my ($udom,$uname,$cdom,$cnum)=@_;
     my $courseid = $cdom.'_'.$cnum;      my $courseid = $cdom.'_'.$cnum;
     $courseid=~s/\_/\//g;  
     $courseid=~s/^(\w)/\/$1/;  
     my $hashid="$udom:$uname:$courseid";      my $hashid="$udom:$uname:$courseid";
     &devalidate_cache_new('getgroups',$hashid);      &devalidate_cache_new('getgroups',$hashid);
 }  }
Line 4055  sub devalidate_getgroups_cache { Line 8159  sub devalidate_getgroups_cache {
 # ------------------------------------------------------------------ Plain Text  # ------------------------------------------------------------------ Plain Text
   
 sub plaintext {  sub plaintext {
     my $short=shift;      my ($short,$type,$cid,$forcedefault) = @_;
     return &Apache::lonlocal::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\//) {      } elsif ($role =~ /^gr\//) {
         my $cwogrp=$url;          my $cwogrp=$url;
         $cwogrp=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;          $cwogrp=~s{^/($match_domain)/($match_courseid)/.*}{$1/$2};
         unless (&allowed('mdg',$cwogrp)) {          unless (&allowed('mdg',$cwogrp)) {
             &logthis('Refused group assignrole: '.              &logthis('Refused group assignrole: '.
               $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.                $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
Line 4086  sub assignrole { Line 8238  sub assignrole {
         $mrole='gr';          $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;
     }      }
Line 4105  sub assignrole { Line 8352  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))) {
Line 4115  sub assignrole { Line 8365  sub assignrole {
 # 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
Line 4122  sub assignrole { Line 8373  sub assignrole {
 # log new user role if status is ok  # log new user role if status is ok
     if ($answer eq 'ok') {      if ($answer eq 'ok') {
  &userrolelog($role,$uname,$udom,$url,$start,$end);   &userrolelog($role,$uname,$udom,$url,$start,$end);
           if (($role eq 'cc') || ($role eq 'in') ||
               ($role eq 'ep') || ($role eq 'ad') ||
               ($role eq 'ta') || ($role eq 'st') ||
               ($role=~/^cr/) || ($role eq 'gr') ||
               ($role eq 'co')) {
   # for course roles, perform group memberships changes triggered by role change.
               unless ($role =~ /^gr/) {
                   &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend,
                                                    $origstart,$selfenroll,$context);
               }
               &courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
                              $selfenroll,$context);
           } elsif (($role eq 'li') || ($role eq 'dg') || ($role eq 'sc') ||
                    ($role eq 'au') || ($role eq 'dc')) {
               &domainrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
                              $context);
           } elsif (($role eq 'ca') || ($role eq 'aa')) {
               &coauthorrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
                                $context);
           }
           if ($role eq 'cc') {
               &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 4158  sub modifyuser { Line 8516  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 4220  sub modifyuser { Line 8586  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) {      if ($email) {
        $email=~s/[^\w\@\.\-\,]//gs;         $email=~s/[^\w\@\.\-\,]//gs;
        if ($email=~/\@/) { $names{'notification'} = $email;         if ($email=~/\@/) { $names{'permanentemail'} = $email; }
    $names{'critnotification'} = $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') { 
           return 'error: '.$reply;
       }
       if ($names{'permanentemail'} ne $oldnames{'permanentemail'}) {
           &Apache::lonnet::devalidate_cache_new('emailscache',$uname.':'.$udom);
       }
       my $sqlresult = &update_allusers_table($uname,$udom,\%names);
     &devalidate_cache_new('namescache',$uname.':'.$udom);      &devalidate_cache_new('namescache',$uname.':'.$udom);
     &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.      $logmsg = 'Success modifying user '.$logmsg;
              $umode.', '.$first.', '.$middle.', '.      &logthis($logmsg);
      $last.', '.$gene.' by '.  
              $env{'user.name'}.' at '.$env{'user.domain'});  
     return 'ok';      return 'ok';
 }  }
   
Line 4256  sub modifyuser { Line 8690  sub modifyuser {
   
 sub modifystudent {  sub modifystudent {
     my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,      my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
         $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid)=@_;          $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid,
           $selfenroll,$context,$inststatus,$credits)=@_;
     if (!$cid) {      if (!$cid) {
  unless ($cid=$env{'request.course.id'}) {   unless ($cid=$env{'request.course.id'}) {
     return 'not_in_class';      return 'not_in_class';
Line 4265  sub modifystudent { Line 8700  sub modifystudent {
 # --------------------------------------------------------------- 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      # student's 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,$credits);
     return $reply;      return $reply;
 }  }
   
 sub modify_student_enrollment {  sub modify_student_enrollment {
     my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid) = @_;      my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,
           $locktype,$cid,$selfenroll,$context,$credits) = @_;
     my ($cdom,$cnum,$chome);      my ($cdom,$cnum,$chome);
     if (!$cid) {      if (!$cid) {
  unless ($cid=$env{'request.course.id'}) {   unless ($cid=$env{'request.course.id'}) {
Line 4309  sub modify_student_enrollment { Line 8746  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 4319  sub modify_student_enrollment { Line 8756  sub modify_student_enrollment {
         $uid    = $tmp{'id'}         if (!defined($uid)    || $uid  eq '');          $uid    = $tmp{'id'}         if (!defined($uid)    || $uid  eq '');
     }      }
     my $fullname = &format_name($first,$middle,$last,$gene,'lastname');      my $fullname = &format_name($first,$middle,$last,$gene,'lastname');
       my $user = "$uname:$udom";
       my %old_entry = &Apache::lonnet::get('classlist',[$user],$cdom,$cnum);
     my $reply=cput('classlist',      my $reply=cput('classlist',
    {"$uname:$udom" =>      {$user => 
  join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) },   join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype,$credits) },
    $cdom,$cnum);     $cdom,$cnum);
     unless (($reply eq 'ok') || ($reply eq 'delayed')) {      if (($reply eq 'ok') || ($reply eq 'delayed')) {
           &devalidate_getsection_cache($udom,$uname,$cid);
       } else { 
  return 'error: '.$reply;   return 'error: '.$reply;
     } else {  
  &devalidate_getsection_cache($udom,$uname,$cid);  
     }      }
     # Add student role to user      # Add student role to user
     my $uurl='/'.$cid;      my $uurl='/'.$cid;
Line 4334  sub modify_student_enrollment { Line 8773  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 4368  sub writecoursepref { Line 8816  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 4378  sub writecoursepref { Line 8826  sub writecoursepref {
 # ---------------------------------------------------------- Make/modify course  # ---------------------------------------------------------- Make/modify course
   
 sub createcourse {  sub createcourse {
     my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,$course_owner)=@_;      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=int(1+rand(9)).      my $uname;
        ('a'..'z','A'..'Z','0'..'9')[int(rand(62))].      if ($cnum =~ /^$match_courseid$/) {
        substr($$.time,0,5).unpack("H8",pack("I32",time)).          my $chome=&homeserver($cnum,$udom,'true');
        unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};          if (($chome eq '') || ($chome eq 'no_host')) {
 # ----------------------------------------------- Make sure that does not exist              $uname = $cnum;
    my $uhome=&homeserver($uname,$udom,'true');          } else {
    unless (($uhome eq '') || ($uhome eq 'no_host')) {              $uname = &generate_coursenum($udom,$crstype);
        $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).          }
         unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};      } else {
        $uhome=&homeserver($uname,$udom,'true');                 $uname = &generate_coursenum($udom,$crstype);
        unless (($uhome eq '') || ($uhome eq 'no_host')) {      }
            return 'error: unable to generate unique course-ID';      return $uname if ($uname =~ /^error/);
        }   # -------------------------------------------------- Check supplied server name
    }      if (!defined($course_server)) {
 # ------------------------------------------------ Check supplied server name          if (defined(&domain($udom,'primary'))) {
     $course_server = $env{'user.homeserver'} if (! defined($course_server));              $course_server = &domain($udom,'primary');
     if (! exists($libserv{$course_server})) {          } else {
         return 'error:bad server name '.$course_server;              $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).':'.&escape($course_owner),$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) {
Line 4438  ENDINITMAP Line 8935  ENDINITMAP
     }      }
 # ----------------------------------------------------------- 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/\&$//;
                   unless ($namespace eq 'courserequests') {
                       $datakey = &escape($datakey);
                   }
                   $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 = &get('file_permissions',\@check,      my %locked = &get('file_permissions',\@check,
       $env{'user.domain'},$env{'user.name'});        $env{'user.domain'},$env{'user.name'});
     my ($tmp)=keys(%locked);      my ($tmp)=keys(%locked);
     if ($tmp=~/^error:/) { undef(%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
Line 4501  sub mark_as_readonly { Line 9112  sub mark_as_readonly {
     my ($tmp)=keys(%current_permissions);      my ($tmp)=keys(%current_permissions);
     if ($tmp=~/^error:/) { undef(%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);
     }      }
     &put('file_permissions',\%current_permissions,$domain,$user);      &put('file_permissions',\%current_permissions,$domain,$user);
Line 4513  sub save_selected_files { Line 9125  sub save_selected_files {
     my ($user, $path, @files) = @_;      my ($user, $path, @files) = @_;
     my $filename = $user."savedfiles";      my $filename = $user."savedfiles";
     my @other_files = &files_not_in_path($user, $path);      my @other_files = &files_not_in_path($user, $path);
     open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);      open (OUT, '>'.$tmpdir.$filename);
     foreach my $file (@files) {      foreach my $file (@files) {
         print (OUT $env{'form.currentpath'}.$file."\n");          print (OUT $env{'form.currentpath'}.$file."\n");
     }      }
Line 4527  sub save_selected_files { Line 9139  sub save_selected_files {
 sub clear_selected_files {  sub clear_selected_files {
     my ($user) = @_;      my ($user) = @_;
     my $filename = $user."savedfiles";      my $filename = $user."savedfiles";
     open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);      open (OUT, '>'.LONCAPA::tempdir().$filename);
     print (OUT undef);      print (OUT undef);
     close (OUT);      close (OUT);
     return ("ok");          return ("ok");    
Line 4537  sub files_in_path { Line 9149  sub files_in_path {
     my ($user, $path) = @_;      my ($user, $path) = @_;
     my $filename = $user."savedfiles";      my $filename = $user."savedfiles";
     my %return_files;      my %return_files;
     open (IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);      open (IN, '<'.LONCAPA::tempdir().$filename);
     while (my $line_in = <IN>) {      while (my $line_in = <IN>) {
         chomp ($line_in);          chomp ($line_in);
         my @paths_and_file = split (m!/!, $line_in);          my @paths_and_file = split (m!/!, $line_in);
Line 4559  sub files_not_in_path { Line 9171  sub files_not_in_path {
     my $filename = $user."savedfiles";      my $filename = $user."savedfiles";
     my @return_files;      my @return_files;
     my $path_part;      my $path_part;
     open (IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);      open(IN, '<'.LONCAPA::.$filename);
     while (<IN>) {      while (my $line = <IN>) {
         #ok, I know it's clunky, but I want it to work          #ok, I know it's clunky, but I want it to work
         my @paths_and_file = split m!/!, $_;          my @paths_and_file = split(m|/|, $line);
         my $file_part = pop (@paths_and_file);          my $file_part = pop(@paths_and_file);
         chomp ($file_part);          chomp($file_part);
         my $path_part = join ('/', @paths_and_file);          my $path_part = join('/', @paths_and_file);
         $path_part .= '/';          $path_part .= '/';
         my $path_and_file = $path_part.$file_part;          my $path_and_file = $path_part.$file_part;
         if ($path_part ne $path) {          if ($path_part ne $path) {
             push (@return_files, ($path_and_file));              push(@return_files, ($path_and_file));
         }          }
     }      }
     close (OUT);      close(OUT);
     return (@return_files);      return (@return_files);
 }  }
   
 #--------------------------------------------------------------Get Marked as Read Only  #----------------------------------------------Get portfolio file permissions
   
   sub get_portfile_permissions {
 sub get_marked_as_readonly {      my ($domain,$user) = @_;
     my ($domain,$user,$what) = @_;  
     my %current_permissions = &dump('file_permissions',$domain,$user);      my %current_permissions = &dump('file_permissions',$domain,$user);
     my ($tmp)=keys(%current_permissions);      my ($tmp)=keys(%current_permissions);
     if ($tmp=~/^error:/) { undef(%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 {
       my ($domain,$user,$what,$group) = @_;
       my $current_permissions = &get_portfile_permissions($domain,$user);
     my @readonly_files;      my @readonly_files;
     my $cmp1=$what;      my $cmp1=$what;
     if (ref($what)) { $cmp1=join('',@{$what}) };      if (ref($what)) { $cmp1=join('',@{$what}) };
     while (my ($file_name,$value) = each(%current_permissions)) {      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}) {
                 my $cmp2=$stored_what;                  my $cmp2=$stored_what;
                 if (ref($stored_what)) { $cmp2=join('',@{$stored_what}) };                  if (ref($stored_what) eq 'ARRAY') {
                       $cmp2=join('',@{$stored_what});
                   }
                 if ($cmp1 eq $cmp2) {                  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  #-----------------------------------------------------------Get Marked as Read Only Hash
   
 sub get_marked_as_readonly_hash {  sub get_marked_as_readonly_hash {
     my ($domain,$user,$what) = @_;      my ($current_permissions,$group,$what) = @_;
     my %current_permissions = &dump('file_permissions',$domain,$user);  
     my ($tmp)=keys(%current_permissions);  
     if ($tmp=~/^error:/) { undef(%current_permissions); }  
   
     my %readonly_files;      my %readonly_files;
     while (my ($file_name,$value) = each(%current_permissions)) {      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) {                  if (ref($stored_what) eq 'ARRAY') {
                     $readonly_files{$file_name} = 'locked';                      foreach my $lock_descriptor(@{$stored_what}) {
                 } elsif (!defined($what)) {                          if ($lock_descriptor eq 'graded') {
                     $readonly_files{$file_name} = 'locked';                              $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';
                               }
                           }
                       }
                   } 
             }              }
         }           } 
     }      }
Line 4629  sub get_marked_as_readonly_hash { Line 9446  sub get_marked_as_readonly_hash {
 sub unmark_as_readonly {  sub unmark_as_readonly {
     # unmarks $file_name (if $file_name is defined), or all files locked by $what       # unmarks $file_name (if $file_name is defined), or all files locked by $what 
     # for portfolio submissions, $what contains [$symb,$crsid]       # for portfolio submissions, $what contains [$symb,$crsid] 
     my ($domain,$user,$what,$file_name) = @_;      my ($domain,$user,$what,$file_name,$group) = @_;
       $file_name = &declutter_portfile($file_name);
     my $symb_crs = $what;      my $symb_crs = $what;
     if (ref($what)) { $symb_crs=join('',@$what); }      if (ref($what)) { $symb_crs=join('',@$what); }
     my %current_permissions = &dump('file_permissions',$domain,$user);      my %current_permissions = &dump('file_permissions',$domain,$user,$group);
     my ($tmp)=keys(%current_permissions);      my ($tmp)=keys(%current_permissions);
     if ($tmp=~/^error:/) { undef(%current_permissions); }      if ($tmp=~/^error:/) { undef(%current_permissions); }
     my @readonly_files = &get_marked_as_readonly($domain,$user,$what);      my @readonly_files = &get_marked_as_readonly($domain,$user,$what,$group);
     foreach my $file (@readonly_files) {      foreach my $file (@readonly_files) {
  if (defined($file_name) && ($file_name ne $file)) { next; }   my $clean_file = &declutter_portfile($file);
    if (defined($file_name) && ($file_name ne $clean_file)) { next; }
  my $current_locks = $current_permissions{$file};   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}) {
                 my $compare=$locker;                  my $compare=$locker;
                 if (ref($locker)) { $compare=join('',@{$locker}) };                  if (ref($locker) eq 'ARRAY') {
                 if ($compare ne $symb_crs) {                      $compare=join('',@{$locker});
                     push(@new_locks, $locker);                      if ($compare ne $symb_crs) {
                           push(@new_locks, $locker);
                       }
                 }                  }
             }              }
             if (scalar(@new_locks) > 0) {              if (scalar(@new_locks) > 0) {
Line 4665  sub unmark_as_readonly { Line 9486  sub unmark_as_readonly {
 # ------------------------------------------------------------ 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('ls2:'.$dirRoot.'/'.$uri,              my $uhome = &homeserver($uname,$udom);
                               homeserver($uname,$udom));              if ($uhome eq 'no_host') {
             my @listing_results;                  return ([],'no_host');
               }
               $listing = &reply('ls3:'.&escape('/'.$uri).':'.$getpropath.':'
                                 .$getuserdir.':'.&escape($dirRoot)
                                 .':'.&escape($uname).':'.&escape($udom),$uhome);
               if ($listing eq 'unknown_cmd') {
                   $listing = &reply('ls2:'.$dirRoot.'/'.$uri,$uhome);
               } else {
                   @listing_results = map { &unescape($_); } split(/:/,$listing);
               }
             if ($listing eq 'unknown_cmd') {              if ($listing eq 'unknown_cmd') {
                 $listing=reply('ls:'.$dirRoot.'/'.$uri,                  $listing = &reply('ls:'.$dirRoot.'/'.$uri,$uhome);
                                homeserver($uname,$udom));  
                 @listing_results = split(/:/,$listing);                  @listing_results = split(/:/,$listing);
             } else {              } else {
                 @listing_results = map { &unescape($_); } split(/:/,$listing);                  @listing_results = map { &unescape($_); } split(/:/,$listing);
             }              }
             return @listing_results;              if (($listing eq 'no_such_host') || ($listing eq 'con_lost') || 
         } elsif(!defined($alternateDirectoryRoot)) {                  ($listing eq 'rejected') || ($listing eq 'refused') ||
             my $tryserver;                  ($listing eq 'no_such_dir') || ($listing eq 'empty')) {
             my %allusers=();                  return ([],$listing);
             foreach $tryserver (keys %libserv) {              } else {
                 if($hostdom{$tryserver} eq $udom) {                  return (\@listing_results);
                     my $listing=reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'.              }
                                       $udom, $tryserver);          } elsif(!$alternateRoot) {
                     my @listing_results;              my (%allusers,%listerror);
                     if ($listing eq 'unknown_cmd') {      my %servers = &get_servers($udom,'library');
                         $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.       foreach my $tryserver (keys(%servers)) {
                                        $udom, $tryserver);                  $listing = &reply('ls3:'.&escape("/res/$udom").':::::'.
                         @listing_results = split(/:/,$listing);                                    &escape($udom),$tryserver);
                     } else {                  if ($listing eq 'unknown_cmd') {
                         @listing_results =      $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'.
                             map { &unescape($_); } split(/:/,$listing);        $udom, $tryserver);
                     }                  } else {
                     if ($listing_results[0] ne 'no_such_dir' &&                       @listing_results = map { &unescape($_); } split(/:/,$listing);
                         $listing_results[0] ne 'empty'       &&  
                         $listing_results[0] ne 'con_lost') {  
                         foreach (@listing_results) {  
                             my ($entry,@stat)=split(/&/,$_);  
                             $allusers{$entry}=1;  
                         }  
                     }  
                 }                  }
    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 $alluserstr='';              my @alluserslist=();
             foreach (sort keys %allusers) {              foreach my $user (sort(keys(%allusers))) {
                 $alluserstr.=$_.'&user:';                  push(@alluserslist,$user.'&user');
             }              }
             $alluserstr=~s/:$//;              return (\@alluserslist);
             return split(/:/,$alluserstr);  
         } else {          } else {
             my @emptyResults = ();              return ([],'missing username');
             push(@emptyResults, 'missing user name');  
             return split(':',@emptyResults);  
         }  
     } elsif(!defined($alternateDirectoryRoot)) {  
         my $tryserver;  
         my %alldom=();  
         foreach $tryserver (keys %libserv) {  
             $alldom{$hostdom{$tryserver}}=1;  
         }          }
         my $alldomstr='';      } elsif(!defined($getpropath)) {
         foreach (sort keys %alldom) {          my $path = $perlvar{'lonDocRoot'}.'/res/'; 
             $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'/&domain:';          my @all_domains = map { $path.$_.'/&domain'; } (sort(&all_domains()));
         }          return (\@all_domains);
         $alldomstr=~s/:$//;  
         return split(/:/,$alldomstr);         
     } else {      } else {
         my @emptyResults = ();          return ([],'missing domain');
         push(@emptyResults, 'missing domain');  
         return split(':',@emptyResults);  
     }      }
 }  }
   
Line 4758  sub dirlist { Line 9597  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 4786  sub GetFileTimestamp { Line 9617  sub GetFileTimestamp {
   
 sub stat_file {  sub stat_file {
     my ($uri) = @_;      my ($uri) = @_;
     $uri = &clutter($uri);      $uri = &clutter_with_no_wrapper($uri);
   
     # we want just the url part without the unneeded accessor url bits      my ($udom,$uname,$file);
     if ($uri =~ m-^/adm/-) {  
  $uri=~s-^/adm/wrapper/-/-;  
  $uri=~s-^/adm/coursedocs/showdoc/-/-;  
     }  
     my ($udom,$uname,$file,$dir);  
     if ($uri =~ m-^/(uploaded|editupload)/-) {      if ($uri =~ m-^/(uploaded|editupload)/-) {
  ($udom,$uname,$file) =   ($udom,$uname,$file) =
     ($uri =~ m-/(?:uploaded|editupload)/?([^/]*)/?([^/]*)/?(.*)-);      ($uri =~ m-/(?:uploaded|editupload)/?($match_domain)/?($match_name)/?(.*)-);
  $file = 'userfiles/'.$file;   $file = 'userfiles/'.$file;
  $dir = &Apache::loncommon::propath($udom,$uname);  
     }      }
     if ($uri =~ m-^/res/-) {      if ($uri =~ m-^/res/-) {
  ($udom,$uname) =    ($udom,$uname) = 
     ($uri =~ m-/(?:res)/?([^/]*)/?([^/]*)/-);      ($uri =~ m-/(?:res)/?($match_domain)/?($match_username)/-);
  $file = $uri;   $file = $uri;
     }      }
   
Line 4810  sub stat_file { Line 9635  sub stat_file {
  # unable to handle the uri   # unable to handle the uri
  return ();   return ();
     }      }
       my $getpropath;
     my ($result) = &dirlist($file,$udom,$uname,$dir);      if ($file =~ /^userfiles\//) {
     my @stats = split('&', $result);          $getpropath = 1;
           }
     if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {      my ($listref,$error) = &dirlist($file,$udom,$uname,$getpropath);
  shift(@stats); #filename is first      if (($error eq 'empty') || ($error eq 'no_such_dir')) {
  return @stats;          return ();
       } else {
           if (ref($listref) eq 'ARRAY') {
               my @stats = split('&',$listref->[0]);
       shift(@stats); #filename is first
       return @stats;
           }
     }      }
     return ();      return ();
 }  }
Line 4844  sub directcondval { Line 9675  sub directcondval {
     untie(%bighash);      untie(%bighash);
  }   }
  my $value = &docondval($sub_condition);   my $value = &docondval($sub_condition);
  &appenv('user.state.'.$env{'request.course.id'}.".$number" => $value);   &appenv({'user.state.'.$env{'request.course.id'}.".$number" => $value});
  return $value;   return $value;
     }      }
     if ($env{'user.state.'.$env{'request.course.id'}}) {      if ($env{'user.state.'.$env{'request.course.id'}}) {
Line 4909  sub devalidatecourseresdata { Line 9740  sub devalidatecourseresdata {
     &devalidate_cache_new('courseres',$hashid);      &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 get_courseresdata {  sub get_courseresdata {
     my ($coursenum,$coursedomain)=@_;      my ($coursenum,$coursedomain)=@_;
Line 4968  sub get_userresdata { Line 9807  sub get_userresdata {
     }      }
     return $tmp;      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 {  sub resdata {
     my ($name,$domain,$type,@which)=@_;      my ($name,$domain,$type,@which)=@_;
     my $result;      my $result;
Line 4979  sub resdata { Line 9832  sub resdata {
     }      }
     if (!ref($result)) { return $result; }          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;
 }  }
   
   sub get_numsuppfiles {
       my ($cnum,$cdom,$ignorecache)=@_;
       my $hashid=$cnum.':'.$cdom;
       my ($suppcount,$cached);
       unless ($ignorecache) {
           ($suppcount,$cached) = &is_cached_new('suppcount',$hashid);
       }
       unless (defined($cached)) {
           my $chome=&homeserver($cnum,$cdom);
           unless ($chome eq 'no_host') {
               ($suppcount,my $errors) = (0,0);
               my $suppmap = 'supplemental.sequence';
               ($suppcount,$errors) =
                   &Apache::loncommon::recurse_supplemental($cnum,$cdom,$suppmap,$suppcount,$errors);
           }
           &do_cache_new('suppcount',$hashid,$suppcount,600);
       }
       return $suppcount;
   }
   
 #  #
 # EXT resource caching routines  # EXT resource caching routines
 #  #
Line 5008  sub EXT_cache_status { Line 9881  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,$cid)=@_;
     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 5023  sub EXT { Line 9896  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'};
Line 5047  sub EXT { Line 9919  sub EXT {
     if ( (defined($Apache::lonhomework::parsing_a_problem)      if ( (defined($Apache::lonhomework::parsing_a_problem)
   || defined($Apache::lonhomework::parsing_a_task))    || defined($Apache::lonhomework::parsing_a_task))
  &&   &&
  ($symbparm eq &symbread()) ) {   ($symbparm eq &symbread()) ) {
  return $Apache::lonhomework::history{$qualifierrest};   # 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') {
Line 5110  sub EXT { Line 9988  sub EXT {
    } elsif ($realm eq 'request') {     } elsif ($realm eq 'request') {
 # ------------------------------------------------------------- request.browser  # ------------------------------------------------------------- request.browser
         if ($space eq 'browser') {          if ($space eq 'browser') {
     if ($qualifier eq 'textremote') {              return $env{'browser.'.$qualifier};
  if (&Apache::lonlocal::mt('textual_remote_display') eq 'on') {  
     return 1;  
  } else {  
     return 0;  
  }  
     } else {  
  return $env{'browser.'.$qualifier};  
     }  
 # ------------------------------------------------------------ request.filename  # ------------------------------------------------------------ request.filename
         } else {          } else {
             return $env{'request.'.$spacequalifierrest};              return $env{'request.'.$spacequalifierrest};
Line 5132  sub EXT { Line 10002  sub EXT {
     if (!$symbparm) { $symbparm=&symbread(); }      if (!$symbparm) { $symbparm=&symbread(); }
  }   }
   
  if ($space eq 'title') {          if ($qualifier eq '') {
     if (!$symbparm) { $symbparm = $env{'request.filename'}; }      if ($space eq 'title') {
     return &gettitle($symbparm);          if (!$symbparm) { $symbparm = $env{'request.filename'}; }
  }          return &gettitle($symbparm);
       }
   
  if ($space eq 'map') {      if ($space eq 'map') {
     my ($map) = &decode_symb($symbparm);          my ($map) = &decode_symb($symbparm);
     return &symbread($map);          return &symbread($map);
  }      }
               if ($space eq 'maptitle') {
                   my ($map) = &decode_symb($symbparm);
                   return &gettitle($map);
               }
       if ($space eq 'filename') {
           if ($symbparm) {
       return &clutter((&decode_symb($symbparm))[2]);
           }
           return &hreflocation('',$env{'request.filename'});
       }
   
               if ((defined($courseid)) && ($courseid eq $env{'request.course.id'}) && $symbparm) {
                   if ($space eq 'visibleparts') {
                       my $navmap = Apache::lonnavmaps::navmap->new();
                       my $item;
                       if (ref($navmap)) {
                           my $res = $navmap->getBySymb($symbparm);
                           my $parts = $res->parts();
                           if (ref($parts) eq 'ARRAY') {
                               $item = join(',',@{$parts});
                           }
                           undef($navmap);
                       }
                       return $item;
                   }
               }
           }
   
  my ($section, $group, @groups);   my ($section, $group, @groups);
  my ($courselevelm,$courselevel);   my ($courselevelm,$courselevel);
  if ($symbparm && defined($courseid) &&           if (($courseid eq '') && ($cid)) {
     $courseid eq $env{'request.course.id'}) {              $courseid = $cid;
           }
    if (($symbparm && $courseid) && 
       (($courseid eq $env{'request.course.id'}) || ($courseid eq $cid))) {
   
     #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;
Line 5159  sub EXT { Line 10060  sub EXT {
     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=&sort_course_groups($env{'request.course.groups'},$courseid);                   @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;
  }   }
                 my $grouplist = &get_users_groups($udom,$uname,$courseid);                  @groups = &get_users_groups($udom,$uname,$courseid);
                 if ($grouplist) {  
                     @groups=&sort_course_groups($grouplist,$courseid);  
                 }  
     }      }
   
     my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;      my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
Line 5183  sub EXT { Line 10082  sub EXT {
 # ----------------------------------------------------------- first, check user  # ----------------------------------------------------------- first, check user
   
     my $userreply=&resdata($uname,$udom,'user',      my $userreply=&resdata($uname,$udom,'user',
        ($courselevelr,$courselevelm,         ([$courselevelr,'resource'],
  $courselevel));   [$courselevelm,'map'     ],
     if (defined($userreply)) { return $userreply; }   [$courselevel, 'course'  ]));
       if (defined($userreply)) { return &get_reply($userreply); }
   
 # ------------------------------------------------ second, check some of course  # ------------------------------------------------ second, check some of course
             my $coursereply;              my $coursereply;
             if (@groups > 0) {              if (@groups > 0) {
                 $coursereply = &check_group_parms($courseid,\@groups,$symbparm,                  $coursereply = &check_group_parms($courseid,\@groups,$symbparm,
                                        $mapparm,$spacequalifierrest);                                         $mapparm,$spacequalifierrest);
                 if (defined($coursereply)) { return $coursereply; }                  if (defined($coursereply)) { return &get_reply($coursereply); }
             }              }
   
     $coursereply=&resdata($env{'course.'.$courseid.'.num'},      $coursereply=&resdata($env{'course.'.$courseid.'.num'},
      $env{'course.'.$courseid.'.domain'},    $env{'course.'.$courseid.'.domain'},
      'course',    'course',
      ($seclevelr,$seclevelm,$seclevel,    ([$seclevelr,   'resource'],
       $courselevelr));     [$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=();
Line 5211  sub EXT { Line 10113  sub EXT {
  $thisparm=$parmhash{$symbparm};   $thisparm=$parmhash{$symbparm};
  untie(%parmhash);   untie(%parmhash);
     }      }
     if ($thisparm) { return $thisparm; }      if ($thisparm) { return &get_reply([$thisparm,'resource']); }
  }   }
 # ------------------------------------------ fourth, look in resource metadata  # ------------------------------------------ fourth, look in resource metadata
   
Line 5224  sub EXT { Line 10126  sub EXT {
     $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 pf course  # ---------------------------------------------- fourth, look in rest of course
  if ($symbparm && defined($courseid) &&    if ($symbparm && defined($courseid) && 
     $courseid eq $env{'request.course.id'}) {      $courseid eq $env{'request.course.id'}) {
     my $coursereply=&resdata($env{'course.'.$courseid.'.num'},      my $coursereply=&resdata($env{'course.'.$courseid.'.num'},
      $env{'course.'.$courseid.'.domain'},       $env{'course.'.$courseid.'.domain'},
      'course',       'course',
      ($courselevelm,$courselevel));       ([$courselevelm,'map'   ],
     if (defined($coursereply)) { return $coursereply; }        [$courselevel, 'course']));
       if (defined($coursereply)) { return &get_reply($coursereply); }
  }   }
 # ------------------------------------------------------------------ Cascade up  # ------------------------------------------------------------------ Cascade up
  unless ($space eq '0') {   unless ($space eq '0') {
Line 5243  sub EXT { Line 10146  sub EXT {
     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 5275  sub EXT { Line 10180  sub EXT {
     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 {  sub check_group_parms {
     my ($courseid,$groups,$symbparm,$mapparm,$what) = @_;      my ($courseid,$groups,$symbparm,$mapparm,$what) = @_;
     my @groupitems = ();      my @groupitems = ();
     my $resultitem;      my $resultitem;
     my @levels = ($symbparm,$mapparm,$what);      my @levels = ([$symbparm,'resource'],[$mapparm,'map'],[$what,'course']);
     foreach my $group (@{$groups}) {      foreach my $group (@{$groups}) {
         foreach my $level (@levels) {          foreach my $level (@levels) {
              my $item = $courseid.'.['.$group.'].'.$level;               my $item = $courseid.'.['.$group.'].'.$level->[0];
              push(@groupitems,$item);               push(@groupitems,[$item,$level->[1]]);
         }          }
     }      }
     my $coursereply = &resdata($env{'course.'.$courseid.'.num'},      my $coursereply = &resdata($env{'course.'.$courseid.'.num'},
Line 5293  sub check_group_parms { Line 10210  sub check_group_parms {
 }  }
   
 sub sort_course_groups { # Sort groups based on defined rankings. Default is sort().  sub sort_course_groups { # Sort groups based on defined rankings. Default is sort().
     my ($grouplist,$courseid) = @_;      my ($courseid,@groups) = @_;
     my @groups = sort(split(/:/,$grouplist));      @groups = sort(@groups);
     return @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"})) {
       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"})) {   if (defined($packagetab{"$pack_type&$name&default"})) {
     return $packagetab{"$pack_type&$name&default"};      return $packagetab{"$pack_type&$name&default"};
  }   }
Line 5312  sub packages_tab_default { Line 10250  sub packages_tab_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 5334  sub add_prefix_and_part { Line 10286  sub add_prefix_and_part {
 # ---------------------------------------------------------------- Get metadata  # ---------------------------------------------------------------- Get metadata
   
 my %metaentry;  my %metaentry;
   my %importedpartids;
 sub metadata {  sub metadata {
     my ($uri,$what,$liburi,$prefix,$depthcount)=@_;      my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
     $uri=&declutter($uri);      $uri=&declutter($uri);
     # if it is a non metadata possible uri return quickly      # if it is a non metadata possible uri return quickly
     if (($uri eq '') ||       if (($uri eq '') || 
  (($uri =~ m|^/*adm/|) &&    (($uri =~ m|^/*adm/|) && 
      ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) ||       ($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard)$})) ||
         ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) ||          ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) {
  ($uri =~ m|home/[^/]+/public_html/|)) {   return undef;
       }
       if (($uri =~ /^priv/ || $uri=~m{^home/httpd/html/priv}) 
    && &Apache::lonxml::get_state('target') =~ /^(|meta)$/) {
  return undef;   return undef;
     }      }
     my $filename=$uri;      my $filename=$uri;
Line 5357  sub metadata { Line 10313  sub metadata {
  if (defined($cached)) { return $result->{':'.$what}; }   if (defined($cached)) { return $result->{':'.$what}; }
     }      }
     {      {
   # Imported parts would go here
           my %importedids=();
           my @origfileimportpartids=();
           my $importedparts=0;
 #  #
 # Is this a recursive call for a library?  # Is this a recursive call for a library?
 #  #
 # 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;
Line 5373  sub metadata { Line 10334  sub metadata {
         my %metathesekeys=();          my %metathesekeys=();
         unless ($filename=~/\.meta$/) { $filename.='.meta'; }          unless ($filename=~/\.meta$/) { $filename.='.meta'; }
  my $metastring;   my $metastring;
  if ($uri !~ m -^(uploaded|editupload)/-) {   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(@{$metaentry{$uri.'.file'}},$file);      #push(@{$metaentry{$uri.'.file'}},$file);
     $metastring=&getfile($file);      $metastring=&getfile($file);
Line 5397  sub metadata { Line 10365  sub metadata {
     } else {      } else {
  $metaentry{':packages'}=$package.$keyroot;   $metaentry{':packages'}=$package.$keyroot;
     }      }
     foreach (sort 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 5433  sub metadata { Line 10401  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)))) {  
  $metaentry{':'.$_}=$metaentry{':'.$_};  
  $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]}) {
     $metaentry{':'.$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=$metaentry{':'.$unikey.'.default'};   my $default=$metaentry{':'.$unikey.'.default'};
Line 5476  sub metadata { Line 10481  sub metadata {
  # 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
     $metaentry{':'.$unikey}=$default;      $metaentry{':'.$unikey}=$default;
  } else {   } elsif ( $internaltext =~ /\S/ ) {
   # either something interesting inside the tag or default    # something interesting inside the tag
                   # uninteresting  
     $metaentry{':'.$unikey}=$internaltext;      $metaentry{':'.$unikey}=$internaltext;
    } else {
     # no interesting values, don't set a default
  }   }
 # end of not-a-package not-a-library import  # end of not-a-package not-a-library import
     }      }
Line 5489  sub metadata { Line 10495  sub metadata {
     }      }
  }   }
  my ($extension) = ($uri =~ /\.(\w+)$/);   my ($extension) = ($uri =~ /\.(\w+)$/);
  foreach my $key (sort(keys(%packagetab))) {   $extension = lc($extension);
    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($metaentry{':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 5514  sub metadata { Line 10525  sub metadata {
  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);
     #$metaentry{':'.$_}=$metacache{$uri}->{':'.$_};   foreach my $rights (split(',',$rights_metadata)) {
     $metathesekeys{$_}=1;      #$metaentry{':'.$rights}=$metacache{$uri}->{':'.$rights};
       $metathesekeys{$rights}=1;
  }   }
     }      }
  }   }
  $metaentry{':keys'}=join(',',keys %metathesekeys);   # uniqifiy package listing
    my %seen;
    my @uniq_packages =
       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);   &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
  $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);   $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);
  &do_cache_new('meta',$uri,\%metaentry,60*60);   &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 $metaentry{':'.$what};      return $metaentry{':'.$what};
Line 5558  sub metadata_create_package_def { Line 10592  sub metadata_create_package_def {
 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 5583  sub metadata_generate_part0 { Line 10617  sub metadata_generate_part0 {
     }      }
 }  }
   
   # ------------------------------------------------------ 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 {
Line 5596  sub gettitle { Line 10646  sub gettitle {
  }   }
  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) {
   # Remember both $symb and $title for dynamic metadata
               $accesshash{$symb.'___crstitle'}=$title;
               $accesshash{&declutter($map).'___'.&declutter($url).'___usage'}=time;
   # Cache this title and then return it
     return &do_cache_new('title',$key,$title,600);      return &do_cache_new('title',$key,$title,600);
  }   }
  $urlsymb=$url;   $urlsymb=$url;
Line 5617  sub gettitle { Line 10674  sub gettitle {
 sub get_slot {  sub get_slot {
     my ($which,$cnum,$cdom)=@_;      my ($which,$cnum,$cdom)=@_;
     if (!$cnum || !$cdom) {      if (!$cnum || !$cdom) {
  (undef,my $courseid)=&Apache::lonxml::whichuser();   (undef,my $courseid)=&whichuser();
  $cdom=$env{'course.'.$courseid.'.domain'};   $cdom=$env{'course.'.$courseid.'.domain'};
  $cnum=$env{'course.'.$courseid.'.num'};   $cnum=$env{'course.'.$courseid.'.num'};
     }      }
Line 5637  sub get_slot { Line 10694  sub get_slot {
     }      }
     return $slotinfo{$which};      return $slotinfo{$which};
 }  }
   
   sub get_reservable_slots {
       my ($cnum,$cdom,$uname,$udom) = @_;
       my $now = time;
       my $reservable_info;
       my $key=join("\0",'reservableslots',$cdom,$cnum,$uname,$udom);
       if (exists($remembered{$key})) {
           $reservable_info = $remembered{$key};
       } else {
           my %resv;
           ($resv{'now_order'},$resv{'now'},$resv{'future_order'},$resv{'future'}) =
           &Apache::loncommon::get_future_slots($cnum,$cdom,$now);
           $reservable_info = \%resv;
           $remembered{$key} = $reservable_info;
       }
       return $reservable_info;
   }
   
   sub get_course_slots {
       my ($cnum,$cdom) = @_;
       my $hashid=$cnum.':'.$cdom;
       my ($result,$cached) = &Apache::lonnet::is_cached_new('allslots',$hashid);
       if (defined($cached)) {
           if (ref($result) eq 'HASH') {
               return %{$result};
           }
       } else {
           my %slots=&Apache::lonnet::dump('slots',$cdom,$cnum);
           my ($tmp) = keys(%slots);
           if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
               &do_cache_new('allslots',$hashid,\%slots,600);
               return %slots;
           }
       }
       return;
   }
   
   sub devalidate_slots_cache {
       my ($cnum,$cdom)=@_;
       my $hashid=$cnum.':'.$cdom;
       &devalidate_cache_new('allslots',$hashid);
   }
   
   sub get_coursechange {
       my ($cdom,$cnum) = @_;
       if ($cdom eq '' || $cnum eq '') {
           return unless ($env{'request.course.id'});
           $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
           $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
       }
       my $hashid=$cdom.'_'.$cnum;
       my ($change,$cached)=&is_cached_new('crschange',$hashid);
       if ((defined($cached)) && ($change ne '')) {
           return $change;
       } else {
           my %crshash;
           %crshash = &get('environment',['internal.contentchange'],$cdom,$cnum);
           if ($crshash{'internal.contentchange'} eq '') {
               $change = $env{'course.'.$cdom.'_'.$cnum.'.internal.created'};
               if ($change eq '') {
                   %crshash = &get('environment',['internal.created'],$cdom,$cnum);
                   $change = $crshash{'internal.created'};
               }
           } else {
               $change = $crshash{'internal.contentchange'};
           }
           my $cachetime = 600;
           &do_cache_new('crschange',$hashid,$change,$cachetime);
       }
       return $change;
   }
   
   sub devalidate_coursechange_cache {
       my ($cnum,$cdom)=@_;
       my $hashid=$cnum.':'.$cdom;
       &devalidate_cache_new('crschange',$hashid);
   }
   
 # ------------------------------------------------- Update symbolic store links  # ------------------------------------------------- Update symbolic store links
   
 sub symblist {  sub symblist {
Line 5646  sub symblist { Line 10781  sub symblist {
     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 my $url (keys %newhash) {      foreach my $url (keys(%newhash)) {
  next if ($url eq 'last_known'   next if ($url eq 'last_known'
  && $env{'form.no_update_last_known'});   && $env{'form.no_update_last_known'});
  $hash{declutter($url)}=&encode_symb($mapname,   $hash{declutter($url)}=&encode_symb($mapname,
Line 5664  sub symblist { Line 10799  sub symblist {
 # --------------------------------------------------------------- Verify a symb  # --------------------------------------------------------------- Verify a symb
   
 sub symbverify {  sub symbverify {
     my ($symb,$thisurl)=@_;      my ($symb,$thisurl,$encstate)=@_;
     my $thisfn=$thisurl;      my $thisfn=$thisurl;
 # wrapper not part of symbs  
     $thisfn=~s/^\/adm\/wrapper//;  
     $thisfn=~s/^\/adm\/coursedocs\/showdoc\///;  
     $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 5686  sub symbverify { Line 10818  sub symbverify {
   
     if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',      if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
                             &GDBM_READER(),0640)) {                              &GDBM_READER(),0640)) {
         my $ids=$bighash{'ids_'.&clutter($thisurl)};          my $noclutter;
         unless ($ids) {           if (($thisurl =~ m{^/adm/wrapper/ext/}) || ($thisurl =~ m{^ext/})) {
            $ids=$bighash{'ids_/'.$thisurl};              $thisurl =~ s/\?.+$//;
               if ($map =~ m{^uploaded/.+\.page$}) {
                   $thisurl =~ s{^(/adm/wrapper|)/ext/}{http://};
                   $thisurl =~ s{^\Qhttp://https://\E}{https://};
                   $noclutter = 1;
               }
           }
           my $ids;
           if ($noclutter) {
               $ids=$bighash{'ids_'.$thisurl};
           } else {
               $ids=$bighash{'ids_'.&clutter($thisurl)};
           }
           unless ($ids) {
               my $idkey = 'ids_'.($thisurl =~ m{^/}? '' : '/').$thisurl;
               $ids=$bighash{$idkey};
         }          }
         if ($ids) {          if ($ids) {
 # ------------------------------------------------------------------- Has ID(s)  # ------------------------------------------------------------------- Has ID(s)
     foreach (split(/\,/,$ids)) {              if ($thisfn =~ m{^/adm/wrapper/ext/}) {
        my ($mapid,$resid)=split(/\./,$_);                  $symb =~ s/\?.+$//;
               }
       foreach my $id (split(/\,/,$ids)) {
          my ($mapid,$resid)=split(/\./,$id);
                if (                 if (
   &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)    &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)
    eq $symb) {      eq $symb) {
    if (($env{'request.role.adv'}) ||                     if (ref($encstate)) {
        $bighash{'encrypted_'.$_} eq $env{'request.enc'}) {                         $$encstate = $bighash{'encrypted_'.$id};
        $okay=1;                      }
    }                     if (($env{'request.role.adv'}) ||
        }                         ($bighash{'encrypted_'.$id} eq $env{'request.enc'}) ||
    }                         ($thisurl eq '/adm/navmaps')) {
                          $okay=1;
                          last;
                      }
                  }
              }
         }          }
  untie(%bighash);   untie(%bighash);
     }      }
Line 5775  sub deversion { Line 10930  sub deversion {
   
 sub symbread {  sub symbread {
     my ($thisfn,$donotrecurse)=@_;      my ($thisfn,$donotrecurse)=@_;
     my $cache_str='request.symbread.cached.'.$thisfn;      my $cache_str;
     if (defined($env{$cache_str})) { return $env{$cache_str}; }      if ($thisfn ne '') {
           $cache_str='request.symbread.cached.'.$thisfn;
           if ($env{$cache_str} ne '') {
               return $env{$cache_str};
           }
      } else {
 # no filename provided? try from environment  # no filename provided? try from environment
     unless ($thisfn) {  
         if ($env{'request.symb'}) {          if ($env{'request.symb'}) {
     return $env{$cache_str}=&symbclean($env{'request.symb'});              return $env{$cache_str}=&symbclean($env{'request.symb'});
  }          }
  $thisfn=$env{'request.filename'};          $thisfn=$env{'request.filename'};
     }      }
     if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }      if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }
 # is that filename actually a symb? Verify, clean, and return  # is that filename actually a symb? Verify, clean, and return
Line 5812  sub symbread { Line 10971  sub symbread {
         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;
Line 5841  sub symbread { Line 11000  sub symbread {
                  } 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=&encode_symb($bighash{'map_id_'.$mapid},                                  $syval=&encode_symb($bighash{'map_id_'.$mapid},
Line 5864  sub symbread { Line 11023  sub symbread {
     return $env{$cache_str}=$syval;      return $env{$cache_str}=$syval;
         }          }
     }      }
     &appenv('request.ambiguous' => $thisfn);      &appenv({'request.ambiguous' => $thisfn});
     return $env{$cache_str}='';      return $env{$cache_str}='';
 }  }
   
Line 5951  sub latest_rnd_algorithm_id { Line 11110  sub latest_rnd_algorithm_id {
   
 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"};
     }      }
Line 5973  sub getCODE { Line 11132  sub getCODE {
     }      }
     return undef;      return undef;
 }  }
   #
   #  Determines the random seed for a specific context:
   #
   # parameters:
   #   symb      - in course context the symb for the seed.
   #   course_id - The course id of the form domain_coursenum.
   #   domain    - Domain for the user.
   #   course    - Course for the user.
   #   cenv      - environment of the course.
   #
   # NOTE:
   #   All parameters are picked out of the environment if missing
   #   or not defined.
   #   If a symb cannot be determined the current time is used instead.
   #
   #  For a given well defined symb, courside, domain, username,
   #  and course environment, the seed is reproducible.
   #
 sub rndseed {  sub rndseed {
     my ($symb,$courseid,$domain,$username)=@_;      my ($symb,$courseid,$domain,$username, $cenv)=@_;
       my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser();
     my ($wsymb,$wcourseid,$wdomain,$wusername)=&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())) {
  if ($which eq '64bit5') {   if ($which eq '64bit5') {
     return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username);      return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username);
Line 6018  sub rndseed_32bit { Line 11201  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 6039  sub rndseed_64bit { Line 11222  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 6063  sub rndseed_64bit2 { Line 11245  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 6085  sub rndseed_64bit3 { Line 11268  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";
Line 6109  sub rndseed_64bit4 { Line 11292  sub rndseed_64bit4 {
   
  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";
Line 6134  sub rndseed_CODE_64bit { Line 11317  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";
Line 6153  sub rndseed_CODE_64bit4 { Line 11336  sub rndseed_CODE_64bit4 {
  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";
Line 6171  sub rndseed_CODE_64bit5 { Line 11354  sub rndseed_CODE_64bit5 {
 sub setup_random_from_rndseed {  sub setup_random_from_rndseed {
     my ($rndseed)=@_;      my ($rndseed)=@_;
     if ($rndseed =~/([,:])/) {      if ($rndseed =~/([,:])/) {
  my ($num1,$num2)=split(/[,:]/,$rndseed);   my ($num1,$num2) = map { abs($_); } (split(/[,:]/,$rndseed));
  &Math::Random::random_set_seed(abs($num1),abs($num2));          if ((!$num1) || (!$num2) || ($num1 > 2147483562) || ($num2 > 2147483398)) {
               &Math::Random::random_set_seed_from_phrase($rndseed);
           } else {
               &Math::Random::random_set_seed($num1,$num2);
           }
     } else {      } else {
  &Math::Random::random_set_seed_from_phrase($rndseed);   &Math::Random::random_set_seed_from_phrase($rndseed);
     }      }
 }  }
   
 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' ||
    $env{"course.$fucourseid.receiptalg"} eq 'receipt3' ) {
  $unique=$env{"course.$fucourseid.internal.encseed"};   $unique=$env{"course.$fucourseid.internal.encseed"};
     } else {      } else {
  $unique=$perlvar{'lonReceipt'};   $unique=$perlvar{'lonReceipt'};
Line 6196  sub recunique { Line 11384  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'||
    $env{"course.$fucourseid.receiptalg"} eq 'receipt3' ) {
  $prefix=$env{"course.$fucourseid.internal.encpref"};   $prefix=$env{"course.$fucourseid.internal.encpref"};
     } else {      } else {
  $prefix=$perlvar{'lonHostID'};   $prefix=$perlvar{'lonHostID'};
Line 6206  sub recprefix { Line 11395  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 6239  sub ireceipt { Line 11435  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 6262  sub getfile { Line 11496  sub getfile {
   
 sub repcopy_userfile {  sub repcopy_userfile {
     my ($file)=@_;      my ($file)=@_;
     if ($file =~ m -^/*(uploaded|editupload)/-) { $file=&filelocation("",$file); }      my $londocroot = $perlvar{'lonDocRoot'};
     if ($file =~ m|^/home/httpd/html/lonUsers/|) { return 'ok'; }      if ($file =~ m{^/*(uploaded|editupload)/}) { $file=&filelocation("",$file); }
       if ($file =~ m{^\Q/home/httpd/lonUsers/\E}) { return 'ok'; }
     my ($cdom,$cnum,$filename) =       my ($cdom,$cnum,$filename) = 
  ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+([^/]+)/+([^/]+)/+(.*)|);   ($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]) {
   # nice, the file we have is up-to-date, just say okay
     return 'ok';      return 'ok';
    } else {
   # the file is outdated, get rid of it
       unlink($file);
  }   }
  $info = '';      }
  $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);  # one way or the other, at this point, we don't have the file
  if ($lwpresp ne 'ok') {  # construct the correct path for the file
     return -1;      my @parts = ($cdom,$cnum); 
  }      if ($filename =~ m|^(.+)/[^/]+$|) {
     } else {   push @parts, split(/\//,$1);
  my $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);      }
  if ($lwpresp ne 'ok') {      my $path = $perlvar{'lonDocRoot'}.'/userfiles';
     my $ua=new LWP::UserAgent;      foreach my $part (@parts) {
     my $request=new HTTP::Request('GET',&tokenwrapper($uri));   $path .= '/'.$part;
     my $response=$ua->request($request);   if (!-e $path) {
     if ($response->is_success()) {      mkdir($path,0770);
  $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) {  
     $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;
       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';      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 6341  sub tokenwrapper { Line 11581  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 6366  sub readfile { Line 11613  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;
 }  }
   
Line 6379  sub filelocation { Line 11626  sub filelocation {
  $file=~s-^/adm/wrapper/-/-;   $file=~s-^/adm/wrapper/-/-;
  $file=~s-^/adm/coursedocs/showdoc/-/-;   $file=~s-^/adm/coursedocs/showdoc/-/-;
     }      }
     if ($file=~m:^/~:) { # is a contruction space reference  
         $location = $file;      if ($file =~ m-^\Q$Apache::lonnet::perlvar{'lonTabDir'}\E/-) {
         $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;  
     } elsif ($file=~m:^/home/[^/]*/public_html/:) {  
  # is a correct contruction space reference  
         $location = $file;          $location = $file;
     } elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file      } elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file
         my ($udom,$uname,$filename)=          my ($udom,$uname,$filename)=
      ($file=~m -^/+(?:uploaded|editupload)/+([^/]+)/+([^/]+)/+(.*)$-);       ($file=~m -^/+(?:uploaded|editupload)/+($match_domain)/+($match_name)/+(.*)$-);
         my $home=&homeserver($uname,$udom);          my $home=&homeserver($uname,$udom);
         my $is_me=0;          my $is_me=0;
         my @ids=&current_machine_ids();          my @ids=&current_machine_ids();
         foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }          foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }
         if ($is_me) {          if ($is_me) {
      $location=&Apache::loncommon::propath($udom,$uname).       $location=propath($udom,$uname).'/userfiles/'.$filename;
        '/userfiles/'.$filename;  
         } else {          } else {
    $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.     $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.
        $udom.'/'.$uname.'/'.$filename;         $udom.'/'.$uname.'/'.$filename;
         }          }
       } elsif ($file =~ m-^/adm/-) {
    $location = $perlvar{'lonDocRoot'}.'/'.$file;
     } else {      } else {
         $file=~s/^\Q$perlvar{'lonDocRoot'}\E//;          $file=~s/^\Q$perlvar{'lonDocRoot'}\E//;
         $file=~s:^/res/:/:;          $file=~s:^/(res|priv)/:/:;
           my $space=$1;
         if ( !( $file =~ m:^/:) ) {          if ( !( $file =~ m:^/:) ) {
             $location = $dir. '/'.$file;              $location = $dir. '/'.$file;
         } else {          } else {
             $location = '/home/httpd/html/res'.$file;              $location = $perlvar{'lonDocRoot'}.'/'.$space.$file;
         }          }
     }      }
     $location=~s://+:/:g; # remove duplicate /      $location=~s://+:/:g; # remove duplicate /
     while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..      while ($location=~m{/\.\./}) {
    if ($location =~ m{/[^/]+/\.\./}) {
       $location=~ s{/[^/]+/\.\./}{/}g;
    } else {
       $location=~ s{/\.\./}{/}g;
    }
       } #remove dir/..
     while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./      while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./
     return $location;      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-^/-)) {
  $file=filelocation($dir,$file);   $file=filelocation($dir,$file);
     } elsif ($file=~m-^/adm/-) {      } elsif ($file=~m-^/adm/-) {
  $file=~s-^/adm/wrapper/-/-;   $file=~s-^/adm/wrapper/-/-;
Line 6424  sub hreflocation { Line 11676  sub hreflocation {
     }      }
     if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) {      if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) {
  $file=~s-^\Q$perlvar{'lonDocRoot'}\E--;   $file=~s-^\Q$perlvar{'lonDocRoot'}\E--;
     } elsif ($file=~m-/home/(\w+)/public_html/-) {  
  $file=~s-^/home/(\w+)/public_html/-/~$1/-;  
     } elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) {      } elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) {
  $file=~s-^/home/httpd/lonUsers/([^/]*)/./././([^/]*)/userfiles/   $file=~s{^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/}
     -/uploaded/$1/$2/-x;          {/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;
   }
   
   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 @ids;      return $domain;
 }  }
   
 # ------------------------------------------------------------- Declutters URLs  # ------------------------------------------------------------- Declutters URLs
Line 6462  sub current_machine_ids { Line 11750  sub current_machine_ids {
 sub declutter {  sub declutter {
     my $thisfn=shift;      my $thisfn=shift;
     if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }      if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }
     $thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//;      unless ($thisfn=~m{^/home/httpd/html/priv/}) {
           $thisfn=~s{^/home/httpd/html}{};
       }
     $thisfn=~s/^\///;      $thisfn=~s/^\///;
     $thisfn=~s|^adm/wrapper/||;      $thisfn=~s|^adm/wrapper/||;
     $thisfn=~s|^adm/coursedocs/showdoc/||;      $thisfn=~s|^adm/coursedocs/showdoc/||;
     $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 6475  sub declutter { Line 11768  sub declutter {
   
 sub clutter {  sub clutter {
     my $thisfn='/'.&declutter(shift);      my $thisfn='/'.&declutter(shift);
     unless ($thisfn=~/^\/(uploaded|editupload|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|^/adm|) {
  if ($thisfn =~ m|/ext/|) {   if ($thisfn =~ m|^/ext/|) {
     $thisfn='/adm/wrapper'.$thisfn;      $thisfn='/adm/wrapper'.$thisfn;
  } else {   } else {
     my ($ext) = ($thisfn =~ /\.(\w+)$/);      my ($ext) = ($thisfn =~ /\.(\w+)$/);
Line 6505  sub clutter { Line 11799  sub clutter {
     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 6514  sub freeze_escape { Line 11817  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 6550  sub correct_line_ends { Line 11838  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',length(&freeze(\%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',length(&freeze(\%homecache))));     &logthis(sprintf("%-20s is %s",'%homecache',length(&nfreeze(\%homecache))));
 #   &logthis(sprintf("%-20s is %s",'%titlecache',length(&freeze(\%titlecache))));  #   &logthis(sprintf("%-20s is %s",'%titlecache',length(&nfreeze(\%titlecache))));
 #   &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&freeze(\%courseresdatacache))));  #   &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&nfreeze(\%courseresdatacache))));
 #1.1 only  #1.1 only
 #   &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&freeze(\%userresdatacache))));  #   &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&nfreeze(\%userresdatacache))));
 #   &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&freeze(\%getsectioncache))));  #   &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&nfreeze(\%getsectioncache))));
 #   &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&freeze(\%courseresversioncache))));  #   &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&nfreeze(\%courseresversioncache))));
 #   &logthis(sprintf("%-20s is %s",'%resversioncache',length(&freeze(\%resversioncache))));  #   &logthis(sprintf("%-20s is %s",'%resversioncache',length(&nfreeze(\%resversioncache))));
    &logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered))));     &logthis(sprintf("%-20s is %s",'%remembered',length(&nfreeze(\%remembered))));
    &logthis(sprintf("%-20s is %s",'kicks',$kicks));     &logthis(sprintf("%-20s is %s",'kicks',$kicks));
    &logthis(sprintf("%-20s is %s",'hits',$hits));     &logthis(sprintf("%-20s is %s",'hits',$hits));
    &flushcourselogs();     &flushcourselogs();
    &logthis("Shutting down");     &logthis("Shutting down");
 }  }
   
 BEGIN {  sub get_dns {
 # ----------------------------------- Read loncapa.conf and loncapa_apache.conf      my ($url,$func,$ignore_cache,$nocache,$hashref) = @_;
     unless ($readit) {      if (!$ignore_cache) {
 {   my ($content,$cached)=
     # FIXME: Use LONCAPA::Configuration::read_conf here and omit next block      &Apache::lonnet::is_cached_new('dns',$url);
     open(my $config,"</etc/httpd/conf/loncapa.conf");   if ($cached) {
       &$func($content,$hashref);
       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) = sort { $b cmp $a } 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);
           unless ($nocache) {
       &do_cache_new('dns',$url,\@content,30*24*60*60);
         }          }
    &$func(\@content,$hashref);
    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,$hashref);
       return;
 }  }
 {  
     open(my $config,"</etc/httpd/conf/loncapa_apache.conf");  
   
     while (my $configline=<$config>) {  # ------------------------------------------------------Get DNS checksums file
         if ($configline =~ /^[^\#]*PerlSetVar/) {  sub parse_dns_checksums_tab {
    my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);      my ($lines,$hashref) = @_;
            chomp($varvalue);      my $machine_dom = &Apache::lonnet::host_domain($perlvar{'lonHostID'});
            $perlvar{$varname}=$varvalue;      my $loncaparev = &get_server_loncaparev($machine_dom);
       my ($release,$timestamp) = split(/\-/,$loncaparev);
       my (%chksum,%revnum);
       if (ref($lines) eq 'ARRAY') {
           chomp(@{$lines});
           my $version = shift(@{$lines});
           if ($version eq $release) {
               foreach my $line (@{$lines}) {
                   my ($file,$version,$shasum) = split(/,/,$line);
                   $chksum{$file} = $shasum;
                   $revnum{$file} = $version;
               }
               if (ref($hashref) eq 'HASH') {
                   %{$hashref} = (
                                   sums     => \%chksum,
                                   versions => \%revnum,
                                 );
               }
         }          }
     }      }
     close($config);      return;
   }
   
   sub fetch_dns_checksums {
       my %checksums;
       my $machine_dom = &Apache::lonnet::host_domain($perlvar{'lonHostID'});
       my $loncaparev = &get_server_loncaparev($machine_dom,$perlvar{'lonHostID'});
       my ($release,$timestamp) = split(/\-/,$loncaparev);
       &get_dns("/adm/dns/checksums/$release",\&parse_dns_checksums_tab,1,1,
                \%checksums);
       return \%checksums;
 }  }
   
 # ------------------------------------------------------------ Read domain file  # ------------------------------------------------------------ Read domain file
 {  {
     %domaindescription = ();      my $loaded;
     %domain_auth_def = ();      my %domain;
     %domain_auth_arg_def = ();  
     my $fh;      sub parse_domain_tab {
     if (open($fh,"<".$Apache::lonnet::perlvar{'lonTabDir'}.'/domain.tab')) {   my ($lines) = @_;
        while (<$fh>) {   foreach my $line (@$lines) {
            next if (/^(\#|\s*$)/);      next if ($line =~ /^(\#|\s*$ )/x);
 #           next if /^\#/;  
            chomp;      chomp($line);
            my ($domain, $domain_description, $def_auth, $def_auth_arg,      my ($name,@elements) = split(/:/,$line,9);
        $def_lang, $city, $longi, $lati, $primary) = split(/:/,$_);      my %this_domain;
    $domain_auth_def{$domain}=$def_auth;      foreach my $field ('description', 'auth_def', 'auth_arg_def',
            $domain_auth_arg_def{$domain}=$def_auth_arg;         'lang_def', 'city', 'longi', 'lati',
    $domaindescription{$domain}=$domain_description;         'primary') {
    $domain_lang_def{$domain}=$def_lang;   $this_domain{$field} = shift(@elements);
    $domain_city{$domain}=$city;      }
    $domain_longi{$domain}=$longi;      $domain{$name} = \%this_domain;
    $domain_lati{$domain}=$lati;   }
            $domain_primary{$domain}=$primary;      }
   
       sub reset_domain_info {
    undef($loaded);
    undef(%domain);
       }
   
       sub load_domain_tab {
    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}) );
   
  #         &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}");   if (!$what) {
 #          &logthis("Domain.tab: $domain ".$domaindescription{$domain} );      return $domain{$name}{'description'};
  }   }
    return $domain{$name}{$what};
     }      }
     close ($fh);  
       sub domain_info {
           &load_domain_tab() if (!$loaded);
           return %domain;
       }
   
 }  }
   
   
 # ------------------------------------------------------------- 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)=split(/:/,$configline);   open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
        $name=~s/\s//g;   my @config = <$config>;
        if ($id && $domain && $role && $name) {   &parse_hosts_tab(\@config);
  $hostname{$id}=$name;   close($config);
  $hostdom{$id}=$domain;   $loaded=1;
  if ($role eq 'library') { $libserv{$id}=$name; }  
        }  
     }      }
     close($config);  
     # FIXME: dev server don't want this, production servers _do_ want this      sub hostname {
     #&get_iphost();   &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});
       }
   
 }  }
   
 sub get_iphost {  { 
     if (%iphost) { return %iphost; }      my %iphost;
     my %name_to_ip;      my %name_to_ip;
     foreach my $id (keys(%hostname)) {      my %lonid_to_ip;
  my $name=$hostname{$id};  
  my $ip;      sub get_hosts_from_ip {
  if (!exists($name_to_ip{$name})) {   my ($ip) = @_;
     $ip = gethostbyname($name);   my %iphosts = &get_iphost();
     if (!$ip || length($ip) ne 4) {   if (ref($iphosts{$ip})) {
  &logthis("Skipping host $id name $name no IP found\n");      return @{$iphosts{$ip}};
  next;   }
    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;
     }      }
     $ip=inet_ntoa($ip);  
     $name_to_ip{$name} = $ip;  
  } else {  
     $ip = $name_to_ip{$name};  
  }   }
  push(@{$iphost{$ip}},$id);  
    # 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}});
    }
    &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 &do_cache_new('internetnames',$lonid,\@idns,12*60*60);
     }      }
     return %iphost;  
 }  }
   
   sub all_loncaparevs {
       return qw(1.1 1.2 1.3 2.0 2.1 2.2 2.3 2.4 2.5 2.6 2.7 2.8 2.9 2.10 2.11);
   }
   
   # ------------------------------------------------------- Read loncaparev table
   {
       sub load_loncaparevs {
           if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") {
               if (open(my $config,"<$perlvar{'lonTabDir'}/loncaparevs.tab")) {
                   while (my $configline=<$config>) {
                       chomp($configline);
                       my ($hostid,$loncaparev)=split(/:/,$configline);
                       $loncaparevs{$hostid}=$loncaparev;
                   }
                   close($config);
               }
           }
       }
   }
   
   # ----------------------------------------------------- Read serverhostID table
   {
       sub load_serverhomeIDs {
           if (-e "$perlvar{'lonTabDir'}/serverhomeIDs.tab") {
               if (open(my $config,"<$perlvar{'lonTabDir'}/serverhomeIDs.tab")) {
                   while (my $configline=<$config>) {
                       chomp($configline);
                       my ($name,$id)=split(/:/,$configline);
                       $serverhomeIDs{$name}=$id;
                   }
                   close($config);
               }
           }
       }
   }
   
   
   BEGIN {
   
   # ----------------------------------- 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 6676  sub get_iphost { Line 12365  sub get_iphost {
     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 6702  sub get_iphost { Line 12393  sub get_iphost {
     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 6726  sub get_iphost { Line 12423  sub get_iphost {
     close($config);      close($config);
 }  }
   
   # --------------------------------------------------------- Read loncaparev table
   
   &load_loncaparevs();
   
   # ------------------------------------------------------- Read serverhostID table
   
   &load_serverhomeIDs();
   
   # ---------------------------------------------------------- Read releaseslist XML
   {
       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();
   
 }  }
   
 $memcache=new Cache::Memcached({'servers'=>['127.0.0.1:11211']});  $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>');
Line 6886  were new keys. I.E. 1:foo will become 1: Line 12630  were new keys. I.E. 1:foo will become 1:
   
 Calling convention:  Calling convention:
   
  my %record=&Apache::lonnet::restore($symb,$courseid,$domain,$uname,$home);   my %record=&Apache::lonnet::restore($symb,$courseid,$domain,$uname);
  &Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname,$home);   &Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname);
   
 For more detailed information, see lonnet specific documentation.  For more detailed information, see lonnet specific documentation.
   
Line 6903  when the connection is brought back up Line 12647  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 6918  that was requested Line 12662  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 6942  authentication scheme Line 12697  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 6970  B<idput($udom,%ids)>: store away a list Line 12730  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 6983  X<userenvironment()> Line 12749  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 6991  passed in @what from the requested user' Line 12767  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 *
   
   constructaccess($url,$setpriv) : check for access to construction space URL
   
   See if the owner domain and name in the URL match those in the
   expected environment.  If so, return three element list
   ($ownername,$ownerdomain,$ownerhome).
   
   Otherwise return the null string.
   
   If second argument 'setpriv' is true, it assigns the privileges,
   and returns the same three element list, unless the owner has
   blocked "ad hoc" Domain Coordinator access to the Author Space,
   in which case the null string is returned.
   
 =item *  =item *
   
Line 7007  and course level Line 12798  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,$hidepriv) :
   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.
   
   =item *
   
   in_course($udom,$uname,$cdom,$cnum,$type,$hideprivileged) : determine if
   user: $uname:$udom has a role in the course: $cdom_$cnum.
   
   Additional optional arguments are: $type (if role checking is to be restricted
   to certain user status types -- previous (expired roles), active (currently
   available roles) or future (roles available in the future), and
   $hideprivileged -- if true will not report course roles for users who
   have active Domain Coordinator role in course's domain or in additional
   domains (specified in 'Domains to check for privileged users' in course
   environment -- set via:  Course Settings -> Classlists and staff listing).
   
   =item *
   
   privileged($username,$domain,$possdomains,$possroles) : returns 1 if user
   $username:$domain is a privileged user (e.g., Domain Coordinator or Super User)
   $possdomains and $possroles are optional array refs -- to domains to check and
   roles to check.  If $possdomains is not specified, a dump will be done of the
   users' roles.db to check for a dc or su role in any domain. This can be
   time consuming if &privileged is called repeatedly (e.g., when displaying a
   classlist), so in such cases, supplying a $possdomains array is preferred, as
   this then allows &privileged_by_domain() to be used, which caches the identity
   of privileged users, eliminating the need for repeated calls to &dump().
   
   =item *
   
   privileged_by_domain($possdomains,$roles) : returns a hash of a hash of a hash,
   where the outer hash keys are domains specified in the $possdomains array ref,
   next inner hash keys are privileged roles specified in the $roles array ref,
   and the innermost hash contains key = value pairs for username:domain = end:start
   for active or future "privileged" users with that role in that domain. To avoid
   repeated dumps of domain roles -- via &get_domain_roles() -- contents of the
   innerhash are cached using priv_$role and $dom as the identifiers.
   
 =back  =back
   
Line 7018  explanation of a user role term Line 12865  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 7035  modifyuserauth($udom,$uname,$umode,$upas Line 12882  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 user's environment.  
 This means the envoking user must be a course coordinator or otherwise  This means the invoking user must be a course coordinator or otherwise
 associated with a course.  associated with a course.
   
 This call is essentially a wrapper for lonnet::modifyuser and  This call is essentially a wrapper for lonnet::modifyuser and
Line 7054  Inputs: Line 12909  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 7082  Inputs: Line 12937  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
   
   =item B<$credits> Number of credits student will earn from this class - only needs to be supplied if value needs to be different from default credits for class.
   
 =back  =back
   
 =item *  =item *
   
 modify_student_enrollment  modify_student_enrollment
   
 Change a students enrollment status in a class.  The environment variable  Change a student's enrollment status in a class.  The environment variable
 'role.request.course' must be defined for this function to proceed.  'role.request.course' must be defined for this function to proceed.
   
 Inputs:  Inputs:
   
 =over 4  =over 4
   
 =item $udom, students domain  =item $udom, student's domain
   
 =item $uname, students name  =item $uname, student's name
   
 =item $uid, students user id  =item $uid, student's user id
   
 =item $first, students first name  =item $first, student's first name
   
 =item $middle  =item $middle
   
Line 7115  Inputs: Line 12986  Inputs:
   
 =item $start  =item $start
   
   =item $type
   
   =item $locktype
   
   =item $cid
   
   =item $selfenroll
   
   =item $context
   
   =item $credits, number of credits student will earn from this class
   
 =back  =back
   
   
Line 7140  revokecustomrole($udom,$uname,$url,$role Line 13023  revokecustomrole($udom,$uname,$url,$role
   
 =item *  =item *
   
 coursedescription($courseid) : returns a hash of information about the  coursedescription($courseid,$options) : returns a hash of information about the
 specified course id, including all environment settings for the  specified course id, including all environment settings for the
 course, the description of the course will be in the hash under the  course, the description of the course will be in the hash under the
 key 'description'  key 'description'
   
   $options is an optional parameter that if supplied is a hash reference that controls
   what how this function works.  It has the following key/values:
   
   =over 4
   
   =item freshen_cache
   
   If defined, and the environment cache for the course is valid, it is 
   returned in the returned hash.
   
   =item one_time
   
   If defined, the last cache time is set to _now_
   
   =item user
   
   If defined, the supplied username is used instead of the current user.
   
   
   =back
   
 =item *  =item *
   
 resdata($name,$domain,$type,@which) : request for current parameter  resdata($name,$domain,$type,@which) : request for current parameter
 setting for a specific $type, where $type is either 'course' or 'user',  setting for a specific $type, where $type is either 'course' or 'user',
 @what should be a list of parameters to ask about. This routine caches  @what should be a list of parameters to ask about. This routine caches
 answers for 5 minutes.  answers for 10 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.
   
   get_numsuppfiles($cnum,$cdom) : retrieve number of files in a course's
   supplemental content area. This routine caches the number of files for
   10 minutes.
   
 =back  =back
   
Line 7165  database) for a course Line 13080  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 7194  resource. Expects the local filesystem p Line 13126  resource. Expects the local filesystem p
   
 =item *  =item *
   
 EXT($varname,$symb,$udom,$uname) : evaluates and returns the value of  EXT($varname,$symb,$udom,$uname,$usection,$recurse,$cid) : evaluates 
 a vairety of different possible values, $varname should be a request  and returns the value of a variety of different possible values,
 string, and the other parameters can be used to specify who and what  $varname should be a request string, and the other parameters can be
 one is asking about.  used to specify who and what one is asking about. Ordinarily, $cid 
   does not need to be specified, as it is retrived from 
   $env{'request.course.id'}, but &Apache::lonnet::EXT() is called
   within lonuserstate::loadmap() when initializing a course, before
   $env{'request.course.id'} has been set, so it needs to be provided
   in that one case.
   
 Possible values for $varname are environment.lastname (or other item  Possible values for $varname are environment.lastname (or other item
 from the envirnment hash), user.name (or someother aspect about the  from the envirnment hash), user.name (or someother aspect about the
Line 7235  returns the data handle Line 13172  returns the data handle
   
 =item *  =item *
   
 symbverify($symb,$thisfn) : verifies that $symb actually exists and is  symbverify($symb,$thisfn,$encstate) : verifies that $symb actually exists
 a possible symb for the URL in $thisfn, and if is an encryypted  and is a possible symb for the URL in $thisfn, and if is an encrypted
 resource that the user accessed using /enc/ returns a 1 on success, 0  resource that the user accessed using /enc/ returns a 1 on success, 0
 on failure, user must be in a course, as it assumes the existance of  on failure, user must be in a course, as it assumes the existence of
 the course initial hash, and uses $env('request.course.id'}  the course initial hash, and uses $env('request.course.id'}.  The third
   arg is an optional reference to a scalar.  If this arg is passed in the
   call to symbverify, it will be set to 1 if the symb has been set to be 
   encrypted; otherwise it will be null.
   
 =item *  =item *
   
Line 7293  expirespread($uname,$udom,$stype,$usymb) Line 13232  expirespread($uname,$udom,$stype,$usymb)
 devalidate($symb) : devalidate temporary spreadsheet calculations,  devalidate($symb) : devalidate temporary spreadsheet calculations,
 forcing spreadsheet to reevaluate the resource scores next time.  forcing spreadsheet to reevaluate the resource scores next time.
   
   =item *
   
   can_edit_resource($file,$cnum,$cdom,$resurl,$symb,$group) : determine if current user can edit a particular resource,
   when viewing in course context.
   
    input: six args -- filename (decluttered), course number, course domain,
                       url, symb (if registered) and group (if this is a
                       group item -- e.g., bulletin board, group page etc.).
   
    output: array of five scalars --
            $cfile -- url for file editing if editable on current server
            $home -- homeserver of resource (i.e., for author if published,
                                             or course if uploaded.).
            $switchserver --  1 if server switch will be needed.
            $forceedit -- 1 if icon/link should be to go to edit mode
            $forceview -- 1 if icon/link should be to go to view mode
   
   =item *
   
   is_course_upload($file,$cnum,$cdom)
   
   Used in course context to determine if current file was uploaded to
   the course (i.e., would be found in /userfiles/docs on the course's
   homeserver.
   
     input: 3 args -- filename (decluttered), course number and course domain.
     output: boolean -- 1 if file was uploaded.
   
 =back  =back
   
 =head2 Storing/Retreiving Data  =head2 Storing/Retreiving Data
Line 7397  cput($namespace,$storehash,$udom,$uname) Line 13364  cput($namespace,$storehash,$udom,$uname)
   
 =item *  =item *
   
   newput($namespace,$storehash,$udom,$uname) :
   
   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 *
   
 eget($namespace,$storearr,$udom,$uname) : returns hash with keys from array  eget($namespace,$storearr,$udom,$uname) : returns hash with keys from array
 reference filled in from namesp (encrypts the return communication)  reference filled in from namesp (encrypts the return communication)
 ($udom and $uname are optional)  ($udom and $uname are optional)
Line 7406  reference filled in from namesp (encrypt Line 13398  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,$ignore_cache) : returns hash with defaults
   for: authentication, language, quotas, timezone, date locale, and portal URL in
   the target domain.
   
   May also include additional key => value pairs for the following groups:
   
   =over
   
   =item
   disk quotas (MB allocated by default to portfolios and authoring spaces).
   
   =over
   
   =item defaultquota, authorquota
   
   =back
   
   =item
   tools (availability of aboutme page, blog, webDAV access for authoring spaces,
   portfolio for users).
   
   =over
   
   =item
   aboutme, blog, webdav, portfolio
   
   =back
   
   =item
   requestcourses: ability to request courses, and how requests are processed.
   
   =over
   
   =item
   official, unofficial, community, textbook
   
   =back
   
   =item
   inststatus: types of institutional affiliation, and order in which they are displayed.
   
   =over
   
   =item
   inststatustypes, inststatusorder, inststatusguest
   
   =back
   
   =item
   coursedefaults: can PDF forms can be created, default credits for courses, default quotas (MB)
   for course's uploaded content.
   
   =over
   
   =item
   canuse_pdfforms, officialcredits, unofficialcredits, textbookcredits, officialquota, unofficialquota, communityquota, textbookquota
   
   =back
   
   =item
   usersessions: set options for hosting of your users in other domains, and hosting of users from other domains
   on your servers.
   
   =over
   
   =item
   remotesessions, hostedsessions
   
   =back
   
   =back
   
   In cases where a domain coordinator has never used the "Set Domain Configuration"
   utility to create a configuration.db file on a domain's primary library server
   only the following domain defaults: auth_def, auth_arg_def, lang_def
   -- corresponding values are authentication type (internal, krb4, krb5,
   or localauth), initial password or a kerberos realm, language (e.g., en-us) --
   will be available. Values are retrieved from cache (if current), unless the
   optional $ignore_cache arg is true, or from domain's configuration.db (if available),
   or lastly from values in lonTabs/dns_domain,tab, or lonTabs/domain.tab.
   
   Typical usage:
   
   %domdefaults = &get_domain_defaults($target_domain);
   
 =back  =back
   
 =head2 Network Status Functions  =head2 Network Status Functions
Line 7414  critical subroutine Line 13505  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 7469  splitting on '&', supports elements that Line 13642  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 7489  logperm() : append a permanent message t Line 13663  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 7545  filelocation except for hrefs Line 13720  filelocation except for hrefs
   
 =item *  =item *
   
 declutter() : declutters URLs (remove docroot, beginning slashes, 'res' etc)  declutter() : declutters URLs -- remove beginning slashes, 'res' etc.
   also removes beginning /home/httpd/html unless /priv/ follows it.
   
 =back  =back
   
Line 7562  userfileupload(): main rotine for puttin Line 13738  userfileupload(): main rotine for puttin
            filename, and the contents of the file to create/modifed exist             filename, and the contents of the file to create/modifed exist
            the filename is in $env{'form.'.$formname.'.filename'} and the             the filename is in $env{'form.'.$formname.'.filename'} and the
            contents of the file is located in $env{'form.'.$formname}             contents of the file is located in $env{'form.'.$formname}
  coursedoc - if true, store the file in the course of the active role   context - if coursedoc, store the file in the course of the active role
              of the current user               of the current user; 
              if 'existingfile': store in 'overwrites' in /home/httpd/perl/tmp
              if 'canceloverwrite': delete file in tmp/overwrites directory
  subdir - required - subdirectory to put the file in under ../userfiles/   subdir - required - subdirectory to put the file in under ../userfiles/
          if undefined, it will be placed in "unknown"           if undefined, it will be placed in "unknown"
   
Line 7585  returns: the new clean filename Line 13763  returns: the new clean filename
   
 =item *  =item *
   
 finishuserfileupload(): routine that creaes and sends the file to  finishuserfileupload(): routine that creates and sends the file to
 userspace, probably shouldn't be called directly  userspace, probably shouldn't be called directly
   
   docuname: username or courseid of destination for the file    docuname: username or courseid of destination for the file
   docudom: domain of user/course of destination for the file    docudom: domain of user/course of destination for the file
   formname: same as for userfileupload()    formname: same as for userfileupload()
   fname: filename (inculding subdirectories) for the file    fname: filename (including subdirectories) for the file
     parser: if 'parse', will parse (html) file to extract references to objects, links etc.
     allfiles: reference to hash used to store objects found by parser
     codebase: reference to hash used for codebases of java objects found by parser
     thumbwidth: width (pixels) of thumbnail to be created for uploaded image
     thumbheight: height (pixels) of thumbnail to be created for uploaded image
     resizewidth: width to be used to resize image using resizeImage from ImageMagick
     resizeheight: height to be used to resize image using resizeImage from ImageMagick
     context: if 'overwrite', will move the uploaded file from its temporary location to
               userfiles to facilitate overwriting a previously uploaded file with same name.
     mimetype: reference to scalar to accommodate mime type determined
               from File::MMagic if $parser = parse.
   
  returns either the url of the uploaded file (/uploaded/....) if successful   returns either the url of the uploaded file (/uploaded/....) if successful
  and /adm/notfound.html if unsuccessful   and /adm/notfound.html if unsuccessful (or an error message if context 
    was 'overwrite').
    
   
 =item *  =item *
   
Line 7631  removeuploadedurl(): convience function Line 13822  removeuploadedurl(): convience function
   Args:    Args:
    url:  a full /uploaded/... url to delete     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.
   
   =item *
   
   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
   
   =item *
   
   get_timebased_id():
   
   Attempts to get a unique timestamp-based suffix for use with items added to a
   course via the Course Editor (e.g., folders, composite pages,
   group bulletin boards).
   
   Args: (first three required; six others optional)
   
   1. prefix (alphanumeric): of keys in hash, e.g., suppsequence, docspage,
      docssequence, or name of group
   
   2. keyid (alphanumeric): name of temporary locking key in hash,
      e.g., num, boardids
   
   3. namespace: name of gdbm file used to store suffixes already assigned;
      file will be named nohist_namespace.db
   
   4. cdom: domain of course; default is current course domain from %env
   
   5. cnum: course number; default is current course number from %env
   
   6. idtype: set to concat if an additional digit is to be appended to the
      unix timestamp to form the suffix, if the plain timestamp is already
      in use.  Default is to not do this, but simply increment the unix
      timestamp by 1 until a unique key is obtained.
   
   7. who: holder of locking key; defaults to user:domain for user.
   
   8. locktries: number of attempts to obtain a lock (sleep of 1s before
      retrying); default is 3.
   
   9. maxtries: number of attempts to obtain a unique suffix; default is 20.
   
   Returns:
   
   1. suffix obtained (numeric)
   
   2. result of deleting locking key (ok if deleted, or lock never obtained)
   
   3. error: contains (localized) error message if an error occurred.
   
   
 =back  =back
   
 =head2 HTTP Helper Routines  =head2 HTTP Helper Routines
Line 7709  symblist($mapname,%newhash) : update sym Line 14034  symblist($mapname,%newhash) : update sym
 =back  =back
   
 =cut  =cut
   
Removed from v.1.732  
changed lines
  Added in v.1.1172.2.52

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