[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.836 and 1.1172.2.118.2.7

version 1.836, 2007/02/23 15:49:23 version 1.1172.2.118.2.7, 2020/09/08 02:08:27
Line 27 Line 27
 #  #
 ###  ###
   
 package Apache::lonnet;  =pod
   
 use strict;  
 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 %coursetypebuf  
    %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;  =head1 NAME
 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;  
 use Math::Random;  
 use LONCAPA qw(:DEFAULT :match);  
 use LONCAPA::Configuration;  
   
 my $readit;  Apache::lonnet.pm
 my $max_connection_retries = 10;     # Or some such value.  
   
 require Exporter;  =head1 SYNOPSIS
   
 our @ISA = qw (Exporter);  This file is an interface to the lonc processes of
 our @EXPORT = qw(%env);  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.
   
 =pod  This is part of the LearningOnline Network with CAPA project
   described at http://www.lon-capa.org.
   
 =head1 Package Variables  =head1 Package Variables
   
Line 86  delayed. Line 68  delayed.
   
 =cut  =cut
   
   package Apache::lonnet;
   
   use strict;
   use LWP::UserAgent();
   use HTTP::Date;
   use Image::Magick;
   use CGI::Cookie;
   
   use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir $deftex
               $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease
               %managerstab $passwdmin);
   
   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( sleep gettimeofday tv_interval );
   use Cache::Memcached;
   use Digest::MD5;
   use Math::Random;
   use File::MMagic;
   use LONCAPA qw(:DEFAULT :match);
   use LONCAPA::Configuration;
   use LONCAPA::lonmetadata;
   use LONCAPA::Lond;
   use LONCAPA::transliterate;
   
   use File::Copy;
   
   my $readit;
   my $max_connection_retries = 20;     # Or some such value.
   
   require Exporter;
   
   our @ISA = qw (Exporter);
   our @EXPORT = qw(%env);
   
 # --------------------------------------------------------------------- Logging  # ------------------------------------ Logging (parameters, docs, slots, roles)
 {  {
     my $logid;      my $logid;
     sub instructor_log {      sub write_log {
  my ($hash_name,$storehash,$delflag,$uname,$udom)=@_;   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);
     }      }
 }  }
   
 sub logtouch {  sub logtouch {
     my $execdir=$perlvar{'lonDaemons'};      my $execdir=$perlvar{'lonDaemons'};
     unless (-e "$execdir/logs/lonnet.log") {      unless (-e "$execdir/logs/lonnet.log") {
  open(my $fh,">>$execdir/logs/lonnet.log");   open(my $fh,">>","$execdir/logs/lonnet.log");
  close $fh;   close $fh;
     }      }
     my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3];      my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3];
Line 127  sub logthis { Line 156  sub logthis {
     my $execdir=$perlvar{'lonDaemons'};      my $execdir=$perlvar{'lonDaemons'};
     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 139  sub logperm { Line 169  sub logperm {
     my $execdir=$perlvar{'lonDaemons'};      my $execdir=$perlvar{'lonDaemons'};
     my $now=time;      my $now=time;
     my $local=localtime($now);      my $local=localtime($now);
     if (open(my $fh,">>$execdir/logs/lonnet.perm.log")) {      if (open(my $fh,">>","$execdir/logs/lonnet.perm.log")) {
  print $fh "$now:$message:$local\n";   print $fh "$now:$message:$local\n";
  close($fh);   close($fh);
     }      }
     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 $hostname = &hostname($lonhost);
                       my $protocol = $protocol{$lonhost};
                       $protocol = 'http' if ($protocol ne 'https');
                       my $url = $protocol.'://'.$hostname.'/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 157  sub subreply { Line 373  sub subreply {
   
     my $lockfile=$peerfile.".lock";      my $lockfile=$peerfile.".lock";
     while (-e $lockfile) { # Need to wait for the lockfile to disappear.      while (-e $lockfile) { # Need to wait for the lockfile to disappear.
  sleep(1);   sleep(0.1);
     }      }
     # At this point, either a loncnew parent is listening or an old lonc      # At this point, either a loncnew parent is listening or an old lonc
     # or loncnew child is listening so we can connect or everything's dead.      # or loncnew child is listening so we can connect or everything's dead.
Line 170  sub subreply { Line 386  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(0.1); # Try again later if failed connection.
     }      }
     my $answer;      my $answer;
     if ($client) {      if ($client) {
Line 189  sub subreply { Line 407  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:".          my $logged = $cmd;
                 " $cmd to $server returned $answer</font>");          if ($cmd =~ /^encrypt:([^:]+):/) {
               my $subcmd = $1;
               if (($subcmd eq 'auth') || ($subcmd eq 'passwd') ||
                   ($subcmd eq 'changeuserauth') || ($subcmd eq 'makeuser') ||
                   ($subcmd eq 'putdom') || ($subcmd eq 'autoexportgrades')) {
                   (undef,undef,my @rest) = split(/:/,$cmd);
                   if (($subcmd eq 'auth') || ($subcmd eq 'putdom')) {
                       splice(@rest,2,1,'Hidden');
                   } elsif ($subcmd eq 'passwd') {
                       splice(@rest,2,2,('Hidden','Hidden'));
                   } elsif (($subcmd eq 'changeuserauth') || ($subcmd eq 'makeuser') ||
                            ($subcmd eq 'autoexportgrades')) {
                       splice(@rest,3,1,'Hidden');
                   }
                   $logged = join(':',('encrypt:'.$subcmd,@rest));
               }
           }
           &logthis("<font color=\"blue\">WARNING:".
                    " $logged to $server returned $answer</font>");
     }      }
     return $answer;      return $answer;
 }  }
Line 201  sub reply { Line 437  sub reply {
 # ----------------------------------------------------------- Send USR1 to lonc  # ----------------------------------------------------------- Send USR1 to lonc
   
 sub reconlonc {  sub reconlonc {
       my ($lonid) = @_;
       if ($lonid) {
           my $hostname = &hostname($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");      &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>;
         chomp($loncpid);          chomp($loncpid);
         if (kill 0 => $loncpid) {          if (kill 0 => $loncpid) {
Line 224  sub reconlonc { Line 478  sub reconlonc {
   
 sub critical {  sub critical {
     my ($cmd,$server)=@_;      my ($cmd,$server)=@_;
     unless ($hostname{$server}) {      unless (&hostname($server)) {
         &logthis("<font color=\"blue\">WARNING:".          &logthis("<font color=\"blue\">WARNING:".
                " Critical message to unknown server ($server)</font>");                 " Critical message to unknown server ($server)</font>");
         return 'no_such_host';          return 'no_such_host';
     }      }
     my $answer=reply($cmd,$server);      my $answer=reply($cmd,$server);
     if ($answer eq 'con_lost') {      if ($answer eq 'con_lost') {
  &reconlonc("$perlvar{'lonSockDir'}/$server");   &reconlonc($server);
  my $answer=reply($cmd,$server);   my $answer=reply($cmd,$server);
         if ($answer eq 'con_lost') {          if ($answer eq 'con_lost') {
             my $now=time;              my $now=time;
Line 243  sub critical { Line 497  sub critical {
             $dumpcount++;              $dumpcount++;
             {              {
  my $dfh;   my $dfh;
  if (open($dfh,">$dfilename")) {   if (open($dfh,">",$dfilename)) {
     print $dfh "$cmd\n";       print $dfh "$cmd\n"; 
     close($dfh);      close($dfh);
  }   }
             }              }
             sleep 2;              sleep 1;
             my $wcmd='';              my $wcmd='';
             {              {
  my $dfh;   my $dfh;
  if (open($dfh,"<$dfilename")) {   if (open($dfh,"<",$dfilename)) {
     $wcmd=<$dfh>;       $wcmd=<$dfh>; 
     close($dfh);      close($dfh);
  }   }
Line 289  sub convert_and_load_session_env { Line 543  sub convert_and_load_session_env {
     my ($lonidsdir,$handle)=@_;      my ($lonidsdir,$handle)=@_;
     my @profile;      my @profile;
     {      {
  open(my $idf,"$lonidsdir/$handle.id");   my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");
    if (!$opened) {
       return 0;
    }
  flock($idf,LOCK_SH);   flock($idf,LOCK_SH);
  @profile=<$idf>;   @profile=<$idf>;
  close($idf);   close($idf);
Line 328  sub transfer_profile_to_env { Line 585  sub transfer_profile_to_env {
   
     my $convert;      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);
  if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",   if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",
  &GDBM_READER(),0640)) {   &GDBM_READER(),0640)) {
Line 360  sub transfer_profile_to_env { Line 620  sub transfer_profile_to_env {
     }      }
 }  }
   
   # ---------------------------------------------------- Check for valid session 
   sub check_for_valid_session {
       my ($r,$name,$userhashref,$domref) = @_;
       my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));
       my ($lonidsdir,$linkname,$pubname,$secure,$lonid);
       if ($name eq 'lonDAV') {
           $lonidsdir=$r->dir_config('lonDAVsessDir');
       } else {
           $lonidsdir=$r->dir_config('lonIDsDir');
           if ($name eq '') {
               $name = 'lonID';
           }
       }
       if ($name eq 'lonID') {
           $secure = 'lonSID';
           $linkname = 'lonLinkID';
           $pubname = 'lonPubID';
           if (exists($cookies{$secure})) {
               $lonid=$cookies{$secure};
           } elsif (exists($cookies{$name})) {
               $lonid=$cookies{$name};
           } elsif ((exists($cookies{$linkname})) && ($ENV{'SERVER_PORT'} != 443)) {
               $lonid=$cookies{$linkname};
           } elsif (exists($cookies{$pubname})) {
               $lonid=$cookies{$pubname};
           }
       } else {
           $lonid=$cookies{$name};
       }
       return undef if (!$lonid);
   
       my $handle=&LONCAPA::clean_handle($lonid->value);
       if (-l "$lonidsdir/$handle.id") {
           my $link = readlink("$lonidsdir/$handle.id");
           if ((-e $link) && ($link =~ m{^\Q$lonidsdir\E/(.+)\.id$})) {
               $handle = $1;
           }
       }
       if (!-e "$lonidsdir/$handle.id") {
           if ((ref($domref)) && ($name eq 'lonID') &&
               ($handle =~ /^($match_username)\_\d+\_($match_domain)\_(.+)$/)) {
               my ($possuname,$possudom,$possuhome) = ($1,$2,$3);
               if ((&domain($possudom) ne '') && (&homeserver($possuname,$possudom) eq $possuhome)) {
                   $$domref = $possudom;
               }
           }
           return undef;
       }
   
       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;
       }
   
       if (!defined($disk_env{'user.name'})
    || !defined($disk_env{'user.domain'})) {
           untie(%disk_env);
    return undef;
       }
   
       if (ref($userhashref) eq 'HASH') {
           $userhashref->{'name'} = $disk_env{'user.name'};
           $userhashref->{'domain'} = $disk_env{'user.domain'};
       }
       untie(%disk_env);
   
       return $handle;
   }
   
 sub timed_flock {  sub timed_flock {
     my ($file,$lock_type) = @_;      my ($file,$lock_type) = @_;
     my $failed=0;      my $failed=0;
Line 380  sub timed_flock { Line 714  sub timed_flock {
     }      }
 }  }
   
   sub get_sessionfile_vars {
       my ($handle,$lonidsdir,$storearr) = @_;
       my %returnhash;
       unless (ref($storearr) eq 'ARRAY') {
           return %returnhash;
       }
       if (-l "$lonidsdir/$handle.id") {
           my $link = readlink("$lonidsdir/$handle.id");
           if ((-e $link) && ($link =~ m{^\Q$lonidsdir\E/(.+)\.id$})) {
               $handle = $1;
           }
       }
       if ((-e "$lonidsdir/$handle.id") &&
           ($handle =~ /^($match_username)\_\d+\_($match_domain)\_(.+)$/)) {
           my ($possuname,$possudom,$possuhome) = ($1,$2,$3);
           if ((&domain($possudom) ne '') && (&homeserver($possuname,$possudom) eq $possuhome)) {
               if (open(my $idf,'+<',"$lonidsdir/$handle.id")) {
                   flock($idf,LOCK_SH);
                   if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",
                           &GDBM_READER(),0640)) {
                       foreach my $item (@{$storearr}) {
                           $returnhash{$item} = $disk_env{$item};
                       }
                       untie(%disk_env);
                   }
               }
           }
       }
       return %returnhash;
   }
   
 # ---------------------------------------------------------- Append Environment  # ---------------------------------------------------------- Append Environment
   
 sub appenv {  sub appenv {
     my %newenv=@_;      my ($newenv,$roles) = @_;
     foreach my $key (keys(%newenv)) {      if (ref($newenv) eq 'HASH') {
  if (($newenv{$key}=~/^user\.role/) || ($newenv{$key}=~/^user\.priv/)) {          foreach my $key (keys(%{$newenv})) {
             &logthis("<font color=\"blue\">WARNING: ".              my $refused = 0;
                 "Attempt to modify environment ".$key." to ".$newenv{$key}      if (($key =~ /^user\.role/) || ($key =~ /^user\.priv/)) {
                 .'</font>');                  $refused = 1;
     delete($newenv{$key});                  if (ref($roles) eq 'ARRAY') {
         } else {                      my ($type,$role) = ($key =~ m{^user\.(role|priv)\.(.+?)\./});
             $env{$key}=$newenv{$key};                      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 $lonids = $perlvar{'lonIDsDir'};
           if ($env{'user.environment'} =~ m{^\Q$lonids/\E$match_username\_\d+\_$match_domain\_[\w\-.]+\.id$}) {
               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);
               }
         }          }
     }  
     open(my $env_file,$env{'user.environment'});  
     if (&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);  
     }      }
     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})) {
                   $refused = 0;
               }
           }
           if ($refused) {
               &logthis("<font color=\"blue\">WARNING: ".
                        "Attempt to delete from environment ".$delthis);
               return 'error';
           }
     }      }
     open(my $env_file,$env{'user.environment'});      my $opened = open(my $env_file,'+<',$env{'user.environment'});
     if (&timed_flock($env_file,LOCK_EX)      if ($opened
    && &timed_flock($env_file,LOCK_EX)
  &&   &&
  tie(my %disk_env,'GDBM_File',$env{'user.environment'},   tie(my %disk_env,'GDBM_File',$env{'user.environment'},
     (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {      (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
  foreach my $key (keys(%disk_env)) {   foreach my $key (keys(%disk_env)) {
     if ($key=~/^$delthis/) {       if ($regexp) {
                 delete($env{$key});                  if ($key=~/^$delthis/) {
                 delete($disk_env{$key});                      delete($env{$key});
                       delete($disk_env{$key});
                   } 
               } else {
                   if ($key=~/^\Q$delthis\E/) {
       delete($env{$key});
       delete($disk_env{$key});
           }
             }              }
  }   }
  untie(%disk_env);   untie(%disk_env);
Line 445  sub get_env_multiple { Line 843  sub get_env_multiple {
     return(@values);      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 454  sub userload { Line 896  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/);
               next if ($filename =~ /^[a-f0-9]+_linked\.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 469  sub userload { Line 913  sub userload {
     return $userloadpercent;      return $userloadpercent;
 }  }
   
 # ------------------------------------------ Fight off request when overloaded  
   
 sub overloaderror {  
     my ($r,$checkserver)=@_;  
     unless ($checkserver) { $checkserver=$perlvar{'lonHostID'}; }  
     my $loadavg;  
     if ($checkserver eq $perlvar{'lonHostID'}) {  
        open(my $loadfile,'/proc/loadavg');  
        $loadavg=<$loadfile>;  
        $loadavg =~ s/\s.*//g;  
        $loadavg = 100*$loadavg/$perlvar{'lonLoadLim'};  
        close($loadfile);  
     } else {  
        $loadavg=&reply('load',$checkserver);  
     }  
     my $overload=$loadavg-100;  
     if ($overload>0) {  
  $r->err_headers_out->{'Retry-After'}=$overload;  
         $r->log_error('Overload of '.$overload.' on '.$checkserver);  
         return 413;  
     }      
     return '';  
 }  
   
 # ------------------------------ Find server with least workload from spare.tab  # ------------------------------ Find server with least workload from spare.tab
   
 sub spareserver {  sub spareserver {
     my ($loadpercent,$userloadpercent,$want_server_name) = @_;      my ($loadpercent,$userloadpercent,$want_server_name,$udom) = @_;
     my $spare_server;      my $spare_server;
     if ($userloadpercent !~ /\d/) { $userloadpercent=0; }      if ($userloadpercent !~ /\d/) { $userloadpercent=0; }
     my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent       my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent 
                                                      :  $userloadpercent;                                                       :  $userloadpercent;
           my ($uint_dom,$remotesessions);
     foreach my $try_server (@{ $spareid{'primary'} }) {      if (($udom ne '') && (&domain($udom) ne '')) {
  ($spare_server, $lowest_load) =          my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
     &compare_server_load($try_server, $spare_server, $lowest_load);          $uint_dom = &Apache::lonnet::internet_dom($uprimary_id);
     }          my %udomdefaults = &Apache::lonnet::get_domain_defaults($udom);
           $remotesessions = $udomdefaults{'remotesessions'};
     my $found_server = ($spare_server ne '' && $lowest_load < 100);      }
       my $spareshash = &this_host_spares($udom);
       if (ref($spareshash) eq 'HASH') {
           if (ref($spareshash->{'primary'}) eq 'ARRAY') {
               foreach my $try_server (@{ $spareshash->{'primary'} }) {
                   next unless (&spare_can_host($udom,$uint_dom,$remotesessions,
                                                $try_server));
           ($spare_server, $lowest_load) =
               &compare_server_load($try_server, $spare_server, $lowest_load);
               }
           }
   
     if (!$found_server) {          my $found_server = ($spare_server ne '' && $lowest_load < 100);
  foreach my $try_server (@{ $spareid{'default'} }) {  
     ($spare_server, $lowest_load) =          if (!$found_server) {
  &compare_server_load($try_server, $spare_server, $lowest_load);              if (ref($spareshash->{'default'}) eq 'ARRAY') { 
  }          foreach my $try_server (@{ $spareshash->{'default'} }) {
                       next unless (&spare_can_host($udom,$uint_dom,
                                                    $remotesessions,$try_server));
               ($spare_server, $lowest_load) =
           &compare_server_load($try_server, $spare_server, $lowest_load);
                   }
       }
           }
     }      }
   
     if (!$want_server_name) {      if (!$want_server_name) {
  $spare_server="http://$hostname{$spare_server}";          if (defined($spare_server)) {
               my $hostname = &hostname($spare_server);
               if (defined($hostname)) {
                   my $protocol = 'http';
                   if ($protocol{$spare_server} eq 'https') {
                       $protocol = $protocol{$spare_server};
                   }
           $spare_server = $protocol.'://'.$hostname;
               }
           }
     }      }
     return $spare_server;      return $spare_server;
 }  }
   
 sub compare_server_load {  sub compare_server_load {
     my ($try_server, $spare_server, $lowest_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 $loadans     = &reply('load',    $try_server);
     my $userloadans = &reply('userload',$try_server);      my $userloadans = &reply('userload',$try_server);
   
     if ($loadans !~ /\d/ && $userloadans !~ /\d/) {      if ($loadans !~ /\d/ && $userloadans !~ /\d/) {
  next; #didn't get a number from the server   return ($spare_server, $lowest_load); #didn't get a number from the server
     }      }
   
     my $load;      my $load;
Line 551  sub compare_server_load { Line 1007  sub compare_server_load {
     }      }
     return ($spare_server,$lowest_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;
   }
   
   # check if user's browser sent load balancer cookie and server still has session
   # and is not overloaded.
   sub check_for_balancer_cookie {
       my ($r,$update_mtime) = @_;
       my ($otherserver,$cookie);
       my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));
       if (exists($cookies{'balanceID'})) {
           my $balid = $cookies{'balanceID'};
           $cookie=&LONCAPA::clean_handle($balid->value);
           my $balancedir=$r->dir_config('lonBalanceDir');
           if ((-d $balancedir) && (-e "$balancedir/$cookie.id")) {
               if ($cookie =~ /^($match_domain)_($match_username)_[a-f0-9]+$/) {
                   my ($possudom,$possuname) = ($1,$2);
                   my $has_session = 0;
                   if ((&domain($possudom) ne '') &&
                       (&homeserver($possuname,$possudom) ne 'no_host')) {
                       my $try_server;
                       my $opened = open(my $idf,'+<',"$balancedir/$cookie.id");
                       if ($opened) {
                           flock($idf,LOCK_SH);
                           while (my $line = <$idf>) {
                               chomp($line);
                               if (&hostname($line) ne '') {
                                   $try_server = $line;
                                   last;
                               }
                           }
                           close($idf);
                           if (($try_server) &&
                               (&has_user_session($try_server,$possudom,$possuname))) {
                               my $lowest_load = 30000;
                               ($otherserver,$lowest_load) =
                                   &compare_server_load($try_server,undef,$lowest_load);
                               if ($otherserver ne '' && $lowest_load < 100) {
                                   $has_session = 1;
                               } else {
                                   undef($otherserver);
                               }
                           }
                       }
                   }
                   if ($has_session) {
                       if ($update_mtime) {
                           my $atime = my $mtime = time;
                           utime($atime,$mtime,"$balancedir/$cookie.id");
                       }
                   } else {
                       unlink("$balancedir/$cookie.id");
                   }
               }
           }
       }
       return ($otherserver,$cookie);
   }
   
   sub delbalcookie {
       my ($cookie,$balancer) =@_;
       if ($cookie =~ /^($match_domain)\_($match_username)\_[a-f0-9]{32}$/) {
           my ($udom,$uname) = ($1,$2);
           my $uprimary_id = &domain($udom,'primary');
           my $uintdom = &internet_dom($uprimary_id);
           my $intdom = &internet_dom($balancer);
           my $serverhomedom = &host_domain($balancer);
           if (($uintdom ne '') && ($uintdom eq $intdom)) {
               return &reply("delbalcookie:$cookie",$balancer);
           }
       }
   }
   
   # -------------------------------- 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 ($login_host,$hostname,$portal_path,$isredirect,$lowest_load);
   }
   
   sub get_course_sessions {
       my ($cnum,$cdom,$lastactivity) = @_;
       my %servers = &internet_dom_servers($cdom);
       my %returnhash;
       foreach my $server (sort(keys(%servers))) {
           my $rep = &reply("coursesessions:$cdom:$cnum:$lastactivity",$server);
           my @pairs=split(/\&/,$rep);
           unless (($rep eq 'unknown_cmd') || ($rep =~ /^error/)) {
               foreach my $item (@pairs) {
                   my ($key,$value)=split(/=/,$item,2);
                   $key = &unescape($key);
                   next if ($key =~ /^error: 2 /);
                   if (exists($returnhash{$key})) {
                       next if ($value < $returnhash{$key});
                   }
                   $returnhash{$key}=$value;
               }
           }
       }
       return %returnhash;
   }
   
 # --------------------------------------------- Try to change a user's password  # --------------------------------------------- Try to change a user's password
   
 sub changepass {  sub changepass {
     my ($uname,$udom,$currentpass,$newpass,$server,$context)=@_;      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:$context",      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 582  sub changepass { Line 1216  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.");
       } elsif ($answer =~ "^prioruse") {
          &logthis("$server refused to change $uname in $udom password because ".
                   "the password had been used before");
     }      }
     return $answer;      return $answer;
 }  }
Line 605  sub queryauthenticate { Line 1245  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= &LONCAPA::clean_username($uname);      $uname= &LONCAPA::clean_username($uname);
     my $uhome=&homeserver($uname,$udom,1);      my $uhome=&homeserver($uname,$udom,1);
       my $newhome;
     if ((!$uhome) || ($uhome eq 'no_host')) {      if ((!$uhome) || ($uhome eq 'no_host')) {
 # Maybe the machine was offline and only re-appeared again recently?  # Maybe the machine was offline and only re-appeared again recently?
         &reconlonc();          &reconlonc();
 # One more  # One more
  my $uhome=&homeserver($uname,$udom,1);   $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')) {   if ((!$uhome) || ($uhome eq 'no_host')) {
     &logthis("User $uname at $udom is unknown in authenticate");      &logthis("User $uname at $udom is unknown in authenticate");
  }      return 'no_host';
  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 632  sub authenticate { Line 1286  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 $try_server_hostname = &hostname($try_server);
       my $serverhomeID = &get_server_homeID($try_server_hostname);
       my $serverhomedom = &host_domain($serverhomeID);
       my %defdomdefaults = &get_domain_defaults($serverhomedom);
       if (ref($defdomdefaults{'offloadnow'}) eq 'HASH') {
           if ($defdomdefaults{'offloadnow'}{$try_server}) {
               $canhost = 0;
           }
       }
       if (($canhost) && ($uint_dom)) {
           my @intdoms;
           my $internet_names = &get_internet_names($try_server);
           if (ref($internet_names) eq 'ARRAY') {
               @intdoms = @{$internet_names};
           }
           unless (grep(/^\Q$uint_dom\E$/,@intdoms)) {
               my $remoterev = &get_server_loncaparev(undef,$try_server);
               $canhost = &can_host_session($udom,$try_server,$remoterev,
                                            $remotesessions,
                                            $defdomdefaults{'hostedsessions'});
           }
       }
       return $canhost;
   }
   
   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,$caller) = @_;
       my ($is_balancer,$currtargets,$currrules,$dom_in_use,$homeintdom,
           $rule_in_effect,$offloadto,$otherserver,$setcookie);
       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 $domneedscache; 
       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);
           } else {
               $domneedscache = $dom_in_use;
           }
       }
       if (ref($result) eq 'HASH') {
           ($is_balancer,$currtargets,$currrules,$setcookie) =
               &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',$serverhomedom,$domconfig{'loadbalancing'},$cachetime);
               } else {
                   $domneedscache = $serverhomedom;
               }
           }
           if (ref($result) eq 'HASH') {
               ($is_balancer,$currtargets,$currrules,$setcookie) =
                   &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);
               }
               unless (defined($cached)) {
                   $domneedscache = $serverhomedom;
               }
           }
       } else {
           if ($perlvar{'lonBalancer'} eq 'yes') {
               $is_balancer = 1;
               $offloadto = &this_host_spares($dom_in_use);
           }
           unless (defined($cached)) {
               $domneedscache = $serverhomedom;
           }
       }
       if ($domneedscache) {
           &do_cache_new('loadbalancing',$domneedscache,$is_balancer,$cachetime);
       }
       if ($is_balancer) {
           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);
                   }
               }
           }
           unless ($caller eq 'login') {
               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});
                       }
                   }
               }
           }
           unless ($homeintdom) {
               undef($setcookie);
           }
       }
       return ($is_balancer,$otherserver,$setcookie);
   }
   
   sub check_balancer_result {
       my ($result,@hosts) = @_;
       my ($is_balancer,$currtargets,$currrules,$setcookie);
       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'};
                       $setcookie = $result->{$key}{'cookie'};
                       last;
                   }
               }
           }
       }
       return ($is_balancer,$currtargets,$currrules,$setcookie);
   }
   
   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 640  sub homeserver { Line 1729  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') {
                delete($badServerCache{$tryserver});       delete($badServerCache{$tryserver}); 
        return $homecache{$index}=$tryserver;      return $homecache{$index}=$tryserver;
            } elsif ($answer eq 'no_host') {   } elsif ($answer eq 'no_host') {
        $badServerCache{$tryserver}=1;      $badServerCache{$tryserver}=1;
            }   }
        }  
     }          }    
     return 'no_host';      return 'no_host';
 }  }
Line 663  sub idget { Line 1752  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('&', map { &escape($_); } @ids);
   my $idlist=join('&',@ids);   $idlist=~tr/A-Z/a-z/; 
           $idlist=~tr/A-Z/a-z/;    my $reply=&reply("idget:$udom:".$idlist,$tryserver);
   my $reply=&reply("idget:$udom:".$idlist,$tryserver);   my @answer=();
           my @answer=();   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]}=&unescape($answer[$i]);
   $returnhash{$ids[$i]}=$answer[$i];      } 
               }    }
           }      } 
        }  
     }      
     return %returnhash;      return %returnhash;
 }  }
   
Line 719  sub idput { Line 1806  sub idput {
     }      }
 }  }
   
 # ------------------------------------------- get items from domain db files     # ---------------------------------------- Delete unwanted IDs from ids.db file
   
   sub iddel {
       my ($udom,$idshashref,$uhome)=@_;
       my %result=();
       unless (ref($idshashref) eq 'HASH') {
           return %result;
       }
       my %servers=();
       while (my ($id,$uname) = each(%{$idshashref})) {
           my $uhom;
           if ($uhome) {
               $uhom = $uhome;
           } else {
               $uhom=&homeserver($uname,$udom);
           }
           if ($uhom ne 'no_host') {
               if ($servers{$uhom}) {
                   $servers{$uhom}.='&'.&escape($id);
               } else {
                   $servers{$uhom}=&escape($id);
               }
           }
       }
       foreach my $server (keys(%servers)) {
           $result{$server} = &critical('iddel:'.$udom.':'.$servers{$server},$uhome);
       }
       return %result;
   }
   
   # ------------------------------dump from db file owned by domainconfig user
   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 {  sub get_dom {
     my ($namespace,$storearr,$udom)=@_;      my ($namespace,$storearr,$udom,$uhome)=@_;
       return if ($udom eq 'public');
     my $items='';      my $items='';
     foreach my $item (@$storearr) {      foreach my $item (@$storearr) {
         $items.=&escape($item).'&';          $items.=&escape($item).'&';
     }      }
     $items=~s/\&$//;      $items=~s/\&$//;
     if (!$udom) { $udom=$env{'user.domain'}; }      if (!$udom) {
     if (exists($domain_primary{$udom})) {          $udom=$env{'user.domain'};
         my $uhome=$domain_primary{$udom};          return if ($udom eq 'public');
         my $rep=&reply("getdom:$udom:$namespace:$items",$uhome);          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;
           if ($namespace =~ /^enc/) {
               $rep=&reply("encrypt:egetdom:$udom:$namespace:$items",$uhome);
           } else {
               $rep=&reply("getdom:$udom:$namespace:$items",$uhome);
           }
           my %returnhash;
           if ($rep eq '' || $rep =~ /^error: 2 /) {
               return %returnhash;
           }
         my @pairs=split(/\&/,$rep);          my @pairs=split(/\&/,$rep);
         if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) {          if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) {
             return @pairs;              return @pairs;
         }          }
         my %returnhash=();  
         my $i=0;          my $i=0;
         foreach my $item (@$storearr) {          foreach my $item (@$storearr) {
             $returnhash{$item}=&thaw_unescape($pairs[$i]);              $returnhash{$item}=&thaw_unescape($pairs[$i]);
Line 744  sub get_dom { Line 1894  sub get_dom {
         }          }
         return %returnhash;          return %returnhash;
     } else {      } else {
         &logthis("get_dom failed - no primary domain server for $udom");          &logthis("get_dom failed - no homeserver and/or domain ($udom) ($uhome)");
     }      }
 }  }
   
 # -------------------------------------------- put items in domain db files   # -------------------------------------------- put items in domain db files 
   
 sub put_dom {  sub put_dom {
     my ($namespace,$storehash,$udom)=@_;      my ($namespace,$storehash,$udom,$uhome)=@_;
     if (!$udom) { $udom=$env{'user.domain'}; }      if (!$udom) {
     if (exists($domain_primary{$udom})) {          $udom=$env{'user.domain'};
         my $uhome=$domain_primary{$udom};          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='';          my $items='';
         foreach my $item (keys(%$storehash)) {          foreach my $item (keys(%$storehash)) {
             $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';              $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
         }          }
         $items=~s/\&$//;          $items=~s/\&$//;
         return &reply("putdom:$udom:$namespace:$items",$uhome);          if ($namespace =~ /^enc/) {
               return &reply("encrypt:putdom:$udom:$namespace:$items",$uhome);
           } else {
               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 '') {
           unless ($homeserver eq $perlvar{'lonHostID'}) {
               if ($srch->{'srchby'} eq 'email') {
                   my $lcrev = &get_server_loncaparev($udom,$homeserver);
                   my ($major,$minor,$subver) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.(\d+)[\w.\-]+\'?$/);
                   if (($major eq '' && $minor eq '') || ($major < 2) ||
                       (($major == 2) && ($minor < 11)) ||
                       (($major == 2) && ($minor == 11) && ($subver < 3))) {
                       return;
                   }
               }
           }
    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('institutional 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) {
               unless ($tryserver eq $perlvar{'lonHostID'}) {
                   if ($srch->{'srchby'} eq 'email') {
                       my $lcrev = &get_server_loncaparev($dom,$tryserver);
                       my ($major,$minor,$subver) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.(\d+)[\w.\-]+\'?$/);
                       next if (($major eq '' && $minor eq '') || ($major < 2) ||
                                (($major == 2) && ($minor < 11)) ||
                                (($major == 2) && ($minor == 11) && ($subver < 3)));
                   }
               }
               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 get_multiple_instusers {
       my ($udom,$users,$caller) = @_;
       my ($outcome,$results);
       if (ref($users) eq 'HASH') {
           my $count = keys(%{$users});
           my $requested = &freeze_escape($users);
           my $homeserver = &domain($udom,'primary');
           if ($homeserver ne '') {
               my $queryid=&reply('querysend:getmultinstusers:::'.$caller.'='.$requested,$homeserver);
               my $host=&hostname($homeserver);
               if ($queryid !~/^\Q$host\E\_/) {
                   &logthis('get_multiple_instusers invalid queryid: '.$queryid.
                            ' for host: '.$homeserver.'in domain '.$udom);
                   return ($outcome,$results);
               }
               my $response = &get_query_reply($queryid);
               my $maxtries = 5;
               if ($count > 100) {
                   $maxtries = 1+int($count/20);
               }
               my $tries = 1;
               while (($response=~/^timeout/) && ($tries <= $maxtries)) {
                   $response = &get_query_reply($queryid);
                   $tries ++;
               }
               if ($response eq '') {
                   $results = {};
                   foreach my $key (keys(%{$users})) {
                       my ($uname,$id);
                       if ($caller eq 'id') {
                           $id = $key;
                       } else {
                           $uname = $key;
                       }
                       my ($resp,%info) = &get_instuser($udom,$uname,$id);
                       $outcome = $resp;
                       if ($resp eq 'ok') {
                           %{$results} = (%{$results}, %info);
                       } else {
                           last;
                       }
                   }
               } elsif(!&error($response) && ($response ne 'refused')) {
                   if (($response eq 'unavailable') || ($response eq 'invalid') || ($response eq 'timeout')) {
                       $outcome = $response;
                   } else {
                       ($outcome,my $userdata) = split(/=/,$response,2);
                       if ($outcome eq 'ok') {
                           $results = &thaw_unescape($userdata);
                       }
                   }
               }
           }
       }
       return ($outcome,$results);
   }
   
   sub inst_rulecheck {
       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','autoenroll',
                                     'helpsettings'],$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'};
           $domdefaults{'intauth_cost'} = $domconfig{'defaults'}{'intauth_cost'};
           $domdefaults{'intauth_switch'} = $domconfig{'defaults'}{'intauth_switch'};
           $domdefaults{'intauth_check'} = $domconfig{'defaults'}{'intauth_check'};
       } 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') {
           $domdefaults{'usejsme'} = $domconfig{'coursedefaults'}{'usejsme'};
           $domdefaults{'uselcmath'} = $domconfig{'coursedefaults'}{'uselcmath'};
           if (ref($domconfig{'coursedefaults'}{'postsubmit'}) eq 'HASH') {
               $domdefaults{'postsubmit'} = $domconfig{'coursedefaults'}{'postsubmit'}{'client'};
           }
           foreach my $type (@coursetypes) {
               if (ref($domconfig{'coursedefaults'}{'coursecredits'}) eq 'HASH') {
                   unless ($type eq 'community') {
                       $domdefaults{$type.'credits'} = $domconfig{'coursedefaults'}{'coursecredits'}{$type};
                   }
               }
               if (ref($domconfig{'coursedefaults'}{'uploadquota'}) eq 'HASH') {
                   $domdefaults{$type.'quota'} = $domconfig{'coursedefaults'}{'uploadquota'}{$type};
               }
               if ($domdefaults{'postsubmit'} eq 'on') {
                   if (ref($domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}) eq 'HASH') {
                       $domdefaults{$type.'postsubtimeout'} =
                           $domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}{$type};
                   }
               }
           }
           if (ref($domconfig{'coursedefaults'}{'canclone'}) eq 'HASH') {
               if (ref($domconfig{'coursedefaults'}{'canclone'}{'instcode'}) eq 'ARRAY') {
                   my @clonecodes = @{$domconfig{'coursedefaults'}{'canclone'}{'instcode'}};
                   if (@clonecodes) {
                       $domdefaults{'canclone'} = join('+',@clonecodes);
                   }
               }
           } elsif ($domconfig{'coursedefaults'}{'canclone'}) {
               $domdefaults{'canclone'}=$domconfig{'coursedefaults'}{'canclone'};
           }
           if ($domconfig{'coursedefaults'}{'texengine'}) {
               $domdefaults{'texengine'} = $domconfig{'coursedefaults'}{'texengine'};
           }
       }
       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{'usersessions'}{'offloadnow'}) eq 'HASH') {
               $domdefaults{'offloadnow'} = $domconfig{'usersessions'}{'offloadnow'};
           }
       }
       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'};
           }
       }
       if (ref($domconfig{'autoenroll'}) eq 'HASH') {
           $domdefaults{'autofailsafe'} = $domconfig{'autoenroll'}{'autofailsafe'};
       }
       if (ref($domconfig{'helpsettings'}) eq 'HASH') {
           $domdefaults{'submitbugs'} = $domconfig{'helpsettings'}{'submitbugs'};
           if (ref($domconfig{'helpsettings'}{'adhoc'}) eq 'HASH') {
               $domdefaults{'adhocroles'} = $domconfig{'helpsettings'}{'adhoc'};
           }
       }
       &do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);
       return %domdefaults;
   }
   
   sub get_dom_cats {
       my ($dom) = @_;
       return unless (&domain($dom));
       my ($cats,$cached)=&is_cached_new('cats',$dom);
       unless (defined($cached)) {
           my %domconfig = &get_dom('configuration',['coursecategories'],$dom);
           if (ref($domconfig{'coursecategories'}) eq 'HASH') {
               if (ref($domconfig{'coursecategories'}{'cats'}) eq 'HASH') {
                   %{$cats} = %{$domconfig{'coursecategories'}{'cats'}};
               } else {
                   $cats = {};
               }
           } else {
               $cats = {};
           }
           &Apache::lonnet::do_cache_new('cats',$dom,$cats,3600);
       }
       return $cats;
   }
   
   sub get_dom_instcats {
       my ($dom) = @_;
       return unless (&domain($dom));
       my ($instcats,$cached)=&is_cached_new('instcats',$dom);
       unless (defined($cached)) {
           my (%coursecodes,%codes,@codetitles,%cat_titles,%cat_order);
           my $totcodes = &retrieve_instcodes(\%coursecodes,$dom);
           if ($totcodes > 0) {
               my $caller = 'global';
               if (&auto_instcode_format($caller,$dom,\%coursecodes,\%codes,
                                         \@codetitles,\%cat_titles,\%cat_order) eq 'ok') {
                   $instcats = {
                                   codes => \%codes,
                                   codetitles => \@codetitles,
                                   cat_titles => \%cat_titles,
                                   cat_order => \%cat_order,
                               };
                   &do_cache_new('instcats',$dom,$instcats,3600);
               }
           }
       }
       return $instcats;
   }
   
   sub retrieve_instcodes {
       my ($coursecodes,$dom) = @_;
       my $totcodes;
       my %courses = &courseiddump($dom,'.',1,'.','.','.',undef,undef,'Course');
       foreach my $course (keys(%courses)) {
           if (ref($courses{$course}) eq 'HASH') {
               if ($courses{$course}{'inst_code'} ne '') {
                   $$coursecodes{$course} = $courses{$course}{'inst_code'};
                   $totcodes ++;
               }
           }
       }
       return $totcodes;
   }
   
   # --------------------------------------------- Get domain config for passwords
   
   sub get_passwdconf {
       my ($dom) = @_;
       my (%passwdconf,$gotconf,$lookup);
       my ($result,$cached)=&is_cached_new('passwdconf',$dom);
       if (defined($cached)) {
           if (ref($result) eq 'HASH') {
               %passwdconf = %{$result};
               $gotconf = 1;
           }
       }
       unless ($gotconf) {
           my %domconfig = &get_dom('configuration',['passwords'],$dom);
           if (ref($domconfig{'passwords'}) eq 'HASH') {
               %passwdconf = %{$domconfig{'passwords'}};
           }
           my $cachetime = 24*60*60;
           &do_cache_new('passwdconf',$dom,\%passwdconf,$cachetime);
       }
       return %passwdconf;
   }
   
   sub course_portal_url {
       my ($cnum,$cdom) = @_;
       my $chome = &homeserver($cnum,$cdom);
       my $hostname = &hostname($chome);
       my $protocol = $protocol{$chome};
       $protocol = 'http' if ($protocol ne 'https');
       my %domdefaults = &get_domain_defaults($cdom);
       my $firsturl;
       if ($domdefaults{'portal_def'}) {
           $firsturl = $domdefaults{'portal_def'};
     } else {      } else {
         &logthis("put_dom failed - no primary domain server for $udom");          $firsturl = $protocol.'://'.$hostname;
     }      }
       return $firsturl;
 }  }
   
 # --------------------------------------------------- Assign a key to a student  # --------------------------------------------------- Assign a key to a student
Line 798  sub assign_access_key { Line 2591  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 990  my %remembered; Line 2783  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);      my $remembered_id=$name.':'.$id;
       $id=&make_key($name,$id);
     $memcache->delete($id);      $memcache->delete($id);
     delete($remembered{$id});      delete($remembered{$remembered_id});
     delete($accessed{$id});      delete($accessed{$remembered_id});
 }  }
   
 sub is_cached_new {  sub is_cached_new {
     my ($name,$id,$debug) = @_;      my ($name,$id,$debug) = @_;
     $id=&escape($name.':'.$id);      my $remembered_id=$name.':'.$id; # this is to avoid make_key (which is slow) for 
     if (exists($remembered{$id})) {                                       # keys in %remembered hash, which persists for
  if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); }                                       # duration of request (no restriction on key length).
  $accessed{$id}=[&gettimeofday()];      if (exists($remembered{$remembered_id})) {
    if ($debug) { &Apache::lonnet::logthis("Early return $remembered_id of $remembered{$remembered_id} "); }
    $accessed{$remembered_id}=[&gettimeofday()];
  $hits++;   $hits++;
  return ($remembered{$id},1);   return ($remembered{$remembered_id},1);
     }      }
       $id=&make_key($name,$id);
     my $value = $memcache->get($id);      my $value = $memcache->get($id);
     if (!(defined($value))) {      if (!(defined($value))) {
  if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); }   if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); }
Line 1017  sub is_cached_new { Line 2823  sub is_cached_new {
  if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); }   if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); }
  $value=undef;   $value=undef;
     }      }
     &make_room($id,$value,$debug);      &make_room($remembered_id,$value,$debug);
     if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); }      if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); }
     return ($value,1);      return ($value,1);
 }  }
   
 sub do_cache_new {  sub do_cache_new {
     my ($name,$id,$value,$time,$debug) = @_;      my ($name,$id,$value,$time,$debug) = @_;
     $id=&escape($name.':'.$id);      my $remembered_id=$name.':'.$id;
       $id=&make_key($name,$id);
     my $setvalue=$value;      my $setvalue=$value;
     if (!defined($setvalue)) {      if (!defined($setvalue)) {
  $setvalue='__undef__';   $setvalue='__undef__';
Line 1033  sub do_cache_new { Line 2840  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($remembered_id,$value,$debug);
     return $value;      return $value;
 }  }
   
 sub make_room {  sub make_room {
     my ($id,$value,$debug)=@_;      my ($remembered_id,$value,$debug)=@_;
     $remembered{$id}=$value;  
       $remembered{$remembered_id}= (ref($value)) ? &Storable::dclone($value)
                                       : $value;
     if ($to_remember<0) { return; }      if ($to_remember<0) { return; }
     $accessed{$id}=[&gettimeofday()];      $accessed{$remembered_id}=[&gettimeofday()];
     if (scalar(keys(%remembered)) <= $to_remember) { return; }      if (scalar(keys(%remembered)) <= $to_remember) { return; }
     my $to_kick;      my $to_kick;
     my $max_time=0;      my $max_time=0;
Line 1070  sub purge_remembered { Line 2883  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 1147  sub chatsend { Line 2970  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 1194  sub subscribe { Line 3026  sub subscribe {
 sub repcopy {  sub repcopy {
     my $filename=shift;      my $filename=shift;
     $filename=~s/\/+/\//g;      $filename=~s/\/+/\//g;
     if ($filename=~m|^/home/httpd/html/adm/|) { return 'ok'; }      my $londocroot = $perlvar{'lonDocRoot'};
     if ($filename=~m|^/home/httpd/html/lonUsers/|) { return 'ok'; }      if ($filename=~m{^\Q$londocroot/adm/\E}) { return 'ok'; }
     if ($filename=~m|^/home/httpd/html/userfiles/| or      if ($filename=~m{^\Q/home/httpd/lonUsers/\E}) { return 'ok'; }
  $filename=~m -^/*(uploaded|editupload)/-) {       if ($filename=~m{^\Q$londocroot/userfiles/\E} or
    $filename=~m{^/*(uploaded|editupload)/}) {
  return &repcopy_userfile($filename);   return &repcopy_userfile($filename);
     }      }
     $filename=~s/[\n\r]//g;      $filename=~s/[\n\r]//g;
Line 1224  sub repcopy { Line 3057  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 1261  sub repcopy { Line 3094  sub repcopy {
     }      }
 }  }
   
   # ------------------------------------------------- Unsubscribe from a resource
   
   sub unsubscribe {
       my ($fname) = @_;
       my $answer;
       if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return $answer; }
       $fname=~s/[\n\r]//g;
       my $author=$fname;
       $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
       my ($udom,$uname)=split(/\//,$author);
       my $home=homeserver($uname,$udom);
       if ($home eq 'no_host') {
           $answer = 'no_host';
       } elsif (grep { $_ eq $home } &current_machine_ids()) {
           $answer = 'home';
       } else {
           $answer = reply("unsub:$fname",$home);
       }
       return $answer;
   }
   
 # ------------------------------------------------ Get server side include body  # ------------------------------------------------ Get server side include body
 sub ssi_body {  sub ssi_body {
     my ($filelink,%form)=@_;      my ($filelink,%form)=@_;
     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;
       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|//(\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
Line 1286  sub absolute_url { Line 3151  sub absolute_url {
     return $protocol.$host_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 ($request,$response);
     my $ua=new LWP::UserAgent;  
       
     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',&absolute_url().$fn);        $request=new HTTP::Request('POST',&absolute_url().$fn);
       $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form));        $request->content(join('&',map {
               my $name = escape($_);
               "$name=" . ( ref($form{$_}) eq 'ARRAY'
               ? join("&$name=", map {escape($_) } @{$form{$_}})
               : &escape($form{$_}) );
           } keys(%form)));
     } else {      } else {
       $request=new HTTP::Request('GET',&absolute_url().$fn);        $request=new HTTP::Request('GET',&absolute_url().$fn);
     }      }
   
     $request->header(Cookie => $ENV{'HTTP_COOKIE'});      $request->header(Cookie => $ENV{'HTTP_COOKIE'});
     my $response=$ua->request($request);  
   
     return $response->content;      if (($env{'request.course.id'}) &&
           ($form{'grade_courseid'} eq $env{'request.course.id'}) &&
           ($form{'grade_username'} ne '') && ($form{'grade_domain'} ne '') &&
           ($form{'grade_symb'} ne '') &&
           (&Apache::lonnet::allowed('mgr',$env{'request.course.id'}.
                                    ($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:'')))) {
           if (LWP::UserAgent->VERSION >= 5.834) {
               my $ua=new LWP::UserAgent;
               $ua->local_address('127.0.0.1');
               $response = $ua->request($request);
           } else {
               {
                   require LWP::Protocol::http;
                   local @LWP::Protocol::http::EXTRA_SOCK_OPTS = (LocalAddr => '127.0.0.1');
                   my $ua=new LWP::UserAgent;
                   $response = $ua->request($request);
                   @LWP::Protocol::http::EXTRA_SOCK_OPTS = ();
               }
           }
       } else {
           my $ua=new LWP::UserAgent;
           $response = $ua->request($request);
       }
       if (wantarray) {
    return ($response->content, $response);
       } else {
    return $response->content;
       }
 }  }
   
 sub externalssi {  sub externalssi {
Line 1314  sub externalssi { Line 3217  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;
       }
   }
   
   # If the local copy of a replicated resource is outdated, trigger a
   # connection from the homeserver to flush the delayed queue. If no update
   # happens, remove local copies of outdated resource (and corresponding
   # metadata file).
   
   sub remove_stale_resfile {
       my ($url) = @_;
       my $removed;
       if ($url=~m{^/res/($match_domain)/($match_username)/}) {
           my $audom = $1;
           my $auname = $2;
           unless (($url =~ /\.\d+\.\w+$/) || ($url =~ m{^/res/lib/templates/})) {
               my $homeserver = &homeserver($auname,$audom);
               unless (($homeserver eq 'no_host') ||
                       (grep { $_ eq $homeserver } &current_machine_ids())) {
                   my $fname = &filelocation('',$url);
                   if (-e $fname) {
                       my $hostname = &hostname($homeserver);
                       if ($hostname) {
                           my $protocol = $protocol{$homeserver};
                           $protocol = 'http' if ($protocol ne 'https');
                           my $uri = $protocol.'://'.$hostname.'/raw/'.&declutter($url);
                           my $ua=new LWP::UserAgent;
                           $ua->timeout(5);
                           my $request=new HTTP::Request('HEAD',$uri);
                           my $response=$ua->request($request);
                           if ($response->is_success()) {
                               my $remmodtime = &HTTP::Date::str2time( $response->header('Last-modified') );
                               my $locmodtime = (stat($fname))[9];
                               if ($locmodtime < $remmodtime) {
                                   my $stale;
                                   my $answer = &reply('pong',$homeserver);
                                   if ($answer eq $homeserver.':'.$perlvar{'lonHostID'}) {
                                       sleep(0.2);
                                       $locmodtime = (stat($fname))[9];
                                       if ($locmodtime < $remmodtime) {
                                           my $posstransfer = $fname.'.in.transfer';
                                           if ((-e $posstransfer) && ($remmodtime < (stat($posstransfer))[9])) {
                                               $removed = 1;
                                           } else {
                                               $stale = 1;
                                           }
                                       } else {
                                           $removed = 1;
                                       }
                                   } else {
                                       $stale = 1;
                                   }
                                   if ($stale) {
                                       if (unlink($fname)) {
                                           if ($uri!~/\.meta$/) {
                                               if (-e $fname.'.meta') {
                                                   unlink($fname.'.meta');
                                               }
                                           }
                                           my $unsubresult = &unsubscribe($fname);
                                           unless ($unsubresult eq 'ok') {
                                               &logthis("no unsub of $fname from $homeserver, reason: $unsubresult");
                                           }
                                           $removed = 1;
                                       }
                                   }
                               }
                           }
                       }
                   }
               }
           }
       }
       return $removed;
 }  }
   
 # -------------------------------- Allow a /uploaded/ URI to be vouched for  # -------------------------------- Allow a /uploaded/ URI to be vouched for
Line 1327  sub allowuploaded { Line 3306  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{^/ext/}) && ($symb ne '')) {
                       my ($map,$id,$res) = &decode_symb($symb);
                       if ($map =~ /\.page$/) {
                           $incourse = 1;
                           if ($env{'form.forceedit'}) {
                               $forceview = 1;
                               $cfile = $map;
                           } else {
                               $forceedit = 1;
                               $cfile =  '/adm/wrapper'.$resurl;
                           }
                       }
                   } elsif ($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) {
                       $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 =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) && ($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'};
                       my $escfile = &unescape($cfile);
                       if ($escfile =~ m{^/adm/$cdom/$cnum/\d+/ext\.tool$}) {
                           $cfile = '/adm/wrapper'.$escfile;
                       } else {
                           $escfile =~ s{^http://}{};
                           $cfile = &escape("/adm/wrapper/ext/$escfile");
                       }
                   }
               } 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 1335  sub allowuploaded { Line 3605  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 1361  sub allowuploaded { Line 3633  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 1384  sub process_coursefile { Line 3657  sub process_coursefile {
                                  $home);                                   $home);
             }              }
         } elsif ($action eq 'uploaddoc') {          } elsif ($action eq 'uploaddoc') {
             open(my $fh,'>'.$filepath.'/'.$fname);              open(my $fh,'>',$filepath.'/'.$fname);
             print $fh $env{'form.'.$source};              print $fh $env{'form.'.$source};
             close($fh);              close($fh);
             if ($parser eq 'parse') {              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 1435  sub store_edited_file { Line 3715  sub store_edited_file {
     ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|);      ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|);
     $fpath=$docudom.'/'.$docuname.'/'.$fpath;      $fpath=$docudom.'/'.$docuname.'/'.$fpath;
     my $filepath = &build_filepath($fpath);      my $filepath = &build_filepath($fpath);
     open(my $fh,'>'.$filepath.'/'.$fname);      open(my $fh,'>',$filepath.'/'.$fname);
     print $fh $content;      print $fh $content;
     close($fh);      close($fh);
     my $home=&homeserver($docuname,$docudom);      my $home=&homeserver($docuname,$docudom);
Line 1460  sub clean_filename { Line 3740  sub clean_filename {
     }      }
 # Replace spaces by underscores  # Replace spaces by underscores
     $fname=~s/\s+/\_/g;      $fname=~s/\s+/\_/g;
   # Transliterate non-ascii text to ascii
       my $lang = &Apache::lonlocal::current_language();
       $fname = &LONCAPA::transliterate::fname_to_ascii($fname,$lang);
 # 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
Line 1468  sub clean_filename { Line 3751  sub clean_filename {
     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, scantron 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) or
 #  #                  if context is 'scantron', $parser is hashref of csv column mapping
   #                  (e.g.,{ PaperID => 0, LastName => 1, FirstName => 2, ID => 3,
   #                          Section => 4, CODE => 5, FirstQuestion => 9 }).
   #        $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});      # If filename now begins with a . prepend unix timestamp _ milliseconds
     if (($formname eq 'screenshot') && ($subdir eq 'helprequests')) { #files uploaded to help request form are handled differently      if ($fname =~ /^\./) {
           my ($s,$usec) = &gettimeofday();
           while (length($usec) < 6) {
               $usec = '0'.$usec;
           }
           $fname = $s.'_'.substr($usec,0,3).$fname;
       }
       # Files uploaded to help request form, or uploaded to "create course" page are handled differently
       if ((($formname eq 'screenshot') && ($subdir eq 'helprequests')) ||
           (($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) ||
            ($context eq 'existingfile') || ($context eq 'canceloverwrite')) {
         my $now = time;          my $now = time;
         my $filepath = 'tmp/helprequests/'.$now;          my $filepath;
         my @parts=split(/\//,$filepath);          if (($formname eq 'screenshot') && ($subdir eq 'helprequests')) {
         my $fullpath = $perlvar{'lonDaemons'};               $filepath = 'tmp/helprequests/'.$now;
         for (my $i=0;$i<@parts;$i++) {          } elsif (($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) {
             $fullpath .= '/'.$parts[$i];               $filepath = 'tmp/addcourse/'.$destudom.'/web/'.$env{'user.name'}.
             if ((-e $fullpath)!=1) {                           '_'.$env{'user.domain'}.'/pending';
                 mkdir($fullpath,0777);          } elsif (($context eq 'existingfile') || ($context eq 'canceloverwrite')) {
               my ($docuname,$docudom);
               if ($destudom =~ /^$match_domain$/) {
                   $docudom = $destudom;
               } else {
                   $docudom = $env{'user.domain'};
               }
               if ($destuname =~ /^$match_username$/) { 
                   $docuname = $destuname;
               } else {
                   $docuname = $env{'user.name'};
               }
               if (exists($env{'form.group'})) {
                   $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
                   $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
               }
               $filepath = 'tmp/overwrites/'.$docudom.'/'.$docuname.'/'.$subdir;
               if ($context eq 'canceloverwrite') {
                   my $tempfile =  $perlvar{'lonDaemons'}.'/'.$filepath.'/'.$fname;
                   if (-e  $tempfile) {
                       my @info = stat($tempfile);
                       if ($info[9] eq $env{'form.timestamp'}) {
                           unlink($tempfile);
                       }
                   }
                   return;
             }              }
         }          }
         open(my $fh,'>'.$fullpath.'/'.$fname);          # Create the directory if not present
         print $fh $env{'form.'.$formname};  
         close($fh);  
         return $fullpath.'/'.$fname;  
     } elsif (($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) { #files uploaded to create course page are handled differently  
         my $filepath = 'tmp/addcourse/'.$destudom.'/web/'.$env{'user.name'}.  
                        '_'.$env{'user.domain'}.'/pending';  
         my @parts=split(/\//,$filepath);          my @parts=split(/\//,$filepath);
         my $fullpath = $perlvar{'lonDaemons'};          my $fullpath = $perlvar{'lonDaemons'};
         for (my $i=0;$i<@parts;$i++) {          for (my $i=0;$i<@parts;$i++) {
Line 1514  sub userfileupload { Line 3881  sub userfileupload {
                 mkdir($fullpath,0777);                  mkdir($fullpath,0777);
             }              }
         }          }
         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 1571  sub finishuserfileupload { Line 3953  sub finishuserfileupload {
     mkdir($filepath,0777);      mkdir($filepath,0777);
         }          }
     }      }
   
 # Save the file  # Save the file
     {      {
  if (!open(FH,'>'.$filepath.'/'.$file)) {   if (!open(FH,'>',$filepath.'/'.$file)) {
     &logthis('Failed to create '.$filepath.'/'.$file);      &logthis('Failed to create '.$filepath.'/'.$file);
     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 (($context ne 'scantron') && ($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); 
               }
           }
       } elsif (($context eq 'scantron') && (ref($parser) eq 'HASH')) {
           my $format = $env{'form.scantron_format'};
           &bubblesheet_converter($docudom,$filepath.'/'.$file,$parser,$format);
       }
       if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {
           my $input = $filepath.'/'.$file;
           my $output = $filepath.'/'.'tn-'.$file;
           my $thumbsize = $thumbwidth.'x'.$thumbheight;
           my @args = ('convert','-sample',$thumbsize,$input,$output);
           system({$args[0]} @args);
           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 1605  sub finishuserfileupload { Line 4043  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 1624  sub extract_embedded_items { Line 4063  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 1653  sub extract_embedded_items { Line 4117  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 1662  sub extract_embedded_items { Line 4129  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 1682  sub extract_embedded_items { Line 4159  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 1702  sub extract_embedded_items { Line 4206  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 1716  sub add_filetype { Line 4237  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 bubblesheet_converter {
       my ($cdom,$fullpath,$config,$format) = @_;
       if ((&domain($cdom) ne '') &&
           ($fullpath =~ m{^\Q$perlvar{'lonDocRoot'}/userfiles/$cdom/\E$match_courseid/scantron_orig}) &&
           (-e $fullpath) && (ref($config) eq 'HASH') && ($format ne '')) {
           my (%csvcols,%csvoptions);
           if (ref($config->{'fields'}) eq 'HASH') {
               %csvcols = %{$config->{'fields'}};
           }
           if (ref($config->{'options'}) eq 'HASH') {
               %csvoptions = %{$config->{'options'}};
           }
           my %csvbynum = reverse(%csvcols);
           my %scantronconf = &get_scantron_config($format,$cdom);
           if (keys(%scantronconf)) {
               my %bynum = (
                             $scantronconf{CODEstart} => 'CODEstart',
                             $scantronconf{IDstart}   => 'IDstart',
                             $scantronconf{PaperID}   => 'PaperID',
                             $scantronconf{FirstName} => 'FirstName',
                             $scantronconf{LastName}  => 'LastName',
                             $scantronconf{Qstart}    => 'Qstart',
                           );
               my @ordered;
               foreach my $item (sort { $a <=> $b } keys(%bynum)) {
                   push(@ordered,$bynum{$item});
               }
               my %mapstart = (
                                 CODEstart => 'CODE',
                                 IDstart   => 'ID',
                                 PaperID   => 'PaperID',
                                 FirstName => 'FirstName',
                                 LastName  => 'LastName',
                                 Qstart    => 'FirstQuestion',
                              );
               my %maplength = (
                                 CODEstart => 'CODElength',
                                 IDstart   => 'IDlength',
                                 PaperID   => 'PaperIDlength',
                                 FirstName => 'FirstNamelength',
                                 LastName  => 'LastNamelength',
               );
               if (open(my $fh,'<',$fullpath)) {
                   my $output;
                   my %lettdig = &letter_to_digits();
                   my %diglett = reverse(%lettdig);
                   my $numletts = scalar(keys(%lettdig));
                   my $num = 0;
                   while (my $line=<$fh>) {
                       $num ++;
                       next if (($num == 1) && ($csvoptions{'hdr'} == 1));
                       $line =~ s{[\r\n]+$}{};
                       my %found;
                       my @values = split(/,/,$line);
                       my ($qstart,$record);
                       for (my $i=0; $i<@values; $i++) {
                           if ((($qstart ne '') && ($i > $qstart)) ||
                               ($csvbynum{$i} eq 'FirstQuestion')) {
                               if ($values[$i] eq '') {
                                   $values[$i] = $scantronconf{'Qoff'};
                               } elsif ($scantronconf{'Qon'} eq 'number') {
                                   if ($values[$i] =~ /^[A-Ja-j]$/) {
                                       $values[$i] = $lettdig{uc($values[$i])};
                                   }
                               } elsif ($scantronconf{'Qon'} eq 'letter') {
                                   if ($values[$i] =~ /^[0-9]$/) {
                                       $values[$i] = $diglett{$values[$i]};
                                   }
                               } else {
                                   if ($values[$i] =~ /^[0-9A-Ja-j]$/) {
                                       my $digit;
                                       if ($values[$i] =~ /^[A-Ja-j]$/) {
                                           $digit = $lettdig{uc($values[$i])}-1;
                                           if ($values[$i] eq 'J') {
                                               $digit += $numletts;
                                           }
                                       } elsif ($values[$i] =~ /^[0-9]$/) {
                                           $digit = $values[$i]-1;
                                           if ($values[$i] eq '0') {
                                               $digit += $numletts;
                                           }
                                       }
                                       my $qval='';
                                       for (my $j=0; $j<$scantronconf{'Qlength'}; $j++) {
                                           if ($j == $digit) {
                                               $qval .= $scantronconf{'Qon'};
                                           } else {
                                               $qval .= $scantronconf{'Qoff'};
                                           }
                                       }
                                       $values[$i] = $qval;
                                   }
                               }
                               if (length($values[$i]) > $scantronconf{'Qlength'}) {
                                   $values[$i] = substr($values[$i],0,$scantronconf{'Qlength'});
                               }
                               my $numblank = $scantronconf{'Qlength'} - length($values[$i]);
                               if ($numblank > 0) {
                                    $values[$i] .= ($scantronconf{'Qoff'} x $numblank);
                               }
                               if ($csvbynum{$i} eq 'FirstQuestion') {
                                   $qstart = $i;
                                   $found{$csvbynum{$i}} = $values[$i];
                               } else {
                                   $found{'FirstQuestion'} .= $values[$i];
                               }
                           } elsif (exists($csvbynum{$i})) {
                               if ($csvoptions{'rem'}) {
                                   $values[$i] =~ s/^\s+//;
                               }
                               if (($csvbynum{$i} eq 'PaperID') && ($csvoptions{'pad'})) {
                                   while (length($values[$i]) < $scantronconf{$maplength{$csvbynum{$i}}}) {
                                       $values[$i] = '0'.$values[$i];
                                   }
                               }
                               $found{$csvbynum{$i}} = $values[$i];
                           }
                       }
                       foreach my $item (@ordered) {
                           my $currlength = 1+length($record);
                           my $numspaces = $scantronconf{$item} - $currlength;
                           if ($numspaces > 0) {
                               $record .= (' ' x $numspaces);
                           }
                           if (($mapstart{$item} ne '') && (exists($found{$mapstart{$item}}))) {
                               unless ($item eq 'Qstart') {
                                   if (length($found{$mapstart{$item}}) > $scantronconf{$maplength{$item}}) {
                                       $found{$mapstart{$item}} = substr($found{$mapstart{$item}},0,$scantronconf{$maplength{$item}});
                                   }
                               }
                               $record .= $found{$mapstart{$item}};
                           }
                       }
                       $output .= "$record\n";
                   }
                   close($fh);
                   if ($output) {
                       if (open(my $fh,'>',$fullpath)) {
                           print $fh $output;
                           close($fh);
                       }
                   }
               }
           }
           return;
       }
   }
   
   sub letter_to_digits {
       my %lettdig = (
                       A => 1,
                       B => 2,
                       C => 3,
                       D => 4,
                       E => 5,
                       F => 6,
                       G => 7,
                       H => 8,
                       I => 9,
                       J => 0,
                     );
       return %lettdig;
   }
   
   sub get_scantron_config {
       my ($which,$cdom) = @_;
       my @lines = &get_scantronformat_file($cdom);
       my %config;
       #FIXME probably should move to XML it has already gotten a bit much now
       foreach my $line (@lines) {
           my ($name,$descrip)=split(/:/,$line);
           if ($name ne $which ) { next; }
           chomp($line);
           my @config=split(/:/,$line);
           $config{'name'}=$config[0];
           $config{'description'}=$config[1];
           $config{'CODElocation'}=$config[2];
           $config{'CODEstart'}=$config[3];
           $config{'CODElength'}=$config[4];
           $config{'IDstart'}=$config[5];
           $config{'IDlength'}=$config[6];
           $config{'Qstart'}=$config[7];
           $config{'Qlength'}=$config[8];
           $config{'Qoff'}=$config[9];
           $config{'Qon'}=$config[10];
           $config{'PaperID'}=$config[11];
           $config{'PaperIDlength'}=$config[12];
           $config{'FirstName'}=$config[13];
           $config{'FirstNamelength'}=$config[14];
           $config{'LastName'}=$config[15];
           $config{'LastNamelength'}=$config[16];
           $config{'BubblesPerRow'}=$config[17];
           last;
       }
       return %config;
   }
   
   sub get_scantronformat_file {
       my ($cdom) = @_;
       if ($cdom eq '') {
           $cdom= $env{'course.'.$env{'request.course.id'}.'.domain'};
       }
       my %domconfig = &get_dom('configuration',['scantron'],$cdom);
       my $gottab = 0;
       my @lines;
       if (ref($domconfig{'scantron'}) eq 'HASH') {
           if ($domconfig{'scantron'}{'scantronformat'} ne '') {
               my $formatfile = &getfile($perlvar{'lonDocRoot'}.$domconfig{'scantron'}{'scantronformat'});
               if ($formatfile ne '-1') {
                   @lines = split("\n",$formatfile,-1);
                   $gottab = 1;
               }
           }
       }
       if (!$gottab) {
           my $confname = $cdom.'-domainconfig';
           my $default = $perlvar{'lonDocRoot'}.'/res/'.$cdom.'/'.$confname.'/default.tab';
           my $formatfile = &getfile($default);
           if ($formatfile ne '-1') {
               @lines = split("\n",$formatfile,-1);
               $gottab = 1;
           }
       }
       if (!$gottab) {
           my @domains = &current_machine_domains();
           if (grep(/^\Q$cdom\E$/,@domains)) {
               if (open(my $fh,'<',$perlvar{'lonTabDir'}.'/scantronformat.tab')) {
                   @lines = <$fh>;
                   close($fh);
               }
           } else {
               if (open(my $fh,'<',$perlvar{'lonTabDir'}.'/default_scantronformat.tab')) {
                   @lines = <$fh>;
                   close($fh);
               }
           }
       }
       return @lines;
   }
   
 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);    
     my $result = &reply("removeuserfile:$docudom/$docuname/$fname",$home);      my $result = &reply("removeuserfile:$docudom/$docuname/$fname",$home);
     if ($result eq 'ok') {      if ($result eq 'ok') {
         if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) {          if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) {
             my $metafile = $fname.'.meta';              my $metafile = $fname.'.meta';
             my $metaresult = &removeuserfile($docuname,$docudom,$metafile);               my $metaresult = &removeuserfile($docuname,$docudom,$metafile); 
     my $url = "/uploaded/$docudom/$docuname/$fname";      my $url = "/uploaded/$docudom/$docuname/$fname";
             my ($file,$group) = (&parse_portfolio_url($url))[3,4];              my ($file,$group) = (&parse_portfolio_url($url))[3,4];   
             my $sqlresult =               my $sqlresult = 
                 &update_portfolio_table($docuname,$docudom,$file,                  &update_portfolio_table($docuname,$docudom,$file,
                                         'portfolio_metadata',$group,                                          'portfolio_metadata',$group,
Line 1792  sub flushcourselogs { Line 4568  sub flushcourselogs {
 # times and course titles for all courseids  # times and course titles for all courseids
 #  #
     my %courseidbuffer=();      my %courseidbuffer=();
     foreach my $crsid (keys %courselogs) {      foreach my $crsid (keys(%courselogs)) {
         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 1805  sub flushcourselogs { Line 4581  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}).':'.&escape($coursetypebuf{$crsid});              'type'        => $coursetypebuf{$crsid},
         } else {              'owner'       => $courseownerbuf{$crsid},
            $courseidbuffer{$coursehombuf{$crsid}}=          };
  &escape($crsid).'='.&escape($coursedescrbuf{$crsid}).  
                          ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}).':'.&escape($coursetypebuf{$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 my $crsid (keys(%courseidbuffer)) {      foreach my $crs_home (keys(%courseidbuffer)) {
         &courseidput($hostdom{$crsid},$courseidbuffer{$crsid},$crsid);          my $response = &courseidput(&host_domain($crs_home),
                                       $courseidbuffer{$crs_home},
                                       $crs_home,'timeonly');
     }      }
 #  #
 # File accesses  # File accesses
Line 1843  sub flushcourselogs { Line 4618  sub flushcourselogs {
             my $result = &inc('nohist_accesscount',\%temphash,$dom,$name);              my $result = &inc('nohist_accesscount',\%temphash,$dom,$name);
             if ($result eq 'ok') {              if ($result eq 'ok') {
                 delete $accesshash{$entry};                  delete $accesshash{$entry};
             } elsif ($result eq 'unknown_cmd') {  
                 # Target server has old code running on it.  
                 my %temphash=($entry => $value);  
                 if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {  
                     delete $accesshash{$entry};  
                 }  
             }              }
         } else {          } else {
             my ($dom,$name) = ($entry=~m{___($match_domain)/($match_name)/(.*)___(\w+)$});              my ($dom,$name) = ($entry=~m{___($match_domain)/($match_name)/(.*)___(\w+)$});
               if (($dom eq 'uploaded') || ($dom eq 'adm')) { next; }
             my %temphash=($entry => $accesshash{$entry});              my %temphash=($entry => $accesshash{$entry});
             if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {              if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {
                 delete $accesshash{$entry};                  delete $accesshash{$entry};
Line 1872  sub flushcourselogs { Line 4642  sub flushcourselogs {
         }          }
     }      }
 #  #
 # Reverse lookup of domain roles (dc, ad, li, sc, au)  # Reverse lookup of domain roles (dc, ad, li, sc, dh, da, 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 1887  sub flushcourselogs { Line 4657  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;
             if ($hostdom{$tryserver} eq $dom) {          if (defined(&domain($dom,'primary'))) {
                 unless (&reply('domroleput:'.$dom.':'.              my $primary=&domain($dom,'primary');
                   $domrolebuffer{$dom},$tryserver) eq 'ok') {              my $hostname=&hostname($primary);
                     &logthis('Put of domain roles failed for '.$dom.' and  '.$tryserver);              $servers{$primary} = $hostname;
                 }          } else {
             }              %servers = &get_servers($dom,'library');
           }
    foreach my $tryserver (keys(%servers)) {
       if (&reply('domroleput:'.$dom.':'.
                  $domrolebuffer{$dom},$tryserver) eq 'ok') {
           last;
       } else {
    &logthis('Put of domain roles failed for '.$dom.' and  '.$tryserver);
       }
         }          }
     }      }
     $dumpcount++;      $dumpcount++;
Line 1931  sub courseacclog { Line 4709  sub courseacclog {
     my $fnsymb=shift;      my $fnsymb=shift;
     unless ($env{'request.course.id'}) { return ''; }      unless ($env{'request.course.id'}) { return ''; }
     my $what=$fnsymb.':'.$env{'user.name'}.':'.$env{'user.domain'};      my $what=$fnsymb.':'.$env{'user.name'}.':'.$env{'user.domain'};
     if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|task|page)$/) {      if ($fnsymb=~/$LONCAPA::assess_re/) {
         $what.=':POST';          $what.=':POST';
         # FIXME: Probably ought to escape things....          # FIXME: Probably ought to escape things....
  foreach my $key (keys(%env)) {   foreach my $key (keys(%env)) {
             if ($key=~/^form\.(.*)/) {              if ($key=~/^form\.(.*)/) {
  $what.=':'.$1.'='.$env{$key};                  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 1958  sub countacc { Line 4741  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 1970  sub linklog { Line 4759  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|dh|da)/ ) {
        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 1993  sub userrolelog { Line 4797  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 my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {      foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
  $nothide{join(':',split(/[\@\:]/,$user))}=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 my $entry (keys %dumphash) {      my %privileged;
       foreach my $entry (keys(%dumphash)) {
  my ($tend,$tstart)=split(/\:/,$dumphash{$entry});   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(/\:/,$entry);          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 ($section) { $key.=' (Sec/Grp '.$section.')'; }              if ($section) { $role .= ':'.$section; }
         if ($returnhash{$key}) {              if ($returnhash{$role}) {
     $returnhash{$key}.=','.$username.':'.$domain;                  $returnhash{$role}.=','.$username.':'.$domain;
               } else {
                   $returnhash{$role}=$username.':'.$domain;
               }
         } else {          } else {
             $returnhash{$key}=$username.':'.$domain;              my $key=&plaintext($role,$crstype);
               if ($section) { $key.=' ('.&Apache::lonlocal::mt('Section [_1]',$section).')'; }
               if ($returnhash{$key}) {
           $returnhash{$key}.=','.$username.':'.$domain;
               } else {
                   $returnhash{$key}=$username.':'.$domain;
               }
         }          }
      }      }
     return %returnhash;      return %returnhash;
 }  }
   
 sub get_my_roles {  sub get_my_roles {
     my ($uname,$udom,$types,$roles,$roledoms)=@_;      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;
       my %privileged;
     foreach my $entry (keys(%dumphash)) {      foreach my $entry (keys(%dumphash)) {
  my ($tend,$tstart)=split(/\:/,$dumphash{$entry});          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; }
         my $status = 'active';          my $status = 'active';
         if (($tend) && ($tend<$now)) {          if (($tend) && ($tend<=$now)) {
             $status = 'previous';              $status = 'previous';
         }           } 
         if (($tstart) && ($now<$tstart)) {          if (($tstart) && ($now<$tstart)) {
Line 2053  sub get_my_roles { Line 4963  sub get_my_roles {
                 next;                  next;
             }              }
         }          }
         my ($role,$username,$domain,$section)=split(/\:/,$entry);          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 (ref($roledoms) eq 'ARRAY') {
             if (!grep(/^\Q$domain\E$/,@{$roledoms})) {              if (!grep(/^\Q$domain\E$/,@{$roledoms})) {
                 next;                  next;
Line 2061  sub get_my_roles { Line 4977  sub get_my_roles {
         }          }
         if (ref($roles) eq 'ARRAY') {          if (ref($roles) eq 'ARRAY') {
             if (!grep(/^\Q$role\E$/,@{$roles})) {              if (!grep(/^\Q$role\E$/,@{$roles})) {
                 next;                  if ($role =~ /^cr\//) {
                       if (!grep(/^cr$/,@{$roles})) {
                           next;
                       }
                   } elsif ($role =~ /^gr\//) {
                       if (!grep(/^gr$/,@{$roles})) {
                           next;
                       }
                   } else {
                       next;
                   }
             }              }
         }           }
  $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;          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;
 }  }
   
   sub get_all_adhocroles {
       my ($dom) = @_;
       my @roles_by_num = ();
       my %domdefaults = &get_domain_defaults($dom);
       my (%description,%access_in_dom,%access_info);
       if (ref($domdefaults{'adhocroles'}) eq 'HASH') {
           my $count = 0;
           my %domcurrent = %{$domdefaults{'adhocroles'}};
           my %ordered;
           foreach my $role (sort(keys(%domcurrent))) {
               my ($order,$desc,$access_in_dom);
               if (ref($domcurrent{$role}) eq 'HASH') {
                   $order = $domcurrent{$role}{'order'};
                   $desc = $domcurrent{$role}{'desc'};
                   $access_in_dom{$role} = $domcurrent{$role}{'access'};
                   $access_info{$role} = $domcurrent{$role}{$access_in_dom{$role}};
               }
               if ($order eq '') {
                   $order = $count;
               }
               $ordered{$order} = $role;
               if ($desc ne '') {
                   $description{$role} = $desc;
               } else {
                   $description{$role}= $role;
               }
               $count++;
           }
           foreach my $item (sort {$a <=> $b } (keys(%ordered))) {
               push(@roles_by_num,$ordered{$item});
           }
       }
       return (\@roles_by_num,\%description,\%access_in_dom,\%access_info);
   }
   
   sub get_my_adhocroles {
       my ($cid,$checkreg) = @_;
       my ($cdom,$cnum,%info,@possroles,$description,$roles_by_num);
       if ($env{'request.course.id'} eq $cid) {
           $cdom = $env{'course.'.$cid.'.domain'};
           $cnum = $env{'course.'.$cid.'.num'};
           $info{'internal.coursecode'} = $env{'course.'.$cid.'.internal.coursecode'};
       } elsif ($cid =~ /^($match_domain)_($match_courseid)$/) {
           $cdom = $1;
           $cnum = $2;
           %info = &Apache::lonnet::get('environment',['internal.coursecode'],
                                        $cdom,$cnum);
       }
       if (($info{'internal.coursecode'} ne '') && ($checkreg)) {
           my $user = $env{'user.name'}.':'.$env{'user.domain'};
           my %rosterhash = &get('classlist',[$user],$cdom,$cnum);
           if ($rosterhash{$user} ne '') {
               my $type = (split(/:/,$rosterhash{$user}))[5];
               return ([],{}) if ($type eq 'auto');
           }
       }
       if (($cdom ne '') && ($cnum ne ''))  {
           if (($env{"user.role.dh./$cdom/"}) || ($env{"user.role.da./$cdom/"})) {
               my $then=$env{'user.login.time'};
               my $update=$env{'user.update.time'};
               if (!$update) {
                   $update = $then;
               }
               my @liveroles;
               foreach my $role ('dh','da') {
                   if ($env{"user.role.$role./$cdom/"}) {
                       my ($tstart,$tend)=split(/\./,$env{"user.role.$role./$cdom/"});
                       my $limit = $update;
                       if ($env{'request.role'} eq "$role./$cdom/") {
                           $limit = $then;
                       }
                       my $activerole = 1;
                       if ($tstart && $tstart>$limit) { $activerole = 0; }
                       if ($tend   && $tend  <$limit) { $activerole = 0; }
                       if ($activerole) {
                           push(@liveroles,$role);
                       }
                   }
               }
               if (@liveroles) {
                   if (&homeserver($cnum,$cdom) ne 'no_host') {
                       my ($accessref,$accessinfo,%access_in_dom);
                       ($roles_by_num,$description,$accessref,$accessinfo) = &get_all_adhocroles($cdom);
                       if (ref($roles_by_num) eq 'ARRAY') {
                           if (@{$roles_by_num}) {
                               my %settings;
                               if ($env{'request.course.id'} eq $cid) {
                                   foreach my $envkey (keys(%env)) {
                                       if ($envkey =~ /^\Qcourse.$cid.\E(internal\.adhoc.+)$/) {
                                           $settings{$1} = $env{$envkey};
                                       }
                                   }
                               } else {
                                   %settings = &dump('environment',$cdom,$cnum,'internal\.adhoc');
                               }
                               my %setincrs;
                               if ($settings{'internal.adhocaccess'}) {
                                   map { $setincrs{$_} = 1; } split(/,/,$settings{'internal.adhocaccess'});
                               }
                               my @statuses;
                               if ($env{'environment.inststatus'}) {
                                   @statuses = split(/,/,$env{'environment.inststatus'});
                               }
                               my $user = $env{'user.name'}.':'.$env{'user.domain'};
                               if (ref($accessref) eq 'HASH') {
                                   %access_in_dom = %{$accessref};
                               }
                               foreach my $role (@{$roles_by_num}) {
                                   my ($curraccess,@okstatus,@personnel);
                                   if ($setincrs{$role}) {
                                       ($curraccess,my $rest) = split(/=/,$settings{'internal.adhoc.'.$role});
                                       if ($curraccess eq 'status') {
                                           @okstatus = split(/\&/,$rest);
                                       } elsif (($curraccess eq 'exc') || ($curraccess eq 'inc')) {
                                           @personnel = split(/\&/,$rest);
                                       }
                                   } else {
                                       $curraccess = $access_in_dom{$role};
                                       if (ref($accessinfo) eq 'HASH') {
                                           if ($curraccess eq 'status') {
                                               if (ref($accessinfo->{$role}) eq 'ARRAY') {
                                                   @okstatus = @{$accessinfo->{$role}};
                                               }
                                           } elsif (($curraccess eq 'exc') || ($curraccess eq 'inc')) {
                                               if (ref($accessinfo->{$role}) eq 'ARRAY') {
                                                   @personnel = @{$accessinfo->{$role}};
                                               }
                                           }
                                       }
                                   }
                                   if ($curraccess eq 'none') {
                                       next;
                                   } elsif ($curraccess eq 'all') {
                                       push(@possroles,$role);
                                   } elsif ($curraccess eq 'dh') {
                                       if (grep(/^dh$/,@liveroles)) {
                                           push(@possroles,$role);
                                       } else {
                                           next;
                                       }
                                   } elsif ($curraccess eq 'da') {
                                       if (grep(/^da$/,@liveroles)) {
                                           push(@possroles,$role);
                                       } else {
                                           next;
                                       }
                                   } elsif ($curraccess eq 'status') {
                                       if (@okstatus) {
                                           if (!@statuses) {
                                               if (grep(/^default$/,@okstatus)) {
                                                   push(@possroles,$role);
                                               }
                                           } else {
                                               foreach my $status (@okstatus) {
                                                   if (grep(/^\Q$status\E$/,@statuses)) {
                                                       push(@possroles,$role);
                                                       last;
                                                   }
                                               }
                                           }
                                       }
                                   } elsif (($curraccess eq 'exc') || ($curraccess eq 'inc')) {
                                       if (grep(/^\Q$user\E$/,@personnel)) {
                                           if ($curraccess eq 'exc') {
                                               push(@possroles,$role);
                                           }
                                       } elsif ($curraccess eq 'inc') {
                                           push(@possroles,$role);
                                       }
                                   }
                               }
                           }
                       }
                   }
               }
           }
       }
       unless (ref($description) eq 'HASH') {
           if (ref($roles_by_num) eq 'ARRAY') {
               my %desc;
               map { $desc{$_} = $_; } (@{$roles_by_num});
               $description = \%desc;
           } else {
               $description = {};
           }
       }
       return (\@possroles,$description);
   }
   
 # ----------------------------------------------------- Frontpage Announcements  # ----------------------------------------------------- Frontpage Announcements
 #  #
 #  #
   
 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);
 }  }
   
 sub getannounce {  sub getannounce {
   
     if (open(my $fh,$perlvar{'lonDocRoot'}.'/announcement.txt')) {      if (open(my $fh,"<",$perlvar{'lonDocRoot'}.'/announcement.txt')) {
  my $announcement='';   my $announcement='';
  while (my $line = <$fh>) { $announcement .= $line; }   while (my $line = <$fh>) { $announcement .= $line; }
  close($fh);   close($fh);
Line 2103  sub getannounce { Line 5239  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,$typefilter,$regexp_ok)=@_;      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,$reqcrsdom,$reqinstcode)=@_;
     if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) {      my $as_hash = 1;
         foreach my $line (      my %returnhash;
                  split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'.      if (!$domfilter) { $domfilter=''; }
        $sincefilter.':'.&escape($descfilter).':'.      my %libserv = &all_library();
                                &escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter).':'.&escape($typefilter).':'.&escape($regexp_ok),      foreach my $tryserver (keys(%libserv)) {
                                $tryserver))) {          if ( (  $hostidflag == 1 
     my ($key,$value)=split(/\=/,$line,2);          && 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,
                                   $reqcrsdom,&escape($reqinstcode))));
                   } 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.
                                ':'.$reqcrsdom.':'.&escape($reqinstcode),$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 2130  sub courseiddump { Line 5342  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 {
Line 2143  sub dcmailput { Line 5398  sub dcmailput {
 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 my $line (split(/\&/,&reply($cmd,$domain_primary{$dom}))) {   foreach my $line (split(/\&/,&reply($cmd,&domain($dom,'primary')))) {
             my ($key,$value) = split(/\=/,$line,2);              my ($key,$value) = split(/\=/,$line,2);
             if (($key) && ($value)) {              if (($key) && ($value)) {
                 $returnhash{&unescape($key)} = &unescape($value);                  $returnhash{&unescape($key)} = &unescape($value);
Line 2161  sub dcmaildump { Line 5417  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 my $line (   %{$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(/\=/,$line,2);      &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  sub get_active_domroles {
       my ($dom,$roles) = @_;
       return () unless (ref($roles) eq 'ARRAY');
       my $now = time;
       my %dompersonnel = &get_domain_roles($dom,$roles,$now,$now);
       my %domroles;
       foreach my $server (keys(%dompersonnel)) {
           foreach my $user (sort(keys(%{$dompersonnel{$server}}))) {
               my ($trole,$uname,$udom,$runame,$rudom,$rsec) = split(/:/,$user);
               $domroles{$uname.':'.$udom} = $dompersonnel{$server}{$user};
           }
       }
       return %domroles;
   }
   
   # ----------------------------------------------------------- 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,$ignorecache)=@_;
       if (($cachedkey eq $uname.':'.$udom) &&
           (abs($cachedtime-time)<5) && (!$env{'form.markaccess'}) &&
           (!$ignorecache)) {
           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,$ignorecache)=@_;
     my ($symb,$courseid,$udom,$uname)=&whichuser();      my ($symb,$courseid,$udom,$uname)=&whichuser();
     if ($argsymb) { $symb=$argsymb; }      if ($argsymb) { $symb=$argsymb; }
     my ($map,$id,$res)=&decode_symb($symb);      my ($map,$id,$res)=&decode_symb($symb);
     if ($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,$ignorecache);
     return $times{"$courseid\0$res"};      return $cachedtimes{"$courseid\0$res"};
 }  }
   
 sub set_first_access {  sub set_first_access {
     my ($type)=@_;      my ($type,$interval)=@_;
     my ($symb,$courseid,$udom,$uname)=&whichuser();      my ($symb,$courseid,$udom,$uname)=&whichuser();
     my ($map,$id,$res)=&decode_symb($symb);      my ($map,$id,$res)=&decode_symb($symb);
     if ($type eq '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='';
     if (!$firstaccess) {      my $firstaccess=&get_first_access($type,$symb,$map);
  return &put('firstaccesstimes',{"$courseid\0$res"=>time},$udom,$uname);      if ($firstaccess) {
           &logthis("First access time already set ($firstaccess) when attempting ".
                    "to set new value (type: $type, extent: $res) for $uname:$udom ".
                    "in $courseid");
           return 'already_set';
       } else {
           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,
                        }
                     );
               if (($cachedtime) && (abs($start-$cachedtime) < 5)) {
                   $cachedtimes{"$courseid\0$res"} = $start;
               }
           } elsif ($putres ne 'refused') {
               &logthis("Result: $putres when attempting to set first access time ".
                        "(type: $type, extent: $res) for $uname:$udom in $courseid");
           }
           return $putres;
     }      }
     return 'already_set';      return 'already_set';
 }  }
   }
   
 sub checkout {  sub checkout {
     my ($symb,$tuname,$tudom,$tcrsid)=@_;      my ($symb,$tuname,$tudom,$tcrsid)=@_;
Line 2228  sub checkout { Line 5556  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 2250  sub checkout { Line 5578  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 2271  sub checkin { Line 5599  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 2280  sub checkin { Line 5608  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 2293  sub checkin { Line 5621  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 2407  sub hashref2str { Line 5735  sub hashref2str {
       $result.='=';        $result.='=';
       #print("Got a ref of ".(ref($key))." skipping.");        #print("Got a ref of ".(ref($key))." skipping.");
     } else {      } else {
  if ($key) {$result.=&escape($key).'=';} else { last; }   if (defined($key)) {$result.=&escape($key).'=';} else { last; }
     }      }
   
     if(ref($hashref->{$key}) eq 'ARRAY') {      if(ref($hashref->{$key}) eq 'ARRAY') {
Line 2559  sub tmpreset { Line 5887  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 2598  sub tmpstore { Line 5926  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 2644  sub tmprestore { Line 5972  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 2673  sub tmprestore { Line 6001  sub tmprestore {
 # ----------------------------------------------------------------------- Store  # ----------------------------------------------------------------------- Store
   
 sub store {  sub store {
     my ($storehash,$symb,$namespace,$domain,$stuname) = @_;      my ($storehash,$symb,$namespace,$domain,$stuname,$laststore) = @_;
     my $home='';      my $home='';
   
     if ($stuname) { $home=&homeserver($stuname,$domain); }      if ($stuname) { $home=&homeserver($stuname,$domain); }
Line 2703  sub store { Line 6031  sub store {
     }      }
     $namevalue=~s/\&$//;      $namevalue=~s/\&$//;
     &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue);      &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue);
     return reply("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");      return reply("store:$domain:$stuname:$namespace:$symb:$namevalue:$laststore","$home");
 }  }
   
 # -------------------------------------------------------------- Critical Store  # -------------------------------------------------------------- Critical Store
   
 sub cstore {  sub cstore {
     my ($storehash,$symb,$namespace,$domain,$stuname) = @_;      my ($storehash,$symb,$namespace,$domain,$stuname,$laststore) = @_;
     my $home='';      my $home='';
   
     if ($stuname) { $home=&homeserver($stuname,$domain); }      if ($stuname) { $home=&homeserver($stuname,$domain); }
Line 2740  sub cstore { Line 6068  sub cstore {
     $namevalue=~s/\&$//;      $namevalue=~s/\&$//;
     &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue);      &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue);
     return critical      return critical
                 ("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");                  ("store:$domain:$stuname:$namespace:$symb:$namevalue:$laststore","$home");
 }  }
   
 # --------------------------------------------------------------------- Restore  # --------------------------------------------------------------------- Restore
Line 2752  sub restore { Line 6080  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 2781  sub restore { Line 6112  sub restore {
 }  }
   
 # ---------------------------------------------------------- Course Description  # ---------------------------------------------------------- Course Description
   #
   #  
   
 sub coursedescription {  sub coursedescription {
     my ($courseid,$args)=@_;      my ($courseid,$args)=@_;
Line 2810  sub coursedescription { Line 6143  sub coursedescription {
  return %returnhash;   return %returnhash;
     }      }
   
     # get the data agin      # get the data again
   
     if (!$args->{'one_time'}) {      if (!$args->{'one_time'}) {
  $envhash{'course.'.$normalid.'.last_cache'}=time;   $envhash{'course.'.$normalid.'.last_cache'}=time;
     }      }
Line 2818  sub coursedescription { Line 6152  sub coursedescription {
     if ($chome ne 'no_host') {      if ($chome ne 'no_host') {
        %returnhash=&dump('environment',$cdomain,$cnum);         %returnhash=&dump('environment',$cdomain,$cnum);
        if (!exists($returnhash{'con_lost'})) {         if (!exists($returnhash{'con_lost'})) {
      my $username = $env{'user.name'}; # Defult username
      if(defined $args->{'user'}) {
          $username = $args->{'user'};
      }
            $returnhash{'home'}= $chome;             $returnhash{'home'}= $chome;
    $returnhash{'domain'} = $cdomain;     $returnhash{'domain'} = $cdomain;
    $returnhash{'num'} = $cnum;     $returnhash{'num'} = $cnum;
Line 2828  sub coursedescription { Line 6166  sub coursedescription {
                $envhash{'course.'.$normalid.'.'.$name}=$value;                 $envhash{'course.'.$normalid.'.'.$name}=$value;
            }             }
            $returnhash{'url'}=&clutter($returnhash{'url'});             $returnhash{'url'}=&clutter($returnhash{'url'});
            $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'.             $returnhash{'fn'}=LONCAPA::tempdir() .
        $env{'user.name'}.'_'.$cdomain.'_'.$cnum;         $username.'_'.$cdomain.'_'.$cnum;
            $envhash{'course.'.$normalid.'.home'}=$chome;             $envhash{'course.'.$normalid.'.home'}=$chome;
            $envhash{'course.'.$normalid.'.domain'}=$cdomain;             $envhash{'course.'.$normalid.'.domain'}=$cdomain;
            $envhash{'course.'.$normalid.'.num'}=$cnum;             $envhash{'course.'.$normalid.'.num'}=$cnum;
        }         }
     }      }
     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 my $entry (split(/&/,$rolesdump)) {          $roles = ['dc','su'];
     if ($entry!~/^rolesdef_/) {      }
  my ($area,$role)=split(/=/,$entry);      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);  
     my $group_privs;  
   
     if ($rolesdump ne '') {      for my $area (grep { ! /^rolesdef_/ } keys(%rolesdump)) {
         foreach my $entry (split(/&/,$rolesdump)) {          my $role = $rolesdump{$area};
   if ($entry!~/^rolesdef_/) {          $area =~ s/\_\w\w$//;
             my ($area,$role)=split(/=/,$entry);  
     $area=~s/\_\w\w$//;          my ($trole, $tend, $tstart, $group_privs);
             my ($trole,$tend,$tstart,$group_privs);  
     if ($role=~/^cr/) {           if ($role =~ /^cr/) {
  if ($role=~m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|) {          # Custom role, defined by a user 
     ($trole,my $trest)=($role=~m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|);          # e.g., user.role.cr/msu/smith/mynewrole
     ($tend,$tstart)=split('_',$trest);              if ($role =~ m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|) {
  } else {                  $trole = $1;
     $trole=$role;                  ($tend, $tstart) = split('_', $2);
  }              } else {
             } elsif ($role =~ m|^gr/|) {                  $trole = $role;
                 ($trole,$tend,$tstart) = split(/_/,$role);  
                 ($trole,$group_privs) = split(/\//,$trole);  
                 $group_privs = &unescape($group_privs);  
     } else {  
  ($trole,$tend,$tstart)=split(/_/,$role);  
     }  
     my %new_role = &set_arearole($trole,$area,$tstart,$tend,$domain,  
  $username);  
     @userroles{keys(%new_role)} = @new_role{keys(%new_role)};  
             if (($tend!=0) && ($tend<$now)) { $trole=''; }  
             if (($tstart!=0) && ($tstart>$now)) { $trole=''; }  
             if (($area ne '') && ($trole ne '')) {  
  my $spec=$trole.'.'.$area;  
  my ($tdummy,$tdomain,$trest)=split(/\//,$area);  
  if ($trole =~ /^cr\//) {  
                     &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);  
                 } elsif ($trole eq 'gr') {  
                     &group_roleprivs(\%allgroups,$area,$group_privs,$tend,$tstart);  
  } else {  
                     &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);  
  }  
             }              }
           }          } elsif ($role =~ m|^gr/|) {
           # Role of member in a group, defined within a course/community
           # e.g., user.role.gr/msu/04935610a19ee4a5fmsul1/leopards
               ($trole, $tend, $tstart) = split(/_/, $role);
               next if $tstart eq '-1';
               ($trole, $group_privs) = split(/\//, $trole);
               $group_privs = &unescape($group_privs);
           } else {
           # Just a normal role, defined in roles.tab
               ($trole, $tend, $tstart) = split(/_/,$role);
           }
   
           my %new_role = &set_arearole($trole,$area,$tstart,$tend,$domain,
                    $username);
           @userroles{keys(%new_role)} = @new_role{keys(%new_role)};
   
           # role expired or not available yet?
           $trole = '' if ($tend != 0 && $tend < $userroles{'user.login.time'}) or 
               ($tstart != 0 && $tstart > $userroles{'user.login.time'});
   
           next if $area eq '' or $trole eq '';
   
           my $spec = "$trole.$area";
           my ($tdummy, $tdomain, $trest) = split(/\//, $area);
   
           if ($trole =~ /^cr\//) {
           # Custom role, defined by a user
               &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);
           } elsif ($trole eq 'gr') {
           # Role of a member in a group, defined within a course/community
               &group_roleprivs(\%allgroups,$area,$group_privs,$tend,$tstart);
               next;
           } else {
           # Normal role, defined in roles.tab
               &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
           }
   
           my $cid = $tdomain.'_'.$trest;
           unless ($firstaccchk{$cid}) {
               if (ref($coursetimerstarts{$cid}) eq 'HASH') {
                   foreach my $item (keys(%{$coursetimerstarts{$cid}})) {
                       $firstaccenv{'course.'.$cid.'.firstaccess.'.$item} = 
                           $coursetimerstarts{$cid}{$item}; 
                   }
               }
               $firstaccchk{$cid} = 1;
           }
           unless ($timerintchk{$cid}) {
               if (ref($coursetimerintervals{$cid}) eq 'HASH') {
                   foreach my $item (keys(%{$coursetimerintervals{$cid}})) {
                       $timerintenv{'course.'.$cid.'.timerinterval.'.$item} =
                          $coursetimerintervals{$cid}{$item};
                   }
               }
               $timerintchk{$cid} = 1;
         }          }
         my ($author,$adv) = &set_userprivs(\%userroles,\%allroles,\%allgroups);  
         $userroles{'user.adv'}    = $adv;  
  $userroles{'user.author'} = $author;  
         $env{'user.adv'}=$adv;  
     }      }
     return \%userroles;    
       @userroles{'user.author','user.adv','user.rar'} = &set_userprivs(\%userroles,
                                                             \%allroles, \%allgroups);
       $env{'user.adv'} = $userroles{'user.adv'};
       $env{'user.rar'} = $userroles{'user.rar'};
   
       return (\%userroles,\%firstaccenv,\%timerintenv);
 }  }
   
 sub set_arearole {  sub set_arearole {
     my ($trole,$area,$tstart,$tend,$domain,$username) = @_;      my ($trole,$area,$tstart,$tend,$domain,$username,$nolog) = @_;
       unless ($nolog) {
 # log the associated role with the area  # log the associated role with the area
     &userrolelog($trole,$username,$domain,$area,$tstart,$tend);          &userrolelog($trole,$username,$domain,$area,$tstart,$tend);
       }
     return ('user.role.'.$trole.'.'.$area => $tstart.'.'.$tend);      return ('user.role.'.$trole.'.'.$area => $tstart.'.'.$tend);
 }  }
   
 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 2955  sub custom_roleprivs { Line 6449  sub custom_roleprivs {
                     $$allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv;                      $$allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv;
                 }                  }
                 if (($trest ne '') && (defined($coursepriv))) {                  if (($trest ne '') && (defined($coursepriv))) {
                       if ($trole =~ m{^cr/$tdomain/$tdomain\Q-domainconfig\E/([^/]+)$}) {
                           my $rolename = $1;
                           $coursepriv = &course_adhocrole_privs($rolename,$tdomain,$trest,$coursepriv);
                       }
                     $$allroles{'cm.'.$area}.=':'.$coursepriv;                      $$allroles{'cm.'.$area}.=':'.$coursepriv;
                     $$allroles{$spec.'.'.$area}.=':'.$coursepriv;                      $$allroles{$spec.'.'.$area}.=':'.$coursepriv;
                 }                  }
Line 2963  sub custom_roleprivs { Line 6461  sub custom_roleprivs {
     }      }
 }  }
   
   sub course_adhocrole_privs {
       my ($rolename,$cdom,$cnum,$coursepriv) = @_;
       my %overrides = &get('environment',["internal.adhocpriv.$rolename"],$cdom,$cnum);
       if ($overrides{"internal.adhocpriv.$rolename"}) {
           my (%currprivs,%storeprivs);
           foreach my $item (split(/:/,$coursepriv)) {
               my ($priv,$restrict) = split(/\&/,$item);
               $currprivs{$priv} = $restrict;
           }
           my (%possadd,%possremove,%full);
           foreach my $item (split(/\:/,$Apache::lonnet::pr{'cr:c'})) {
               my ($priv,$restrict)=split(/\&/,$item);
               $full{$priv} = $restrict;
           }
           foreach my $item (split(/,/,$overrides{"internal.adhocpriv.$rolename"})) {
                next if ($item eq '');
                my ($rule,$rest) = split(/=/,$item);
                next unless (($rule eq 'off') || ($rule eq 'on'));
                foreach my $priv (split(/:/,$rest)) {
                    if ($priv ne '') {
                        if ($rule eq 'off') {
                            $possremove{$priv} = 1;
                        } else {
                            $possadd{$priv} = 1;
                        }
                    }
                }
            }
            foreach my $priv (sort(keys(%full))) {
                if (exists($currprivs{$priv})) {
                    unless (exists($possremove{$priv})) {
                        $storeprivs{$priv} = $currprivs{$priv};
                    }
                } elsif (exists($possadd{$priv})) {
                    $storeprivs{$priv} = $full{$priv};
                }
            }
            $coursepriv = ':'.join(':',map { $_.'&'.$storeprivs{$_}; } sort(keys(%storeprivs)));
        }
        return $coursepriv;
   }
   
 sub group_roleprivs {  sub group_roleprivs {
     my ($allgroups,$area,$group_privs,$tend,$tstart) = @_;      my ($allgroups,$area,$group_privs,$tend,$tstart) = @_;
     my $access = 1;      my $access = 1;
Line 2994  sub standard_roleprivs { Line 6534  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 $rar=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+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\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};
                           }
                     }                      }
                 }                  }
             }              }
Line 3021  sub set_userprivs { Line 6575  sub set_userprivs {
     }      }
     foreach my $role (keys(%{$allroles})) {      foreach my $role (keys(%{$allroles})) {
         my %thesepriv;          my %thesepriv;
         if (($role=~/^au/) || ($role=~/^ca/)) { $author=1; }          if (($role=~/^au/) || ($role=~/^ca/) || ($role=~/^aa/)) { $author=1; }
         foreach my $item (split(/:/,$$allroles{$role})) {          foreach my $item (split(/:/,$$allroles{$role})) {
             if ($item ne '') {              if ($item ne '') {
                 my ($privilege,$restrictions)=split(/&/,$item);                  my ($privilege,$restrictions)=split(/&/,$item);
Line 3031  sub set_userprivs { Line 6585  sub set_userprivs {
                     $thesepriv{$privilege}.=$restrictions;                      $thesepriv{$privilege}.=$restrictions;
                 }                  }
                 if ($thesepriv{'adv'} eq 'F') { $adv=1; }                  if ($thesepriv{'adv'} eq 'F') { $adv=1; }
                   if ($thesepriv{'rar'} eq 'F') { $rar=1; }
             }              }
         }          }
         my $thesestr='';          my $thesestr='';
         foreach my $priv (keys(%thesepriv)) {          foreach my $priv (sort(keys(%thesepriv))) {
     $thesestr.=':'.$priv.'&'.$thesepriv{$priv};      $thesestr.=':'.$priv.'&'.$thesepriv{$priv};
  }   }
         $userroles->{'user.priv.'.$role} = $thesestr;          $userroles->{'user.priv.'.$role} = $thesestr;
     }      }
     return ($author,$adv);      return ($author,$adv,$rar);
   }
   
   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,$rar)= &set_userprivs(\%userroles,\%allroles,\%allgroups,
                                                                      \%groups_roles);
                               &appenv(\%userroles,\@rolecodes);
                               &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$spec);
                           }
                       }
                       $$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,$sec) = @_;
       my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum;
       if ($sec) {
           $cckey .= '/'.$sec;
       }
       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,$sec);
               $setprivs = 1;
           }
       } else {
           &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller,$sec);
           $setprivs = 1;
       }
       return $setprivs;
   }
   
   sub set_adhoc_privileges {
   # role can be cc, ca, or cr/<dom>/<dom>-domainconfig/role
       my ($dcdom,$pickedcourse,$role,$caller,$sec) = @_;
       my $area = '/'.$dcdom.'/'.$pickedcourse;
       if ($sec ne '') {
           $area .= '/'.$sec;
       }
       my $spec = $role.'.'.$area;
       my %userroles = &set_arearole($role,$area,'','',$env{'user.domain'},
                                     $env{'user.name'},1);
       my %rolehash = ();
       if ($role =~ m{^\Qcr/$dcdom/$dcdom\E\-domainconfig/(\w+)$}) {
           my $rolename = $1;
           &custom_roleprivs(\%rolehash,$role,$dcdom,$pickedcourse,$spec,$area);
           my %domdef = &get_domain_defaults($dcdom);
           if (ref($domdef{'adhocroles'}) eq 'HASH') {
               if (ref($domdef{'adhocroles'}{$rolename}) eq 'HASH') {
                   &appenv({'request.role.desc' => $domdef{'adhocroles'}{$rolename}{'desc'},});
               }
           }
       } else {
           &standard_roleprivs(\%rolehash,$role,$dcdom,$spec,$pickedcourse,$area);
       }
       my ($author,$adv,$rar)= &set_userprivs(\%userroles,\%rolehash);
       &appenv(\%userroles,[$role,'cm']);
       &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$spec);
       unless ($caller eq 'constructaccess' && $env{'request.course.id'}) {
           &appenv( {'request.role'        => $spec,
                     'request.role.domain' => $dcdom,
                     'request.course.sec'  => $sec, 
                    }
                  );
           my $tadv=0;
           if (&allowed('adv') eq 'F') { $tadv=1; }
           &appenv({'request.role.adv'    => $tadv});
       }
 }  }
   
 # --------------------------------------------------------------- get interface  # --------------------------------------------------------------- get interface
Line 3077  sub del { Line 6811  sub del {
    foreach my $item (@$storearr) {     foreach my $item (@$storearr) {
        $items.=&escape($item).'&';         $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) {      if ($regexp) {
  $regexp=&escape($regexp);          $regexp=&escape($regexp);
     } else {      } else {
  $regexp='.';          $regexp='.';
       }
       if (grep { $_ eq $uhome } &current_machine_ids()) {
           # user is hosted on this machine
           my $reply = LONCAPA::Lond::dump_with_regexp(join(':', ($udomain,
                       $uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'});
           return %{&unserialize($reply, $escapedkeys)};
     }      }
     my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);      my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
     my @pairs=split(/\&/,$rep);      my @pairs=split(/\&/,$rep);
     my %returnhash=();      my %returnhash=();
     foreach my $item (@pairs) {      if (!($rep =~ /^error/ )) {
  my ($key,$value)=split(/=/,$item,2);   foreach my $item (@pairs) {
  $key = &unescape($key);      my ($key,$value)=split(/=/,$item,2);
  next if ($key =~ /^error: 2 /);              $key = &unescape($key) unless ($escapedkeys);
  $returnhash{$key}=&thaw_unescape($value);      next if ($key =~ /^error: 2 /);
       $returnhash{$key}=&thaw_unescape($value);
    }
     }      }
     return %returnhash;      return %returnhash;
 }  }
   
   
 # --------------------------------------------------------- dumpstore interface  # --------------------------------------------------------- dumpstore interface
   
 sub dumpstore {  sub dumpstore {
    my ($namespace,$udomain,$uname,$regexp,$range)=@_;     my ($namespace,$udomain,$uname,$regexp,$range)=@_;
    if (!$udomain) { $udomain=$env{'user.domain'}; }     # same as dump but keys must be escaped. They may contain colon separated
    if (!$uname) { $uname=$env{'user.name'}; }     # lists of values that may themself contain colons (e.g. symbs).
    my $uhome=&homeserver($uname,$udomain);     return &dump($namespace, $udomain, $uname, $regexp, $range, 1);
    if ($regexp) {  
        $regexp=&escape($regexp);  
    } else {  
        $regexp='.';  
    }  
    my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);  
    my @pairs=split(/\&/,$rep);  
    my %returnhash=();  
    foreach my $item (@pairs) {  
        my ($key,$value)=split(/=/,$item,2);  
        next if ($key =~ /^error: 2 /);  
        $returnhash{$key}=&thaw_unescape($value);  
    }  
    return %returnhash;  
 }  }
   
 # -------------------------------------------------------------- keys interface  # -------------------------------------------------------------- keys interface
Line 3155  sub currentdump { Line 6902  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=();
    #     #
    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 = &dumpstore($courseid,$sdom,$sname,'.');         my @tmp = &dumpstore($courseid,$sdom,$sname,'.');
Line 3276  sub newput { Line 7031  sub newput {
 # ---------------------------------------------------------  putstore interface  # ---------------------------------------------------------  putstore interface
   
 sub putstore {  sub putstore {
    my ($namespace,$symb,$version,$storehash,$udomain,$uname)=@_;     my ($namespace,$symb,$version,$storehash,$udomain,$uname,$tolog)=@_;
    if (!$udomain) { $udomain=$env{'user.domain'}; }     if (!$udomain) { $udomain=$env{'user.domain'}; }
    if (!$uname) { $uname=$env{'user.name'}; }     if (!$uname) { $uname=$env{'user.name'}; }
    my $uhome=&homeserver($uname,$udomain);     my $uhome=&homeserver($uname,$udomain);
Line 3290  sub putstore { Line 7045  sub putstore {
    my $reply =     my $reply =
        &reply("putstore:$udomain:$uname:$namespace:$esc_symb:$esc_v:$items",         &reply("putstore:$udomain:$uname:$namespace:$esc_symb:$esc_v:$items",
       $uhome);        $uhome);
      if (($tolog) && ($reply eq 'ok')) {
          my $namevalue='';
          foreach my $key (keys(%{$storehash})) {
              $namevalue.=&escape($key).'='.&freeze_escape($storehash->{$key}).'&';
          }
          $namevalue .= 'ip='.&escape($ENV{'REMOTE_ADDR'}).
                        '&host='.&escape($perlvar{'lonHostID'}).
                        '&version='.$esc_v.
                        '&by='.&escape($env{'user.name'}.':'.$env{'user.domain'});
          &Apache::lonnet::courselog($symb.':'.$uname.':'.$udomain.':PUTSTORE:'.$namevalue);
      }
    if ($reply eq 'unknown_cmd') {     if ($reply eq 'unknown_cmd') {
        # gfall back to way things use to be done         # gfall back to way things use to be done
        return &old_putstore($namespace,$symb,$version,$storehash,$udomain,         return &old_putstore($namespace,$symb,$version,$storehash,$udomain,
Line 3383  sub tmpget { Line 7149  sub tmpget {
     if (!defined($server)) { $server = $perlvar{'lonHostID'}; }      if (!defined($server)) { $server = $perlvar{'lonHostID'}; }
     my $rep=&reply("tmpget:$token",$server);      my $rep=&reply("tmpget:$token",$server);
     my %returnhash;      my %returnhash;
       if ($rep =~ /^(con_lost|error|no_such_host)/i) {
           return %returnhash;
       }
     foreach my $item (split(/\&/,$rep)) {      foreach my $item (split(/\&/,$rep)) {
  my ($key,$value)=split(/=/,$item);   my ($key,$value)=split(/=/,$item);
  $returnhash{&unescape($key)}=&thaw_unescape($value);   $returnhash{&unescape($key)}=&thaw_unescape($value);
Line 3390  sub tmpget { Line 7159  sub tmpget {
     return %returnhash;      return %returnhash;
 }  }
   
 # ------------------------------------------------------------ tmpget interface  # ------------------------------------------------------------ tmpdel interface
 sub tmpdel {  sub tmpdel {
     my ($token,$server)=@_;      my ($token,$server)=@_;
     if (!defined($server)) { $server = $perlvar{'lonHostID'}; }      if (!defined($server)) { $server = $perlvar{'lonHostID'}; }
     return &reply("tmpdel:$token",$server);      return &reply("tmpdel:$token",$server);
 }  }
   
   # ------------------------------------------------------------ get_timebased_id
   
   sub get_timebased_id {
       my ($prefix,$keyid,$namespace,$cdom,$cnum,$idtype,$who,$locktries,
           $maxtries) = @_;
       my ($newid,$error,$dellock);
       unless (($prefix =~ /^\w+$/) && ($keyid =~ /^\w+$/) && ($namespace ne '')) {
           return ('','ok','invalid call to get suffix');
       }
   
   # set defaults for any optional args for which values were not supplied
       if ($who eq '') {
           $who = $env{'user.name'}.':'.$env{'user.domain'};
       }
       if (!$locktries) {
           $locktries = 3;
       }
       if (!$maxtries) {
           $maxtries = 10;
       }
   
       if (($cdom eq '') || ($cnum eq '')) {
           if ($env{'request.course.id'}) {
               $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
               $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
           }
           if (($cdom eq '') || ($cnum eq '')) {
               return ('','ok','call to get suffix not in course context');
           }
       }
   
   # construct locking item
       my $lockhash = {
                         $prefix."\0".'locked_'.$keyid => $who,
                      };
       my $tries = 0;
   
   # attempt to get lock on nohist_$namespace file
       my $gotlock = &Apache::lonnet::newput('nohist_'.$namespace,$lockhash,$cdom,$cnum);
       while (($gotlock ne 'ok') && $tries <$locktries) {
           $tries ++;
           sleep 1;
           $gotlock = &Apache::lonnet::newput('nohist_'.$namespace,$lockhash,$cdom,$cnum);
       }
   
   # attempt to get unique identifier, based on current timestamp
       if ($gotlock eq 'ok') {
           my %inuse = &Apache::lonnet::dump('nohist_'.$namespace,$cdom,$cnum,$prefix);
           my $id = time;
           $newid = $id;
           if ($idtype eq 'addcode') {
               $newid .= &sixnum_code();
           }
           my $idtries = 0;
           while (exists($inuse{$prefix."\0".$newid}) && $idtries < $maxtries) {
               if ($idtype eq 'concat') {
                   $newid = $id.$idtries;
               } elsif ($idtype eq 'addcode') {
                   $newid = $newid.&sixnum_code();
               } else {
                   $newid ++;
               }
               $idtries ++;
           }
           if (!exists($inuse{$prefix."\0".$newid})) {
               my %new_item =  (
                                 $prefix."\0".$newid => $who,
                               );
               my $putresult = &Apache::lonnet::put('nohist_'.$namespace,\%new_item,
                                                    $cdom,$cnum);
               if ($putresult ne 'ok') {
                   undef($newid);
                   $error = 'error saving new item: '.$putresult;
               }
           } else {
                undef($newid);
                $error = ('error: no unique suffix available for the new item ');
           }
   #  remove lock
           my @del_lock = ($prefix."\0".'locked_'.$keyid);
           $dellock = &Apache::lonnet::del('nohist_'.$namespace,\@del_lock,$cdom,$cnum);
       } else {
           $error = "error: could not obtain lockfile\n";
           $dellock = 'ok';
           if (($prefix eq 'paste') && ($namespace eq 'courseeditor') && ($keyid eq 'num')) {
               $dellock = 'nolock';
           }
       }
       return ($newid,$dellock,$error);
   }
   
   sub sixnum_code {
       my $code;
       for (0..6) {
           $code .= int( rand(9) );
       }
       return $code;
   }
   
 # -------------------------------------------------- portfolio access checking  # -------------------------------------------------- portfolio access checking
   
 sub portfolio_access {  sub portfolio_access {
     my ($requrl) = @_;      my ($requrl,$clientip) = @_;
     my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl);      my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl);
     my $result = &get_portfolio_access($udom,$unum,$file_name,$group);      my $result = &get_portfolio_access($udom,$unum,$file_name,$group,$clientip);
     if ($result) {      if ($result) {
         my %setters;          my %setters;
         if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {          if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
Line 3428  sub portfolio_access { Line 7296  sub portfolio_access {
 }  }
   
 sub get_portfolio_access {  sub get_portfolio_access {
     my ($udom,$unum,$file_name,$group,$access_hash) = @_;      my ($udom,$unum,$file_name,$group,$clientip,$access_hash) = @_;
   
     if (!ref($access_hash)) {      if (!ref($access_hash)) {
  my $current_perms = &get_portfile_permissions($udom,$unum);   my $current_perms = &get_portfile_permissions($udom,$unum);
Line 3437  sub get_portfolio_access { Line 7305  sub get_portfolio_access {
  $access_hash = $access_controls{$file_name};   $access_hash = $access_controls{$file_name};
     }      }
   
     my ($public,$guest,@domains,@users,@courses,@groups);      my ($public,$guest,@domains,@users,@courses,@groups,@ips);
     my $now = time;      my $now = time;
     if (ref($access_hash) eq 'HASH') {      if (ref($access_hash) eq 'HASH') {
         foreach my $key (keys(%{$access_hash})) {          foreach my $key (keys(%{$access_hash})) {
Line 3461  sub get_portfolio_access { Line 7329  sub get_portfolio_access {
                 push(@courses,$key);                  push(@courses,$key);
             } elsif ($scope eq 'group') {              } elsif ($scope eq 'group') {
                 push(@groups,$key);                  push(@groups,$key);
               } elsif ($scope eq 'ip') {
                   push(@ips,$key);
             }              }
         }          }
         if ($public) {          if ($public) {
             return 'ok';              return 'ok';
           } elsif (@ips > 0) {
               my $allowed;
               foreach my $ipkey (@ips) {
                   if (ref($access_hash->{$ipkey}{'ip'}) eq 'ARRAY') {
                       if (&Apache::loncommon::check_ip_acc(join(',',@{$access_hash->{$ipkey}{'ip'}}),$clientip)) {
                           $allowed = 1;
                           last;
                       }
                   }
               }
               if ($allowed) {
                   return 'ok';
               }
         }          }
         if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {          if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
             if ($guest) {              if ($guest) {
Line 3482  sub get_portfolio_access { Line 7365  sub get_portfolio_access {
             }              }
             if (@users > 0) {              if (@users > 0) {
                 foreach my $userkey (@users) {                  foreach my $userkey (@users) {
                     if (exists($access_hash->{$userkey}{'users'}{$env{'user.name'}.':'.$env{'user.domain'}})) {                      if (ref($access_hash->{$userkey}{'users'}) eq 'ARRAY') {
                         return 'ok';                          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 %roleshash;
Line 3494  sub get_portfolio_access { Line 7384  sub get_portfolio_access {
                 my (%allgroups,%allroles);                   my (%allgroups,%allroles); 
                 my ($start,$end,$role,$sec,$group);                  my ($start,$end,$role,$sec,$group);
                 foreach my $envkey (%env) {                  foreach my $envkey (%env) {
                     if ($envkey =~ m-^user\.role\.(gr|cc|in|ta|ep|st)\./($match_domain)/($match_courseid)/?([^/]*)$-) {                      if ($envkey =~ m-^user\.role\.(gr|cc|co|in|ta|ep|ad|st)\./($match_domain)/($match_courseid)/?([^/]*)$-) {
                         my $cid = $2.'_'.$3;                           my $cid = $2.'_'.$3; 
                         if ($1 eq 'gr') {                          if ($1 eq 'gr') {
                             $group = $4;                              $group = $4;
Line 3633  sub is_portfolio_file { Line 7523  sub is_portfolio_file {
     return;      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;
           }
           return $access;
       }
   
       my ($is_adv,%domdef);
       if (ref($is_advref) eq 'HASH') {
           $is_adv = $is_advref->{'is_adv'};
       } else {
           $is_adv = &is_advanced_user($udom,$uname);
       }
       if (ref($domdefref) eq 'HASH') {
           %domdef = %{$domdefref};
       } else {
           %domdef = &get_domain_defaults($udom);
       }
       if (ref($domdef{$tool}) eq 'HASH') {
           if ($is_adv) {
               if ($domdef{$tool}{'_LC_adv'} ne '') {
                   if ($domdef{$tool}{'_LC_adv'}) { 
                       $access = 1;
                   } else {
                       $access = 0;
                   }
                   return $access;
               }
           }
           if ($inststatus ne '') {
               my ($hasaccess,$hasnoaccess);
               foreach my $affiliation (split(/:/,$inststatus)) {
                   if ($domdef{$tool}{$affiliation} ne '') { 
                       if ($domdef{$tool}{$affiliation}) {
                           $hasaccess = 1;
                       } else {
                           $hasnoaccess = 1;
                       }
                   }
               }
               if ($hasaccess || $hasnoaccess) {
                   if ($hasaccess) {
                       $access = 1;
                   } elsif ($hasnoaccess) {
                       $access = 0; 
                   }
                   return $access;
               }
           } else {
               if ($domdef{$tool}{'default'} ne '') {
                   if ($domdef{$tool}{'default'}) {
                       $access = 1;
                   } elsif ($domdef{$tool}{'default'} == 0) {
                       $access = 0;
                   }
                   return $access;
               }
           }
       } else {
           if (($context eq 'tools') && ($tool ne 'webdav')) {
               $access = 1;
           } else {
               $access = 0;
           }
           return $access;
       }
   }
   
   sub is_course_owner {
       my ($cdom,$cnum,$udom,$uname) = @_;
       if (($udom eq '') || ($uname eq '')) {
           $udom = $env{'user.domain'};
           $uname = $env{'user.name'};
       }
       unless (($udom eq '') || ($uname eq '')) {
           if (exists($env{'course.'.$cdom.'_'.$cnum.'.internal.courseowner'})) {
               if ($env{'course.'.$cdom.'_'.$cnum.'.internal.courseowner'} eq $uname.':'.$udom) {
                   return 1;
               } else {
                   my %courseinfo = &Apache::lonnet::coursedescription($cdom.'/'.$cnum);
                   if ($courseinfo{'internal.courseowner'} eq $uname.':'.$udom) {
                       return 1;
                   }
               }
           }
       }
       return;
   }
   
   sub is_advanced_user {
       my ($udom,$uname) = @_;
       if ($udom ne '' && $uname ne '') {
           if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
               if (wantarray) {
                   return ($env{'user.adv'},$env{'user.author'});
               } else {
                   return $env{'user.adv'};
               }
           }
       }
       my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1);
       my %allroles;
       my ($is_adv,$is_author);
       foreach my $role (keys(%roleshash)) {
           my ($trest,$tdomain,$trole,$sec) = split(/:/,$role);
           my $area = '/'.$tdomain.'/'.$trest;
           if ($sec ne '') {
               $area .= '/'.$sec;
           }
           if (($area ne '') && ($trole ne '')) {
               my $spec=$trole.'.'.$area;
               if ($trole =~ /^cr\//) {
                   &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);
               } elsif ($trole ne 'gr') {
                   &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
               }
               if ($trole eq 'au') {
                   $is_author = 1;
               }
           }
       }
       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  # ---------------------------------------------- Custom access rule evaluation
   
Line 3644  sub customaccess { Line 7789  sub customaccess {
     $ucrs = &LONCAPA::clean_username($ucrs);      $ucrs = &LONCAPA::clean_username($ucrs);
     my $access=0;      my $access=0;
     foreach my $right (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) {      foreach my $right (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) {
  my ($effect,$realm,$role)=split(/\:/,$right);   my ($effect,$realm,$role,$type)=split(/\:/,$right);
         if ($role) {   if ($type eq 'user') {
    if ($role ne $urole) { next; }      foreach my $scope (split(/\s*\,\s*/,$realm)) {
         }   my ($tdom,$tuname)=split(m{/},$scope);
         foreach my $scope (split(/\s*\,\s*/,$realm)) {   if ($tdom) {
             my ($tdom,$tcrs,$tsec)=split(/\_/,$scope);      if ($tdom ne $env{'user.domain'}) { next; }
             if ($tdom) {   }
  if ($tdom ne $udom) { next; }   if ($tuname) {
             }      if ($tuname ne $env{'user.name'}) { next; }
             if ($tcrs) {   }
  if ($tcrs ne $ucrs) { next; }   $access=($effect eq 'allow');
             }   last;
             if ($tsec) {      }
  if ($tsec ne $usec) { next; }   } else {
             }      if ($role) {
             $access=($effect eq 'allow');   if ($role ne $urole) { next; }
             last;      }
         }      foreach my $scope (split(/\s*\,\s*/,$realm)) {
  if ($realm eq '' && $role eq '') {   my ($tdom,$tcrs,$tsec)=split(/\_/,$scope);
             $access=($effect eq 'allow');   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 3672  sub customaccess { Line 7831  sub customaccess {
 # ------------------------------------------------- Check for a user privilege  # ------------------------------------------------- Check for a user privilege
   
 sub allowed {  sub allowed {
     my ($priv,$uri,$symb,$role)=@_;      my ($priv,$uri,$symb,$role,$clientip,$noblockcheck)=@_;
     my $ver_orguri=$uri;      my $ver_orguri=$uri;
     $uri=&deversion($uri);      $uri=&deversion($uri);
     my $orguri=$uri;      my $orguri=$uri;
Line 3689  sub allowed { Line 7848  sub allowed {
   
     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{/(?:smppg|bulletinboard)$}))       if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard|ext\.tool)$})) 
  || (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) ))    || (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) )) 
  && ($priv eq 'bre')) {   && ($priv eq 'bre')) {
  return 'F';   return 'F';
Line 3774  sub allowed { Line 7933  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 3794  sub allowed { Line 8013  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;          if ($priv eq 'mip') {
               my $rem = $1;
               if (($uri ne '') && ($env{'request.course.id'} eq $uri) &&
                   ($env{'course.'.$env{'request.course.id'}.'.internal.courseowner'} eq $env{'user.name'}.':'.$env{'user.domain'})) {
                   my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
                   if ($cdom ne '') {
                       my %passwdconf = &get_passwdconf($cdom);
                       if (ref($passwdconf{'crsownerchg'}) eq 'HASH') {
                           if (ref($passwdconf{'crsownerchg'}{'by'}) eq 'ARRAY') {
                               if (@{$passwdconf{'crsownerchg'}{'by'}}) {
                                   my @inststatuses = split(':',$env{'environment.inststatus'});
                                   unless (@inststatuses) {
                                       @inststatuses = ('default');
                                   }
                                   foreach my $status (@inststatuses) {
                                       if (grep(/^\Q$status\E$/,@{$passwdconf{'crsownerchg'}{'by'}})) {
                                           $thisallowed.=$rem;
                                       }
                                   }
                               }
                           }
                       }
                   }
               }
           } else {
               unless (($priv eq 'bro') && (!$ownaccess)) {
                   $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 3805  sub allowed { Line 8052  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 $value = $1;
                   if ($noblockcheck) {
                       $thisallowed.=$value;
                   } else {
                       my @blockers = &has_comm_blocking($priv,$symb,$uri);
                       if (@blockers > 0) {
                           $thisallowed = 'B';
                       } else {
                           $thisallowed.=$value;
                       }
                   }
             }              }
         } else {          } else {
             my $refuri = $env{'httpref.'.$orguri} || $env{'httpref.'.$ver_orguri};              my $refuri = $env{'httpref.'.$orguri} || $env{'httpref.'.$ver_orguri};
Line 3816  sub allowed { Line 8073  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';                          if ($noblockcheck) {
                               $thisallowed='F';
                           } else {
                               my @blockers = &has_comm_blocking($priv,$symb,$refuri);
                               if (@blockers > 0) {
                                   $thisallowed = 'B';
                               } else {
                                   $thisallowed='F';
                               }
                           }
                     }                      }
                 }                  }
             }              }
Line 3827  sub allowed { Line 8093  sub allowed {
  && $thisallowed ne 'F'    && $thisallowed ne 'F' 
  && $thisallowed ne '2'   && $thisallowed ne '2'
  && &is_portfolio_url($uri)) {   && &is_portfolio_url($uri)) {
  $thisallowed = &portfolio_access($uri);   $thisallowed = &portfolio_access($uri,$clientip);
     }      }
           
 # 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 3858  sub allowed { Line 8123  sub allowed {
   
     if ($env{'request.course.id'}) {      if ($env{'request.course.id'}) {
   
   # If this is modifying password (internal auth) domains must match for user and user's role.
   
           if ($priv eq 'mip') {
               if ($env{'user.domain'} eq $env{'request.role.domain'}) {
                   return $thisallowed;
               } else {
                   return '';
               }
           }
   
        $courseprivid=$env{'request.course.id'};         $courseprivid=$env{'request.course.id'};
        if ($env{'request.course.sec'}) {         if ($env{'request.course.sec'}) {
           $courseprivid.='/'.$env{'request.course.sec'};            $courseprivid.='/'.$env{'request.course.sec'};
Line 3869  sub allowed { Line 8144  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') {
                      if ($noblockcheck) {
                          $thisallowed.=$value;
                      } else {
                          my @blockers = &has_comm_blocking($priv,$symb,$uri);
                          if (@blockers > 0) {
                              $thisallowed = 'B';
                          } else {
                              $thisallowed.=$value;
                          }
                      }
                  } else {
                      $thisallowed.=$value;
                  }
                $checkreferer=0;                 $checkreferer=0;
            }             }
        }         }
Line 3897  sub allowed { Line 8186  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') {
                         if ($noblockcheck) {
                             $thisallowed.=$value;
                         } else {
                             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 3935  sub allowed { Line 8238  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 4001  sub allowed { Line 8304  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 4011  sub allowed { Line 8314  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 4025  sub allowed { Line 8328  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 4057  sub allowed { Line 8360  sub allowed {
    return 'F';     return 'F';
 }  }
   
   # ------------------------------------------- Check construction space access
   
   sub constructaccess {
       my ($url,$setpriv)=@_;
   
   # We do not allow editing of previous versions of files
       if ($url=~/\.(\d+)\.(\w+)$/) { return ''; }
   
   # Get username and domain from URL
       my ($ownername,$ownerdomain,$ownerhome);
   
       ($ownerdomain,$ownername) =
           ($url=~ m{^(?:\Q$perlvar{'lonDocRoot'}\E|)/priv/($match_domain)/($match_username)(?:/|$)});
   
   # The URL does not really point to any authorspace, forget it
       unless (($ownername) && ($ownerdomain)) { return ''; }
   
   # Now we need to see if the user has access to the authorspace of
   # $ownername at $ownerdomain
   
       if (($ownername eq $env{'user.name'}) && ($ownerdomain eq $env{'user.domain'})) {
   # Real author for this?
          $ownerhome = $env{'user.home'};
          if (exists($env{'user.priv.au./'.$ownerdomain.'/./'})) {
             return ($ownername,$ownerdomain,$ownerhome);
          }
       } else {
   # Co-author for this?
           if (exists($env{'user.priv.ca./'.$ownerdomain.'/'.$ownername.'./'}) ||
               exists($env{'user.priv.aa./'.$ownerdomain.'/'.$ownername.'./'}) ) {
               $ownerhome = &homeserver($ownername,$ownerdomain);
               return ($ownername,$ownerdomain,$ownerhome);
           }
       }
   
   # We don't have any access right now. If we are not possibly going to do anything about this,
   # we might as well leave
      unless ($setpriv) { return ''; }
   
   # Backdoor access?
       my $allowed=&allowed('eco',$ownerdomain);
   # Nope
       unless ($allowed) { return ''; }
   # Looks like we may have access, but could be locked by the owner of the construction space
       if ($allowed eq 'U') {
           my %blocked=&get('environment',['domcoord.author'],
                            $ownerdomain,$ownername);
   # Is blocked by owner
           if ($blocked{'domcoord.author'} eq 'blocked') { return ''; }
       }
       if (($allowed eq 'F') || ($allowed eq 'U')) {
   # Grant temporary access
           my $then=$env{'user.login.time'};
           my $update=$env{'user.update.time'};
           if (!$update) { $update = $then; }
           my $refresh=$env{'user.refresh.time'};
           if (!$refresh) { $refresh = $update; }
           my $now = time;
           &check_adhoc_privs($ownerdomain,$ownername,$update,$refresh,
                              $now,'ca','constructaccess');
           $ownerhome = &homeserver($ownername,$ownerdomain);
           return($ownername,$ownerdomain,$ownerhome);
       }
   # No business here
       return '';
   }
   
   # ----------------------------------------------------------- Content Blocking
   
   {
   # Caches for faster Course Contents display where content blocking
   # is in operation (i.e., interval param set) for timed quiz.
   #
   # User for whom data are being temporarily cached.
   my $cacheduser='';
   # Cached blockers for this user (a hash of blocking items).
   my %cachedblockers=();
   # When the data were last cached.
   my $cachedlast='';
   
   sub load_all_blockers {
       my ($uname,$udom,$blocks)=@_;
       if (($uname ne '') && ($udom ne '')) {
           if (($cacheduser eq $uname.':'.$udom) &&
               (abs($cachedlast-time)<5)) {
               return;
           }
       }
       $cachedlast=time;
       $cacheduser=$uname.':'.$udom;
       %cachedblockers = &get_commblock_resources($blocks);
   }
   
   sub get_comm_blocks {
       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 get_commblock_resources {
       my ($blocks) = @_;
       my %blockers = ();
       return %blockers unless ($env{'request.course.id'});
       return %blockers if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/);
       my %commblocks;
       if (ref($blocks) eq 'HASH') {
           %commblocks = %{$blocks};
       } else {
           %commblocks = &get_comm_blocks();
       }
       return %blockers unless (keys(%commblocks) > 0);
       my $navmap = Apache::lonnavmaps::navmap->new();
       return %blockers unless (ref($navmap));
       my $now = time;
       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 (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'maps'}})) {
                                   $blockers{$block}{maps} = $commblocks{$block}{'blocks'}{'docs'}{'maps'};
                               }
                           }
                           if (ref($commblocks{$block}{'blocks'}{'docs'}{'resources'}) eq 'HASH') {
                               if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'resources'}})) {
                                   $blockers{$block}{'resources'} = $commblocks{$block}{'blocks'}{'docs'}{'resources'};
                               }
                           }
                       }
                   }
               }
           } 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 @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,0,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);
                                               if ($interval[1] eq 'map') {
                                                   last;
                                               }
                                           }
                                       }
                                   }
                               }
                           }
                       }
                       if ($interval[0] =~ /^(\d+)/) {
                           my $timelimit = $1; 
                           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+$timelimit;
                               if ($timesup > $now) {
                                   my $activeblock;
                                   foreach my $res (@to_test) {
                                       if ($res->answerable()) {
                                           $activeblock = 1;
                                           last;
                                       }
                                   }
                                   if ($activeblock) {
                                       if (ref($commblocks{$block}{'blocks'}{'docs'}{'maps'}) eq 'HASH') {
                                            if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'maps'}})) {
                                                $blockers{$block}{'maps'} = $commblocks{$block}{'blocks'}{'docs'}{'maps'};
                                            }
                                       }
                                       if (ref($commblocks{$block}{'blocks'}{'docs'}{'resources'}) eq 'HASH') {
                                           if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'resources'}})) {
                                               $blockers{$block}{'resources'} = $commblocks{$block}{'blocks'}{'docs'}{'resources'};
                                           }
                                       }
                                   }
                               }
                           }
                       }
                   }
               }
           }
       }
       return %blockers;
   }
   
   sub has_comm_blocking {
       my ($priv,$symb,$uri,$blocks) = @_;
       my @blockers;
       return unless ($env{'request.course.id'});
       return unless ($priv eq 'bre');
       return if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/);
       return if ($env{'request.state'} eq 'construct');
       &load_all_blockers($env{'user.name'},$env{'user.domain'},$blocks);
       return unless (keys(%cachedblockers) > 0);
       my (%possibles,@symbs);
       if (!$symb) {
           $symb = &symbread($uri,1,1,1,\%possibles);
       }
       if ($symb) {
           @symbs = ($symb);
       } elsif (keys(%possibles)) {
           @symbs = keys(%possibles);
       }
       my $noblock;
       foreach my $symb (@symbs) {
           last if ($noblock);
           my ($map,$resid,$resurl)=&decode_symb($symb);
           foreach my $block (keys(%cachedblockers)) {
               if ($block =~ /^firstaccess____(.+)$/) {
                   my $item = $1;
                   if (($item eq $map) || ($item eq $symb)) {
                       $noblock = 1;
                       last;
                   }
               }
               if (ref($cachedblockers{$block}) eq 'HASH') {
                   if (ref($cachedblockers{$block}{'resources'}) eq 'HASH') {
                       if ($cachedblockers{$block}{'resources'}{$symb}) {
                           unless (grep(/^\Q$block\E$/,@blockers)) {
                               push(@blockers,$block);
                           }
                       }
                   }
               }
               if (ref($cachedblockers{$block}{'maps'}) eq 'HASH') {
                   if ($cachedblockers{$block}{'maps'}{$map}) {
                       unless (grep(/^\Q$block\E$/,@blockers)) {
                           push(@blockers,$block);
                       }
                   }
               }
           }
       }
       return if ($noblock);
       return @blockers;
   }
   }
   
   # -------------------------------- Deversion and split uri into path an filename
   
   #
   #   Removes the version 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 4105  sub get_symb_from_alias { Line 8711  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,$uname,$udom)=@_;
     foreach my $role (split(':',$sysrole)) {      foreach my $role (split(':',$sysrole)) {
  my ($crole,$cqual)=split(/\&/,$role);   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"; }
Line 4133  sub definerole { Line 8739  sub definerole {
             }              }
         }          }
     }      }
       my $uhome;
       if (($uname ne '') && ($udom ne '')) {
           $uhome = &homeserver($uname,$udom);
           return $uhome if ($uhome eq 'no_host');
       } else {
           $uname = $env{'user.name'};
           $udom = $env{'user.domain'};
           $uhome = $env{'user.home'};
       }
     my $command="encrypt:rolesput:$env{'user.domain'}:$env{'user.name'}:".      my $command="encrypt:rolesput:$env{'user.domain'}:$env{'user.name'}:".
                 "$env{'user.domain'}:$env{'user.name'}:".                  "$udom:$uname:rolesdef_$rolename=".
         "rolesdef_$rolename=".  
                 escape($sysrole.'_'.$domrole.'_'.$courole);                  escape($sysrole.'_'.$domrole.'_'.$courole);
     return reply($command,$env{'user.home'});      return reply($command,$uhome);
   } else {    } else {
     return 'refused';      return 'refused';
   }    }
Line 4146  sub definerole { Line 8760  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 4171  sub log_query { Line 8790  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);
Line 4183  sub log_query { Line 8802  sub log_query {
   
 sub update_portfolio_table {  sub update_portfolio_table {
     my ($uname,$udom,$file_name,$query,$group,$action) = @_;      my ($uname,$udom,$file_name,$query,$group,$action) = @_;
       if ($group ne '') {
           $file_name =~s /^\Q$group\E//;
       }
     my $homeserver = &homeserver($uname,$udom);      my $homeserver = &homeserver($uname,$udom);
     my $queryid=      my $queryid=
         &reply("querysend:".$query.':'.&escape($uname.':'.$udom.':'.$group).          &reply("querysend:".$query.':'.&escape($uname.':'.$udom.':'.$group).
Line 4191  sub update_portfolio_table { Line 8813  sub update_portfolio_table {
     return $reply;      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 {
     my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_;      my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_;
     my $homeserver;      my ($homeserver,$sleep,$loopmax);
     my $maxtries = 1;      my $maxtries = 1;
     if ($context eq 'automated') {      if ($context eq 'automated') {
         $homeserver = $perlvar{'lonHostID'};          $homeserver = $perlvar{'lonHostID'};
           $sleep = 2;
           $loopmax = 100;
         $maxtries = 10; # will wait for up to 2000s for retrieval of classlist data before timeout          $maxtries = 10; # will wait for up to 2000s for retrieval of classlist data before timeout
     } else {      } else {
         $homeserver = &homeserver($cnum,$dom);          $homeserver = &homeserver($cnum,$dom);
     }      }
     my $host=$hostname{$homeserver};      my $host=&hostname($homeserver);
     my $cmd = '';      my $cmd = '';
     foreach my $affiliate (keys %{$affiliatesref}) {      foreach my $affiliate (keys(%{$affiliatesref})) {
         $cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';          $cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';
     }      }
     $cmd =~ s/%%$//;      $cmd =~ s/%%$//;
Line 4216  sub fetch_enrollment_query { Line 8856  sub fetch_enrollment_query {
         &logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum);           &logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum); 
         return 'error: '.$queryid;          return 'error: '.$queryid;
     }      }
     my $reply = &get_query_reply($queryid);      my $reply = &get_query_reply($queryid,$sleep,$loopmax);
     my $tries = 1;      my $tries = 1;
     while (($reply=~/^timeout/) && ($tries < $maxtries)) {      while (($reply=~/^timeout/) && ($tries < $maxtries)) {
         $reply = &get_query_reply($queryid);          $reply = &get_query_reply($queryid,$sleep,$loopmax);
         $tries ++;          $tries ++;
     }      }
     if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {      if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
         &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);          &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);
     } else {      } else {
         my @responses = split/:/,$reply;          my @responses = split(/:/,$reply);
         if ($homeserver eq $perlvar{'lonHostID'}) {          if (grep { $_ eq $homeserver } &current_machine_ids()) {
             foreach my $line (@responses) {              foreach my $line (@responses) {
                 my ($key,$value) = split(/=/,$line,2);                  my ($key,$value) = split(/=/,$line,2);
                 $$replyref{$key} = $value;                  $$replyref{$key} = $value;
             }              }
         } else {          } else {
             my $pathname = $perlvar{'lonDaemons'}.'/tmp';              my $pathname = LONCAPA::tempdir();
             foreach my $line (@responses) {              foreach my $line (@responses) {
                 my ($key,$value) = split(/=/,$line);                  my ($key,$value) = split(/=/,$line);
                 $$replyref{$key} = $value;                  $$replyref{$key} = $value;
Line 4244  sub fetch_enrollment_query { Line 8884  sub fetch_enrollment_query {
                         if ($xml_classlist =~ /^error/) {                          if ($xml_classlist =~ /^error/) {
                             &logthis('fetch_enrollment_query - autoretrieve error: '.$xml_classlist.' for '.$filename.' from server: '.$homeserver.' '.$context.' '.$cnum);                              &logthis('fetch_enrollment_query - autoretrieve error: '.$xml_classlist.' for '.$filename.' from server: '.$homeserver.' '.$context.' '.$cnum);
                         } else {                          } else {
                             if ( open(FILE,">$destname") ) {                              if ( open(FILE,">",$destname) ) {
                                 print FILE &unescape($xml_classlist);                                  print FILE &unescape($xml_classlist);
                                 close(FILE);                                  close(FILE);
                             } else {                              } else {
Line 4261  sub fetch_enrollment_query { Line 8901  sub fetch_enrollment_query {
 }  }
   
 sub get_query_reply {  sub get_query_reply {
     my $queryid=shift;      my ($queryid,$sleep,$loopmax) = @_;
     my $replyfile=$perlvar{'lonDaemons'}.'/tmp/'.$queryid;      if (($sleep eq '') || ($sleep !~ /^\d+\.?\d*$/)) {
           $sleep = 0.2;
       }
       if (($loopmax eq '') || ($loopmax =~ /\D/)) {
           $loopmax = 100;
       }
       my $replyfile=LONCAPA::tempdir().$queryid;
     my $reply='';      my $reply='';
     for (1..100) {      for (1..$loopmax) {
  sleep 2;   sleep($sleep);
         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 4300  sub courselog_query { Line 8946  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 4308  sub userlog_query { Line 8960  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;
 }  }
   
Line 4338  sub auto_validate_courseID { Line 9017  sub auto_validate_courseID {
     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 4394  sub auto_photochoice { Line 9102  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 my $affiliate (keys(%{$affiliatesref})) {      foreach my $affiliate (keys(%{$affiliatesref})) {
Line 4434  sub auto_instcode_format { Line 9142  sub auto_instcode_format {
     my $courses = '';      my $courses = '';
     my @homeservers;      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)) {
                 if (!grep(/^\Q$tryserver\E$/,@homeservers)) {      if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
                     push(@homeservers,$tryserver);   push(@homeservers,$tryserver);
                 }      }
           }
       } elsif ($caller eq 'requests') {
           if ($codedom =~ /^$match_domain$/) {
               my $chome = &domain($codedom,'primary');
               unless ($chome eq 'no_host') {
                   push(@homeservers,$chome);
             }              }
         }          }
     } else {      } else {
Line 4455  sub auto_instcode_format { Line 9169  sub auto_instcode_format {
         $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$server);          $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$server);
         if ($response !~ /(con_lost|error|no_such_host|refused)/) {          if ($response !~ /(con_lost|error|no_such_host|refused)/) {
             my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) =               my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = 
  split/:/,$response;   split(/:/,$response);
             %{$codes} = (%{$codes},&str2hash($codes_str));              %{$codes} = (%{$codes},&str2hash($codes_str));
             push(@{$codetitles},&str2array($codetitles_str));              push(@{$codetitles},&str2array($codetitles_str));
             %{$cat_titles} = (%{$cat_titles},&str2hash($cat_titles_str));              %{$cat_titles} = (%{$cat_titles},&str2hash($cat_titles_str));
Line 4473  sub auto_instcode_format { Line 9187  sub auto_instcode_format {
 sub auto_instcode_defaults {  sub auto_instcode_defaults {
     my ($domain,$returnhash,$code_order) = @_;      my ($domain,$returnhash,$code_order) = @_;
     my @homeservers;      my @homeservers;
     foreach my $tryserver (keys(%libserv)) {  
         if ($hostdom{$tryserver} eq $domain) {      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)) {              if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
                 push(@homeservers,$tryserver);                  push(@homeservers,$tryserver);
             }              }
         }          }
     }      }
     my $ok_response = 0;  
     my $response;      my $response;
     while (@homeservers > 0 && $ok_response == 0) {      foreach my $server (@homeservers) {
         my $server = shift(@homeservers);          $response=&reply('autopossibleinstcodes:'.$domain,$server);
         $response=&reply('autoinstcodedefaults:'.$domain,$server);          next if ($response =~ /(con_lost|error|no_such_host|refused)/);
         if ($response !~ /(con_lost|error|no_such_host|refused)/) {          my ($codetitlestr,$codeorderstr,$cat_title,$cat_order) = 
             foreach my $pair (split(/\&/,$response)) {              split(':',$response);
                 my ($name,$value)=split(/\=/,$pair);          @{$codetitles} = map { &unescape($_); } (split('&',$codetitlestr));
                 if ($name eq 'code_order') {          @{$code_order} = map { &unescape($_); } (split('&',$codeorderstr));
                     @{$code_order} = split(/\&/,&unescape($value));          foreach my $item (split('&',$cat_title)) {   
                 } else {              my ($name,$value)=split('=',$item);
                     $returnhash->{&unescape($name)}=&unescape($value);              $cat_titles->{&unescape($name)}=&thaw_unescape($value);
                 }          }
           foreach my $item (split('&',$cat_order)) {
               my ($name,$value)=split('=',$item);
               $cat_orders->{&unescape($name)}=&thaw_unescape($value);
           }
           return 'ok';
       }
       return $response;
   }
   
   sub auto_courserequest_checks {
       my ($dom) = @_;
       my ($homeserver,%validations);
       if ($dom =~ /^$match_domain$/) {
           $homeserver = &domain($dom,'primary');
       }
       unless ($homeserver eq 'no_host') {
           my $response=&reply('autocrsreqchecks:'.$dom,$homeserver);
           unless ($response =~ /(con_lost|error|no_such_host|refused)/) {
               my @items = split(/&/,$response);
               foreach my $item (@items) {
                   my ($key,$value) = split('=',$item);
                   $validations{&unescape($key)} = &thaw_unescape($value);
             }              }
             $ok_response = 1;  
         }          }
     }      }
     if ($ok_response) {      return %validations; 
         return 'ok';  }
     } else {  
         return $response;  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 {  sub auto_validate_class_sec {
     my ($cdom,$cnum,$owner,$inst_class) = @_;      my ($cdom,$cnum,$owners,$inst_class) = @_;
     my $homeserver = &homeserver($cnum,$cdom);      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.':'.      my $response=&reply('autovalidateclass_sec:'.$inst_class.':'.
                         &escape($owner).':'.$cdom,$homeserver);                          &escape($ownerlist).':'.$cdom,$homeserver);
     return $response;      return $response;
 }  }
   
   sub auto_validate_instclasses {
       my ($cdom,$cnum,$owners,$classesref) = @_;
       my ($homeserver,%validations);
       $homeserver = &homeserver($cnum,$cdom);
       unless ($homeserver eq 'no_host') {
           my $ownerlist;
           if (ref($owners) eq 'ARRAY') {
               $ownerlist = join(',',@{$owners});
           } else {
               $ownerlist = $owners;
           }
           if (ref($classesref) eq 'HASH') {
               my $classes = &freeze_escape($classesref);
               my $response=&reply('autovalidateinstclasses:'.&escape($ownerlist).
                                   ':'.$cdom.':'.$classes,$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_crsreq_update {
       my ($cdom,$cnum,$crstype,$action,$ownername,$ownerdomain,$fullname,$title,
           $code,$accessstart,$accessend,$inbound) = @_;
       my ($homeserver,%crsreqresponse);
       if ($cdom =~ /^$match_domain$/) {
           $homeserver = &domain($cdom,'primary');
       }
       unless (($homeserver eq 'no_host') || ($homeserver eq '')) {
           my $info;
           if (ref($inbound) eq 'HASH') {
               $info = &freeze_escape($inbound);
           }
           my $response=&reply('autocrsrequpdate:'.$cdom.':'.$cnum.':'.&escape($crstype).
                               ':'.&escape($action).':'.&escape($ownername).':'.
                               &escape($ownerdomain).':'.&escape($fullname).':'.
                               &escape($title).':'.&escape($code).':'.
                               &escape($accessstart).':'.&escape($accessend).':'.$info,$homeserver);
           unless ($response =~ /(con_lost|error|no_such_host|refused)/) {
               my @items = split(/&/,$response);
               foreach my $item (@items) {
                   my ($key,$value) = split('=',$item);
                   $crsreqresponse{&unescape($key)} = &thaw_unescape($value);
               }
           }
       }
       return \%crsreqresponse;
   }
   
   sub auto_export_grades {
       my ($cdom,$cnum,$inforef,$gradesref) = @_;
       my ($homeserver,%exportresponse);
       if ($cdom =~ /^$match_domain$/) {
           $homeserver = &domain($cdom,'primary');
       }
       unless (($homeserver eq 'no_host') || ($homeserver eq '')) {
           my $info;
           if (ref($inforef) eq 'HASH') {
               $info = &freeze_escape($inforef);
           }
           if (ref($gradesref) eq 'HASH') {
               my $grades = &freeze_escape($gradesref);
               my $response=&reply('encrypt:autoexportgrades:'.$cdom.':'.$cnum.':'.
                                   $info.':'.$grades,$homeserver);
               unless ($response =~ /(con_lost|error|no_such_host|refused|unknown_command)/) {
                   my @items = split(/&/,$response);
                   foreach my $item (@items) {
                       my ($key,$value) = split('=',$item);
                       $exportresponse{&unescape($key)} = &thaw_unescape($value);
                   }
               }
           }
       }
       return \%exportresponse;
   }
   
   sub check_instcode_cloning {
       my ($codedefaults,$code_order,$cloner,$clonefromcode,$clonetocode) = @_;
       unless ((ref($codedefaults) eq 'HASH') && (ref($code_order) eq 'ARRAY')) {
           return;
       }
       my $canclone;
       if (@{$code_order} > 0) {
           my $instcoderegexp ='^';
           my @clonecodes = split(/\&/,$cloner);
           foreach my $item (@{$code_order}) {
               if (grep(/^\Q$item\E=/,@clonecodes)) {
                   foreach my $pair (@clonecodes) {
                       my ($key,$val) = split(/\=/,$pair,2);
                       $val = &unescape($val);
                       if ($key eq $item) {
                           $instcoderegexp .= '('.$val.')';
                           last;
                       }
                   }
               } else {
                   $instcoderegexp .= $codedefaults->{$item};
               }
           }
           $instcoderegexp .= '$';
           my (@from,@to);
           eval {
                  (@from) = ($clonefromcode =~ /$instcoderegexp/);
                  (@to) = ($clonetocode =~ /$instcoderegexp/);
           };
           if ((@from > 0) && (@to > 0)) {
               my @diffs = &Apache::loncommon::compare_arrays(\@from,\@to);
               if (!@diffs) {
                   $canclone = 1;
               }
           }
       }
       return $canclone;
   }
   
   sub default_instcode_cloning {
       my ($clonedom,$domdefclone,$clonefromcode,$clonetocode,$codedefaultsref,$codeorderref) = @_;
       my (%codedefaults,@code_order,$canclone);
       if ((ref($codedefaultsref) eq 'HASH') && (ref($codeorderref) eq 'ARRAY')) {
           %codedefaults = %{$codedefaultsref};
           @code_order = @{$codeorderref};
       } elsif ($clonedom) {
           &auto_instcode_defaults($clonedom,\%codedefaults,\@code_order);
       }
       if (($domdefclone) && (@code_order)) {
           my @clonecodes = split(/\+/,$domdefclone);
           my $instcoderegexp ='^';
           foreach my $item (@code_order) {
               if (grep(/^\Q$item\E$/,@clonecodes)) {
                   $instcoderegexp .= '('.$codedefaults{$item}.')';
               } else {
                   $instcoderegexp .= $codedefaults{$item};
               }
           }
           $instcoderegexp .= '$';
           my (@from,@to);
           eval {
               (@from) = ($clonefromcode =~ /$instcoderegexp/);
               (@to) = ($clonetocode =~ /$instcoderegexp/);
           };
           if ((@from > 0) && (@to > 0)) {
               my @diffs = &Apache::loncommon::compare_arrays(\@from,\@to);
               if (!@diffs) {
                   $canclone = 1;
               }
           }
       }
       return $canclone;
   }
   
 # ------------------------------------------------------- Course Group routines  # ------------------------------------------------------- Course Group routines
   
 sub get_coursegroups {  sub get_coursegroups {
Line 4556  sub toggle_coursegroup_status { Line 9505  sub toggle_coursegroup_status {
 }  }
   
 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);
     }      }
Line 4649  sub devalidate_getgroups_cache { Line 9598  sub devalidate_getgroups_cache {
 # ------------------------------------------------------------------ Plain Text  # ------------------------------------------------------------------ Plain Text
   
 sub plaintext {  sub plaintext {
     my ($short,$type,$cid) = @_;      my ($short,$type,$cid,$forcedefault) = @_;
     if ($short =~ /^cr/) {      if ($short =~ m{^cr/}) {
  return (split('/',$short))[-1];   return (split('/',$short))[-1];
     }      }
     if (!defined($cid)) {      if (!defined($cid)) {
         $cid = $env{'request.course.id'};          $cid = $env{'request.course.id'};
     }      }
     if (defined($cid) && defined($env{'course.'.$cid.'.'.$short.'.plaintext'})) {  
         return &Apache::lonlocal::mt($env{'course.'.$cid.'.'.$short.  
                                           '.plaintext'});  
     }  
     my %rolenames = (      my %rolenames = (
                       Course => 'std',                        Course    => 'std',
                       Group => 'alt1',                        Community => 'alt1',
                     );                      );
     if (defined($type) &&       if ($cid ne '') {
          defined($rolenames{$type}) &&           if ($env{'course.'.$cid.'.'.$short.'.plaintext'} ne '') {
          defined($prp{$short}{$rolenames{$type}})) {              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}});          return &Apache::lonlocal::mt($prp{$short}{$rolenames{$type}});
     } else {      } elsif ($cid ne '') {
         return &Apache::lonlocal::mt($prp{$short}{'std'});          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/^\/($match_domain)\/($match_courseid)\/.*/$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\//) {
Line 4701  sub assignrole { Line 9678  sub assignrole {
     } else {      } else {
         my $cwosec=$url;          my $cwosec=$url;
         $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$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 4721  sub assignrole { Line 9793  sub assignrole {
     }      }
     my $origstart = $start;      my $origstart = $start;
     my $origend = $end;      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 4731  sub assignrole { Line 9804  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 4738  sub assignrole { Line 9812  sub assignrole {
 # log new user role if status is ok  # log new user role if status is ok
     if ($answer eq 'ok') {      if ($answer eq 'ok') {
  &userrolelog($role,$uname,$udom,$url,$start,$end);   &userrolelog($role,$uname,$udom,$url,$start,$end);
           if (($role eq 'cc') || ($role eq 'in') ||
               ($role eq 'ep') || ($role eq 'ad') ||
               ($role eq 'ta') || ($role eq 'st') ||
               ($role=~/^cr/) || ($role eq 'gr') ||
               ($role eq 'co')) {
 # for course roles, perform group memberships changes triggered by role change.  # for course roles, perform group memberships changes triggered by role change.
         unless ($role =~ /^gr/) {              unless ($role =~ /^gr/) {
             &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend,                  &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend,
                                              $origstart);                                                   $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') || ($role eq 'dh') ||
                    ($role eq 'da')) {
               &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
   
 sub modifyuserauth {  sub modifyuserauth {
     my ($udom,$uname,$umode,$upass)=@_;      my ($udom,$uname,$umode,$upass)=@_;
     my $uhome=&homeserver($uname,$udom);      my $uhome=&homeserver($uname,$udom);
     unless (&allowed('mau',$udom)) { return 'refused'; }      my $allowed;
       if (&allowed('mau',$udom)) {
           $allowed = 1;
       } elsif (($umode eq 'internal') && ($udom eq $env{'user.domain'}) &&
                ($env{'request.course.id'}) && (&allowed('mip',$env{'request.course.id'})) &&
                (!$env{'course.'.$env{'request.course.id'}.'.internal.nopasswdchg'})) {
           my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
           my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
           if (($cdom ne '') && ($cnum ne '')) {
               my $is_owner = &is_course_owner($cdom,$cnum);
               if ($is_owner) {
                   $allowed = 1;
               }
           }
       }
       unless ($allowed) { return 'refused'; }
     &logthis('Call to modify user authentication '.$udom.', '.$uname.', '.      &logthis('Call to modify user authentication '.$udom.', '.$uname.', '.
              $umode.' by '.$env{'user.name'}.' at '.$env{'user.domain'}.               $umode.' by '.$env{'user.name'}.' at '.$env{'user.domain'}.
              ' in domain '.$env{'request.role.domain'});                 ' in domain '.$env{'request.role.domain'});  
Line 4779  sub modifyuser { Line 9971  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= &LONCAPA::clean_domain($udom);      $udom= &LONCAPA::clean_domain($udom);
     $uname=&LONCAPA::clean_username($uname);      $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 4841  sub modifyuser { Line 10041  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 4877  sub modifyuser { Line 10145  sub modifyuser {
   
 sub modifystudent {  sub modifystudent {
     my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,      my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
         $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid)=@_;          $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid,
           $selfenroll,$context,$inststatus,$credits,$instsec)=@_;
     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 4886  sub modifystudent { Line 10155  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,$instsec);
     return $reply;      return $reply;
 }  }
   
 sub modify_student_enrollment {  sub modify_student_enrollment {
     my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid) = @_;      my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,
           $locktype,$cid,$selfenroll,$context,$credits,$instsec) = @_;
     my ($cdom,$cnum,$chome);      my ($cdom,$cnum,$chome);
     if (!$cid) {      if (!$cid) {
  unless ($cid=$env{'request.course.id'}) {   unless ($cid=$env{'request.course.id'}) {
Line 4940  sub modify_student_enrollment { Line 10211  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,$instsec) },
    $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 4955  sub modify_student_enrollment { Line 10228  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 5000  sub writecoursepref { Line 10282  sub writecoursepref {
   
 sub createcourse {  sub createcourse {
     my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,      my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,
         $course_owner,$crstype)=@_;          $course_owner,$crstype,$cnum,$context,$category,$callercontext)=@_;
     $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) {
               my $reload;
               if (($callercontext eq 'auto') &&
                  ($ownerdom eq $env{'user.domain'}) && ($ownername eq $env{'user.name'})) {
                   $reload = 'reload';
               }
               if (&usertools_access($ownername,$ownerdom,$category,$reload,
                                     $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).':'.      my $newcourse = {
                   &escape($crstype),$uhome);                      $udom.'_'.$uname => {
     &flushcourselogs();                                       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 5061  ENDINITMAP Line 10395  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 {  sub is_course {
     my ($cdom,$cnum) = @_;      my ($cdom, $cnum) = scalar(@_) == 1 ? 
     my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,           ($_[0] =~ /^($match_domain)_($match_courseid)$/)  :  @_;
  undef,'.');      return unless (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/));
     if (exists($courses{$cdom.'_'.$cnum})) {      my $uhome=&homeserver($cnum,$cdom);
         return 1;      my $iscourse;
       if (grep { $_ eq $uhome } current_machine_ids()) {
           $iscourse = &LONCAPA::Lond::is_course($cdom,$cnum);
       } else {
           my $hashid = $cdom.':'.$cnum;
           ($iscourse,my $cached) = &is_cached_new('iscourse',$hashid);
           unless (defined($cached)) {
               my %courses = &courseiddump($cdom, '.', 1, '.', '.',
                                           $cnum,undef,undef,'.');
               $iscourse = 0;
               if (exists($courses{$cdom.'_'.$cnum})) {
                   $iscourse = 1;
               }
               &do_cache_new('iscourse',$hashid,$iscourse,3600);
           }
     }      }
     return 0;      return unless($iscourse);
       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);
Line 5122  sub is_locked { Line 10555  sub is_locked {
     if (ref($locked{$file_name}) eq 'ARRAY') {      if (ref($locked{$file_name}) eq 'ARRAY') {
         $is_locked = 'false';          $is_locked = 'false';
         foreach my $entry (@{$locked{$file_name}}) {          foreach my $entry (@{$locked{$file_name}}) {
            if (ref($entry) eq 'ARRAY') {              if (ref($entry) eq 'ARRAY') {
                $is_locked = 'true';                 $is_locked = 'true';
                last;                 if (ref($which) eq 'ARRAY') {
                      push(@{$which},$entry);
                  } else {
                      last;
                  }
            }             }
        }         }
     } else {      } else {
         $is_locked = 'false';          $is_locked = 'false';
     }      }
       return $is_locked;
 }  }
   
 sub declutter_portfile {  sub declutter_portfile {
Line 5159  sub save_selected_files { Line 10597  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,'>',LONCAPA::tempdir().$filename);
     foreach my $file (@files) {      foreach my $file (@files) {
         print (OUT $env{'form.currentpath'}.$file."\n");          print (OUT $env{'form.currentpath'}.$file."\n");
     }      }
Line 5173  sub save_selected_files { Line 10611  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 5183  sub files_in_path { Line 10621  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 5205  sub files_not_in_path { Line 10643  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::tempdir().$filename);
     while (my $line = <IN>) {      while (my $line = <IN>) {
         #ok, I know it's clunky, but I want it to work          #ok, I know it's clunky, but I want it to work
         my @paths_and_file = split(m|/|, $line);          my @paths_and_file = split(m|/|, $line);
Line 5318  sub modify_access_controls { Line 10756  sub modify_access_controls {
     my $tries = 0;      my $tries = 0;
     my $gotlock = &newput('file_permissions',$lockhash,$domain,$user);      my $gotlock = &newput('file_permissions',$lockhash,$domain,$user);
         
     while (($gotlock ne 'ok') && $tries <3) {      while (($gotlock ne 'ok') && $tries < 10) {
         $tries ++;          $tries ++;
         sleep 1;          sleep(0.1);
         $gotlock = &newput('file_permissions',$lockhash,$domain,$user);          $gotlock = &newput('file_permissions',$lockhash,$domain,$user);
     }      }
     if ($gotlock eq 'ok') {      if ($gotlock eq 'ok') {
Line 5346  sub modify_access_controls { Line 10784  sub modify_access_controls {
                 }                  }
             }              }
         }          }
           my ($group);
           if (&is_course($domain,$user)) {
               ($group,my $file) = split(/\//,$file_name,2);
           }
         $deloutcome = &del('file_permissions',\@deletions,$domain,$user);          $deloutcome = &del('file_permissions',\@deletions,$domain,$user);
         $new_values{$file_name."\0".'accesscontrol'} = \%new_control;          $new_values{$file_name."\0".'accesscontrol'} = \%new_control;
         $outcome = &put('file_permissions',\%new_values,$domain,$user);          $outcome = &put('file_permissions',\%new_values,$domain,$user);
         #  remove lock          #  remove lock
         my @del_lock = ($file_name."\0".'locked_access_records');          my @del_lock = ($file_name."\0".'locked_access_records');
         my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user);          my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user);
         my ($file,$group);  
         if (&is_course($domain,$user)) {  
             ($group,$file) = split(/\//,$file_name,2);  
         } else {  
             $file = $file_name;  
         }  
         my $sqlresult =          my $sqlresult =
             &update_portfolio_table($user,$domain,$file,'portfolio_access',              &update_portfolio_table($user,$domain,$file_name,'portfolio_access',
                                     $group);                                      $group);
     } else {      } else {
         $outcome = "error: could not obtain lockfile\n";            $outcome = "error: could not obtain lockfile\n";  
Line 5522  sub unmark_as_readonly { Line 10958  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') {              if ($listing eq 'unknown_cmd') {
                 $listing = &reply('ls:'.$dirRoot.'/'.$uri,                  $listing = &reply('ls2:'.$dirRoot.'/'.$uri,$uhome);
   &homeserver($uname,$udom));              } else {
                   @listing_results = map { &unescape($_); } split(/:/,$listing);
               }
               if ($listing eq 'unknown_cmd') {
                   $listing = &reply('ls:'.$dirRoot.'/'.$uri,$uhome);
                 @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 %allusers;                  ($listing eq 'no_such_dir') || ($listing eq 'empty')) {
             foreach my $tryserver (keys(%libserv)) {                  return ([],$listing);
                 if($hostdom{$tryserver} eq $udom) {              } else {
                     my $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'.                  return (\@listing_results);
  $udom, $tryserver);              }
                     my @listing_results;          } elsif(!$alternateRoot) {
                     if ($listing eq 'unknown_cmd') {              my (%allusers,%listerror);
                         $listing = &reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.      my %servers = &get_servers($udom,'library');
   $udom, $tryserver);       foreach my $tryserver (keys(%servers)) {
                         @listing_results = split(/:/,$listing);                  $listing = &reply('ls3:'.&escape("/res/$udom").':::::'.
                     } else {                                    &escape($udom),$tryserver);
                         @listing_results =                  if ($listing eq 'unknown_cmd') {
                             map { &unescape($_); } split(/:/,$listing);      $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'.
                     }        $udom, $tryserver);
                     if ($listing_results[0] ne 'no_such_dir' &&                   } else {
                         $listing_results[0] ne 'empty'       &&                      @listing_results = map { &unescape($_); } split(/:/,$listing);
                         $listing_results[0] ne 'con_lost') {  
                         foreach my $line (@listing_results) {  
                             my ($entry) = split(/&/,$line,2);  
                             $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 my $user (sort(keys(%allusers))) {              foreach my $user (sort(keys(%allusers))) {
                 $alluserstr.=$user.'&user:';                  push(@alluserslist,$user.'&user');
             }              }
             $alluserstr=~s/:$//;              if (!%listerror) {
             return split(/:/,$alluserstr);                  # no errors
                   return (\@alluserslist);
               } elsif (scalar(keys(%servers)) == 1) {
                   # one library server, one error
                   my ($key) = keys(%listerror);
                   return (\@alluserslist, $listerror{$key});
               } elsif ( grep { $_ eq 'con_lost' } values(%listerror) ) {
                   # con_lost indicates that we might miss data from at least one
                   # library server
                   return (\@alluserslist, 'con_lost');
               } else {
                   # multiple library servers and no con_lost -> data should be
                   # complete.
                   return (\@alluserslist);
               }
   
         } else {          } else {
             return ('missing user name');              return ([],'missing username');
         }          }
     } elsif(!defined($alternateDirectoryRoot)) {      } elsif(!defined($getpropath)) {
         my $tryserver;          my $path = $perlvar{'lonDocRoot'}.'/res/'; 
         my %alldom=();          my @all_domains = map { $path.$_.'/&domain'; } (sort(&all_domains()));
         foreach $tryserver (keys(%libserv)) {          return (\@all_domains);
             $alldom{$hostdom{$tryserver}}=1;  
         }  
         my $alldomstr='';  
         foreach my $domain (sort(keys(%alldom))) {  
             $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain:';  
         }  
         $alldomstr=~s/:$//;  
         return split(/:/,$alldomstr);         
     } else {      } else {
         return ('missing domain');          return ([],'missing domain');
     }      }
 }  }
   
Line 5610  sub dirlist { Line 11085  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 = &LONCAPA::clean_domain($studentDomain);      $studentDomain = &LONCAPA::clean_domain($studentDomain);
     $studentName   = &LONCAPA::clean_username($studentName);      $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 5640  sub stat_file { Line 11107  sub stat_file {
     my ($uri) = @_;      my ($uri) = @_;
     $uri = &clutter_with_no_wrapper($uri);      $uri = &clutter_with_no_wrapper($uri);
   
     my ($udom,$uname,$file,$dir);      my ($udom,$uname,$file);
     if ($uri =~ m-^/(uploaded|editupload)/-) {      if ($uri =~ m-^/(uploaded|editupload)/-) {
  ($udom,$uname,$file) =   ($udom,$uname,$file) =
     ($uri =~ m-/(?:uploaded|editupload)/?($match_domain)/?($match_name)/?(.*)-);      ($uri =~ m-/(?:uploaded|editupload)/?($match_domain)/?($match_name)/?(.*)-);
  $file = 'userfiles/'.$file;   $file = 'userfiles/'.$file;
  $dir = &propath($udom,$uname);  
     }      }
     if ($uri =~ m-^/res/-) {      if ($uri =~ m-^/res/-) {
  ($udom,$uname) =    ($udom,$uname) = 
Line 5657  sub stat_file { Line 11123  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 5691  sub directcondval { Line 11163  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 5758  sub devalidatecourseresdata { Line 11230  sub devalidatecourseresdata {
   
   
 # --------------------------------------------------- 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 5805  sub get_userresdata { Line 11284  sub get_userresdata {
     }      }
     #error 2 occurs when the .db doesn't exist      #error 2 occurs when the .db doesn't exist
     if ($tmp!~/error: 2 /) {      if ($tmp!~/error: 2 /) {
  &logthis("<font color=\"blue\">WARNING:".          if ((!defined($cached)) || ($tmp ne 'con_lost')) {
  " Trying to get resource data for ".      &logthis("<font color=\"blue\">WARNING:".
  $uname." at ".$udom.": ".       " Trying to get resource data for ".
  $tmp."</font>");       $uname." at ".$udom.": ".
        $tmp."</font>");
           }
     } elsif ($tmp=~/error: 2 /) {      } elsif ($tmp=~/error: 2 /) {
  #&EXT_cache_set($udom,$uname);   #&EXT_cache_set($udom,$uname);
  &do_cache_new('userres',$hashid,undef,600);   &do_cache_new('userres',$hashid,undef,600);
Line 5816  sub get_userresdata { Line 11297  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 5827  sub resdata { Line 11322  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 (ref($item) eq 'ARRAY') {
     return $result->{$item};      if (defined($result->{$item->[0]})) {
  }          return [$result->{$item->[0]},$item->[1]];
       }
           }
     }      }
     return undef;      return undef;
 }  }
   
   sub get_domain_ltitools {
       my ($cdom) = @_;
       my %ltitools;
       my ($result,$cached)=&is_cached_new('ltitools',$cdom);
       if (defined($cached)) {
           if (ref($result) eq 'HASH') {
               %ltitools = %{$result};
           }
       } else {
           my %domconfig = &get_dom('configuration',['ltitools'],$cdom);
           if (ref($domconfig{'ltitools'}) eq 'HASH') {
               %ltitools = %{$domconfig{'ltitools'}};
               my %encdomconfig = &get_dom('encconfig',['ltitools'],$cdom);
               if (ref($encdomconfig{'ltitools'}) eq 'HASH') {
                   foreach my $id (keys(%ltitools)) {
                       if (ref($encdomconfig{'ltitools'}{$id}) eq 'HASH') {
                           foreach my $item ('key','secret') {
                               $ltitools{$id}{$item} = $encdomconfig{'ltitools'}{$id}{$item};
                           }
                       }
                   }
               }
           }
           my $cachetime = 24*60*60;
           &do_cache_new('ltitools',$cdom,\%ltitools,$cachetime);
       }
       return %ltitools;
   }
   
   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 5856  sub EXT_cache_status { Line 11402  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 5963  sub EXT { Line 11509  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 5985  sub EXT { Line 11523  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;
   
Line 6034  sub EXT { Line 11603  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 6062  sub EXT { Line 11634  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 6075  sub EXT { Line 11647  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 6094  sub EXT { Line 11667  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
Line 6129  sub EXT { Line 11701  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 6163  sub packages_tab_default { Line 11747  sub packages_tab_default {
     $do_default=1;      $do_default=1;
  } elsif ($pack_type eq 'extension') {   } elsif ($pack_type eq 'extension') {
     push(@extension,[$package,$pack_type,$pack_part]);      push(@extension,[$package,$pack_type,$pack_part]);
  } else {   } 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]);      push(@specifics,[$package,$pack_type,$pack_part]);
  }   }
     }      }
Line 6222  sub add_prefix_and_part { Line 11807  sub add_prefix_and_part {
 # ---------------------------------------------------------------- Get metadata  # ---------------------------------------------------------------- Get metadata
   
 my %metaentry;  my %metaentry;
   my %importedpartids;
   my %importedrespids;
 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|ext\.tool)$})) ||
         ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) ||          ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) {
  ($uri =~ m|home/$match_username/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 6245  sub metadata { Line 11835  sub metadata {
  if (defined($cached)) { return $result->{':'.$what}; }   if (defined($cached)) { return $result->{':'.$what}; }
     }      }
     {      {
   # Imported parts would go here
           my @origfiletagids=();
           my $importedparts=0;
   
   # Imported responseids would go here
           my $importedresponses=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 6261  sub metadata { Line 11858  sub metadata {
         my %metathesekeys=();          my %metathesekeys=();
         unless ($filename=~/\.meta$/) { $filename.='.meta'; }          unless ($filename=~/\.meta$/) { $filename.='.meta'; }
  my $metastring;   my $metastring;
  if ($uri !~ m -^(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 6321  sub metadata { Line 11925  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 $importid=$token->[2]->{'id'};
                           my $importmode=$token->[2]->{'importmode'};
   #
   # Check metadata for imported file to
   # see if it contained response items
   #
                           my %currmetaentry = %metaentry;
                           my $libresponseorder = &metadata($location,'responseorder');
                           my $origfile;
                           if ($libresponseorder ne '') {
                               if ($#origfiletagids<0) {
                                   undef(%importedrespids);
                                   undef(%importedpartids);
                               }
                               @{$importedrespids{$importid}} = split(/\s*,\s*/,$libresponseorder);
                               if (@{$importedrespids{$importid}} > 0) {
                                   $importedresponses = 1;
   # We need to get the original file and the imported file to get the response order correct
   # Load and inspect original file
                                   if ($#origfiletagids<0) {
                                       my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri);
                                       $origfile=&getfile($origfilelocation);
                                       @origfiletagids=($origfile=~/<((?:\w+)response|import|part)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
                                   }
                               }
                           }
   # Do not overwrite contents of %metaentry hash for resource itself with 
   # hash populated for imported library file
                           %metaentry = %currmetaentry;
                           undef(%currmetaentry);
                           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 we didn't do that already
                              if ($#origfiletagids<0) {
                                  undef(%importedrespids);
                                  undef(%importedpartids);
                                  if ($origfile eq '') {
                                      my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri);
                                      $origfile=&getfile($origfilelocation);
                                      @origfiletagids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
                                  }
                              }
   
   # Load and inspect imported file
                              my $impfile=&getfile($location);
                              my @impfilepartids=($impfile=~/<part[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
                              if ($#impfilepartids>=0) {
   # This problem had parts
                                  $importedpartids{$token->[2]->{'id'}}=join(',',@impfilepartids);
                              } else {
   # Importing by turning a single problem into a problem part
   # It gets the import-tags ID as part-ID
                                  $unikey=&add_prefix_and_part($prefix,$token->[2]->{'id'});
                                  $importedpartids{$token->[2]->{'id'}}=$token->[2]->{'id'};
                              }
                           } else {
   # Normal import
                              $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});
                              if (defined($token->[2]->{'id'})) {
                                 $unikey.='_'.$token->[2]->{'id'};
                              }
                           }
   
  if ($depthcount<20) {   if ($depthcount<20) {
     my $location=$parser->get_text('/import');  
     my $dir=$filename;  
     $dir=~s|[^/]*$||;  
     $location=&filelocation($dir,$location);  
     my $metadata =       my $metadata = 
  &metadata($uri,'keys', $location,$unikey,   &metadata($uri,'keys', $location,$unikey,
   $depthcount+1);    $depthcount+1);
Line 6349  sub metadata { Line 12013  sub metadata {
  $metaentry{':'.$meta}=$metaentry{':'.$meta};   $metaentry{':'.$meta}=$metaentry{':'.$meta};
  $metathesekeys{$meta}=1;   $metathesekeys{$meta}=1;
     }      }
  }  
     } else {   
   
                           }
       } else {
   #
   # Not importing, some other kind of non-package, non-library start tag
   # 
                           $unikey=$entry.&add_prefix_and_part($prefix,$token->[2]->{'part'});
                           if (defined($token->[2]->{'id'})) {
                               $unikey.='_'.$token->[2]->{'id'};
                           }
  if (defined($token->[2]->{'name'})) {    if (defined($token->[2]->{'name'})) { 
     $unikey.='_'.$token->[2]->{'name'};       $unikey.='_'.$token->[2]->{'name'}; 
  }   }
Line 6366  sub metadata { Line 12037  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 6379  sub metadata { Line 12051  sub metadata {
     }      }
  }   }
  my ($extension) = ($uri =~ /\.(\w+)$/);   my ($extension) = ($uri =~ /\.(\w+)$/);
    $extension = lc($extension);
    if ($extension eq 'htm') { $extension='html'; }
   
  foreach my $key (keys(%packagetab)) {   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'})) {  
    if (!exists($metaentry{':packages'})
       || $packagetab{"import_defaults&extension_$extension"}) {
     foreach my $key (keys(%packagetab)) {      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; }
Line 6419  sub metadata { Line 12096  sub metadata {
     grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'}));      grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'}));
  $metaentry{':packages'} = join(',',@uniq_packages);   $metaentry{':packages'} = join(',',@uniq_packages);
   
           if (($importedresponses) || ($importedparts)) {
               if ($importedparts) {
   # We had imported parts and need to rebuild partorder
                   $metaentry{':partorder'}='';
                   $metathesekeys{'partorder'}=1;
               }
               if ($importedresponses) {
   # We had imported responses and need to rebuild responseorder
                   $metaentry{':responseorder'}='';
                   $metathesekeys{'responseorder'}=1;
               }
               for (my $index=0;$index<$#origfiletagids;$index+=2) {
                   my $origid = $origfiletagids[$index+1];
                   if ($origfiletagids[$index] eq 'part') {
   # Original part, part of the problem
                       if ($importedparts) {
                           $metaentry{':partorder'}.=','.$origid;
                       }
                   } elsif ($origfiletagids[$index] eq 'import') {
                       if ($importedparts) {
   # We have imported parts at this position
                           $metaentry{':partorder'}.=','.$importedpartids{$origid};
                       }
                       if ($importedresponses) {
   # We have imported responses at this position
                           if (ref($importedrespids{$origid}) eq 'ARRAY') {
                               $metaentry{':responseorder'}.=','.join(',',map { $origid.'_'.$_ } @{$importedrespids{$origid}});
                           }
                       }
                   } else {
   # Original response item, part of the problem
                       if ($importedresponses) {
                           $metaentry{':responseorder'}.=','.$origid;
                       }
                   }
               }
               if ($importedparts) {
                   $metaentry{':partorder'}=~s/^\,//;
               }
               if ($importedresponses) {
                   $metaentry{':responseorder'}=~s/^\,//;
               }
           }
   
  $metaentry{':keys'} = join(',',keys(%metathesekeys));   $metaentry{':keys'} = join(',',keys(%metathesekeys));
  &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);   &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
  $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);   $metaentry{':allpossiblekeys'}=join(',',keys(%metathesekeys));
  &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 6491  sub devalidate_title_cache { Line 12212  sub devalidate_title_cache {
     &devalidate_cache_new('title',$key);      &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 6504  sub gettitle { Line 12230  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 6545  sub get_slot { Line 12278  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 6554  sub symblist { Line 12365  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 6572  sub symblist { Line 12383  sub symblist {
 # --------------------------------------------------------------- Verify a symb  # --------------------------------------------------------------- Verify a symb
   
 sub symbverify {  sub symbverify {
     my ($symb,$thisurl)=@_;      my ($symb,$thisurl,$encstate)=@_;
     my $thisfn=$thisurl;      my $thisfn=$thisurl;
     $thisfn=&declutter($thisfn);      $thisfn=&declutter($thisfn);
 # direct jump to resource in page or to a sequence - will construct own symbs  # direct jump to resource in page or to a sequence - will construct own symbs
Line 6591  sub symbverify { Line 12402  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)};          if (($thisurl =~ m{^/adm/wrapper/ext/}) || ($thisurl =~ m{^ext/})) {
         unless ($ids) {               $thisurl =~ s/\?.+$//;
            $ids=$bighash{'ids_/'.$thisurl};              if ($map =~ m{^uploaded/.+\.page$}) {
                   $thisurl =~ s{^(/adm/wrapper|)/ext/}{http://};
                   $thisurl =~ s{^\Qhttp://https://\E}{https://};
               }
           }
           my $ids;
           if ($map =~ m{^uploaded/.+\.page$}) {
               $ids=$bighash{'ids_'.&clutter_with_no_wrapper($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)
               if ($thisfn =~ m{^/adm/wrapper/ext/}) {
                   $symb =~ s/\?.+$//;
               }
     foreach my $id (split(/\,/,$ids)) {      foreach my $id (split(/\,/,$ids)) {
        my ($mapid,$resid)=split(/\./,$id);         my ($mapid,$resid)=split(/\./,$id);
                if (                 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_'.$id} 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 6679  sub deversion { Line 12511  sub deversion {
 # ------------------------------------------------------ Return symb list entry  # ------------------------------------------------------ Return symb list entry
   
 sub symbread {  sub symbread {
     my ($thisfn,$donotrecurse)=@_;      my ($thisfn,$donotrecurse,$ignorecachednull,$checkforblock,$possibles)=@_;
     my $cache_str='request.symbread.cached.'.$thisfn;      my $cache_str='request.symbread.cached.'.$thisfn;
     if (defined($env{$cache_str})) { return $env{$cache_str}; }      if (defined($env{$cache_str})) {
           if ($ignorecachednull) {
               return $env{$cache_str} unless ($env{$cache_str} eq '');
           } else {
               return $env{$cache_str};
           }
       }
 # no filename provided? try from environment  # no filename provided? try from environment
     unless ($thisfn) {      unless ($thisfn) {
         if ($env{'request.symb'}) {          if ($env{'request.symb'}) {
     return $env{$cache_str}=&symbclean($env{'request.symb'});              return $env{$cache_str}=&symbclean($env{'request.symb'});
  }          }
  $thisfn=$env{'request.filename'};          $thisfn=$env{'request.filename'};
     }      }
     if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }      if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }
 # is that filename actually a symb? Verify, clean, and return  # is that filename actually a symb? Verify, clean, and return
Line 6717  sub symbread { Line 12555  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 6743  sub symbread { Line 12581  sub symbread {
      my ($mapid,$resid)=split(/\./,$ids);       my ($mapid,$resid)=split(/\./,$ids);
      $syval=&encode_symb($bighash{'map_id_'.$mapid},       $syval=&encode_symb($bighash{'map_id_'.$mapid},
     $resid,$thisfn);      $resid,$thisfn);
                  } elsif (!$donotrecurse) {                       if (ref($possibles) eq 'HASH') {
                            $possibles->{$syval} = 1;
                        }
                        if ($checkforblock) {
                            my @blockers = &has_comm_blocking('bre',$syval,$bighash{'src_'.$ids});
                            if (@blockers) {
                                $syval = '';
                                return;
                            }
                        }
                    } elsif ((!$donotrecurse) || ($checkforblock) || (ref($possibles) eq 'HASH')) {
 # ------------------------------------------ There is more than one possibility  # ------------------------------------------ There is more than one possibility
                      my $realpossible=0;                       my $realpossible=0;
                      foreach my $id (@possibilities) {                       foreach my $id (@possibilities) {
  my $file=$bighash{'src_'.$id};   my $file=$bighash{'src_'.$id};
                          if (&allowed('bre',$file)) {                           my $canaccess;
              my ($mapid,$resid)=split(/\./,$id);                           if (($donotrecurse) || ($checkforblock) || (ref($possibles) eq 'HASH')) {
                             if ($bighash{'map_type_'.$mapid} ne 'page') {                               $canaccess = 1;
  $realpossible++;                           } else {
                                 $syval=&encode_symb($bighash{'map_id_'.$mapid},                               $canaccess = &allowed('bre',$file);
     $resid,$thisfn);                           }
                             }                           if ($canaccess) {
                 my ($mapid,$resid)=split(/\./,$id);
                                if ($bighash{'map_type_'.$mapid} ne 'page') {
                                    my $poss_syval=&encode_symb($bighash{'map_id_'.$mapid},
                                                                $resid,$thisfn);
                                    if (ref($possibles) eq 'HASH') {
                                        $possibles->{$syval} = 1;
                                    }
                                    if ($checkforblock) {
                                        my @blockers = &has_comm_blocking('bre',$poss_syval,$file);
                                        unless (@blockers > 0) {
                                            $syval = $poss_syval;
                                            $realpossible++;
                                        }
                                    } else {
                                        $syval = $poss_syval;
                                        $realpossible++;
                                    }
                                }
  }   }
                      }                       }
      if ($realpossible!=1) { $syval=''; }       if ($realpossible!=1) { $syval=''; }
Line 6762  sub symbread { Line 12628  sub symbread {
                      $syval='';                       $syval='';
                  }                   }
       }        }
               untie(%bighash)                untie(%bighash);
            }             }
         }          }
         if ($syval) {          if ($syval) {
     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 6878  sub getCODE { Line 12744  sub getCODE {
     }      }
     return undef;      return undef;
 }  }
   #
   #  Determines the random seed for a specific context:
   #
   # parameters:
   #   symb      - in course context the symb for the seed.
   #   course_id - The course id of the form domain_coursenum.
   #   domain    - Domain for the user.
   #   course    - Course for the user.
   #   cenv      - environment of the course.
   #
   # NOTE:
   #   All parameters are picked out of the environment if missing
   #   or not defined.
   #   If a symb cannot be determined the current time is used instead.
   #
   #  For a given well defined symb, courside, domain, username,
   #  and course environment, the seed is reproducible.
   #
 sub rndseed {  sub rndseed {
     my ($symb,$courseid,$domain,$username)=@_;      my ($symb,$courseid,$domain,$username, $cenv)=@_;
   
     my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser();      my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser();
     if (!$symb) {      if (!defined($symb)) {
  unless ($symb=$wsymb) { return time; }   unless ($symb=$wsymb) { return time; }
     }      }
     if (!$courseid) { $courseid=$wcourseid; }      if (!defined $courseid) { 
     if (!$domain) { $domain=$wdomain; }   $courseid=$wcourseid; 
     if (!$username) { $username=$wusername }      }
     my $which=&get_rand_alg();      if (!defined $domain) { $domain=$wdomain; }
       if (!defined $username) { $username=$wusername }
   
       my $which;
       if (defined($cenv->{'rndseed'})) {
    $which = $cenv->{'rndseed'};
       } else {
    $which =&get_rand_alg($courseid);
       }
     if (defined(&getCODE())) {      if (defined(&getCODE())) {
  if ($which eq '64bit5') {   if ($which eq '64bit5') {
     return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username);      return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username);
Line 7077  sub rndseed_CODE_64bit5 { Line 12966  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);
     }      }
Line 7215  sub getfile { Line 13108  sub getfile {
   
 sub repcopy_userfile {  sub repcopy_userfile {
     my ($file)=@_;      my ($file)=@_;
     if ($file =~ m -^/*(uploaded|editupload)/-) { $file=&filelocation("",$file); }      my $londocroot = $perlvar{'lonDocRoot'};
     if ($file =~ m|^/home/httpd/html/lonUsers/|) { return 'ok'; }      if ($file =~ m{^/*(uploaded|editupload)/}) { $file=&filelocation("",$file); }
       if ($file =~ m{^\Q/home/httpd/lonUsers/\E}) { return 'ok'; }
     my ($cdom,$cnum,$filename) =       my ($cdom,$cnum,$filename) = 
  ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_name)/+(.*)|);   ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_name)/+(.*)|);
     my $uri="/uploaded/$cdom/$cnum/$filename";      my $uri="/uploaded/$cdom/$cnum/$filename";
Line 7262  sub repcopy_userfile { Line 13156  sub repcopy_userfile {
     if (-e $transferfile) { return 'ok'; }      if (-e $transferfile) { return 'ok'; }
     my $request;      my $request;
     $uri=~s/^\///;      $uri=~s/^\///;
     $request=new HTTP::Request('GET','http://'.$hostname{&homeserver($cnum,$cdom)}.'/raw/'.$uri);      my $homeserver = &homeserver($cnum,$cdom);
       my $hostname = &hostname($homeserver);
       my $protocol = $protocol{$homeserver};
       $protocol = 'http' if ($protocol ne 'https');
       $request=new HTTP::Request('GET',$protocol.'://'.$hostname.'/raw/'.$uri);
     my $response=$ua->request($request,$transferfile);      my $response=$ua->request($request,$transferfile);
 # did it work?  # did it work?
     if ($response->is_error()) {      if ($response->is_error()) {
Line 7277  sub repcopy_userfile { Line 13175  sub repcopy_userfile {
   
 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 $hostname = &hostname($homeserver);
           my $protocol = $protocol{$homeserver};
           $protocol = 'http' if ($protocol ne 'https');
           return $protocol.'://'.$hostname.'/'.$uri.
                (($uri=~/\?/)?'&':'?').'token='.$token.                 (($uri=~/\?/)?'&':'?').'token='.$token.
                                '&tokenissued='.$perlvar{'lonHostID'};                                 '&tokenissued='.$perlvar{'lonHostID'};
     } else {      } else {
Line 7300  sub tokenwrapper { Line 13202  sub tokenwrapper {
 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 $hostname = &hostname($homeserver);
       my $protocol = $protocol{$homeserver};
       $protocol = 'http' if ($protocol ne 'https');
       $uri = $protocol.'://'.$hostname.'/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 7320  sub readfile { Line 13226  sub readfile {
     my $file = shift;      my $file = shift;
     if ( (! -e $file ) || ($file eq '') ) { return -1; };      if ( (! -e $file ) || ($file eq '') ) { return -1; };
     my $fh;      my $fh;
     open($fh,"<$file");      open($fh,"<",$file);
     my $a='';      my $a='';
     while (my $line = <$fh>) { $a .= $line; }      while (my $line = <$fh>) { $a .= $line; }
     return $a;      return $a;
Line 7335  sub filelocation { Line 13241  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/$match_username/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)=
Line 7349  sub filelocation { Line 13252  sub filelocation {
         my @ids=&current_machine_ids();          my @ids=&current_machine_ids();
         foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }          foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }
         if ($is_me) {          if ($is_me) {
      $location=&propath($udom,$uname).       $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 7380  sub hreflocation { Line 13291  sub hreflocation {
     }      }
     if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) {      if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) {
  $file=~s-^\Q$perlvar{'lonDocRoot'}\E--;   $file=~s-^\Q$perlvar{'lonDocRoot'}\E--;
     } elsif ($file=~m-/home/($match_username)/public_html/-) {  
  $file=~s-^/home/($match_username)/public_html/-/~$1/-;  
     } elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) {      } elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) {
  $file=~s-^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/   $file=~s{^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/}
     -/uploaded/$1/$2/-x;          {/uploaded/$1/$2/}x;
       }
       if ($file=~ m{^/userfiles/}) {
    $file =~ s{^/userfiles/}{/uploaded/};
     }      }
     return $file;      return $file;
 }  }
   
   
   
   
   
 sub current_machine_domains {  sub current_machine_domains {
     my $hostname=$hostname{$perlvar{'lonHostID'}};      return &machine_domains(&hostname($perlvar{'lonHostID'}));
   }
   
   sub machine_domains {
       my ($hostname) = @_;
     my @domains;      my @domains;
       my %hostname = &all_hostnames();
     while( my($id, $name) = each(%hostname)) {      while( my($id, $name) = each(%hostname)) {
 # &logthis("-$id-$name-$hostname-");  # &logthis("-$id-$name-$hostname-");
  if ($hostname eq $name) {   if ($hostname eq $name) {
     push(@domains,$hostdom{$id});      push(@domains,&host_domain($id));
  }   }
     }      }
     return @domains;      return @domains;
 }  }
   
 sub current_machine_ids {  sub current_machine_ids {
     my $hostname=$hostname{$perlvar{'lonHostID'}};      return &machine_ids(&hostname($perlvar{'lonHostID'}));
   }
   
   sub machine_ids {
       my ($hostname) = @_;
       $hostname ||= &hostname($perlvar{'lonHostID'});
     my @ids;      my @ids;
     while( my($id, $name) = each(%hostname)) {      my %name_to_host = &all_names();
 # &logthis("-$id-$name-$hostname-");      if (ref($name_to_host{$hostname}) eq 'ARRAY') {
  if ($hostname eq $name) {   return @{ $name_to_host{$hostname} };
     push(@ids,$id);  
  }  
     }      }
     return @ids;      return;
 }  }
   
 sub additional_machine_domains {  sub additional_machine_domains {
     my @domains;      my @domains;
     open(my $fh,"<$perlvar{'lonTabDir'}/expected_domains.tab");      open(my $fh,"<","$perlvar{'lonTabDir'}/expected_domains.tab");
     while( my $line = <$fh>) {      while( my $line = <$fh>) {
         $line =~ s/\s//g;          $line =~ s/\s//g;
         push(@domains,$line);          push(@domains,$line);
Line 7436  sub default_login_domain { Line 13360  sub default_login_domain {
     return $domain;      return $domain;
 }  }
   
   sub shared_institution {
       my ($dom) = @_;
       my $same_intdom;
       my $hostintdom = &internet_dom($perlvar{'lonHostID'});
       if ($hostintdom ne '') {
           my %iphost = &get_iphost();
           my $primary_id = &domain($dom,'primary');
           my $primary_ip = &get_host_ip($primary_id);
           if (ref($iphost{$primary_ip}) eq 'ARRAY') {
               foreach my $id (@{$iphost{$primary_ip}}) {
                   my $intdom = &internet_dom($id);
                   if ($intdom eq $hostintdom) {
                       $same_intdom = 1;
                       last;
                   }
               }
           }
       }
       return $same_intdom;
   }
   
   sub uses_sts {
       my ($ignore_cache) = @_;
       my $lonhost = $perlvar{'lonHostID'};
       my $hostname = &hostname($lonhost);
       my $sts_on;
       if ($protocol{$lonhost} eq 'https') {
           my $cachetime = 12*3600;
           if (!$ignore_cache) {
               ($sts_on,my $cached)=&is_cached_new('stspolicy',$lonhost);
               if (defined($cached)) {
                   return $sts_on;
               }
           }
           my $ua=new LWP::UserAgent;
           my $url = $protocol{$lonhost}.'://'.$hostname.'/index.html';
           my $request=new HTTP::Request('HEAD',$url);
           my $response=$ua->request($request);
           if ($response->is_success) {
               my $has_sts = $response->header('Strict-Transport-Security');
               if ($has_sts eq '') {
                   $sts_on = 0;
               } else {
                   if ($has_sts =~ /\Qmax-age=\E(\d+)/) {
                       my $maxage = $1;
                       if ($maxage) {
                           $sts_on = 1;
                       } else {
                           $sts_on = 0;
                       }
                   } else {
                       $sts_on = 0;
                   }
               }
               return &do_cache_new('stspolicy',$lonhost,$sts_on,$cachetime);
           }
       }
       return;
   }
   
 # ------------------------------------------------------------- Declutters URLs  # ------------------------------------------------------------- Declutters URLs
   
 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 7454  sub declutter { Line 13443  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 7480  sub clutter { Line 13470  sub clutter {
 # &logthis("Got a blank emb style");  # &logthis("Got a blank emb style");
     }      }
  }   }
       } elsif ($thisfn =~ m{^/adm/$match_domain/$match_courseid/\d+/ext\.tool$}) {
           $thisfn='/adm/wrapper'.$thisfn;
     }      }
     return $thisfn;      return $thisfn;
 }  }
Line 7523  sub correct_line_ends { Line 13515  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)=
     my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf');      &Apache::lonnet::is_cached_new('dns',$url);
     %perlvar = (%perlvar,%{$configvars});   if ($cached) {
       &$func($content,$hashref);
       return;
    }
       }
   
       my %alldns;
       if (open(my $config,"<","$perlvar{'lonTabDir'}/hosts.tab")) {
           foreach my $dns (<$config>) {
       next if ($dns !~ /^\^(\S*)/x);
               my $line = $1;
               my ($host,$protocol) = split(/:/,$line);
               if ($protocol ne 'https') {
                   $protocol = 'http';
               }
       $alldns{$host} = $protocol;
           }
           close($config);
       }
       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;
       }
       my $which = (split('/',$url))[3];
       &logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n");
       if (open(my $config,"<","$perlvar{'lonTabDir'}/dns_$which.tab")) {
           my @content = <$config>;
           &$func(\@content,$hashref);
       }
       return;
   }
   
   # ------------------------------------------------------Get DNS checksums file
   sub parse_dns_checksums_tab {
       my ($lines,$hashref) = @_;
       my $lonhost = $perlvar{'lonHostID'};
       my $machine_dom = &Apache::lonnet::host_domain($lonhost);
       my $loncaparev = &get_server_loncaparev($machine_dom);
       my $distro = (split(/\:/,&get_server_distarch($lonhost)))[0];
       my $webconfdir = '/etc/httpd/conf';
       if ($distro =~ /^(ubuntu|debian)(\d+)$/) {
           $webconfdir = '/etc/apache2';
       } elsif ($distro =~ /^sles(\d+)$/) {
           if ($1 >= 10) {
               $webconfdir = '/etc/apache2';
           }
       } elsif ($distro =~ /^suse(\d+\.\d+)$/) {
           if ($1 >= 10.0) {
               $webconfdir = '/etc/apache2';
           }
       }
       my ($release,$timestamp) = split(/\-/,$loncaparev);
       my (%chksum,%revnum);
       if (ref($lines) eq 'ARRAY') {
           chomp(@{$lines});
           my $version = shift(@{$lines});
           if ($version eq $release) {
               foreach my $line (@{$lines}) {
                   my ($file,$version,$shasum) = split(/,/,$line);
                   if ($file =~ m{^/etc/httpd/conf}) {
                       if ($webconfdir eq '/etc/apache2') {
                           $file =~ s{^\Q/etc/httpd/conf/\E}{$webconfdir/};
                       }
                   }
                   $chksum{$file} = $shasum;
                   $revnum{$file} = $version;
               }
               if (ref($hashref) eq 'HASH') {
                   %{$hashref} = (
                                   sums     => \%chksum,
                                   versions => \%revnum,
                                 );
               }
           }
       }
       return;
   }
   
   sub fetch_dns_checksums {
       my %checksums;
       my $machine_dom = &Apache::lonnet::host_domain($perlvar{'lonHostID'});
       my $loncaparev = &get_server_loncaparev($machine_dom,$perlvar{'lonHostID'});
       my ($release,$timestamp) = split(/\-/,$loncaparev);
       &get_dns("/adm/dns/checksums/$release",\&parse_dns_checksums_tab,1,1,
                \%checksums);
       return \%checksums;
 }  }
   
 # ------------------------------------------------------------ Read domain file  # ------------------------------------------------------------ Read domain file
 {  {
     %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 (my $line = <$fh>) {   foreach my $line (@$lines) {
            next if ($line =~ /^(\#|\s*$)/);      next if ($line =~ /^(\#|\s*$ )/x);
 #           next if /^\#/;  
            chomp $line;      chomp($line);
            my ($domain, $domain_description, $def_auth, $def_auth_arg,      my ($name,@elements) = split(/:/,$line,9);
        $def_lang, $city, $longi, $lati, $primary) = split(/:/,$line,9);      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);
       }
   
  #         &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}");      sub load_domain_tab {
 #          &logthis("Domain.tab: $domain ".$domaindescription{$domain} );   my ($ignore_cache,$nocache) = @_;
    &get_dns('/adm/dns/domain',\&parse_domain_tab,$ignore_cache,$nocache);
    my $fh;
    if (open($fh,"<",$perlvar{'lonTabDir'}.'/domain.tab')) {
       my @lines = <$fh>;
       &parse_domain_tab(\@lines);
  }   }
    close($fh);
    $loaded = 1;
     }      }
     close ($fh);  
       sub domain {
    &load_domain_tab() if (!$loaded);
   
    my ($name,$what) = @_;
    return if ( !exists($domain{$name}) );
   
    if (!$what) {
       return $domain{$name}{'description'};
    }
    return $domain{$name}{$what};
       }
   
       sub domain_info {
           &load_domain_tab() if (!$loaded);
           return %domain;
       }
   
 }  }
   
   
 # ------------------------------------------------------------- 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) {
                   if ((exists($hostname{$id})) && ($hostname{$id} ne '')) {
                       my $curr = $hostname{$id};
                       my $skip;
                       if (ref($name_to_host{$curr}) eq 'ARRAY') {
                           if (($curr eq $name) && (@{$name_to_host{$curr}} == 1)) {
                               $skip = 1;
                           } else {
                               @{$name_to_host{$curr}} = grep { $_ ne $id } @{$name_to_host{$curr}};
                           }
                       }
                       unless ($skip) {
                           push(@{$name_to_host{$name}},$id);
                       }
                   } else {
                       push(@{$name_to_host{$name}},$id);
                   }
    $hostname{$id}=$name;
    $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,$nocache) = @_;
        chomp($configline);   &get_dns('/adm/dns/hosts',\&parse_hosts_tab,$ignore_cache,$nocache);
        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 {
           my ($ignore_cache,$nocache) = @_;
    &load_hosts_tab($ignore_cache,$nocache) 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");      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,$nocache) = @_;
   
    if (!$ignore_cache) {
       if (%iphost) {
    return %iphost;
     }      }
     $ip=inet_ntoa($ip);      my ($ip_info,$cached)=
     $name_to_ip{$name} = $ip;   &Apache::lonnet::is_cached_new('iphost','iphost');
  } else {      if ($cached) {
     $ip = $name_to_ip{$name};   %iphost      = %{$ip_info->[0]};
    %name_to_ip  = %{$ip_info->[1]};
    %lonid_to_ip = %{$ip_info->[2]};
    return %iphost;
       }
    }
   
    # get yesterday's info for fallback
    my %old_name_to_ip;
    my ($ip_info,$cached)=
       &Apache::lonnet::is_cached_new('iphost','iphost');
    if ($cached) {
       %old_name_to_ip = %{$ip_info->[1]};
    }
   
    my %name_to_host = &all_names($ignore_cache,$nocache);
    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}});
  }   }
  push(@{$iphost{$ip}},$id);          unless ($nocache) {
       &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);
       }
   
   }
   
   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);
               }
           }
     }      }
     return %iphost;  
 }  }
   
   # ----------------------------------------------------- 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");
   
     while (my $configline=<$config>) {      while (my $configline=<$config>) {
        chomp($configline);         chomp($configline);
Line 7637  sub get_iphost { Line 14090  sub get_iphost {
 }  }
 # ------------------------------------------------------------ Read permissions  # ------------------------------------------------------------ Read permissions
 {  {
     open(my $config,"<$perlvar{'lonTabDir'}/roles.tab");      open(my $config,"<","$perlvar{'lonTabDir'}/roles.tab");
   
     while (my $configline=<$config>) {      while (my $configline=<$config>) {
  chomp($configline);   chomp($configline);
Line 7651  sub get_iphost { Line 14104  sub get_iphost {
   
 # -------------------------------------------- Read plain texts for permissions  # -------------------------------------------- Read plain texts for permissions
 {  {
     open(my $config,"<$perlvar{'lonTabDir'}/rolesplain.tab");      open(my $config,"<","$perlvar{'lonTabDir'}/rolesplain.tab");
   
     while (my $configline=<$config>) {      while (my $configline=<$config>) {
  chomp($configline);   chomp($configline);
Line 7671  sub get_iphost { Line 14124  sub get_iphost {
   
 # ---------------------------------------------------------- Read package table  # ---------------------------------------------------------- Read package table
 {  {
     open(my $config,"<$perlvar{'lonTabDir'}/packages.tab");      open(my $config,"<","$perlvar{'lonTabDir'}/packages.tab");
   
     while (my $configline=<$config>) {      while (my $configline=<$config>) {
  if ($configline !~ /\S/ || $configline=~/^#/) { next; }   if ($configline !~ /\S/ || $configline=~/^#/) { next; }
Line 7686  sub get_iphost { Line 14139  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();
   
 }  }
   
   # ------------- set default texengine (domain default overrides this)
   {
       $deftex = LONCAPA::texengine();
   }
   
   # ------------- set default minimum length for passwords for internal auth users
   {
       $passwdmin = LONCAPA::passwd_min();
   }
   
 $memcache=new Cache::Memcached({'servers'           => ['127.0.0.1:11211'],  $memcache=new Cache::Memcached({'servers'           => ['127.0.0.1:11211'],
  'compress_threshold'=> 20_000,   '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 7848  were new keys. I.E. 1:foo will become 1: Line 14356  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,$laststore);
   
 For more detailed information, see lonnet specific documentation.  For more detailed information, see lonnet specific documentation.
   
Line 7865  when the connection is brought back up Line 14373  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 7880  that was requested Line 14388  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)   =item * get_env_multiple($name) 
   
Line 7911  authentication scheme Line 14423  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 7939  B<idput($udom,%ids)>: store away a list Line 14456  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 7952  X<userenvironment()> Line 14475  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 7960  passed in @what from the requested user' Line 14493  passed in @what from the requested user'
   
 =item *  =item *
   
 allowed($priv,$uri,$symb,$role) : check for a user privilege; returns codes for allowed actions  allowed($priv,$uri,$symb,$role,$clientip,$noblockcheck) : check for a user privilege; 
   returns codes for allowed actions.
   
   The first argument is required, all others are optional.
   
   $priv is the privilege being checked.
   $uri contains additional information about what is being checked for access (e.g.,
   URL, course ID etc.).
   $symb is the unique resource instance identifier in a course; if needed,
   but not provided, it will be retrieved via a call to &symbread().
   $role is the role for which a priv is being checked (only used if priv is evb).
   $clientip is the user's IP address (only used when checking for access to portfolio
   files).
   $noblockcheck, if true, skips calls to &has_comm_blocking() for the bre priv. This
   prevents recursive calls to &allowed.
   
  F: full access   F: full access
  U,I,K: authentication modes (cxx only)   U,I,K: authentication modes (cxx only)
  '': forbidden   '': forbidden
  1: user needs to choose course   1: user needs to choose course
  2: browse allowed   2: browse allowed
  A: passphrase authentication needed   A: passphrase authentication needed
    B: access temporarily blocked because of a blocking event in a course.
   
   =item *
   
   constructaccess($url,$setpriv) : check for access to construction space URL
   
   See if the owner domain and name in the URL match those in the
   expected environment.  If so, return three element list
   ($ownername,$ownerdomain,$ownerhome).
   
   Otherwise return the null string.
   
   If second argument 'setpriv' is true, it assigns the privileges,
   and returns the same three element list, unless the owner has
   blocked "ad hoc" Domain Coordinator access to the Author Space,
   in which case the null string is returned.
   
 =item *  =item *
   
 definerole($rolename,$sysrole,$domrole,$courole) : define role; define a custom  definerole($rolename,$sysrole,$domrole,$courole,$uname,$udom) : define role;
 role rolename set privileges in format of lonTabs/roles.tab for system, domain,  define a custom role rolename set privileges in format of lonTabs/roles.tab
 and course level  for system, domain, and course level. $uname and $udom are optional (current
   user's username and domain will be used when either of $uname or $udom are absent.
   
 =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 *  =item *
   
 get_my_roles($uname,$udom,$types,$roles,$roledoms) : All arguments are  in_course($udom,$uname,$cdom,$cnum,$type,$hideprivileged) : determine if
 optional.  Returns a hash of a user's roles, with keys set to  user: $uname:$udom has a role in the course: $cdom_$cnum.
 colon-sparated $uname,$udom,and $role, and value set to  
 colon-separated start and end times for the role. If no username and  Additional optional arguments are: $type (if role checking is to be restricted
 domain are specified, will default to current user/domain. Types,  to certain user status types -- previous (expired roles), active (currently
 roles, and roledoms are references to arrays, of role statuses  available roles) or future (roles available in the future), and
 (active, future or previous), roles (e.g., cc,in, st etc.) and domains  $hideprivileged -- if true will not report course roles for users who
 of the roles which can be used to restrict the list if roles  have active Domain Coordinator role in course's domain or in additional
 reported. If no array ref is provided for types, will default to  domains (specified in 'Domains to check for privileged users' in course
 return only active roles.  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 8000  return only active roles. Line 14608  return only active roles.
   
 =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 8017  modifyuserauth($udom,$uname,$umode,$upas Line 14625  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 8036  Inputs: Line 14652  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 8064  Inputs: Line 14680  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 8097  Inputs: Line 14729  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
   
   =item $instsec, institutional course section code for student
   
 =back  =back
   
   
Line 8122  revokecustomrole($udom,$uname,$url,$role Line 14768  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 8147  database) for a course Line 14825  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
   
   =head2 Bubblesheet Configuration
   
   =over 4
   
   =item *
   
   get_scantron_config($which)
   
   $which - the name of the configuration to parse from the file.
   
   Parses and returns the bubblesheet configuration line selected as a
   hash of configuration file fields.
   
   
   Returns:
       If the named configuration is not in the file, an empty
       hash is returned.
   
       a hash with the fields
         name         - internal name for the this configuration setup
         description  - text to display to operator that describes this config
         CODElocation - if 0 or the string 'none'
                             - no CODE exists for this config
                        if -1 || the string 'letter'
                             - a CODE exists for this config and is
                               a string of letters
                        Unsupported value (but planned for future support)
                             if a positive integer
                                  - The CODE exists as the first n items from
                                    the question section of the form
                             if the string 'number'
                                  - The CODE exists for this config and is
                                    a string of numbers
         CODEstart   - (only matter if a CODE exists) column in the line where
                        the CODE starts
         CODElength  - length of the CODE
         IDstart     - column where the student/employee ID starts
         IDlength    - length of the student/employee ID info
         Qstart      - column where the information from the bubbled
                       'questions' start
         Qlength     - number of columns comprising a single bubble line from
                       the sheet. (usually either 1 or 10)
         Qon         - either a single character representing the character used
                       to signal a bubble was chosen in the positional setup, or
                       the string 'letter' if the letter of the chosen bubble is
                       in the final, or 'number' if a number representing the
                       chosen bubble is in the file (1->A 0->J)
         Qoff        - the character used to represent that a bubble was
                       left blank
         PaperID     - if the scanning process generates a unique number for each
                       sheet scanned the column that this ID number starts in
         PaperIDlength - number of columns that comprise the unique ID number
                         for the sheet of paper
         FirstName   - column that the first name starts in
         FirstNameLength - number of columns that the first name spans
         LastName    - column that the last name starts in
         LastNameLength - number of columns that the last name spans
         BubblesPerRow - number of bubbles available in each row used to
                         bubble an answer. (If not specified, 10 assumed).
   
   
   =item *
   
   get_scantronformat_file($cdom)
   
   $cdom - the course's domain (optional); if not supplied, uses
   domain for current $env{'request.course.id'}.
   
   Returns an array containing lines from the scantron format file for
   the domain of the course.
   
   If a url for a custom.tab file is listed in domain's configuration.db,
   lines are from this file.
   
   Otherwise, if a default.tab has been published in RES space by the
   domainconfig user, lines are from this file.
   
   Otherwise, fall back to getting lines from the legacy file on the
   local server:  /home/httpd/lonTabs/default_scantronformat.tab
   
 =back  =back
   
Line 8176  resource. Expects the local filesystem p Line 14953  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 8212  will be stored for query Line 14994  will be stored for query
   
 =item *  =item *
   
 symbread($filename) : return symbolic list entry (filename argument optional);  symbread($filename,$donotrecurse,$ignorecachednull,$checkforblock,$possibles) :
   return symbolic list entry (all arguments optional).
   
   Args: filename is the filename (including path) for the file for which a symb
   is required; donotrecurse, if true will prevent calls to allowed() being made
   to check access status if more than one resource was found in the bighash
   (see rev. 1.249) to avoid an infinite loop if an ambiguous resource is part of
   a randompick); ignorecachednull, if true will prevent a symb of '' being
   returned if $env{$cache_str} is defined as ''; checkforblock if true will
   cause possible symbs to be checked to determine if they are subject to content
   blocking, if so they will not be included as possible symbs; possibles is a
   ref to a hash, which, as a side effect, will be populated with all possible
   symbs (content blocking not tested).
   
 returns the data handle  returns the data handle
   
 =item *  =item *
   
 symbverify($symb,$thisfn) : 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 8275  expirespread($uname,$udom,$stype,$usymb) Line 15072  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 8283  forcing spreadsheet to reevaluate the re Line 15108  forcing spreadsheet to reevaluate the re
   
 =item *  =item *
   
 store($storehash,$symb,$namespace,$udom,$uname) : stores hash permanently  store($storehash,$symb,$namespace,$udom,$uname,$laststore) : stores hash 
 for this url; hashref needs to be given and should be a \%hashname; the  permanently for this url; hashref needs to be given and should be a \%hashname;
 remaining args aren't required and if they aren't passed or are '' they will  the remaining args aren't required and if they aren't passed or are '' they will
 be derived from the env  be derived from the env (with the exception of $laststore, which is an
   optional arg used when a user's submission is stored in grading).
   $laststore is $version=$timestamp, where $version is the most recent version
   number retrieved for the corresponding $symb in the $namespace db file, and
   $timestamp is the timestamp for that transaction (UNIX time).
   $laststore is currently only passed when cstore() is called by
   structuretags::finalize_storage().
   
 =item *  =item *
   
 cstore($storehash,$symb,$namespace,$udom,$uname) : same as store but  cstore($storehash,$symb,$namespace,$udom,$uname,$laststore) : same as store 
 uses critical subroutine  but uses critical subroutine
   
 =item *  =item *
   
Line 8314  $range should be either an integer '100' Line 15145  $range should be either an integer '100'
   
 =item *  =item *
   
 putstore($namespace,$symb,$version,$storehash,$udomain,$uname) :  putstore($namespace,$symb,$version,$storehash,$udomain,$uname,$tolog) :
 replaces a &store() version of data with a replacement set of data  replaces a &store() version of data with a replacement set of data
 for a particular resource in a namespace passed in the $storehash hash   for a particular resource in a namespace passed in the $storehash hash 
 reference  reference. If $tolog is true, the transaction is logged in the courselog
   with an action=PUTSTORE.
   
 =item *  =item *
   
Line 8397  Returns: Line 15229  Returns:
  'key_exists: <key>' -> failed to anything out of $storehash, as at   'key_exists: <key>' -> failed to anything out of $storehash, as at
                         least <key> already existed in the db (other                          least <key> already existed in the db (other
                         requested keys may also already exist)                          requested keys may also already exist)
  'error: <msg>' -> unable to tie the DB or other erorr occured   'error: <msg>' -> unable to tie the DB or other error occurred
  'con_lost' -> unable to contact request server   'con_lost' -> unable to contact request server
  'refused' -> action was not allowed by remote machine   'refused' -> action was not allowed by remote machine
   
Line 8415  critical subroutine Line 15247  critical subroutine
   
 =item *  =item *
   
 get_dom($namespace,$storearr,$udomain) : returns hash with keys from array  get_dom($namespace,$storearr,$udom,$uhome) : returns hash with keys from
 reference filled in from namespace found in domain level on primary domain server ($udomain is optional)  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 *  =item *
   
 put_dom($namespace,$storehash,$udomain) :  stores hash in namespace at domain level on primary domain server ($udomain is optional)  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
   
Line 8430  put_dom($namespace,$storehash,$udomain) Line 15353  put_dom($namespace,$storehash,$udomain)
   
 =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 8485  splitting on '&', supports elements that Line 15490  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 8505  logperm() : append a permanent message t Line 15511  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 8561  filelocation except for hrefs Line 15568  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 8578  userfileupload(): main rotine for puttin Line 15586  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 8601  returns: the new clean filename Line 15611  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.
             if hashref, and context is scantron, will convert csv format to standard format
     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 8716  Internal notes: Line 15740  Internal notes:
     
  Locks on files (resulting from submission of portfolio file to a homework problem stored in array of arrays.   Locks on files (resulting from submission of portfolio file to a homework problem stored in array of arrays.
   
   =item *
   
 modify_access_controls():  modify_access_controls():
   
 Modifies access controls for a portfolio file  Modifies access controls for a portfolio file
Line 8733  Returns: Line 15759  Returns:
 3. reference to hash of any new or updated access controls.  3. reference to hash of any new or updated access controls.
 4. reference to hash used to map incoming IDs to uniqueIDs assigned to control.  4. reference to hash used to map incoming IDs to uniqueIDs assigned to control.
    key = integer (inbound ID)     key = integer (inbound ID)
    value = uniqueID       value = uniqueID
   
   =item *
   
   get_timebased_id():
   
   Attempts to get a unique timestamp-based suffix for use with items added to a
   course via the Course Editor (e.g., folders, composite pages,
   group bulletin boards).
   
   Args: (first three required; six others optional)
   
   1. prefix (alphanumeric): of keys in hash, e.g., suppsequence, docspage,
      docssequence, or name of group
   
   2. keyid (alphanumeric): name of temporary locking key in hash,
      e.g., num, boardids
   
   3. namespace: name of gdbm file used to store suffixes already assigned;
      file will be named nohist_namespace.db
   
   4. cdom: domain of course; default is current course domain from %env
   
   5. cnum: course number; default is current course number from %env
   
   6. idtype: set to concat if an additional digit is to be appended to the
      unix timestamp to form the suffix, if the plain timestamp is already
      in use.  Default is to not do this, but simply increment the unix
      timestamp by 1 until a unique key is obtained.
   
   7. who: holder of locking key; defaults to user:domain for user.
   
   8. locktries: number of attempts to obtain a lock (sleep of 1s before
      retrying); default is 3.
   
   9. maxtries: number of attempts to obtain a unique suffix; default is 20.
   
   Returns:
   
   1. suffix obtained (numeric)
   
   2. result of deleting locking key (ok if deleted, or lock never obtained)
   
   3. error: contains (localized) error message if an error occurred.
   
   
 =back  =back
   
Line 8813  symblist($mapname,%newhash) : update sym Line 15883  symblist($mapname,%newhash) : update sym
 =back  =back
   
 =cut  =cut
   
Removed from v.1.836  
changed lines
  Added in v.1.1172.2.118.2.7

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