Return to lonnet.pm CVS log

Up to [LON-CAPA] / loncom / lonnet / perl

- backport 1.895

    1: # The LearningOnline Network
    2: # TCP networking package
    3: #
    4: # $Id: lonnet.pm,v 1.890.2.3 2007/06/25 23:34:34 albertel Exp $
    5: #
    6: # Copyright Michigan State University Board of Trustees
    7: #
    8: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
    9: #
   10: # LON-CAPA is free software; you can redistribute it and/or modify
   11: # it under the terms of the GNU General Public License as published by
   12: # the Free Software Foundation; either version 2 of the License, or
   13: # (at your option) any later version.
   14: #
   15: # LON-CAPA is distributed in the hope that it will be useful,
   16: # but WITHOUT ANY WARRANTY; without even the implied warranty of
   17: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   18: # GNU General Public License for more details.
   19: #
   20: # You should have received a copy of the GNU General Public License
   21: # along with LON-CAPA; if not, write to the Free Software
   22: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
   23: #
   24: # /home/httpd/html/adm/gpl.txt
   25: #
   26: # http://www.lon-capa.org/
   27: #
   28: ###
   29: 
   30: package Apache::lonnet;
   31: 
   32: use strict;
   33: use LWP::UserAgent();
   34: use HTTP::Date;
   35: # use Date::Parse;
   36: use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir
   37:             $_64bit %env);
   38: 
   39: my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash,
   40:     %userrolehash, $processmarker, $dumpcount, %coursedombuf,
   41:     %coursenumbuf, %coursehombuf, %coursedescrbuf, %courseinstcodebuf,
   42:     %courseownerbuf, %coursetypebuf);
   43: 
   44: use IO::Socket;
   45: use GDBM_File;
   46: use HTML::LCParser;
   47: use Fcntl qw(:flock);
   48: use Storable qw(thaw nfreeze);
   49: use Time::HiRes qw( gettimeofday tv_interval );
   50: use Cache::Memcached;
   51: use Digest::MD5;
   52: use Math::Random;
   53: use LONCAPA qw(:DEFAULT :match);
   54: use LONCAPA::Configuration;
   55: 
   56: my $readit;
   57: my $max_connection_retries = 10;     # Or some such value.
   58: 
   59: require Exporter;
   60: 
   61: our @ISA = qw (Exporter);
   62: our @EXPORT = qw(%env);
   63: 
   64: =pod
   65: 
   66: =head1 Package Variables
   67: 
   68: These are largely undocumented, so if you decipher one please note it here.
   69: 
   70: =over 4
   71: 
   72: =item $processmarker
   73: 
   74: Contains the time this process was started and this servers host id.
   75: 
   76: =item $dumpcount
   77: 
   78: Counts the number of times a message log flush has been attempted (regardless
   79: of success) by this process.  Used as part of the filename when messages are
   80: delayed.
   81: 
   82: =back
   83: 
   84: =cut
   85: 
   86: 
   87: # --------------------------------------------------------------------- Logging
   88: {
   89:     my $logid;
   90:     sub instructor_log {
   91: 	my ($hash_name,$storehash,$delflag,$uname,$udom)=@_;
   92: 	$logid++;
   93: 	my $id=time().'00000'.$$.'00000'.$logid;
   94: 	return &Apache::lonnet::put('nohist_'.$hash_name,
   95: 				    { $id => {
   96: 					'exe_uname' => $env{'user.name'},
   97: 					'exe_udom'  => $env{'user.domain'},
   98: 					'exe_time'  => time(),
   99: 					'exe_ip'    => $ENV{'REMOTE_ADDR'},
  100: 					'delflag'   => $delflag,
  101: 					'logentry'  => $storehash,
  102: 					'uname'     => $uname,
  103: 					'udom'      => $udom,
  104: 				    }
  105: 				  },
  106: 				    $env{'course.'.$env{'request.course.id'}.'.domain'},
  107: 				    $env{'course.'.$env{'request.course.id'}.'.num'}
  108: 				    );
  109:     }
  110: }
  111: 
  112: sub logtouch {
  113:     my $execdir=$perlvar{'lonDaemons'};
  114:     unless (-e "$execdir/logs/lonnet.log") {	
  115: 	open(my $fh,">>$execdir/logs/lonnet.log");
  116: 	close $fh;
  117:     }
  118:     my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3];
  119:     chown($wwwuid,$wwwgid,$execdir.'/logs/lonnet.log');
  120: }
  121: 
  122: sub logthis {
  123:     my $message=shift;
  124:     my $execdir=$perlvar{'lonDaemons'};
  125:     my $now=time;
  126:     my $local=localtime($now);
  127:     if (open(my $fh,">>$execdir/logs/lonnet.log")) {
  128: 	print $fh "$local ($$): $message\n";
  129: 	close($fh);
  130:     }
  131:     return 1;
  132: }
  133: 
  134: sub logperm {
  135:     my $message=shift;
  136:     my $execdir=$perlvar{'lonDaemons'};
  137:     my $now=time;
  138:     my $local=localtime($now);
  139:     if (open(my $fh,">>$execdir/logs/lonnet.perm.log")) {
  140: 	print $fh "$now:$message:$local\n";
  141: 	close($fh);
  142:     }
  143:     return 1;
  144: }
  145: 
  146: sub create_connection {
  147:     my ($hostname,$lonid) = @_;
  148:     my $client=IO::Socket::UNIX->new(Peer    => $perlvar{'lonSockCreate'},
  149: 				     Type    => SOCK_STREAM,
  150: 				     Timeout => 10);
  151:     return 0 if (!$client);
  152:     print $client (join(':',$hostname,$lonid,&machine_ids($hostname))."\n");
  153:     my $result = <$client>;
  154:     chomp($result);
  155:     return 1 if ($result eq 'done');
  156:     return 0;
  157: }
  158: 
  159: 
  160: # -------------------------------------------------- Non-critical communication
  161: sub subreply {
  162:     my ($cmd,$server)=@_;
  163:     my $peerfile="$perlvar{'lonSockDir'}/".&hostname($server);
  164:     #
  165:     #  With loncnew process trimming, there's a timing hole between lonc server
  166:     #  process exit and the master server picking up the listen on the AF_UNIX
  167:     #  socket.  In that time interval, a lock file will exist:
  168: 
  169:     my $lockfile=$peerfile.".lock";
  170:     while (-e $lockfile) {	# Need to wait for the lockfile to disappear.
  171: 	sleep(1);
  172:     }
  173:     # At this point, either a loncnew parent is listening or an old lonc
  174:     # or loncnew child is listening so we can connect or everything's dead.
  175:     #
  176:     #   We'll give the connection a few tries before abandoning it.  If
  177:     #   connection is not possible, we'll con_lost back to the client.
  178:     #   
  179:     my $client;
  180:     for (my $retries = 0; $retries < $max_connection_retries; $retries++) {
  181: 	$client=IO::Socket::UNIX->new(Peer    =>"$peerfile",
  182: 				      Type    => SOCK_STREAM,
  183: 				      Timeout => 10);
  184: 	if ($client) {
  185: 	    last;		# Connected!
  186: 	} else {
  187: 	    &create_connection(&hostname($server),$server);
  188: 	}
  189:         sleep(1);		# Try again later if failed connection.
  190:     }
  191:     my $answer;
  192:     if ($client) {
  193: 	print $client "sethost:$server:$cmd\n";
  194: 	$answer=<$client>;
  195: 	if (!$answer) { $answer="con_lost"; }
  196: 	chomp($answer);
  197:     } else {
  198: 	$answer = 'con_lost';	# Failed connection.
  199:     }
  200:     return $answer;
  201: }
  202: 
  203: sub reply {
  204:     my ($cmd,$server)=@_;
  205:     unless (defined(&hostname($server))) { return 'no_such_host'; }
  206:     my $answer=subreply($cmd,$server);
  207:     if (($answer=~/^refused/) || ($answer=~/^rejected/)) {
  208:        &logthis("<font color=\"blue\">WARNING:".
  209:                 " $cmd to $server returned $answer</font>");
  210:     }
  211:     return $answer;
  212: }
  213: 
  214: # ----------------------------------------------------------- Send USR1 to lonc
  215: 
  216: sub reconlonc {
  217:     &logthis("Trying to reconnect lonc");
  218:     my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
  219:     if (open(my $fh,"<$loncfile")) {
  220: 	my $loncpid=<$fh>;
  221:         chomp($loncpid);
  222:         if (kill 0 => $loncpid) {
  223: 	    &logthis("lonc at pid $loncpid responding, sending USR1");
  224:             kill USR1 => $loncpid;
  225:             sleep 1;
  226:          } else {
  227: 	    &logthis(
  228:                "<font color=\"blue\">WARNING:".
  229:                " lonc at pid $loncpid not responding, giving up</font>");
  230:         }
  231:     } else {
  232: 	&logthis('<font color="blue">WARNING: lonc not running, giving up</font>');
  233:     }
  234: }
  235: 
  236: # ------------------------------------------------------ Critical communication
  237: 
  238: sub critical {
  239:     my ($cmd,$server)=@_;
  240:     unless (&hostname($server)) {
  241:         &logthis("<font color=\"blue\">WARNING:".
  242:                " Critical message to unknown server ($server)</font>");
  243:         return 'no_such_host';
  244:     }
  245:     my $answer=reply($cmd,$server);
  246:     if ($answer eq 'con_lost') {
  247: 	&reconlonc("$perlvar{'lonSockDir'}/$server");
  248: 	my $answer=reply($cmd,$server);
  249:         if ($answer eq 'con_lost') {
  250:             my $now=time;
  251:             my $middlename=$cmd;
  252:             $middlename=substr($middlename,0,16);
  253:             $middlename=~s/\W//g;
  254:             my $dfilename=
  255:       "$perlvar{'lonSockDir'}/delayed/$now.$dumpcount.$$.$middlename.$server";
  256:             $dumpcount++;
  257:             {
  258: 		my $dfh;
  259: 		if (open($dfh,">$dfilename")) {
  260: 		    print $dfh "$cmd\n"; 
  261: 		    close($dfh);
  262: 		}
  263:             }
  264:             sleep 2;
  265:             my $wcmd='';
  266:             {
  267: 		my $dfh;
  268: 		if (open($dfh,"<$dfilename")) {
  269: 		    $wcmd=<$dfh>; 
  270: 		    close($dfh);
  271: 		}
  272:             }
  273:             chomp($wcmd);
  274:             if ($wcmd eq $cmd) {
  275: 		&logthis("<font color=\"blue\">WARNING: ".
  276:                          "Connection buffer $dfilename: $cmd</font>");
  277:                 &logperm("D:$server:$cmd");
  278: 	        return 'con_delayed';
  279:             } else {
  280:                 &logthis("<font color=\"red\">CRITICAL:"
  281:                         ." Critical connection failed: $server $cmd</font>");
  282:                 &logperm("F:$server:$cmd");
  283:                 return 'con_failed';
  284:             }
  285:         }
  286:     }
  287:     return $answer;
  288: }
  289: 
  290: # ------------------------------------------- check if return value is an error
  291: 
  292: sub error {
  293:     my ($result) = @_;
  294:     if ($result =~ /^(con_lost|no_such_host|error: (\d+) (.*))/) {
  295: 	if ($2 == 2) { return undef; }
  296: 	return $1;
  297:     }
  298:     return undef;
  299: }
  300: 
  301: sub convert_and_load_session_env {
  302:     my ($lonidsdir,$handle)=@_;
  303:     my @profile;
  304:     {
  305: 	open(my $idf,"$lonidsdir/$handle.id");
  306: 	flock($idf,LOCK_SH);
  307: 	@profile=<$idf>;
  308: 	close($idf);
  309:     }
  310:     my %temp_env;
  311:     foreach my $line (@profile) {
  312: 	if ($line !~ m/=/) {
  313: 	    return 0;
  314: 	}
  315: 	chomp($line);
  316: 	my ($envname,$envvalue)=split(/=/,$line,2);
  317: 	$temp_env{&unescape($envname)} = &unescape($envvalue);
  318:     }
  319:     unlink("$lonidsdir/$handle.id");
  320:     if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",&GDBM_WRCREAT(),
  321: 	    0640)) {
  322: 	%disk_env = %temp_env;
  323: 	@env{keys(%temp_env)} = @disk_env{keys(%temp_env)};
  324: 	untie(%disk_env);
  325:     }
  326:     return 1;
  327: }
  328: 
  329: # ------------------------------------------- Transfer profile into environment
  330: my $env_loaded;
  331: sub transfer_profile_to_env {
  332:     my ($lonidsdir,$handle,$force_transfer) = @_;
  333:     if (!$force_transfer && $env_loaded) { return; } 
  334: 
  335:     if (!defined($lonidsdir)) {
  336: 	$lonidsdir = $perlvar{'lonIDsDir'};
  337:     }
  338:     if (!defined($handle)) {
  339:         ($handle) = ($env{'user.environment'} =~m|/([^/]+)\.id$| );
  340:     }
  341: 
  342:     my $convert;
  343:     {
  344:     	open(my $idf,"$lonidsdir/$handle.id");
  345: 	flock($idf,LOCK_SH);
  346: 	if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",
  347: 		&GDBM_READER(),0640)) {
  348: 	    @env{keys(%disk_env)} = @disk_env{keys(%disk_env)};
  349: 	    untie(%disk_env);
  350: 	} else {
  351: 	    $convert = 1;
  352: 	}
  353:     }
  354:     if ($convert) {
  355: 	if (!&convert_and_load_session_env($lonidsdir,$handle)) {
  356: 	    &logthis("Failed to load session, or convert session.");
  357: 	}
  358:     }
  359: 
  360:     my %remove;
  361:     while ( my $envname = each(%env) ) {
  362:         if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {
  363:             if ($time < time-300) {
  364:                 $remove{$key}++;
  365:             }
  366:         }
  367:     }
  368: 
  369:     $env{'user.environment'} = "$lonidsdir/$handle.id";
  370:     $env_loaded=1;
  371:     foreach my $expired_key (keys(%remove)) {
  372:         &delenv($expired_key);
  373:     }
  374: }
  375: 
  376: sub timed_flock {
  377:     my ($file,$lock_type) = @_;
  378:     my $failed=0;
  379:     eval {
  380: 	local $SIG{__DIE__}='DEFAULT';
  381: 	local $SIG{ALRM}=sub {
  382: 	    $failed=1;
  383: 	    die("failed lock");
  384: 	};
  385: 	alarm(13);
  386: 	flock($file,$lock_type);
  387: 	alarm(0);
  388:     };
  389:     if ($failed) {
  390: 	return undef;
  391:     } else {
  392: 	return 1;
  393:     }
  394: }
  395: 
  396: # ---------------------------------------------------------- Append Environment
  397: 
  398: sub appenv {
  399:     my %newenv=@_;
  400:     foreach my $key (keys(%newenv)) {
  401: 	if (($newenv{$key}=~/^user\.role/) || ($newenv{$key}=~/^user\.priv/)) {
  402:             &logthis("<font color=\"blue\">WARNING: ".
  403:                 "Attempt to modify environment ".$key." to ".$newenv{$key}
  404:                 .'</font>');
  405: 	    delete($newenv{$key});
  406:         } else {
  407:             $env{$key}=$newenv{$key};
  408:         }
  409:     }
  410:     open(my $env_file,$env{'user.environment'});
  411:     if (&timed_flock($env_file,LOCK_EX)
  412: 	&&
  413: 	tie(my %disk_env,'GDBM_File',$env{'user.environment'},
  414: 	    (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
  415: 	while (my ($key,$value) = each(%newenv)) {
  416: 	    $disk_env{$key} = $value;
  417: 	}
  418: 	untie(%disk_env);
  419:     }
  420:     return 'ok';
  421: }
  422: # ----------------------------------------------------- Delete from Environment
  423: 
  424: sub delenv {
  425:     my $delthis=shift;
  426:     if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {
  427:         &logthis("<font color=\"blue\">WARNING: ".
  428:                 "Attempt to delete from environment ".$delthis);
  429:         return 'error';
  430:     }
  431:     open(my $env_file,$env{'user.environment'});
  432:     if (&timed_flock($env_file,LOCK_EX)
  433: 	&&
  434: 	tie(my %disk_env,'GDBM_File',$env{'user.environment'},
  435: 	    (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
  436: 	foreach my $key (keys(%disk_env)) {
  437: 	    if ($key=~/^$delthis/) { 
  438:                 delete($env{$key});
  439:                 delete($disk_env{$key});
  440:             }
  441: 	}
  442: 	untie(%disk_env);
  443:     }
  444:     return 'ok';
  445: }
  446: 
  447: sub get_env_multiple {
  448:     my ($name) = @_;
  449:     my @values;
  450:     if (defined($env{$name})) {
  451:         # exists is it an array
  452:         if (ref($env{$name})) {
  453:             @values=@{ $env{$name} };
  454:         } else {
  455:             $values[0]=$env{$name};
  456:         }
  457:     }
  458:     return(@values);
  459: }
  460: 
  461: # ------------------------------------------ Find out current server userload
  462: # there is a copy in lond
  463: sub userload {
  464:     my $numusers=0;
  465:     {
  466: 	opendir(LONIDS,$perlvar{'lonIDsDir'});
  467: 	my $filename;
  468: 	my $curtime=time;
  469: 	while ($filename=readdir(LONIDS)) {
  470: 	    if ($filename eq '.' || $filename eq '..') {next;}
  471: 	    my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];
  472: 	    if ($curtime-$mtime < 1800) { $numusers++; }
  473: 	}
  474: 	closedir(LONIDS);
  475:     }
  476:     my $userloadpercent=0;
  477:     my $maxuserload=$perlvar{'lonUserLoadLim'};
  478:     if ($maxuserload) {
  479: 	$userloadpercent=100*$numusers/$maxuserload;
  480:     }
  481:     $userloadpercent=sprintf("%.2f",$userloadpercent);
  482:     return $userloadpercent;
  483: }
  484: 
  485: # ------------------------------------------ Fight off request when overloaded
  486: 
  487: sub overloaderror {
  488:     my ($r,$checkserver)=@_;
  489:     unless ($checkserver) { $checkserver=$perlvar{'lonHostID'}; }
  490:     my $loadavg;
  491:     if ($checkserver eq $perlvar{'lonHostID'}) {
  492:        open(my $loadfile,'/proc/loadavg');
  493:        $loadavg=<$loadfile>;
  494:        $loadavg =~ s/\s.*//g;
  495:        $loadavg = 100*$loadavg/$perlvar{'lonLoadLim'};
  496:        close($loadfile);
  497:     } else {
  498:        $loadavg=&reply('load',$checkserver);
  499:     }
  500:     my $overload=$loadavg-100;
  501:     if ($overload>0) {
  502: 	$r->err_headers_out->{'Retry-After'}=$overload;
  503:         $r->log_error('Overload of '.$overload.' on '.$checkserver);
  504:         return 413;
  505:     }    
  506:     return '';
  507: }
  508: 
  509: # ------------------------------ Find server with least workload from spare.tab
  510: 
  511: sub spareserver {
  512:     my ($loadpercent,$userloadpercent,$want_server_name) = @_;
  513:     my $spare_server;
  514:     if ($userloadpercent !~ /\d/) { $userloadpercent=0; }
  515:     my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent 
  516:                                                      :  $userloadpercent;
  517:     
  518:     foreach my $try_server (@{ $spareid{'primary'} }) {
  519: 	($spare_server, $lowest_load) =
  520: 	    &compare_server_load($try_server, $spare_server, $lowest_load);
  521:     }
  522: 
  523:     my $found_server = ($spare_server ne '' && $lowest_load < 100);
  524: 
  525:     if (!$found_server) {
  526: 	foreach my $try_server (@{ $spareid{'default'} }) {
  527: 	    ($spare_server, $lowest_load) =
  528: 		&compare_server_load($try_server, $spare_server, $lowest_load);
  529: 	}
  530:     }
  531: 
  532:     if (!$want_server_name) {
  533: 	$spare_server="http://".&hostname($spare_server);
  534:     }
  535:     return $spare_server;
  536: }
  537: 
  538: sub compare_server_load {
  539:     my ($try_server, $spare_server, $lowest_load) = @_;
  540: 
  541:     my $loadans     = &reply('load',    $try_server);
  542:     my $userloadans = &reply('userload',$try_server);
  543: 
  544:     if ($loadans !~ /\d/ && $userloadans !~ /\d/) {
  545: 	next; #didn't get a number from the server
  546:     }
  547: 
  548:     my $load;
  549:     if ($loadans =~ /\d/) {
  550: 	if ($userloadans =~ /\d/) {
  551: 	    #both are numbers, pick the bigger one
  552: 	    $load = ($loadans > $userloadans) ? $loadans 
  553: 		                              : $userloadans;
  554: 	} else {
  555: 	    $load = $loadans;
  556: 	}
  557:     } else {
  558: 	$load = $userloadans;
  559:     }
  560: 
  561:     if (($load =~ /\d/) && ($load < $lowest_load)) {
  562: 	$spare_server = $try_server;
  563: 	$lowest_load  = $load;
  564:     }
  565:     return ($spare_server,$lowest_load);
  566: }
  567: # --------------------------------------------- Try to change a user's password
  568: 
  569: sub changepass {
  570:     my ($uname,$udom,$currentpass,$newpass,$server,$context)=@_;
  571:     $currentpass = &escape($currentpass);
  572:     $newpass     = &escape($newpass);
  573:     my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass:$context",
  574: 		       $server);
  575:     if (! $answer) {
  576: 	&logthis("No reply on password change request to $server ".
  577: 		 "by $uname in domain $udom.");
  578:     } elsif ($answer =~ "^ok") {
  579:         &logthis("$uname in $udom successfully changed their password ".
  580: 		 "on $server.");
  581:     } elsif ($answer =~ "^pwchange_failure") {
  582: 	&logthis("$uname in $udom was unable to change their password ".
  583: 		 "on $server.  The action was blocked by either lcpasswd ".
  584: 		 "or pwchange");
  585:     } elsif ($answer =~ "^non_authorized") {
  586:         &logthis("$uname in $udom did not get their password correct when ".
  587: 		 "attempting to change it on $server.");
  588:     } elsif ($answer =~ "^auth_mode_error") {
  589:         &logthis("$uname in $udom attempted to change their password despite ".
  590: 		 "not being locally or internally authenticated on $server.");
  591:     } elsif ($answer =~ "^unknown_user") {
  592:         &logthis("$uname in $udom attempted to change their password ".
  593: 		 "on $server but were unable to because $server is not ".
  594: 		 "their home server.");
  595:     } elsif ($answer =~ "^refused") {
  596: 	&logthis("$server refused to change $uname in $udom password because ".
  597: 		 "it was sent an unencrypted request to change the password.");
  598:     }
  599:     return $answer;
  600: }
  601: 
  602: # ----------------------- Try to determine user's current authentication scheme
  603: 
  604: sub queryauthenticate {
  605:     my ($uname,$udom)=@_;
  606:     my $uhome=&homeserver($uname,$udom);
  607:     if (!$uhome) {
  608: 	&logthis("User $uname at $udom is unknown when looking for authentication mechanism");
  609: 	return 'no_host';
  610:     }
  611:     my $answer=reply("encrypt:currentauth:$udom:$uname",$uhome);
  612:     if ($answer =~ /^(unknown_user|refused|con_lost)/) {
  613: 	&logthis("User $uname at $udom threw error $answer when checking authentication mechanism");
  614:     }
  615:     return $answer;
  616: }
  617: 
  618: # --------- Try to authenticate user from domain's lib servers (first this one)
  619: 
  620: sub authenticate {
  621:     my ($uname,$upass,$udom)=@_;
  622:     $upass=&escape($upass);
  623:     $uname= &LONCAPA::clean_username($uname);
  624:     my $uhome=&homeserver($uname,$udom,1);
  625:     if ((!$uhome) || ($uhome eq 'no_host')) {
  626: # Maybe the machine was offline and only re-appeared again recently?
  627:         &reconlonc();
  628: # One more
  629: 	my $uhome=&homeserver($uname,$udom,1);
  630: 	if ((!$uhome) || ($uhome eq 'no_host')) {
  631: 	    &logthis("User $uname at $udom is unknown in authenticate");
  632: 	}
  633: 	return 'no_host';
  634:     }
  635:     my $answer=reply("encrypt:auth:$udom:$uname:$upass",$uhome);
  636:     if ($answer eq 'authorized') {
  637: 	&logthis("User $uname at $udom authorized by $uhome"); 
  638: 	return $uhome; 
  639:     }
  640:     if ($answer eq 'non_authorized') {
  641: 	&logthis("User $uname at $udom rejected by $uhome");
  642: 	return 'no_host'; 
  643:     }
  644:     &logthis("User $uname at $udom threw error $answer when checking authentication mechanism");
  645:     return 'no_host';
  646: }
  647: 
  648: # ---------------------- Find the homebase for a user from domain's lib servers
  649: 
  650: my %homecache;
  651: sub homeserver {
  652:     my ($uname,$udom,$ignoreBadCache)=@_;
  653:     my $index="$uname:$udom";
  654: 
  655:     if (exists($homecache{$index})) { return $homecache{$index}; }
  656: 
  657:     my %servers = &get_servers($udom,'library');
  658:     foreach my $tryserver (keys(%servers)) {
  659:         next if ($ignoreBadCache ne 'true' && 
  660: 		 exists($badServerCache{$tryserver}));
  661: 
  662: 	my $answer=reply("home:$udom:$uname",$tryserver);
  663: 	if ($answer eq 'found') {
  664: 	    delete($badServerCache{$tryserver}); 
  665: 	    return $homecache{$index}=$tryserver;
  666: 	} elsif ($answer eq 'no_host') {
  667: 	    $badServerCache{$tryserver}=1;
  668: 	}
  669:     }    
  670:     return 'no_host';
  671: }
  672: 
  673: # ------------------------------------- Find the usernames behind a list of IDs
  674: 
  675: sub idget {
  676:     my ($udom,@ids)=@_;
  677:     my %returnhash=();
  678:     
  679:     my %servers = &get_servers($udom,'library');
  680:     foreach my $tryserver (keys(%servers)) {
  681: 	my $idlist=join('&',@ids);
  682: 	$idlist=~tr/A-Z/a-z/; 
  683: 	my $reply=&reply("idget:$udom:".$idlist,$tryserver);
  684: 	my @answer=();
  685: 	if (($reply ne 'con_lost') && ($reply!~/^error\:/)) {
  686: 	    @answer=split(/\&/,$reply);
  687: 	}                    ;
  688: 	my $i;
  689: 	for ($i=0;$i<=$#ids;$i++) {
  690: 	    if ($answer[$i]) {
  691: 		$returnhash{$ids[$i]}=$answer[$i];
  692: 	    } 
  693: 	}
  694:     } 
  695:     return %returnhash;
  696: }
  697: 
  698: # ------------------------------------- Find the IDs behind a list of usernames
  699: 
  700: sub idrget {
  701:     my ($udom,@unames)=@_;
  702:     my %returnhash=();
  703:     foreach my $uname (@unames) {
  704:         $returnhash{$uname}=(&userenvironment($udom,$uname,'id'))[1];
  705:     }
  706:     return %returnhash;
  707: }
  708: 
  709: # ------------------------------- Store away a list of names and associated IDs
  710: 
  711: sub idput {
  712:     my ($udom,%ids)=@_;
  713:     my %servers=();
  714:     foreach my $uname (keys(%ids)) {
  715: 	&cput('environment',{'id'=>$ids{$uname}},$udom,$uname);
  716:         my $uhom=&homeserver($uname,$udom);
  717:         if ($uhom ne 'no_host') {
  718:             my $id=&escape($ids{$uname});
  719:             $id=~tr/A-Z/a-z/;
  720:             my $esc_unam=&escape($uname);
  721: 	    if ($servers{$uhom}) {
  722: 		$servers{$uhom}.='&'.$id.'='.$esc_unam;
  723:             } else {
  724:                 $servers{$uhom}=$id.'='.$esc_unam;
  725:             }
  726:         }
  727:     }
  728:     foreach my $server (keys(%servers)) {
  729:         &critical('idput:'.$udom.':'.$servers{$server},$server);
  730:     }
  731: }
  732: 
  733: # ------------------------------------------- get items from domain db files   
  734: 
  735: sub get_dom {
  736:     my ($namespace,$storearr,$udom,$uhome)=@_;
  737:     my $items='';
  738:     foreach my $item (@$storearr) {
  739:         $items.=&escape($item).'&';
  740:     }
  741:     $items=~s/\&$//;
  742:     if (!$udom) {
  743:         $udom=$env{'user.domain'};
  744:         if (defined(&domain($udom,'primary'))) {
  745:             $uhome=&domain($udom,'primary');
  746:         } else {
  747:             undef($uhome);
  748:         }
  749:     } else {
  750:         if (!$uhome) {
  751:             if (defined(&domain($udom,'primary'))) {
  752:                 $uhome=&domain($udom,'primary');
  753:             }
  754:         }
  755:     }
  756:     if ($udom && $uhome && ($uhome ne 'no_host')) {
  757:         my $rep=&reply("getdom:$udom:$namespace:$items",$uhome);
  758:         my %returnhash;
  759:         if ($rep eq '' || $rep =~ /^error: 2 /) {
  760:             return %returnhash;
  761:         }
  762:         my @pairs=split(/\&/,$rep);
  763:         if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) {
  764:             return @pairs;
  765:         }
  766:         my $i=0;
  767:         foreach my $item (@$storearr) {
  768:             $returnhash{$item}=&thaw_unescape($pairs[$i]);
  769:             $i++;
  770:         }
  771:         return %returnhash;
  772:     } else {
  773:         &logthis("get_dom failed - no homeserver and/or domain ($udom) ($uhome)");
  774:     }
  775: }
  776: 
  777: # -------------------------------------------- put items in domain db files 
  778: 
  779: sub put_dom {
  780:     my ($namespace,$storehash,$udom,$uhome)=@_;
  781:     if (!$udom) {
  782:         $udom=$env{'user.domain'};
  783:         if (defined(&domain($udom,'primary'))) {
  784:             $uhome=&domain($udom,'primary');
  785:         } else {
  786:             undef($uhome);
  787:         }
  788:     } else {
  789:         if (!$uhome) {
  790:             if (defined(&domain($udom,'primary'))) {
  791:                 $uhome=&domain($udom,'primary');
  792:             }
  793:         }
  794:     } 
  795:     if ($udom && $uhome && ($uhome ne 'no_host')) {
  796:         my $items='';
  797:         foreach my $item (keys(%$storehash)) {
  798:             $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
  799:         }
  800:         $items=~s/\&$//;
  801:         return &reply("putdom:$udom:$namespace:$items",$uhome);
  802:     } else {
  803:         &logthis("put_dom failed - no homeserver and/or domain");
  804:     }
  805: }
  806: 
  807: sub retrieve_inst_usertypes {
  808:     my ($udom) = @_;
  809:     my (%returnhash,@order);
  810:     if (defined(&domain($udom,'primary'))) {
  811:         my $uhome=&domain($udom,'primary');
  812:         my $rep=&reply("inst_usertypes:$udom",$uhome);
  813:         my ($hashitems,$orderitems) = split(/:/,$rep); 
  814:         my @pairs=split(/\&/,$hashitems);
  815:         foreach my $item (@pairs) {
  816:             my ($key,$value)=split(/=/,$item,2);
  817:             $key = &unescape($key);
  818:             next if ($key =~ /^error: 2 /);
  819:             $returnhash{$key}=&thaw_unescape($value);
  820:         }
  821:         my @esc_order = split(/\&/,$orderitems);
  822:         foreach my $item (@esc_order) {
  823:             push(@order,&unescape($item));
  824:         }
  825:     } else {
  826:         &logthis("get_dom failed - no primary domain server for $udom");
  827:     }
  828:     return (\%returnhash,\@order);
  829: }
  830: 
  831: sub is_domainimage {
  832:     my ($url) = @_;
  833:     if ($url=~m-^/+res/+($match_domain)/+\1\-domainconfig/+(img|logo|domlogo)/+-) {
  834:         if (&domain($1) ne '') {
  835:             return '1';
  836:         }
  837:     }
  838:     return;
  839: }
  840: 
  841: # --------------------------------------------------- Assign a key to a student
  842: 
  843: sub assign_access_key {
  844: #
  845: # a valid key looks like uname:udom#comments
  846: # comments are being appended
  847: #
  848:     my ($ckey,$kdom,$knum,$cdom,$cnum,$udom,$uname,$logentry)=@_;
  849:     $kdom=
  850:    $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($kdom));
  851:     $knum=
  852:    $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($knum));
  853:     $cdom=
  854:    $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($cdom));
  855:     $cnum=
  856:    $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($cnum));
  857:     $udom=$env{'user.name'} unless (defined($udom));
  858:     $uname=$env{'user.domain'} unless (defined($uname));
  859:     my %existing=&get('accesskeys',[$ckey],$kdom,$knum);
  860:     if (($existing{$ckey}=~/^\#(.*)$/) || # - new key
  861:         ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#(.*)$/)) { 
  862:                                                   # assigned to this person
  863:                                                   # - this should not happen,
  864:                                                   # unless something went wrong
  865:                                                   # the first time around
  866: # ready to assign
  867:         $logentry=$1.'; '.$logentry;
  868:         if (&put('accesskeys',{$ckey=>$uname.':'.$udom.'#'.$logentry},
  869:                                                  $kdom,$knum) eq 'ok') {
  870: # key now belongs to user
  871: 	    my $envkey='key.'.$cdom.'_'.$cnum;
  872:             if (&put('environment',{$envkey => $ckey}) eq 'ok') {
  873:                 &appenv('environment.'.$envkey => $ckey);
  874:                 return 'ok';
  875:             } else {
  876:                 return 
  877:   'error: Count not permanently assign key, will need to be re-entered later.';
  878: 	    }
  879:         } else {
  880:             return 'error: Could not assign key, try again later.';
  881:         }
  882:     } elsif (!$existing{$ckey}) {
  883: # the key does not exist
  884: 	return 'error: The key does not exist';
  885:     } else {
  886: # the key is somebody else's
  887: 	return 'error: The key is already in use';
  888:     }
  889: }
  890: 
  891: # ------------------------------------------ put an additional comment on a key
  892: 
  893: sub comment_access_key {
  894: #
  895: # a valid key looks like uname:udom#comments
  896: # comments are being appended
  897: #
  898:     my ($ckey,$cdom,$cnum,$logentry)=@_;
  899:     $cdom=
  900:    $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($cdom));
  901:     $cnum=
  902:    $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($cnum));
  903:     my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
  904:     if ($existing{$ckey}) {
  905:         $existing{$ckey}.='; '.$logentry;
  906: # ready to assign
  907:         if (&put('accesskeys',{$ckey=>$existing{$ckey}},
  908:                                                  $cdom,$cnum) eq 'ok') {
  909: 	    return 'ok';
  910:         } else {
  911: 	    return 'error: Count not store comment.';
  912:         }
  913:     } else {
  914: # the key does not exist
  915: 	return 'error: The key does not exist';
  916:     }
  917: }
  918: 
  919: # ------------------------------------------------------ Generate a set of keys
  920: 
  921: sub generate_access_keys {
  922:     my ($number,$cdom,$cnum,$logentry)=@_;
  923:     $cdom=
  924:    $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($cdom));
  925:     $cnum=
  926:    $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($cnum));
  927:     unless (&allowed('mky',$cdom)) { return 0; }
  928:     unless (($cdom) && ($cnum)) { return 0; }
  929:     if ($number>10000) { return 0; }
  930:     sleep(2); # make sure don't get same seed twice
  931:     srand(time()^($$+($$<<15))); # from "Programming Perl"
  932:     my $total=0;
  933:     for (my $i=1;$i<=$number;$i++) {
  934:        my $newkey=sprintf("%lx",int(100000*rand)).'-'.
  935:                   sprintf("%lx",int(100000*rand)).'-'.
  936:                   sprintf("%lx",int(100000*rand));
  937:        $newkey=~s/1/g/g; # folks mix up 1 and l
  938:        $newkey=~s/0/h/g; # and also 0 and O
  939:        my %existing=&get('accesskeys',[$newkey],$cdom,$cnum);
  940:        if ($existing{$newkey}) {
  941:            $i--;
  942:        } else {
  943: 	  if (&put('accesskeys',
  944:               { $newkey => '# generated '.localtime().
  945:                            ' by '.$env{'user.name'}.'@'.$env{'user.domain'}.
  946:                            '; '.$logentry },
  947: 		   $cdom,$cnum) eq 'ok') {
  948:               $total++;
  949: 	  }
  950:        }
  951:     }
  952:     &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},
  953:          'Generated '.$total.' keys for '.$cnum.' at '.$cdom);
  954:     return $total;
  955: }
  956: 
  957: # ------------------------------------------------------- Validate an accesskey
  958: 
  959: sub validate_access_key {
  960:     my ($ckey,$cdom,$cnum,$udom,$uname)=@_;
  961:     $cdom=
  962:    $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($cdom));
  963:     $cnum=
  964:    $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($cnum));
  965:     $udom=$env{'user.domain'} unless (defined($udom));
  966:     $uname=$env{'user.name'} unless (defined($uname));
  967:     my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
  968:     return ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#/);
  969: }
  970: 
  971: # ------------------------------------- Find the section of student in a course
  972: sub devalidate_getsection_cache {
  973:     my ($udom,$unam,$courseid)=@_;
  974:     my $hashid="$udom:$unam:$courseid";
  975:     &devalidate_cache_new('getsection',$hashid);
  976: }
  977: 
  978: sub courseid_to_courseurl {
  979:     my ($courseid) = @_;
  980:     #already url style courseid
  981:     return $courseid if ($courseid =~ m{^/});
  982: 
  983:     if (exists($env{'course.'.$courseid.'.num'})) {
  984: 	my $cnum = $env{'course.'.$courseid.'.num'};
  985: 	my $cdom = $env{'course.'.$courseid.'.domain'};
  986: 	return "/$cdom/$cnum";
  987:     }
  988: 
  989:     my %courseinfo=&Apache::lonnet::coursedescription($courseid);
  990:     if (exists($courseinfo{'num'})) {
  991: 	return "/$courseinfo{'domain'}/$courseinfo{'num'}";
  992:     }
  993: 
  994:     return undef;
  995: }
  996: 
  997: sub getsection {
  998:     my ($udom,$unam,$courseid)=@_;
  999:     my $cachetime=1800;
 1000: 
 1001:     my $hashid="$udom:$unam:$courseid";
 1002:     my ($result,$cached)=&is_cached_new('getsection',$hashid);
 1003:     if (defined($cached)) { return $result; }
 1004: 
 1005:     my %Pending; 
 1006:     my %Expired;
 1007:     #
 1008:     # Each role can either have not started yet (pending), be active, 
 1009:     #    or have expired.
 1010:     #
 1011:     # If there is an active role, we are done.
 1012:     #
 1013:     # If there is more than one role which has not started yet, 
 1014:     #     choose the one which will start sooner
 1015:     # If there is one role which has not started yet, return it.
 1016:     #
 1017:     # If there is more than one expired role, choose the one which ended last.
 1018:     # If there is a role which has expired, return it.
 1019:     #
 1020:     $courseid = &courseid_to_courseurl($courseid);
 1021:     my %roleshash = &dump('roles',$udom,$unam,$courseid);
 1022:     foreach my $key (keys(%roleshash)) {
 1023:         next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/);
 1024:         my $section=$1;
 1025:         if ($key eq $courseid.'_st') { $section=''; }
 1026:         my ($dummy,$end,$start)=split(/\_/,&unescape($roleshash{$key}));
 1027:         my $now=time;
 1028:         if (defined($end) && $end && ($now > $end)) {
 1029:             $Expired{$end}=$section;
 1030:             next;
 1031:         }
 1032:         if (defined($start) && $start && ($now < $start)) {
 1033:             $Pending{$start}=$section;
 1034:             next;
 1035:         }
 1036:         return &do_cache_new('getsection',$hashid,$section,$cachetime);
 1037:     }
 1038:     #
 1039:     # Presumedly there will be few matching roles from the above
 1040:     # loop and the sorting time will be negligible.
 1041:     if (scalar(keys(%Pending))) {
 1042:         my ($time) = sort {$a <=> $b} keys(%Pending);
 1043:         return &do_cache_new('getsection',$hashid,$Pending{$time},$cachetime);
 1044:     } 
 1045:     if (scalar(keys(%Expired))) {
 1046:         my @sorted = sort {$a <=> $b} keys(%Expired);
 1047:         my $time = pop(@sorted);
 1048:         return &do_cache_new('getsection',$hashid,$Expired{$time},$cachetime);
 1049:     }
 1050:     return &do_cache_new('getsection',$hashid,'-1',$cachetime);
 1051: }
 1052: 
 1053: sub save_cache {
 1054:     &purge_remembered();
 1055:     #&Apache::loncommon::validate_page();
 1056:     undef(%env);
 1057:     undef($env_loaded);
 1058: }
 1059: 
 1060: my $to_remember=-1;
 1061: my %remembered;
 1062: my %accessed;
 1063: my $kicks=0;
 1064: my $hits=0;
 1065: sub make_key {
 1066:     my ($name,$id) = @_;
 1067:     if (length($id) > 65 
 1068: 	&& length(&escape($id)) > 200) {
 1069: 	$id=length($id).':'.&Digest::MD5::md5_hex($id);
 1070:     }
 1071:     return &escape($name.':'.$id);
 1072: }
 1073: 
 1074: sub devalidate_cache_new {
 1075:     my ($name,$id,$debug) = @_;
 1076:     if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); }
 1077:     $id=&make_key($name,$id);
 1078:     $memcache->delete($id);
 1079:     delete($remembered{$id});
 1080:     delete($accessed{$id});
 1081: }
 1082: 
 1083: sub is_cached_new {
 1084:     my ($name,$id,$debug) = @_;
 1085:     $id=&make_key($name,$id);
 1086:     if (exists($remembered{$id})) {
 1087: 	if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); }
 1088: 	$accessed{$id}=[&gettimeofday()];
 1089: 	$hits++;
 1090: 	return ($remembered{$id},1);
 1091:     }
 1092:     my $value = $memcache->get($id);
 1093:     if (!(defined($value))) {
 1094: 	if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); }
 1095: 	return (undef,undef);
 1096:     }
 1097:     if ($value eq '__undef__') {
 1098: 	if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); }
 1099: 	$value=undef;
 1100:     }
 1101:     &make_room($id,$value,$debug);
 1102:     if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); }
 1103:     return ($value,1);
 1104: }
 1105: 
 1106: sub do_cache_new {
 1107:     my ($name,$id,$value,$time,$debug) = @_;
 1108:     $id=&make_key($name,$id);
 1109:     my $setvalue=$value;
 1110:     if (!defined($setvalue)) {
 1111: 	$setvalue='__undef__';
 1112:     }
 1113:     if (!defined($time) ) {
 1114: 	$time=600;
 1115:     }
 1116:     if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); }
 1117:     if (!($memcache->set($id,$setvalue,$time))) {
 1118: 	&logthis("caching of id -> $id  failed");
 1119:     }
 1120:     # need to make a copy of $value
 1121:     #&make_room($id,$value,$debug);
 1122:     return $value;
 1123: }
 1124: 
 1125: sub make_room {
 1126:     my ($id,$value,$debug)=@_;
 1127:     $remembered{$id}=$value;
 1128:     if ($to_remember<0) { return; }
 1129:     $accessed{$id}=[&gettimeofday()];
 1130:     if (scalar(keys(%remembered)) <= $to_remember) { return; }
 1131:     my $to_kick;
 1132:     my $max_time=0;
 1133:     foreach my $other (keys(%accessed)) {
 1134: 	if (&tv_interval($accessed{$other}) > $max_time) {
 1135: 	    $to_kick=$other;
 1136: 	    $max_time=&tv_interval($accessed{$other});
 1137: 	}
 1138:     }
 1139:     delete($remembered{$to_kick});
 1140:     delete($accessed{$to_kick});
 1141:     $kicks++;
 1142:     if ($debug) { &logthis("kicking $to_kick $max_time $kicks\n"); }
 1143:     return;
 1144: }
 1145: 
 1146: sub purge_remembered {
 1147:     #&logthis("Tossing ".scalar(keys(%remembered)));
 1148:     #&logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered))));
 1149:     undef(%remembered);
 1150:     undef(%accessed);
 1151: }
 1152: # ------------------------------------- Read an entry from a user's environment
 1153: 
 1154: sub userenvironment {
 1155:     my ($udom,$unam,@what)=@_;
 1156:     my %returnhash=();
 1157:     my @answer=split(/\&/,
 1158:                 &reply('get:'.$udom.':'.$unam.':environment:'.join('&',@what),
 1159:                       &homeserver($unam,$udom)));
 1160:     my $i;
 1161:     for ($i=0;$i<=$#what;$i++) {
 1162: 	$returnhash{$what[$i]}=&unescape($answer[$i]);
 1163:     }
 1164:     return %returnhash;
 1165: }
 1166: 
 1167: # ---------------------------------------------------------- Get a studentphoto
 1168: sub studentphoto {
 1169:     my ($udom,$unam,$ext) = @_;
 1170:     my $home=&Apache::lonnet::homeserver($unam,$udom);
 1171:     if (defined($env{'request.course.id'})) {
 1172:         if ($env{'course.'.$env{'request.course.id'}.'.internal.showphoto'}) {
 1173:             if ($udom eq $env{'course.'.$env{'request.course.id'}.'.domain'}) {
 1174:                 return(&retrievestudentphoto($udom,$unam,$ext)); 
 1175:             } else {
 1176:                 my ($result,$perm_reqd)=
 1177: 		    &Apache::lonnet::auto_photo_permission($unam,$udom);
 1178:                 if ($result eq 'ok') {
 1179:                     if (!($perm_reqd eq 'yes')) {
 1180:                         return(&retrievestudentphoto($udom,$unam,$ext));
 1181:                     }
 1182:                 }
 1183:             }
 1184:         }
 1185:     } else {
 1186:         my ($result,$perm_reqd) = 
 1187: 	    &Apache::lonnet::auto_photo_permission($unam,$udom);
 1188:         if ($result eq 'ok') {
 1189:             if (!($perm_reqd eq 'yes')) {
 1190:                 return(&retrievestudentphoto($udom,$unam,$ext));
 1191:             }
 1192:         }
 1193:     }
 1194:     return '/adm/lonKaputt/lonlogo_broken.gif';
 1195: }
 1196: 
 1197: sub retrievestudentphoto {
 1198:     my ($udom,$unam,$ext,$type) = @_;
 1199:     my $home=&Apache::lonnet::homeserver($unam,$udom);
 1200:     my $ret=&Apache::lonnet::reply("studentphoto:$udom:$unam:$ext:$type",$home);
 1201:     if ($ret eq 'ok') {
 1202:         my $url="/uploaded/$udom/$unam/internal/studentphoto.$ext";
 1203:         if ($type eq 'thumbnail') {
 1204:             $url="/uploaded/$udom/$unam/internal/studentphoto_tn.$ext"; 
 1205:         }
 1206:         my $tokenurl=&Apache::lonnet::tokenwrapper($url);
 1207:         return $tokenurl;
 1208:     } else {
 1209:         if ($type eq 'thumbnail') {
 1210:             return '/adm/lonKaputt/genericstudent_tn.gif';
 1211:         } else { 
 1212:             return '/adm/lonKaputt/lonlogo_broken.gif';
 1213:         }
 1214:     }
 1215: }
 1216: 
 1217: # -------------------------------------------------------------------- New chat
 1218: 
 1219: sub chatsend {
 1220:     my ($newentry,$anon,$group)=@_;
 1221:     my $cnum=$env{'course.'.$env{'request.course.id'}.'.num'};
 1222:     my $cdom=$env{'course.'.$env{'request.course.id'}.'.domain'};
 1223:     my $chome=$env{'course.'.$env{'request.course.id'}.'.home'};
 1224:     &reply('chatsend:'.$cdom.':'.$cnum.':'.
 1225: 	   &escape($env{'user.domain'}.':'.$env{'user.name'}.':'.$anon.':'.
 1226: 		   &escape($newentry)).':'.$group,$chome);
 1227: }
 1228: 
 1229: # ------------------------------------------ Find current version of a resource
 1230: 
 1231: sub getversion {
 1232:     my $fname=&clutter(shift);
 1233:     unless ($fname=~/^\/res\//) { return -1; }
 1234:     return &currentversion(&filelocation('',$fname));
 1235: }
 1236: 
 1237: sub currentversion {
 1238:     my $fname=shift;
 1239:     my ($result,$cached)=&is_cached_new('resversion',$fname);
 1240:     if (defined($cached)) { return $result; }
 1241:     my $author=$fname;
 1242:     $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
 1243:     my ($udom,$uname)=split(/\//,$author);
 1244:     my $home=homeserver($uname,$udom);
 1245:     if ($home eq 'no_host') { 
 1246:         return -1; 
 1247:     }
 1248:     my $answer=reply("currentversion:$fname",$home);
 1249:     if (($answer eq 'con_lost') || ($answer eq 'rejected')) {
 1250: 	return -1;
 1251:     }
 1252:     return &do_cache_new('resversion',$fname,$answer,600);
 1253: }
 1254: 
 1255: # ----------------------------- Subscribe to a resource, return URL if possible
 1256: 
 1257: sub subscribe {
 1258:     my $fname=shift;
 1259:     if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return ''; }
 1260:     $fname=~s/[\n\r]//g;
 1261:     my $author=$fname;
 1262:     $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
 1263:     my ($udom,$uname)=split(/\//,$author);
 1264:     my $home=homeserver($uname,$udom);
 1265:     if ($home eq 'no_host') {
 1266:         return 'not_found';
 1267:     }
 1268:     my $answer=reply("sub:$fname",$home);
 1269:     if (($answer eq 'con_lost') || ($answer eq 'rejected')) {
 1270: 	$answer.=' by '.$home;
 1271:     }
 1272:     return $answer;
 1273: }
 1274:     
 1275: # -------------------------------------------------------------- Replicate file
 1276: 
 1277: sub repcopy {
 1278:     my $filename=shift;
 1279:     $filename=~s/\/+/\//g;
 1280:     if ($filename=~m|^/home/httpd/html/adm/|) { return 'ok'; }
 1281:     if ($filename=~m|^/home/httpd/html/lonUsers/|) { return 'ok'; }
 1282:     if ($filename=~m|^/home/httpd/html/userfiles/| or
 1283: 	$filename=~m -^/*(uploaded|editupload)/-) { 
 1284: 	return &repcopy_userfile($filename);
 1285:     }
 1286:     $filename=~s/[\n\r]//g;
 1287:     my $transname="$filename.in.transfer";
 1288: # FIXME: this should flock
 1289:     if ((-e $filename) || (-e $transname)) { return 'ok'; }
 1290:     my $remoteurl=subscribe($filename);
 1291:     if ($remoteurl =~ /^con_lost by/) {
 1292: 	   &logthis("Subscribe returned $remoteurl: $filename");
 1293:            return 'unavailable';
 1294:     } elsif ($remoteurl eq 'not_found') {
 1295: 	   #&logthis("Subscribe returned not_found: $filename");
 1296: 	   return 'not_found';
 1297:     } elsif ($remoteurl =~ /^rejected by/) {
 1298: 	   &logthis("Subscribe returned $remoteurl: $filename");
 1299:            return 'forbidden';
 1300:     } elsif ($remoteurl eq 'directory') {
 1301:            return 'ok';
 1302:     } else {
 1303:         my $author=$filename;
 1304:         $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
 1305:         my ($udom,$uname)=split(/\//,$author);
 1306:         my $home=homeserver($uname,$udom);
 1307:         unless ($home eq $perlvar{'lonHostID'}) {
 1308:            my @parts=split(/\//,$filename);
 1309:            my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";
 1310:            if ($path ne "$perlvar{'lonDocRoot'}/res") {
 1311:                &logthis("Malconfiguration for replication: $filename");
 1312: 	       return 'bad_request';
 1313:            }
 1314:            my $count;
 1315:            for ($count=5;$count<$#parts;$count++) {
 1316:                $path.="/$parts[$count]";
 1317:                if ((-e $path)!=1) {
 1318: 		   mkdir($path,0777);
 1319:                }
 1320:            }
 1321:            my $ua=new LWP::UserAgent;
 1322:            my $request=new HTTP::Request('GET',"$remoteurl");
 1323:            my $response=$ua->request($request,$transname);
 1324:            if ($response->is_error()) {
 1325: 	       unlink($transname);
 1326:                my $message=$response->status_line;
 1327:                &logthis("<font color=\"blue\">WARNING:"
 1328:                        ." LWP get: $message: $filename</font>");
 1329:                return 'unavailable';
 1330:            } else {
 1331: 	       if ($remoteurl!~/\.meta$/) {
 1332:                   my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');
 1333:                   my $mresponse=$ua->request($mrequest,$filename.'.meta');
 1334:                   if ($mresponse->is_error()) {
 1335: 		      unlink($filename.'.meta');
 1336:                       &logthis(
 1337:                      "<font color=\"yellow\">INFO: No metadata: $filename</font>");
 1338:                   }
 1339: 	       }
 1340:                rename($transname,$filename);
 1341:                return 'ok';
 1342:            }
 1343:        }
 1344:     }
 1345: }
 1346: 
 1347: # ------------------------------------------------ Get server side include body
 1348: sub ssi_body {
 1349:     my ($filelink,%form)=@_;
 1350:     if (! exists($form{'LONCAPA_INTERNAL_no_discussion'})) {
 1351:         $form{'LONCAPA_INTERNAL_no_discussion'}='true';
 1352:     }
 1353:     my $output=($filelink=~/^http\:/?&externalssi($filelink):
 1354:                                      &ssi($filelink,%form));
 1355:     $output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+?// END LON-CAPA Internal\s*(-->)?\s||gs;
 1356:     $output=~s/^.*?\<body[^\>]*\>//si;
 1357:     $output=~s/(.*)\<\/body\s*\>.*?$/$1/si;
 1358:     return $output;
 1359: }
 1360: 
 1361: # --------------------------------------------------------- Server Side Include
 1362: 
 1363: sub absolute_url {
 1364:     my ($host_name) = @_;
 1365:     my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://');
 1366:     if ($host_name eq '') {
 1367: 	$host_name = $ENV{'SERVER_NAME'};
 1368:     }
 1369:     return $protocol.$host_name;
 1370: }
 1371: 
 1372: sub ssi {
 1373: 
 1374:     my ($fn,%form)=@_;
 1375: 
 1376:     my $ua=new LWP::UserAgent;
 1377:     
 1378:     my $request;
 1379: 
 1380:     $form{'no_update_last_known'}=1;
 1381:     &Apache::lonenc::check_encrypt(\$fn);
 1382:     if (%form) {
 1383:       $request=new HTTP::Request('POST',&absolute_url().$fn);
 1384:       $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form));
 1385:     } else {
 1386:       $request=new HTTP::Request('GET',&absolute_url().$fn);
 1387:     }
 1388: 
 1389:     $request->header(Cookie => $ENV{'HTTP_COOKIE'});
 1390:     my $response=$ua->request($request);
 1391: 
 1392:     return $response->content;
 1393: }
 1394: 
 1395: sub externalssi {
 1396:     my ($url)=@_;
 1397:     my $ua=new LWP::UserAgent;
 1398:     my $request=new HTTP::Request('GET',$url);
 1399:     my $response=$ua->request($request);
 1400:     return $response->content;
 1401: }
 1402: 
 1403: # -------------------------------- Allow a /uploaded/ URI to be vouched for
 1404: 
 1405: sub allowuploaded {
 1406:     my ($srcurl,$url)=@_;
 1407:     $url=&clutter(&declutter($url));
 1408:     my $dir=$url;
 1409:     $dir=~s/\/[^\/]+$//;
 1410:     my %httpref=();
 1411:     my $httpurl=&hreflocation('',$url);
 1412:     $httpref{'httpref.'.$httpurl}=$srcurl;
 1413:     &Apache::lonnet::appenv(%httpref);
 1414: }
 1415: 
 1416: # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course
 1417: # input: action, courseID, current domain, intended
 1418: #        path to file, source of file, instruction to parse file for objects,
 1419: #        ref to hash for embedded objects,
 1420: #        ref to hash for codebase of java objects.
 1421: #
 1422: # output: url to file (if action was uploaddoc), 
 1423: #         ok if successful, or diagnostic message otherwise (if action was propagate or copy)
 1424: #
 1425: # Allows directory structure to be used within lonUsers/../userfiles/ for a 
 1426: # course.
 1427: #
 1428: # action = propagate - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
 1429: #          will be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles in
 1430: #          course's home server.
 1431: #
 1432: # action = copy - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file will
 1433: #          be copied from $source (current location) to 
 1434: #          /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
 1435: #         and will then be copied to
 1436: #          /home/httpd/lonUsers/$domain/1/2/3/$course/userfiles/$file in
 1437: #         course's home server.
 1438: #
 1439: # action = uploaddoc - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
 1440: #         will be retrived from $env{form.uploaddoc} (from DOCS interface) to
 1441: #         /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
 1442: #         and will then be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles/$file
 1443: #         in course's home server.
 1444: #
 1445: 
 1446: sub process_coursefile {
 1447:     my ($action,$docuname,$docudom,$file,$source,$parser,$allfiles,$codebase)=@_;
 1448:     my $fetchresult;
 1449:     my $home=&homeserver($docuname,$docudom);
 1450:     if ($action eq 'propagate') {
 1451:         $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
 1452: 			     $home);
 1453:     } else {
 1454:         my $fpath = '';
 1455:         my $fname = $file;
 1456:         ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|);
 1457:         $fpath=$docudom.'/'.$docuname.'/'.$fpath;
 1458:         my $filepath = &build_filepath($fpath);
 1459:         if ($action eq 'copy') {
 1460:             if ($source eq '') {
 1461:                 $fetchresult = 'no source file';
 1462:                 return $fetchresult;
 1463:             } else {
 1464:                 my $destination = $filepath.'/'.$fname;
 1465:                 rename($source,$destination);
 1466:                 $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
 1467:                                  $home);
 1468:             }
 1469:         } elsif ($action eq 'uploaddoc') {
 1470:             open(my $fh,'>'.$filepath.'/'.$fname);
 1471:             print $fh $env{'form.'.$source};
 1472:             close($fh);
 1473:             if ($parser eq 'parse') {
 1474:                 my $parse_result = &extract_embedded_items($filepath,$fname,$allfiles,$codebase);
 1475:                 unless ($parse_result eq 'ok') {
 1476:                     &logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result);
 1477:                 }
 1478:             }
 1479:             $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
 1480:                                  $home);
 1481:             if ($fetchresult eq 'ok') {
 1482:                 return '/uploaded/'.$fpath.'/'.$fname;
 1483:             } else {
 1484:                 &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.
 1485:                         ' to host '.$home.': '.$fetchresult);
 1486:                 return '/adm/notfound.html';
 1487:             }
 1488:         }
 1489:     }
 1490:     unless ( $fetchresult eq 'ok') {
 1491:         &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.
 1492:              ' to host '.$home.': '.$fetchresult);
 1493:     }
 1494:     return $fetchresult;
 1495: }
 1496: 
 1497: sub build_filepath {
 1498:     my ($fpath) = @_;
 1499:     my $filepath=$perlvar{'lonDocRoot'}.'/userfiles';
 1500:     unless ($fpath eq '') {
 1501:         my @parts=split('/',$fpath);
 1502:         foreach my $part (@parts) {
 1503:             $filepath.= '/'.$part;
 1504:             if ((-e $filepath)!=1) {
 1505:                 mkdir($filepath,0777);
 1506:             }
 1507:         }
 1508:     }
 1509:     return $filepath;
 1510: }
 1511: 
 1512: sub store_edited_file {
 1513:     my ($primary_url,$content,$docudom,$docuname,$fetchresult) = @_;
 1514:     my $file = $primary_url;
 1515:     $file =~ s#^/uploaded/$docudom/$docuname/##;
 1516:     my $fpath = '';
 1517:     my $fname = $file;
 1518:     ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|);
 1519:     $fpath=$docudom.'/'.$docuname.'/'.$fpath;
 1520:     my $filepath = &build_filepath($fpath);
 1521:     open(my $fh,'>'.$filepath.'/'.$fname);
 1522:     print $fh $content;
 1523:     close($fh);
 1524:     my $home=&homeserver($docuname,$docudom);
 1525:     $$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
 1526: 			  $home);
 1527:     if ($$fetchresult eq 'ok') {
 1528:         return '/uploaded/'.$fpath.'/'.$fname;
 1529:     } else {
 1530:         &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.
 1531: 		 ' to host '.$home.': '.$$fetchresult);
 1532:         return '/adm/notfound.html';
 1533:     }
 1534: }
 1535: 
 1536: sub clean_filename {
 1537:     my ($fname,$args)=@_;
 1538: # Replace Windows backslashes by forward slashes
 1539:     $fname=~s/\\/\//g;
 1540:     if (!$args->{'keep_path'}) {
 1541:         # Get rid of everything but the actual filename
 1542: 	$fname=~s/^.*\/([^\/]+)$/$1/;
 1543:     }
 1544: # Replace spaces by underscores
 1545:     $fname=~s/\s+/\_/g;
 1546: # Replace all other weird characters by nothing
 1547:     $fname=~s{[^/\w\.\-]}{}g;
 1548: # Replace all .\d. sequences with _\d. so they no longer look like version
 1549: # numbers
 1550:     $fname=~s/\.(\d+)(?=\.)/_$1/g;
 1551:     return $fname;
 1552: }
 1553: 
 1554: # --------------- Take an uploaded file and put it into the userfiles directory
 1555: # input: $formname - the contents of the file are in $env{"form.$formname"}
 1556: #                    the desired filenam is in $env{"form.$formname.filename"}
 1557: #        $coursedoc - if true up to the current course
 1558: #                     if false
 1559: #        $subdir - directory in userfile to store the file into
 1560: #        $parser - instruction to parse file for objects ($parser = parse)    
 1561: #        $allfiles - reference to hash for embedded objects
 1562: #        $codebase - reference to hash for codebase of java objects
 1563: #        $desuname - username for permanent storage of uploaded file
 1564: #        $dsetudom - domain for permanaent storage of uploaded file
 1565: #        $thumbwidth - width (pixels) of thumbnail to make for uploaded image 
 1566: #        $thumbheight - height (pixels) of thumbnail to make for uploaded image
 1567: # 
 1568: # output: url of file in userspace, or error: <message> 
 1569: #             or /adm/notfound.html if failure to upload occurse
 1570: 
 1571: 
 1572: sub userfileupload {
 1573:     my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname,
 1574:         $destudom,$thumbwidth,$thumbheight)=@_;
 1575:     if (!defined($subdir)) { $subdir='unknown'; }
 1576:     my $fname=$env{'form.'.$formname.'.filename'};
 1577:     $fname=&clean_filename($fname);
 1578: # See if there is anything left
 1579:     unless ($fname) { return 'error: no uploaded file'; }
 1580:     chop($env{'form.'.$formname});
 1581:     if (($formname eq 'screenshot') && ($subdir eq 'helprequests')) { #files uploaded to help request form are handled differently
 1582:         my $now = time;
 1583:         my $filepath = 'tmp/helprequests/'.$now;
 1584:         my @parts=split(/\//,$filepath);
 1585:         my $fullpath = $perlvar{'lonDaemons'};
 1586:         for (my $i=0;$i<@parts;$i++) {
 1587:             $fullpath .= '/'.$parts[$i];
 1588:             if ((-e $fullpath)!=1) {
 1589:                 mkdir($fullpath,0777);
 1590:             }
 1591:         }
 1592:         open(my $fh,'>'.$fullpath.'/'.$fname);
 1593:         print $fh $env{'form.'.$formname};
 1594:         close($fh);
 1595:         return $fullpath.'/'.$fname;
 1596:     } elsif (($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) { #files uploaded to create course page are handled differently
 1597:         my $filepath = 'tmp/addcourse/'.$destudom.'/web/'.$env{'user.name'}.
 1598:                        '_'.$env{'user.domain'}.'/pending';
 1599:         my @parts=split(/\//,$filepath);
 1600:         my $fullpath = $perlvar{'lonDaemons'};
 1601:         for (my $i=0;$i<@parts;$i++) {
 1602:             $fullpath .= '/'.$parts[$i];
 1603:             if ((-e $fullpath)!=1) {
 1604:                 mkdir($fullpath,0777);
 1605:             }
 1606:         }
 1607:         open(my $fh,'>'.$fullpath.'/'.$fname);
 1608:         print $fh $env{'form.'.$formname};
 1609:         close($fh);
 1610:         return $fullpath.'/'.$fname;
 1611:     }
 1612:     
 1613: # Create the directory if not present
 1614:     $fname="$subdir/$fname";
 1615:     if ($coursedoc) {
 1616: 	my $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
 1617: 	my $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
 1618:         if ($env{'form.folder'} =~ m/^(default|supplemental)/) {
 1619:             return &finishuserfileupload($docuname,$docudom,
 1620: 					 $formname,$fname,$parser,$allfiles,
 1621: 					 $codebase,$thumbwidth,$thumbheight);
 1622:         } else {
 1623:             $fname=$env{'form.folder'}.'/'.$fname;
 1624:             return &process_coursefile('uploaddoc',$docuname,$docudom,
 1625: 				       $fname,$formname,$parser,
 1626: 				       $allfiles,$codebase);
 1627:         }
 1628:     } elsif (defined($destuname)) {
 1629:         my $docuname=$destuname;
 1630:         my $docudom=$destudom;
 1631: 	return &finishuserfileupload($docuname,$docudom,$formname,$fname,
 1632: 				     $parser,$allfiles,$codebase,
 1633:                                      $thumbwidth,$thumbheight);
 1634:         
 1635:     } else {
 1636:         my $docuname=$env{'user.name'};
 1637:         my $docudom=$env{'user.domain'};
 1638:         if (exists($env{'form.group'})) {
 1639:             $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
 1640:             $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
 1641:         }
 1642: 	return &finishuserfileupload($docuname,$docudom,$formname,$fname,
 1643: 				     $parser,$allfiles,$codebase,
 1644:                                      $thumbwidth,$thumbheight);
 1645:     }
 1646: }
 1647: 
 1648: sub finishuserfileupload {
 1649:     my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase,
 1650:         $thumbwidth,$thumbheight) = @_;
 1651:     my $path=$docudom.'/'.$docuname.'/';
 1652:     my $filepath=$perlvar{'lonDocRoot'};
 1653:     my ($fnamepath,$file,$fetchthumb);
 1654:     $file=$fname;
 1655:     if ($fname=~m|/|) {
 1656:         ($fnamepath,$file) = ($fname =~ m|^(.*)/([^/]+)$|);
 1657: 	$path.=$fnamepath.'/';
 1658:     }
 1659:     my @parts=split(/\//,$filepath.'/userfiles/'.$path);
 1660:     my $count;
 1661:     for ($count=4;$count<=$#parts;$count++) {
 1662:         $filepath.="/$parts[$count]";
 1663:         if ((-e $filepath)!=1) {
 1664: 	    mkdir($filepath,0777);
 1665:         }
 1666:     }
 1667: # Save the file
 1668:     {
 1669: 	if (!open(FH,'>'.$filepath.'/'.$file)) {
 1670: 	    &logthis('Failed to create '.$filepath.'/'.$file);
 1671: 	    print STDERR ('Failed to create '.$filepath.'/'.$file."\n");
 1672: 	    return '/adm/notfound.html';
 1673: 	}
 1674: 	if (!print FH ($env{'form.'.$formname})) {
 1675: 	    &logthis('Failed to write to '.$filepath.'/'.$file);
 1676: 	    print STDERR ('Failed to write to '.$filepath.'/'.$file."\n");
 1677: 	    return '/adm/notfound.html';
 1678: 	}
 1679: 	close(FH);
 1680:     }
 1681:     if ($parser eq 'parse') {
 1682:         my $parse_result = &extract_embedded_items($filepath,$file,$allfiles,
 1683: 						   $codebase);
 1684:         unless ($parse_result eq 'ok') {
 1685:             &logthis('Failed to parse '.$filepath.$file.
 1686: 		     ' for embedded media: '.$parse_result); 
 1687:         }
 1688:     }
 1689:     if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {
 1690:         my $input = $filepath.'/'.$file;
 1691:         my $output = $filepath.'/'.'tn-'.$file;
 1692:         my $thumbsize = $thumbwidth.'x'.$thumbheight;
 1693:         system("convert -sample $thumbsize $input $output");
 1694:         if (-e $filepath.'/'.'tn-'.$file) {
 1695:             $fetchthumb  = 1; 
 1696:         }
 1697:     }
 1698:  
 1699: # Notify homeserver to grep it
 1700: #
 1701:     my $docuhome=&homeserver($docuname,$docudom);
 1702:     my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);
 1703:     if ($fetchresult eq 'ok') {
 1704:         if ($fetchthumb) {
 1705:             my $thumbresult= &reply('fetchuserfile:'.$path.'tn-'.$file,$docuhome);
 1706:             if ($thumbresult ne 'ok') {
 1707:                 &logthis('Failed to transfer '.$path.'tn-'.$file.' to host '.
 1708:                          $docuhome.': '.$thumbresult);
 1709:             }
 1710:         }
 1711: #
 1712: # Return the URL to it
 1713:         return '/uploaded/'.$path.$file;
 1714:     } else {
 1715:         &logthis('Failed to transfer '.$path.$file.' to host '.$docuhome.
 1716: 		 ': '.$fetchresult);
 1717:         return '/adm/notfound.html';
 1718:     }
 1719: }
 1720: 
 1721: sub extract_embedded_items {
 1722:     my ($filepath,$file,$allfiles,$codebase,$content) = @_;
 1723:     my @state = ();
 1724:     my %javafiles = (
 1725:                       codebase => '',
 1726:                       code => '',
 1727:                       archive => ''
 1728:                     );
 1729:     my %mediafiles = (
 1730:                       src => '',
 1731:                       movie => '',
 1732:                      );
 1733:     my $p;
 1734:     if ($content) {
 1735:         $p = HTML::LCParser->new($content);
 1736:     } else {
 1737:         $p = HTML::LCParser->new($filepath.'/'.$file);
 1738:     }
 1739:     while (my $t=$p->get_token()) {
 1740: 	if ($t->[0] eq 'S') {
 1741: 	    my ($tagname, $attr) = ($t->[1],$t->[2]);
 1742: 	    push(@state, $tagname);
 1743:             if (lc($tagname) eq 'allow') {
 1744:                 &add_filetype($allfiles,$attr->{'src'},'src');
 1745:             }
 1746: 	    if (lc($tagname) eq 'img') {
 1747: 		&add_filetype($allfiles,$attr->{'src'},'src');
 1748: 	    }
 1749: 	    if (lc($tagname) eq 'a') {
 1750: 		&add_filetype($allfiles,$attr->{'href'},'href');
 1751: 	    }
 1752:             if (lc($tagname) eq 'script') {
 1753:                 if ($attr->{'archive'} =~ /\.jar$/i) {
 1754:                     &add_filetype($allfiles,$attr->{'archive'},'archive');
 1755:                 } else {
 1756:                     &add_filetype($allfiles,$attr->{'src'},'src');
 1757:                 }
 1758:             }
 1759:             if (lc($tagname) eq 'link') {
 1760:                 if (lc($attr->{'rel'}) eq 'stylesheet') { 
 1761:                     &add_filetype($allfiles,$attr->{'href'},'href');
 1762:                 }
 1763:             }
 1764: 	    if (lc($tagname) eq 'object' ||
 1765: 		(lc($tagname) eq 'embed' && lc($state[-2]) ne 'object')) {
 1766: 		foreach my $item (keys(%javafiles)) {
 1767: 		    $javafiles{$item} = '';
 1768: 		}
 1769: 	    }
 1770: 	    if (lc($state[-2]) eq 'object' && lc($tagname) eq 'param') {
 1771: 		my $name = lc($attr->{'name'});
 1772: 		foreach my $item (keys(%javafiles)) {
 1773: 		    if ($name eq $item) {
 1774: 			$javafiles{$item} = $attr->{'value'};
 1775: 			last;
 1776: 		    }
 1777: 		}
 1778: 		foreach my $item (keys(%mediafiles)) {
 1779: 		    if ($name eq $item) {
 1780: 			&add_filetype($allfiles, $attr->{'value'}, 'value');
 1781: 			last;
 1782: 		    }
 1783: 		}
 1784: 	    }
 1785: 	    if (lc($tagname) eq 'embed' || lc($tagname) eq 'applet') {
 1786: 		foreach my $item (keys(%javafiles)) {
 1787: 		    if ($attr->{$item}) {
 1788: 			$javafiles{$item} = $attr->{$item};
 1789: 			last;
 1790: 		    }
 1791: 		}
 1792: 		foreach my $item (keys(%mediafiles)) {
 1793: 		    if ($attr->{$item}) {
 1794: 			&add_filetype($allfiles,$attr->{$item},$item);
 1795: 			last;
 1796: 		    }
 1797: 		}
 1798: 	    }
 1799: 	} elsif ($t->[0] eq 'E') {
 1800: 	    my ($tagname) = ($t->[1]);
 1801: 	    if ($javafiles{'codebase'} ne '') {
 1802: 		$javafiles{'codebase'} .= '/';
 1803: 	    }  
 1804: 	    if (lc($tagname) eq 'applet' ||
 1805: 		lc($tagname) eq 'object' ||
 1806: 		(lc($tagname) eq 'embed' && lc($state[-2]) ne 'object')
 1807: 		) {
 1808: 		foreach my $item (keys(%javafiles)) {
 1809: 		    if ($item ne 'codebase' && $javafiles{$item} ne '') {
 1810: 			my $file=$javafiles{'codebase'}.$javafiles{$item};
 1811: 			&add_filetype($allfiles,$file,$item);
 1812: 		    }
 1813: 		}
 1814: 	    } 
 1815: 	    pop @state;
 1816: 	}
 1817:     }
 1818:     return 'ok';
 1819: }
 1820: 
 1821: sub add_filetype {
 1822:     my ($allfiles,$file,$type)=@_;
 1823:     if (exists($allfiles->{$file})) {
 1824: 	unless (grep/^\Q$type\E$/, @{$allfiles->{$file}}) {
 1825: 	    push(@{$allfiles->{$file}}, &escape($type));
 1826: 	}
 1827:     } else {
 1828: 	@{$allfiles->{$file}} = (&escape($type));
 1829:     }
 1830: }
 1831: 
 1832: sub removeuploadedurl {
 1833:     my ($url)=@_;
 1834:     my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);
 1835:     return &removeuserfile($uname,$udom,$fname);
 1836: }
 1837: 
 1838: sub removeuserfile {
 1839:     my ($docuname,$docudom,$fname)=@_;
 1840:     my $home=&homeserver($docuname,$docudom);
 1841:     my $result = &reply("removeuserfile:$docudom/$docuname/$fname",$home);
 1842:     if ($result eq 'ok') {
 1843:         if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) {
 1844:             my $metafile = $fname.'.meta';
 1845:             my $metaresult = &removeuserfile($docuname,$docudom,$metafile); 
 1846: 	    my $url = "/uploaded/$docudom/$docuname/$fname";
 1847:             my ($file,$group) = (&parse_portfolio_url($url))[3,4];
 1848:             my $sqlresult = 
 1849:                 &update_portfolio_table($docuname,$docudom,$file,
 1850:                                         'portfolio_metadata',$group,
 1851:                                         'delete');
 1852:         }
 1853:     }
 1854:     return $result;
 1855: }
 1856: 
 1857: sub mkdiruserfile {
 1858:     my ($docuname,$docudom,$dir)=@_;
 1859:     my $home=&homeserver($docuname,$docudom);
 1860:     return &reply("mkdiruserfile:".&escape("$docudom/$docuname/$dir"),$home);
 1861: }
 1862: 
 1863: sub renameuserfile {
 1864:     my ($docuname,$docudom,$old,$new)=@_;
 1865:     my $home=&homeserver($docuname,$docudom);
 1866:     my $result = &reply("renameuserfile:$docudom:$docuname:".
 1867:                         &escape("$old").':'.&escape("$new"),$home);
 1868:     if ($result eq 'ok') {
 1869:         if (($old !~ /\.meta$/) && (&is_portfolio_file($old))) {
 1870:             my $oldmeta = $old.'.meta';
 1871:             my $newmeta = $new.'.meta';
 1872:             my $metaresult = 
 1873:                 &renameuserfile($docuname,$docudom,$oldmeta,$newmeta);
 1874: 	    my $url = "/uploaded/$docudom/$docuname/$old";
 1875:             my ($file,$group) = (&parse_portfolio_url($url))[3,4];
 1876:             my $sqlresult = 
 1877:                 &update_portfolio_table($docuname,$docudom,$file,
 1878:                                         'portfolio_metadata',$group,
 1879:                                         'delete');
 1880:         }
 1881:     }
 1882:     return $result;
 1883: }
 1884: 
 1885: # ------------------------------------------------------------------------- Log
 1886: 
 1887: sub log {
 1888:     my ($dom,$nam,$hom,$what)=@_;
 1889:     return critical("log:$dom:$nam:$what",$hom);
 1890: }
 1891: 
 1892: # ------------------------------------------------------------------ Course Log
 1893: #
 1894: # This routine flushes several buffers of non-mission-critical nature
 1895: #
 1896: 
 1897: sub flushcourselogs {
 1898:     &logthis('Flushing log buffers');
 1899: #
 1900: # course logs
 1901: # This is a log of all transactions in a course, which can be used
 1902: # for data mining purposes
 1903: #
 1904: # It also collects the courseid database, which lists last transaction
 1905: # times and course titles for all courseids
 1906: #
 1907:     my %courseidbuffer=();
 1908:     foreach my $crsid (keys %courselogs) {
 1909:         if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$crsid}.':'.
 1910: 		          &escape($courselogs{$crsid}),
 1911: 		          $coursehombuf{$crsid}) eq 'ok') {
 1912: 	    delete $courselogs{$crsid};
 1913:         } else {
 1914:             &logthis('Failed to flush log buffer for '.$crsid);
 1915:             if (length($courselogs{$crsid})>40000) {
 1916:                &logthis("<font color=\"blue\">WARNING: Buffer for ".$crsid.
 1917:                         " exceeded maximum size, deleting.</font>");
 1918:                delete $courselogs{$crsid};
 1919:             }
 1920:         }
 1921:         if ($courseidbuffer{$coursehombuf{$crsid}}) {
 1922:            $courseidbuffer{$coursehombuf{$crsid}}.='&'.
 1923: 			 &escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
 1924:                          ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}).':'.&escape($coursetypebuf{$crsid});
 1925:         } else {
 1926:            $courseidbuffer{$coursehombuf{$crsid}}=
 1927: 			 &escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
 1928:                          ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}).':'.&escape($coursetypebuf{$crsid});
 1929:         }
 1930:     }
 1931: #
 1932: # Write course id database (reverse lookup) to homeserver of courses 
 1933: # Is used in pickcourse
 1934: #
 1935:     foreach my $crs_home (keys(%courseidbuffer)) {
 1936:         &courseidput(&host_domain($crs_home),$courseidbuffer{$crs_home},
 1937: 		     $crs_home);
 1938:     }
 1939: #
 1940: # File accesses
 1941: # Writes to the dynamic metadata of resources to get hit counts, etc.
 1942: #
 1943:     foreach my $entry (keys(%accesshash)) {
 1944:         if ($entry =~ /___count$/) {
 1945:             my ($dom,$name);
 1946:             ($dom,$name,undef)=
 1947: 		($entry=~m{___($match_domain)/($match_name)/(.*)___count$});
 1948:             if (! defined($dom) || $dom eq '' || 
 1949:                 ! defined($name) || $name eq '') {
 1950:                 my $cid = $env{'request.course.id'};
 1951:                 $dom  = $env{'request.'.$cid.'.domain'};
 1952:                 $name = $env{'request.'.$cid.'.num'};
 1953:             }
 1954:             my $value = $accesshash{$entry};
 1955:             my (undef,$url,undef) = ($entry =~ /^(.*)___(.*)___count$/);
 1956:             my %temphash=($url => $value);
 1957:             my $result = &inc('nohist_accesscount',\%temphash,$dom,$name);
 1958:             if ($result eq 'ok') {
 1959:                 delete $accesshash{$entry};
 1960:             } elsif ($result eq 'unknown_cmd') {
 1961:                 # Target server has old code running on it.
 1962:                 my %temphash=($entry => $value);
 1963:                 if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {
 1964:                     delete $accesshash{$entry};
 1965:                 }
 1966:             }
 1967:         } else {
 1968:             my ($dom,$name) = ($entry=~m{___($match_domain)/($match_name)/(.*)___(\w+)$});
 1969:             my %temphash=($entry => $accesshash{$entry});
 1970:             if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {
 1971:                 delete $accesshash{$entry};
 1972:             }
 1973:         }
 1974:     }
 1975: #
 1976: # Roles
 1977: # Reverse lookup of user roles for course faculty/staff and co-authorship
 1978: #
 1979:     foreach my $entry (keys(%userrolehash)) {
 1980:         my ($role,$uname,$udom,$runame,$rudom,$rsec)=
 1981: 	    split(/\:/,$entry);
 1982:         if (&Apache::lonnet::put('nohist_userroles',
 1983:              { $role.':'.$uname.':'.$udom.':'.$rsec => $userrolehash{$entry} },
 1984:                 $rudom,$runame) eq 'ok') {
 1985: 	    delete $userrolehash{$entry};
 1986:         }
 1987:     }
 1988: #
 1989: # Reverse lookup of domain roles (dc, ad, li, sc, au)
 1990: #
 1991:     my %domrolebuffer = ();
 1992:     foreach my $entry (keys %domainrolehash) {
 1993:         my ($role,$uname,$udom,$runame,$rudom,$rsec)=split/:/,$entry;
 1994:         if ($domrolebuffer{$rudom}) {
 1995:             $domrolebuffer{$rudom}.='&'.&escape($entry).
 1996:                       '='.&escape($domainrolehash{$entry});
 1997:         } else {
 1998:             $domrolebuffer{$rudom}.=&escape($entry).
 1999:                       '='.&escape($domainrolehash{$entry});
 2000:         }
 2001:         delete $domainrolehash{$entry};
 2002:     }
 2003:     foreach my $dom (keys(%domrolebuffer)) {
 2004: 	my %servers = &get_servers($dom,'library');
 2005: 	foreach my $tryserver (keys(%servers)) {
 2006: 	    unless (&reply('domroleput:'.$dom.':'.
 2007: 			   $domrolebuffer{$dom},$tryserver) eq 'ok') {
 2008: 		&logthis('Put of domain roles failed for '.$dom.' and  '.$tryserver);
 2009: 	    }
 2010:         }
 2011:     }
 2012:     $dumpcount++;
 2013: }
 2014: 
 2015: sub courselog {
 2016:     my $what=shift;
 2017:     $what=time.':'.$what;
 2018:     unless ($env{'request.course.id'}) { return ''; }
 2019:     $coursedombuf{$env{'request.course.id'}}=
 2020:        $env{'course.'.$env{'request.course.id'}.'.domain'};
 2021:     $coursenumbuf{$env{'request.course.id'}}=
 2022:        $env{'course.'.$env{'request.course.id'}.'.num'};
 2023:     $coursehombuf{$env{'request.course.id'}}=
 2024:        $env{'course.'.$env{'request.course.id'}.'.home'};
 2025:     $coursedescrbuf{$env{'request.course.id'}}=
 2026:        $env{'course.'.$env{'request.course.id'}.'.description'};
 2027:     $courseinstcodebuf{$env{'request.course.id'}}=
 2028:        $env{'course.'.$env{'request.course.id'}.'.internal.coursecode'};
 2029:     $courseownerbuf{$env{'request.course.id'}}=
 2030:        $env{'course.'.$env{'request.course.id'}.'.internal.courseowner'};
 2031:     $coursetypebuf{$env{'request.course.id'}}=
 2032:        $env{'course.'.$env{'request.course.id'}.'.type'};
 2033:     if (defined $courselogs{$env{'request.course.id'}}) {
 2034: 	$courselogs{$env{'request.course.id'}}.='&'.$what;
 2035:     } else {
 2036: 	$courselogs{$env{'request.course.id'}}.=$what;
 2037:     }
 2038:     if (length($courselogs{$env{'request.course.id'}})>4048) {
 2039: 	&flushcourselogs();
 2040:     }
 2041: }
 2042: 
 2043: sub courseacclog {
 2044:     my $fnsymb=shift;
 2045:     unless ($env{'request.course.id'}) { return ''; }
 2046:     my $what=$fnsymb.':'.$env{'user.name'}.':'.$env{'user.domain'};
 2047:     if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|task|page)$/) {
 2048:         $what.=':POST';
 2049:         # FIXME: Probably ought to escape things....
 2050: 	foreach my $key (keys(%env)) {
 2051:             if ($key=~/^form\.(.*)/) {
 2052: 		$what.=':'.$1.'='.$env{$key};
 2053:             }
 2054:         }
 2055:     } elsif ($fnsymb =~ m:^/adm/searchcat:) {
 2056:         # FIXME: We should not be depending on a form parameter that someone
 2057:         # editing lonsearchcat.pm might change in the future.
 2058:         if ($env{'form.phase'} eq 'course_search') {
 2059:             $what.= ':POST';
 2060:             # FIXME: Probably ought to escape things....
 2061:             foreach my $element ('courseexp','crsfulltext','crsrelated',
 2062:                                  'crsdiscuss') {
 2063:                 $what.=':'.$element.'='.$env{'form.'.$element};
 2064:             }
 2065:         }
 2066:     }
 2067:     &courselog($what);
 2068: }
 2069: 
 2070: sub countacc {
 2071:     my $url=&declutter(shift);
 2072:     return if (! defined($url) || $url eq '');
 2073:     unless ($env{'request.course.id'}) { return ''; }
 2074:     $accesshash{$env{'request.course.id'}.'___'.$url.'___course'}=1;
 2075:     my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count';
 2076:     $accesshash{$key}++;
 2077: }
 2078: 
 2079: sub linklog {
 2080:     my ($from,$to)=@_;
 2081:     $from=&declutter($from);
 2082:     $to=&declutter($to);
 2083:     $accesshash{$from.'___'.$to.'___comefrom'}=1;
 2084:     $accesshash{$to.'___'.$from.'___goto'}=1;
 2085: }
 2086:   
 2087: sub userrolelog {
 2088:     my ($trole,$username,$domain,$area,$tstart,$tend)=@_;
 2089:     if (($trole=~/^ca/) || ($trole=~/^aa/) ||
 2090:         ($trole=~/^in/) || ($trole=~/^cc/) ||
 2091:         ($trole=~/^ep/) || ($trole=~/^cr/) ||
 2092:         ($trole=~/^ta/)) {
 2093:        my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
 2094:        $userrolehash
 2095:          {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
 2096:                     =$tend.':'.$tstart;
 2097:     }
 2098:     if (($trole=~/^dc/) || ($trole=~/^ad/) ||
 2099:         ($trole=~/^li/) || ($trole=~/^li/) ||
 2100:         ($trole=~/^au/) || ($trole=~/^dg/) ||
 2101:         ($trole=~/^sc/)) {
 2102:        my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
 2103:        $domainrolehash
 2104:          {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
 2105:                     = $tend.':'.$tstart;
 2106:     }
 2107: }
 2108: 
 2109: sub get_course_adv_roles {
 2110:     my $cid=shift;
 2111:     $cid=$env{'request.course.id'} unless (defined($cid));
 2112:     my %coursehash=&coursedescription($cid);
 2113:     my %nothide=();
 2114:     foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
 2115: 	$nothide{join(':',split(/[\@\:]/,$user))}=1;
 2116:     }
 2117:     my %returnhash=();
 2118:     my %dumphash=
 2119:             &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});
 2120:     my $now=time;
 2121:     foreach my $entry (keys %dumphash) {
 2122: 	my ($tend,$tstart)=split(/\:/,$dumphash{$entry});
 2123:         if (($tstart) && ($tstart<0)) { next; }
 2124:         if (($tend) && ($tend<$now)) { next; }
 2125:         if (($tstart) && ($now<$tstart)) { next; }
 2126:         my ($role,$username,$domain,$section)=split(/\:/,$entry);
 2127: 	if ($username eq '' || $domain eq '') { next; }
 2128: 	if ((&privileged($username,$domain)) && 
 2129: 	    (!$nothide{$username.':'.$domain})) { next; }
 2130: 	if ($role eq 'cr') { next; }
 2131:         my $key=&plaintext($role);
 2132:         if ($section) { $key.=' (Sec/Grp '.$section.')'; }
 2133:         if ($returnhash{$key}) {
 2134: 	    $returnhash{$key}.=','.$username.':'.$domain;
 2135:         } else {
 2136:             $returnhash{$key}=$username.':'.$domain;
 2137:         }
 2138:      }
 2139:     return %returnhash;
 2140: }
 2141: 
 2142: sub get_my_roles {
 2143:     my ($uname,$udom,$context,$types,$roles,$roledoms)=@_;
 2144:     unless (defined($uname)) { $uname=$env{'user.name'}; }
 2145:     unless (defined($udom)) { $udom=$env{'user.domain'}; }
 2146:     my %dumphash;
 2147:     if ($context eq 'userroles') { 
 2148:         %dumphash = &dump('roles',$udom,$uname);
 2149:     } else {
 2150:         %dumphash=
 2151:             &dump('nohist_userroles',$udom,$uname);
 2152:     }
 2153:     my %returnhash=();
 2154:     my $now=time;
 2155:     foreach my $entry (keys(%dumphash)) {
 2156:         my ($role,$tend,$tstart);
 2157:         if ($context eq 'userroles') {
 2158: 	    ($role,$tend,$tstart)=split(/_/,$dumphash{$entry});
 2159:         } else {
 2160:             ($tend,$tstart)=split(/\:/,$dumphash{$entry});
 2161:         }
 2162:         if (($tstart) && ($tstart<0)) { next; }
 2163:         my $status = 'active';
 2164:         if (($tend) && ($tend<$now)) {
 2165:             $status = 'previous';
 2166:         } 
 2167:         if (($tstart) && ($now<$tstart)) {
 2168:             $status = 'future';
 2169:         }
 2170:         if (ref($types) eq 'ARRAY') {
 2171:             if (!grep(/^\Q$status\E$/,@{$types})) {
 2172:                 next;
 2173:             } 
 2174:         } else {
 2175:             if ($status ne 'active') {
 2176:                 next;
 2177:             }
 2178:         }
 2179:         my ($rolecode,$username,$domain,$section,$area);
 2180:         if ($context eq 'userroles') {
 2181:             ($area,$rolecode) = split(/_/,$entry);
 2182:             (undef,$domain,$username,$section) = split(/\//,$area);
 2183:         } else {
 2184:             ($role,$username,$domain,$section) = split(/\:/,$entry);
 2185:         }
 2186:         if (ref($roledoms) eq 'ARRAY') {
 2187:             if (!grep(/^\Q$domain\E$/,@{$roledoms})) {
 2188:                 next;
 2189:             }
 2190:         }
 2191:         if (ref($roles) eq 'ARRAY') {
 2192:             if (!grep(/^\Q$role\E$/,@{$roles})) {
 2193:                 next;
 2194:             }
 2195:         }
 2196: 	$returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;
 2197:     }
 2198:     return %returnhash;
 2199: }
 2200: 
 2201: # ----------------------------------------------------- Frontpage Announcements
 2202: #
 2203: #
 2204: 
 2205: sub postannounce {
 2206:     my ($server,$text)=@_;
 2207:     unless (&allowed('psa',&host_domain($server))) { return 'refused'; }
 2208:     unless ($text=~/\w/) { $text=''; }
 2209:     return &reply('setannounce:'.&escape($text),$server);
 2210: }
 2211: 
 2212: sub getannounce {
 2213: 
 2214:     if (open(my $fh,$perlvar{'lonDocRoot'}.'/announcement.txt')) {
 2215: 	my $announcement='';
 2216: 	while (my $line = <$fh>) { $announcement .= $line; }
 2217: 	close($fh);
 2218: 	if ($announcement=~/\w/) { 
 2219: 	    return 
 2220:    '<table bgcolor="#FF5555" cellpadding="5" cellspacing="3">'.
 2221:    '<tr><td bgcolor="#FFFFFF"><tt>'.$announcement.'</tt></td></tr></table>'; 
 2222: 	} else {
 2223: 	    return '';
 2224: 	}
 2225:     } else {
 2226: 	return '';
 2227:     }
 2228: }
 2229: 
 2230: # ---------------------------------------------------------- Course ID routines
 2231: # Deal with domain's nohist_courseid.db files
 2232: #
 2233: 
 2234: sub courseidput {
 2235:     my ($domain,$what,$coursehome)=@_;
 2236:     return &reply('courseidput:'.$domain.':'.$what,$coursehome);
 2237: }
 2238: 
 2239: sub courseiddump {
 2240:     my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_;
 2241:     my %returnhash=();
 2242:     unless ($domfilter) { $domfilter=''; }
 2243:     my %libserv = &all_library();
 2244:     foreach my $tryserver (keys(%libserv)) {
 2245:         if ( (  $hostidflag == 1 
 2246: 	        && grep(/^\Q$tryserver\E$/,@{$hostidref}) ) 
 2247: 	     || (!defined($hostidflag)) ) {
 2248: 
 2249: 	    if ($domfilter eq ''
 2250: 		|| (&host_domain($tryserver) eq $domfilter)) {
 2251: 	        foreach my $line (
 2252:                  split(/\&/,&reply('courseiddump:'.&host_domain($tryserver).':'.
 2253: 			       $sincefilter.':'.&escape($descfilter).':'.
 2254:                                &escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter).':'.&escape($typefilter).':'.&escape($regexp_ok),
 2255:                                $tryserver))) {
 2256: 		    my ($key,$value)=split(/\=/,$line,2);
 2257:                     if (($key) && ($value)) {
 2258: 		        $returnhash{&unescape($key)}=$value;
 2259:                     }
 2260:                 }
 2261:             }
 2262:         }
 2263:     }
 2264:     return %returnhash;
 2265: }
 2266: 
 2267: # ---------------------------------------------------------- DC e-mail
 2268: 
 2269: sub dcmailput {
 2270:     my ($domain,$msgid,$message,$server)=@_;
 2271:     my $status = &Apache::lonnet::critical(
 2272:        'dcmailput:'.$domain.':'.&escape($msgid).'='.
 2273:        &escape($message),$server);
 2274:     return $status;
 2275: }
 2276: 
 2277: sub dcmaildump {
 2278:     my ($dom,$startdate,$enddate,$senders) = @_;
 2279:     my %returnhash=();
 2280: 
 2281:     if (defined(&domain($dom,'primary'))) {
 2282:         my $cmd='dcmaildump:'.$dom.':'.&escape($startdate).':'.
 2283:                                                          &escape($enddate).':';
 2284: 	my @esc_senders=map { &escape($_)} @$senders;
 2285: 	$cmd.=&escape(join('&',@esc_senders));
 2286: 	foreach my $line (split(/\&/,&reply($cmd,&domain($dom,'primary')))) {
 2287:             my ($key,$value) = split(/\=/,$line,2);
 2288:             if (($key) && ($value)) {
 2289:                 $returnhash{&unescape($key)} = &unescape($value);
 2290:             }
 2291:         }
 2292:     }
 2293:     return %returnhash;
 2294: }
 2295: # ---------------------------------------------------------- Domain roles
 2296: 
 2297: sub get_domain_roles {
 2298:     my ($dom,$roles,$startdate,$enddate)=@_;
 2299:     if (undef($startdate) || $startdate eq '') {
 2300:         $startdate = '.';
 2301:     }
 2302:     if (undef($enddate) || $enddate eq '') {
 2303:         $enddate = '.';
 2304:     }
 2305:     my $rolelist = join(':',@{$roles});
 2306:     my %personnel = ();
 2307: 
 2308:     my %servers = &get_servers($dom,'library');
 2309:     foreach my $tryserver (keys(%servers)) {
 2310: 	%{$personnel{$tryserver}}=();
 2311: 	foreach my $line (split(/\&/,&reply('domrolesdump:'.$dom.':'.
 2312: 					    &escape($startdate).':'.
 2313: 					    &escape($enddate).':'.
 2314: 					    &escape($rolelist), $tryserver))) {
 2315: 	    my ($key,$value) = split(/\=/,$line,2);
 2316: 	    if (($key) && ($value)) {
 2317: 		$personnel{$tryserver}{&unescape($key)} = &unescape($value);
 2318: 	    }
 2319: 	}
 2320:     }
 2321:     return %personnel;
 2322: }
 2323: 
 2324: # ----------------------------------------------------------- Check out an item
 2325: 
 2326: sub get_first_access {
 2327:     my ($type,$argsymb)=@_;
 2328:     my ($symb,$courseid,$udom,$uname)=&whichuser();
 2329:     if ($argsymb) { $symb=$argsymb; }
 2330:     my ($map,$id,$res)=&decode_symb($symb);
 2331:     if ($type eq 'map') {
 2332: 	$res=&symbread($map);
 2333:     } else {
 2334: 	$res=$symb;
 2335:     }
 2336:     my %times=&get('firstaccesstimes',["$courseid\0$res"],$udom,$uname);
 2337:     return $times{"$courseid\0$res"};
 2338: }
 2339: 
 2340: sub set_first_access {
 2341:     my ($type)=@_;
 2342:     my ($symb,$courseid,$udom,$uname)=&whichuser();
 2343:     my ($map,$id,$res)=&decode_symb($symb);
 2344:     if ($type eq 'map') {
 2345: 	$res=&symbread($map);
 2346:     } else {
 2347: 	$res=$symb;
 2348:     }
 2349:     my $firstaccess=&get_first_access($type,$symb);
 2350:     if (!$firstaccess) {
 2351: 	return &put('firstaccesstimes',{"$courseid\0$res"=>time},$udom,$uname);
 2352:     }
 2353:     return 'already_set';
 2354: }
 2355: 
 2356: sub checkout {
 2357:     my ($symb,$tuname,$tudom,$tcrsid)=@_;
 2358:     my $now=time;
 2359:     my $lonhost=$perlvar{'lonHostID'};
 2360:     my $infostr=&escape(
 2361:                  'CHECKOUTTOKEN&'.
 2362:                  $tuname.'&'.
 2363:                  $tudom.'&'.
 2364:                  $tcrsid.'&'.
 2365:                  $symb.'&'.
 2366: 		 $now.'&'.$ENV{'REMOTE_ADDR'});
 2367:     my $token=&reply('tmpput:'.$infostr,$lonhost);
 2368:     if ($token=~/^error\:/) { 
 2369:         &logthis("<font color=\"blue\">WARNING: ".
 2370:                 "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.
 2371:                  "</font>");
 2372:         return ''; 
 2373:     }
 2374: 
 2375:     $token=~s/^(\d+)\_.*\_(\d+)$/$1\*$2\*$lonhost/;
 2376:     $token=~tr/a-z/A-Z/;
 2377: 
 2378:     my %infohash=('resource.0.outtoken' => $token,
 2379:                   'resource.0.checkouttime' => $now,
 2380:                   'resource.0.outremote' => $ENV{'REMOTE_ADDR'});
 2381: 
 2382:     unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
 2383:        return '';
 2384:     } else {
 2385:         &logthis("<font color=\"blue\">WARNING: ".
 2386:                 "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.
 2387:                  "</font>");
 2388:     }    
 2389: 
 2390:     if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
 2391:                          &escape('Checkout '.$infostr.' - '.
 2392:                                                  $token)) ne 'ok') {
 2393: 	return '';
 2394:     } else {
 2395:         &logthis("<font color=\"blue\">WARNING: ".
 2396:                 "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.
 2397:                  "</font>");
 2398:     }
 2399:     return $token;
 2400: }
 2401: 
 2402: # ------------------------------------------------------------ Check in an item
 2403: 
 2404: sub checkin {
 2405:     my $token=shift;
 2406:     my $now=time;
 2407:     my ($ta,$tb,$lonhost)=split(/\*/,$token);
 2408:     $lonhost=~tr/A-Z/a-z/;
 2409:     my $dtoken=$ta.'_'.&hostname($lonhost).'_'.$tb;
 2410:     $dtoken=~s/\W/\_/g;
 2411:     my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
 2412:                  split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));
 2413: 
 2414:     unless (($tuname) && ($tudom)) {
 2415:         &logthis('Check in '.$token.' ('.$dtoken.') failed');
 2416:         return '';
 2417:     }
 2418:     
 2419:     unless (&allowed('mgr',$tcrsid)) {
 2420:         &logthis('Check in '.$token.' ('.$dtoken.') unauthorized: '.
 2421:                  $env{'user.name'}.' - '.$env{'user.domain'});
 2422:         return '';
 2423:     }
 2424: 
 2425:     my %infohash=('resource.0.intoken' => $token,
 2426:                   'resource.0.checkintime' => $now,
 2427:                   'resource.0.inremote' => $ENV{'REMOTE_ADDR'});
 2428: 
 2429:     unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
 2430:        return '';
 2431:     }    
 2432: 
 2433:     if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
 2434:                          &escape('Checkin - '.$token)) ne 'ok') {
 2435: 	return '';
 2436:     }
 2437: 
 2438:     return ($symb,$tuname,$tudom,$tcrsid);    
 2439: }
 2440: 
 2441: # --------------------------------------------- Set Expire Date for Spreadsheet
 2442: 
 2443: sub expirespread {
 2444:     my ($uname,$udom,$stype,$usymb)=@_;
 2445:     my $cid=$env{'request.course.id'}; 
 2446:     if ($cid) {
 2447:        my $now=time;
 2448:        my $key=$uname.':'.$udom.':'.$stype.':'.$usymb;
 2449:        return &reply('put:'.$env{'course.'.$cid.'.domain'}.':'.
 2450:                             $env{'course.'.$cid.'.num'}.
 2451: 	        	    ':nohist_expirationdates:'.
 2452:                             &escape($key).'='.$now,
 2453:                             $env{'course.'.$cid.'.home'})
 2454:     }
 2455:     return 'ok';
 2456: }
 2457: 
 2458: # ----------------------------------------------------- Devalidate Spreadsheets
 2459: 
 2460: sub devalidate {
 2461:     my ($symb,$uname,$udom)=@_;
 2462:     my $cid=$env{'request.course.id'}; 
 2463:     if ($cid) {
 2464:         # delete the stored spreadsheets for
 2465:         # - the student level sheet of this user in course's homespace
 2466:         # - the assessment level sheet for this resource 
 2467:         #   for this user in user's homespace
 2468: 	# - current conditional state info
 2469: 	my $key=$uname.':'.$udom.':';
 2470:         my $status=
 2471: 	    &del('nohist_calculatedsheets',
 2472: 		 [$key.'studentcalc:'],
 2473: 		 $env{'course.'.$cid.'.domain'},
 2474: 		 $env{'course.'.$cid.'.num'})
 2475: 		.' '.
 2476: 	    &del('nohist_calculatedsheets_'.$cid,
 2477: 		 [$key.'assesscalc:'.$symb],$udom,$uname);
 2478:         unless ($status eq 'ok ok') {
 2479:            &logthis('Could not devalidate spreadsheet '.
 2480:                     $uname.' at '.$udom.' for '.
 2481: 		    $symb.': '.$status);
 2482:         }
 2483: 	&delenv('user.state.'.$cid);
 2484:     }
 2485: }
 2486: 
 2487: sub get_scalar {
 2488:     my ($string,$end) = @_;
 2489:     my $value;
 2490:     if ($$string =~ s/^([^&]*?)($end)/$2/) {
 2491: 	$value = $1;
 2492:     } elsif ($$string =~ s/^([^&]*?)&//) {
 2493: 	$value = $1;
 2494:     }
 2495:     return &unescape($value);
 2496: }
 2497: 
 2498: sub array2str {
 2499:   my (@array) = @_;
 2500:   my $result=&arrayref2str(\@array);
 2501:   $result=~s/^__ARRAY_REF__//;
 2502:   $result=~s/__END_ARRAY_REF__$//;
 2503:   return $result;
 2504: }
 2505: 
 2506: sub arrayref2str {
 2507:   my ($arrayref) = @_;
 2508:   my $result='__ARRAY_REF__';
 2509:   foreach my $elem (@$arrayref) {
 2510:     if(ref($elem) eq 'ARRAY') {
 2511:       $result.=&arrayref2str($elem).'&';
 2512:     } elsif(ref($elem) eq 'HASH') {
 2513:       $result.=&hashref2str($elem).'&';
 2514:     } elsif(ref($elem)) {
 2515:       #print("Got a ref of ".(ref($elem))." skipping.");
 2516:     } else {
 2517:       $result.=&escape($elem).'&';
 2518:     }
 2519:   }
 2520:   $result=~s/\&$//;
 2521:   $result .= '__END_ARRAY_REF__';
 2522:   return $result;
 2523: }
 2524: 
 2525: sub hash2str {
 2526:   my (%hash) = @_;
 2527:   my $result=&hashref2str(\%hash);
 2528:   $result=~s/^__HASH_REF__//;
 2529:   $result=~s/__END_HASH_REF__$//;
 2530:   return $result;
 2531: }
 2532: 
 2533: sub hashref2str {
 2534:   my ($hashref)=@_;
 2535:   my $result='__HASH_REF__';
 2536:   foreach my $key (sort(keys(%$hashref))) {
 2537:     if (ref($key) eq 'ARRAY') {
 2538:       $result.=&arrayref2str($key).'=';
 2539:     } elsif (ref($key) eq 'HASH') {
 2540:       $result.=&hashref2str($key).'=';
 2541:     } elsif (ref($key)) {
 2542:       $result.='=';
 2543:       #print("Got a ref of ".(ref($key))." skipping.");
 2544:     } else {
 2545: 	if ($key) {$result.=&escape($key).'=';} else { last; }
 2546:     }
 2547: 
 2548:     if(ref($hashref->{$key}) eq 'ARRAY') {
 2549:       $result.=&arrayref2str($hashref->{$key}).'&';
 2550:     } elsif(ref($hashref->{$key}) eq 'HASH') {
 2551:       $result.=&hashref2str($hashref->{$key}).'&';
 2552:     } elsif(ref($hashref->{$key})) {
 2553:        $result.='&';
 2554:       #print("Got a ref of ".(ref($hashref->{$key}))." skipping.");
 2555:     } else {
 2556:       $result.=&escape($hashref->{$key}).'&';
 2557:     }
 2558:   }
 2559:   $result=~s/\&$//;
 2560:   $result .= '__END_HASH_REF__';
 2561:   return $result;
 2562: }
 2563: 
 2564: sub str2hash {
 2565:     my ($string)=@_;
 2566:     my ($hash)=&str2hashref('__HASH_REF__'.$string.'__END_HASH_REF__');
 2567:     return %$hash;
 2568: }
 2569: 
 2570: sub str2hashref {
 2571:   my ($string) = @_;
 2572: 
 2573:   my %hash;
 2574: 
 2575:   if($string !~ /^__HASH_REF__/) {
 2576:       if (! ($string eq '' || !defined($string))) {
 2577: 	  $hash{'error'}='Not hash reference';
 2578:       }
 2579:       return (\%hash, $string);
 2580:   }
 2581: 
 2582:   $string =~ s/^__HASH_REF__//;
 2583: 
 2584:   while($string !~ /^__END_HASH_REF__/) {
 2585:       #key
 2586:       my $key='';
 2587:       if($string =~ /^__HASH_REF__/) {
 2588:           ($key, $string)=&str2hashref($string);
 2589:           if(defined($key->{'error'})) {
 2590:               $hash{'error'}='Bad data';
 2591:               return (\%hash, $string);
 2592:           }
 2593:       } elsif($string =~ /^__ARRAY_REF__/) {
 2594:           ($key, $string)=&str2arrayref($string);
 2595:           if($key->[0] eq 'Array reference error') {
 2596:               $hash{'error'}='Bad data';
 2597:               return (\%hash, $string);
 2598:           }
 2599:       } else {
 2600:           $string =~ s/^(.*?)=//;
 2601: 	  $key=&unescape($1);
 2602:       }
 2603:       $string =~ s/^=//;
 2604: 
 2605:       #value
 2606:       my $value='';
 2607:       if($string =~ /^__HASH_REF__/) {
 2608:           ($value, $string)=&str2hashref($string);
 2609:           if(defined($value->{'error'})) {
 2610:               $hash{'error'}='Bad data';
 2611:               return (\%hash, $string);
 2612:           }
 2613:       } elsif($string =~ /^__ARRAY_REF__/) {
 2614:           ($value, $string)=&str2arrayref($string);
 2615:           if($value->[0] eq 'Array reference error') {
 2616:               $hash{'error'}='Bad data';
 2617:               return (\%hash, $string);
 2618:           }
 2619:       } else {
 2620: 	  $value=&get_scalar(\$string,'__END_HASH_REF__');
 2621:       }
 2622:       $string =~ s/^&//;
 2623: 
 2624:       $hash{$key}=$value;
 2625:   }
 2626: 
 2627:   $string =~ s/^__END_HASH_REF__//;
 2628: 
 2629:   return (\%hash, $string);
 2630: }
 2631: 
 2632: sub str2array {
 2633:     my ($string)=@_;
 2634:     my ($array)=&str2arrayref('__ARRAY_REF__'.$string.'__END_ARRAY_REF__');
 2635:     return @$array;
 2636: }
 2637: 
 2638: sub str2arrayref {
 2639:   my ($string) = @_;
 2640:   my @array;
 2641: 
 2642:   if($string !~ /^__ARRAY_REF__/) {
 2643:       if (! ($string eq '' || !defined($string))) {
 2644: 	  $array[0]='Array reference error';
 2645:       }
 2646:       return (\@array, $string);
 2647:   }
 2648: 
 2649:   $string =~ s/^__ARRAY_REF__//;
 2650: 
 2651:   while($string !~ /^__END_ARRAY_REF__/) {
 2652:       my $value='';
 2653:       if($string =~ /^__HASH_REF__/) {
 2654:           ($value, $string)=&str2hashref($string);
 2655:           if(defined($value->{'error'})) {
 2656:               $array[0] ='Array reference error';
 2657:               return (\@array, $string);
 2658:           }
 2659:       } elsif($string =~ /^__ARRAY_REF__/) {
 2660:           ($value, $string)=&str2arrayref($string);
 2661:           if($value->[0] eq 'Array reference error') {
 2662:               $array[0] ='Array reference error';
 2663:               return (\@array, $string);
 2664:           }
 2665:       } else {
 2666: 	  $value=&get_scalar(\$string,'__END_ARRAY_REF__');
 2667:       }
 2668:       $string =~ s/^&//;
 2669: 
 2670:       push(@array, $value);
 2671:   }
 2672: 
 2673:   $string =~ s/^__END_ARRAY_REF__//;
 2674: 
 2675:   return (\@array, $string);
 2676: }
 2677: 
 2678: # -------------------------------------------------------------------Temp Store
 2679: 
 2680: sub tmpreset {
 2681:   my ($symb,$namespace,$domain,$stuname) = @_;
 2682:   if (!$symb) {
 2683:     $symb=&symbread();
 2684:     if (!$symb) { $symb= $env{'request.url'}; }
 2685:   }
 2686:   $symb=escape($symb);
 2687: 
 2688:   if (!$namespace) { $namespace=$env{'request.state'}; }
 2689:   $namespace=~s/\//\_/g;
 2690:   $namespace=~s/\W//g;
 2691: 
 2692:   if (!$domain) { $domain=$env{'user.domain'}; }
 2693:   if (!$stuname) { $stuname=$env{'user.name'}; }
 2694:   if ($domain eq 'public' && $stuname eq 'public') {
 2695:       $stuname=$ENV{'REMOTE_ADDR'};
 2696:   }
 2697:   my $path=$perlvar{'lonDaemons'}.'/tmp';
 2698:   my %hash;
 2699:   if (tie(%hash,'GDBM_File',
 2700: 	  $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
 2701: 	  &GDBM_WRCREAT(),0640)) {
 2702:     foreach my $key (keys %hash) {
 2703:       if ($key=~ /:$symb/) {
 2704: 	delete($hash{$key});
 2705:       }
 2706:     }
 2707:   }
 2708: }
 2709: 
 2710: sub tmpstore {
 2711:   my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
 2712: 
 2713:   if (!$symb) {
 2714:     $symb=&symbread();
 2715:     if (!$symb) { $symb= $env{'request.url'}; }
 2716:   }
 2717:   $symb=escape($symb);
 2718: 
 2719:   if (!$namespace) {
 2720:     # I don't think we would ever want to store this for a course.
 2721:     # it seems this will only be used if we don't have a course.
 2722:     #$namespace=$env{'request.course.id'};
 2723:     #if (!$namespace) {
 2724:       $namespace=$env{'request.state'};
 2725:     #}
 2726:   }
 2727:   $namespace=~s/\//\_/g;
 2728:   $namespace=~s/\W//g;
 2729:   if (!$domain) { $domain=$env{'user.domain'}; }
 2730:   if (!$stuname) { $stuname=$env{'user.name'}; }
 2731:   if ($domain eq 'public' && $stuname eq 'public') {
 2732:       $stuname=$ENV{'REMOTE_ADDR'};
 2733:   }
 2734:   my $now=time;
 2735:   my %hash;
 2736:   my $path=$perlvar{'lonDaemons'}.'/tmp';
 2737:   if (tie(%hash,'GDBM_File',
 2738: 	  $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
 2739: 	  &GDBM_WRCREAT(),0640)) {
 2740:     $hash{"version:$symb"}++;
 2741:     my $version=$hash{"version:$symb"};
 2742:     my $allkeys=''; 
 2743:     foreach my $key (keys(%$storehash)) {
 2744:       $allkeys.=$key.':';
 2745:       $hash{"$version:$symb:$key"}=&freeze_escape($$storehash{$key});
 2746:     }
 2747:     $hash{"$version:$symb:timestamp"}=$now;
 2748:     $allkeys.='timestamp';
 2749:     $hash{"$version:keys:$symb"}=$allkeys;
 2750:     if (untie(%hash)) {
 2751:       return 'ok';
 2752:     } else {
 2753:       return "error:$!";
 2754:     }
 2755:   } else {
 2756:     return "error:$!";
 2757:   }
 2758: }
 2759: 
 2760: # -----------------------------------------------------------------Temp Restore
 2761: 
 2762: sub tmprestore {
 2763:   my ($symb,$namespace,$domain,$stuname) = @_;
 2764: 
 2765:   if (!$symb) {
 2766:     $symb=&symbread();
 2767:     if (!$symb) { $symb= $env{'request.url'}; }
 2768:   }
 2769:   $symb=escape($symb);
 2770: 
 2771:   if (!$namespace) { $namespace=$env{'request.state'}; }
 2772: 
 2773:   if (!$domain) { $domain=$env{'user.domain'}; }
 2774:   if (!$stuname) { $stuname=$env{'user.name'}; }
 2775:   if ($domain eq 'public' && $stuname eq 'public') {
 2776:       $stuname=$ENV{'REMOTE_ADDR'};
 2777:   }
 2778:   my %returnhash;
 2779:   $namespace=~s/\//\_/g;
 2780:   $namespace=~s/\W//g;
 2781:   my %hash;
 2782:   my $path=$perlvar{'lonDaemons'}.'/tmp';
 2783:   if (tie(%hash,'GDBM_File',
 2784: 	  $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
 2785: 	  &GDBM_READER(),0640)) {
 2786:     my $version=$hash{"version:$symb"};
 2787:     $returnhash{'version'}=$version;
 2788:     my $scope;
 2789:     for ($scope=1;$scope<=$version;$scope++) {
 2790:       my $vkeys=$hash{"$scope:keys:$symb"};
 2791:       my @keys=split(/:/,$vkeys);
 2792:       my $key;
 2793:       $returnhash{"$scope:keys"}=$vkeys;
 2794:       foreach $key (@keys) {
 2795: 	$returnhash{"$scope:$key"}=&thaw_unescape($hash{"$scope:$symb:$key"});
 2796: 	$returnhash{"$key"}=&thaw_unescape($hash{"$scope:$symb:$key"});
 2797:       }
 2798:     }
 2799:     if (!(untie(%hash))) {
 2800:       return "error:$!";
 2801:     }
 2802:   } else {
 2803:     return "error:$!";
 2804:   }
 2805:   return %returnhash;
 2806: }
 2807: 
 2808: # ----------------------------------------------------------------------- Store
 2809: 
 2810: sub store {
 2811:     my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
 2812:     my $home='';
 2813: 
 2814:     if ($stuname) { $home=&homeserver($stuname,$domain); }
 2815: 
 2816:     $symb=&symbclean($symb);
 2817:     if (!$symb) { unless ($symb=&symbread()) { return ''; } }
 2818: 
 2819:     if (!$domain) { $domain=$env{'user.domain'}; }
 2820:     if (!$stuname) { $stuname=$env{'user.name'}; }
 2821: 
 2822:     &devalidate($symb,$stuname,$domain);
 2823: 
 2824:     $symb=escape($symb);
 2825:     if (!$namespace) { 
 2826:        unless ($namespace=$env{'request.course.id'}) { 
 2827:           return ''; 
 2828:        } 
 2829:     }
 2830:     if (!$home) { $home=$env{'user.home'}; }
 2831: 
 2832:     $$storehash{'ip'}=$ENV{'REMOTE_ADDR'};
 2833:     $$storehash{'host'}=$perlvar{'lonHostID'};
 2834: 
 2835:     my $namevalue='';
 2836:     foreach my $key (keys(%$storehash)) {
 2837:         $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
 2838:     }
 2839:     $namevalue=~s/\&$//;
 2840:     &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue);
 2841:     return reply("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");
 2842: }
 2843: 
 2844: # -------------------------------------------------------------- Critical Store
 2845: 
 2846: sub cstore {
 2847:     my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
 2848:     my $home='';
 2849: 
 2850:     if ($stuname) { $home=&homeserver($stuname,$domain); }
 2851: 
 2852:     $symb=&symbclean($symb);
 2853:     if (!$symb) { unless ($symb=&symbread()) { return ''; } }
 2854: 
 2855:     if (!$domain) { $domain=$env{'user.domain'}; }
 2856:     if (!$stuname) { $stuname=$env{'user.name'}; }
 2857: 
 2858:     &devalidate($symb,$stuname,$domain);
 2859: 
 2860:     $symb=escape($symb);
 2861:     if (!$namespace) { 
 2862:        unless ($namespace=$env{'request.course.id'}) { 
 2863:           return ''; 
 2864:        } 
 2865:     }
 2866:     if (!$home) { $home=$env{'user.home'}; }
 2867: 
 2868:     $$storehash{'ip'}=$ENV{'REMOTE_ADDR'};
 2869:     $$storehash{'host'}=$perlvar{'lonHostID'};
 2870: 
 2871:     my $namevalue='';
 2872:     foreach my $key (keys(%$storehash)) {
 2873:         $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
 2874:     }
 2875:     $namevalue=~s/\&$//;
 2876:     &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue);
 2877:     return critical
 2878:                 ("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");
 2879: }
 2880: 
 2881: # --------------------------------------------------------------------- Restore
 2882: 
 2883: sub restore {
 2884:     my ($symb,$namespace,$domain,$stuname) = @_;
 2885:     my $home='';
 2886: 
 2887:     if ($stuname) { $home=&homeserver($stuname,$domain); }
 2888: 
 2889:     if (!$symb) {
 2890:       unless ($symb=escape(&symbread())) { return ''; }
 2891:     } else {
 2892:       $symb=&escape(&symbclean($symb));
 2893:     }
 2894:     if (!$namespace) { 
 2895:        unless ($namespace=$env{'request.course.id'}) { 
 2896:           return ''; 
 2897:        } 
 2898:     }
 2899:     if (!$domain) { $domain=$env{'user.domain'}; }
 2900:     if (!$stuname) { $stuname=$env{'user.name'}; }
 2901:     if (!$home) { $home=$env{'user.home'}; }
 2902:     my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home");
 2903: 
 2904:     my %returnhash=();
 2905:     foreach my $line (split(/\&/,$answer)) {
 2906: 	my ($name,$value)=split(/\=/,$line);
 2907:         $returnhash{&unescape($name)}=&thaw_unescape($value);
 2908:     }
 2909:     my $version;
 2910:     for ($version=1;$version<=$returnhash{'version'};$version++) {
 2911:        foreach my $item (split(/\:/,$returnhash{$version.':keys'})) {
 2912:           $returnhash{$item}=$returnhash{$version.':'.$item};
 2913:        }
 2914:     }
 2915:     return %returnhash;
 2916: }
 2917: 
 2918: # ---------------------------------------------------------- Course Description
 2919: 
 2920: sub coursedescription {
 2921:     my ($courseid,$args)=@_;
 2922:     $courseid=~s/^\///;
 2923:     $courseid=~s/\_/\//g;
 2924:     my ($cdomain,$cnum)=split(/\//,$courseid);
 2925:     my $chome=&homeserver($cnum,$cdomain);
 2926:     my $normalid=$cdomain.'_'.$cnum;
 2927:     # need to always cache even if we get errors otherwise we keep 
 2928:     # trying and trying and trying to get the course description.
 2929:     my %envhash=();
 2930:     my %returnhash=();
 2931:     
 2932:     my $expiretime=600;
 2933:     if ($env{'request.course.id'} eq $normalid) {
 2934: 	$expiretime=120;
 2935:     }
 2936: 
 2937:     my $prefix='course.'.$cdomain.'_'.$cnum.'.';
 2938:     if (!$args->{'freshen_cache'}
 2939: 	&& ((time-$env{$prefix.'last_cache'}) < $expiretime) ) {
 2940: 	foreach my $key (keys(%env)) {
 2941: 	    next if ($key !~ /^\Q$prefix\E(.*)/);
 2942: 	    my ($setting) = $1;
 2943: 	    $returnhash{$setting} = $env{$key};
 2944: 	}
 2945: 	return %returnhash;
 2946:     }
 2947: 
 2948:     # get the data agin
 2949:     if (!$args->{'one_time'}) {
 2950: 	$envhash{'course.'.$normalid.'.last_cache'}=time;
 2951:     }
 2952: 
 2953:     if ($chome ne 'no_host') {
 2954:        %returnhash=&dump('environment',$cdomain,$cnum);
 2955:        if (!exists($returnhash{'con_lost'})) {
 2956:            $returnhash{'home'}= $chome;
 2957: 	   $returnhash{'domain'} = $cdomain;
 2958: 	   $returnhash{'num'} = $cnum;
 2959:            if (!defined($returnhash{'type'})) {
 2960:                $returnhash{'type'} = 'Course';
 2961:            }
 2962:            while (my ($name,$value) = each %returnhash) {
 2963:                $envhash{'course.'.$normalid.'.'.$name}=$value;
 2964:            }
 2965:            $returnhash{'url'}=&clutter($returnhash{'url'});
 2966:            $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'.
 2967: 	       $env{'user.name'}.'_'.$cdomain.'_'.$cnum;
 2968:            $envhash{'course.'.$normalid.'.home'}=$chome;
 2969:            $envhash{'course.'.$normalid.'.domain'}=$cdomain;
 2970:            $envhash{'course.'.$normalid.'.num'}=$cnum;
 2971:        }
 2972:     }
 2973:     if (!$args->{'one_time'}) {
 2974: 	&appenv(%envhash);
 2975:     }
 2976:     return %returnhash;
 2977: }
 2978: 
 2979: # -------------------------------------------------See if a user is privileged
 2980: 
 2981: sub privileged {
 2982:     my ($username,$domain)=@_;
 2983:     my $rolesdump=&reply("dump:$domain:$username:roles",
 2984: 			&homeserver($username,$domain));
 2985:     if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return 0; }
 2986:     my $now=time;
 2987:     if ($rolesdump ne '') {
 2988:         foreach my $entry (split(/&/,$rolesdump)) {
 2989: 	    if ($entry!~/^rolesdef_/) {
 2990: 		my ($area,$role)=split(/=/,$entry);
 2991: 		$area=~s/\_\w\w$//;
 2992: 		my ($trole,$tend,$tstart)=split(/_/,$role);
 2993: 		if (($trole eq 'dc') || ($trole eq 'su')) {
 2994: 		    my $active=1;
 2995: 		    if ($tend) {
 2996: 			if ($tend<$now) { $active=0; }
 2997: 		    }
 2998: 		    if ($tstart) {
 2999: 			if ($tstart>$now) { $active=0; }
 3000: 		    }
 3001: 		    if ($active) { return 1; }
 3002: 		}
 3003: 	    }
 3004: 	}
 3005:     }
 3006:     return 0;
 3007: }
 3008: 
 3009: # -------------------------------------------------------- Get user privileges
 3010: 
 3011: sub rolesinit {
 3012:     my ($domain,$username,$authhost)=@_;
 3013:     my $rolesdump=reply("dump:$domain:$username:roles",$authhost);
 3014:     if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; }
 3015:     my %allroles=();
 3016:     my %allgroups=();   
 3017:     my $now=time;
 3018:     my %userroles = ('user.login.time' => $now);
 3019:     my $group_privs;
 3020: 
 3021:     if ($rolesdump ne '') {
 3022:         foreach my $entry (split(/&/,$rolesdump)) {
 3023: 	  if ($entry!~/^rolesdef_/) {
 3024:             my ($area,$role)=split(/=/,$entry);
 3025: 	    $area=~s/\_\w\w$//;
 3026:             my ($trole,$tend,$tstart,$group_privs);
 3027: 	    if ($role=~/^cr/) { 
 3028: 		if ($role=~m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|) {
 3029: 		    ($trole,my $trest)=($role=~m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|);
 3030: 		    ($tend,$tstart)=split('_',$trest);
 3031: 		} else {
 3032: 		    $trole=$role;
 3033: 		}
 3034:             } elsif ($role =~ m|^gr/|) {
 3035:                 ($trole,$tend,$tstart) = split(/_/,$role);
 3036:                 ($trole,$group_privs) = split(/\//,$trole);
 3037:                 $group_privs = &unescape($group_privs);
 3038: 	    } else {
 3039: 		($trole,$tend,$tstart)=split(/_/,$role);
 3040: 	    }
 3041: 	    my %new_role = &set_arearole($trole,$area,$tstart,$tend,$domain,
 3042: 					 $username);
 3043: 	    @userroles{keys(%new_role)} = @new_role{keys(%new_role)};
 3044:             if (($tend!=0) && ($tend<$now)) { $trole=''; }
 3045:             if (($tstart!=0) && ($tstart>$now)) { $trole=''; }
 3046:             if (($area ne '') && ($trole ne '')) {
 3047: 		my $spec=$trole.'.'.$area;
 3048: 		my ($tdummy,$tdomain,$trest)=split(/\//,$area);
 3049: 		if ($trole =~ /^cr\//) {
 3050:                     &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);
 3051:                 } elsif ($trole eq 'gr') {
 3052:                     &group_roleprivs(\%allgroups,$area,$group_privs,$tend,$tstart);
 3053: 		} else {
 3054:                     &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
 3055: 		}
 3056:             }
 3057:           }
 3058:         }
 3059:         my ($author,$adv) = &set_userprivs(\%userroles,\%allroles,\%allgroups);
 3060:         $userroles{'user.adv'}    = $adv;
 3061: 	$userroles{'user.author'} = $author;
 3062:         $env{'user.adv'}=$adv;
 3063:     }
 3064:     return \%userroles;  
 3065: }
 3066: 
 3067: sub set_arearole {
 3068:     my ($trole,$area,$tstart,$tend,$domain,$username) = @_;
 3069: # log the associated role with the area
 3070:     &userrolelog($trole,$username,$domain,$area,$tstart,$tend);
 3071:     return ('user.role.'.$trole.'.'.$area => $tstart.'.'.$tend);
 3072: }
 3073: 
 3074: sub custom_roleprivs {
 3075:     my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_;
 3076:     my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
 3077:     my $homsvr=homeserver($rauthor,$rdomain);
 3078:     if (&hostname($homsvr) ne '') {
 3079:         my ($rdummy,$roledef)=
 3080:             &get('roles',["rolesdef_$rrole"],$rdomain,$rauthor);
 3081:         if (($rdummy ne 'con_lost') && ($roledef ne '')) {
 3082:             my ($syspriv,$dompriv,$coursepriv)=split(/\_/,$roledef);
 3083:             if (defined($syspriv)) {
 3084:                 $$allroles{'cm./'}.=':'.$syspriv;
 3085:                 $$allroles{$spec.'./'}.=':'.$syspriv;
 3086:             }
 3087:             if ($tdomain ne '') {
 3088:                 if (defined($dompriv)) {
 3089:                     $$allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv;
 3090:                     $$allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv;
 3091:                 }
 3092:                 if (($trest ne '') && (defined($coursepriv))) {
 3093:                     $$allroles{'cm.'.$area}.=':'.$coursepriv;
 3094:                     $$allroles{$spec.'.'.$area}.=':'.$coursepriv;
 3095:                 }
 3096:             }
 3097:         }
 3098:     }
 3099: }
 3100: 
 3101: sub group_roleprivs {
 3102:     my ($allgroups,$area,$group_privs,$tend,$tstart) = @_;
 3103:     my $access = 1;
 3104:     my $now = time;
 3105:     if (($tend!=0) && ($tend<$now)) { $access = 0; }
 3106:     if (($tstart!=0) && ($tstart>$now)) { $access=0; }
 3107:     if ($access) {
 3108:         my ($course,$group) = ($area =~ m|(/$match_domain/$match_courseid)/([^/]+)$|);
 3109:         $$allgroups{$course}{$group} .=':'.$group_privs;
 3110:     }
 3111: }
 3112: 
 3113: sub standard_roleprivs {
 3114:     my ($allroles,$trole,$tdomain,$spec,$trest,$area) = @_;
 3115:     if (defined($pr{$trole.':s'})) {
 3116:         $$allroles{'cm./'}.=':'.$pr{$trole.':s'};
 3117:         $$allroles{$spec.'./'}.=':'.$pr{$trole.':s'};
 3118:     }
 3119:     if ($tdomain ne '') {
 3120:         if (defined($pr{$trole.':d'})) {
 3121:             $$allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
 3122:             $$allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
 3123:         }
 3124:         if (($trest ne '') && (defined($pr{$trole.':c'}))) {
 3125:             $$allroles{'cm.'.$area}.=':'.$pr{$trole.':c'};
 3126:             $$allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'};
 3127:         }
 3128:     }
 3129: }
 3130: 
 3131: sub set_userprivs {
 3132:     my ($userroles,$allroles,$allgroups) = @_; 
 3133:     my $author=0;
 3134:     my $adv=0;
 3135:     my %grouproles = ();
 3136:     if (keys(%{$allgroups}) > 0) {
 3137:         foreach my $role (keys %{$allroles}) {
 3138:             my ($trole,$area,$sec,$extendedarea);
 3139:             if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)\.-) {
 3140:                 $trole = $1;
 3141:                 $area = $2;
 3142:                 $sec = $3;
 3143:                 $extendedarea = $area.$sec;
 3144:                 if (exists($$allgroups{$area})) {
 3145:                     foreach my $group (keys(%{$$allgroups{$area}})) {
 3146:                         my $spec = $trole.'.'.$extendedarea;
 3147:                         $grouproles{$spec.'.'.$area.'/'.$group} = 
 3148:                                                 $$allgroups{$area}{$group};
 3149:                     }
 3150:                 }
 3151:             }
 3152:         }
 3153:     }
 3154:     foreach my $group (keys(%grouproles)) {
 3155:         $$allroles{$group} = $grouproles{$group};
 3156:     }
 3157:     foreach my $role (keys(%{$allroles})) {
 3158:         my %thesepriv;
 3159:         if (($role=~/^au/) || ($role=~/^ca/)) { $author=1; }
 3160:         foreach my $item (split(/:/,$$allroles{$role})) {
 3161:             if ($item ne '') {
 3162:                 my ($privilege,$restrictions)=split(/&/,$item);
 3163:                 if ($restrictions eq '') {
 3164:                     $thesepriv{$privilege}='F';
 3165:                 } elsif ($thesepriv{$privilege} ne 'F') {
 3166:                     $thesepriv{$privilege}.=$restrictions;
 3167:                 }
 3168:                 if ($thesepriv{'adv'} eq 'F') { $adv=1; }
 3169:             }
 3170:         }
 3171:         my $thesestr='';
 3172:         foreach my $priv (keys(%thesepriv)) {
 3173: 	    $thesestr.=':'.$priv.'&'.$thesepriv{$priv};
 3174: 	}
 3175:         $userroles->{'user.priv.'.$role} = $thesestr;
 3176:     }
 3177:     return ($author,$adv);
 3178: }
 3179: 
 3180: # --------------------------------------------------------------- get interface
 3181: 
 3182: sub get {
 3183:    my ($namespace,$storearr,$udomain,$uname)=@_;
 3184:    my $items='';
 3185:    foreach my $item (@$storearr) {
 3186:        $items.=&escape($item).'&';
 3187:    }
 3188:    $items=~s/\&$//;
 3189:    if (!$udomain) { $udomain=$env{'user.domain'}; }
 3190:    if (!$uname) { $uname=$env{'user.name'}; }
 3191:    my $uhome=&homeserver($uname,$udomain);
 3192: 
 3193:    my $rep=&reply("get:$udomain:$uname:$namespace:$items",$uhome);
 3194:    my @pairs=split(/\&/,$rep);
 3195:    if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) {
 3196:      return @pairs;
 3197:    }
 3198:    my %returnhash=();
 3199:    my $i=0;
 3200:    foreach my $item (@$storearr) {
 3201:       $returnhash{$item}=&thaw_unescape($pairs[$i]);
 3202:       $i++;
 3203:    }
 3204:    return %returnhash;
 3205: }
 3206: 
 3207: # --------------------------------------------------------------- del interface
 3208: 
 3209: sub del {
 3210:    my ($namespace,$storearr,$udomain,$uname)=@_;
 3211:    my $items='';
 3212:    foreach my $item (@$storearr) {
 3213:        $items.=&escape($item).'&';
 3214:    }
 3215:    $items=~s/\&$//;
 3216:    if (!$udomain) { $udomain=$env{'user.domain'}; }
 3217:    if (!$uname) { $uname=$env{'user.name'}; }
 3218:    my $uhome=&homeserver($uname,$udomain);
 3219: 
 3220:    return &reply("del:$udomain:$uname:$namespace:$items",$uhome);
 3221: }
 3222: 
 3223: # -------------------------------------------------------------- dump interface
 3224: 
 3225: sub dump {
 3226:     my ($namespace,$udomain,$uname,$regexp,$range)=@_;
 3227:     if (!$udomain) { $udomain=$env{'user.domain'}; }
 3228:     if (!$uname) { $uname=$env{'user.name'}; }
 3229:     my $uhome=&homeserver($uname,$udomain);
 3230:     if ($regexp) {
 3231: 	$regexp=&escape($regexp);
 3232:     } else {
 3233: 	$regexp='.';
 3234:     }
 3235:     my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
 3236:     my @pairs=split(/\&/,$rep);
 3237:     my %returnhash=();
 3238:     foreach my $item (@pairs) {
 3239: 	my ($key,$value)=split(/=/,$item,2);
 3240: 	$key = &unescape($key);
 3241: 	next if ($key =~ /^error: 2 /);
 3242: 	$returnhash{$key}=&thaw_unescape($value);
 3243:     }
 3244:     return %returnhash;
 3245: }
 3246: 
 3247: # --------------------------------------------------------- dumpstore interface
 3248: 
 3249: sub dumpstore {
 3250:    my ($namespace,$udomain,$uname,$regexp,$range)=@_;
 3251:    if (!$udomain) { $udomain=$env{'user.domain'}; }
 3252:    if (!$uname) { $uname=$env{'user.name'}; }
 3253:    my $uhome=&homeserver($uname,$udomain);
 3254:    if ($regexp) {
 3255:        $regexp=&escape($regexp);
 3256:    } else {
 3257:        $regexp='.';
 3258:    }
 3259:    my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
 3260:    my @pairs=split(/\&/,$rep);
 3261:    my %returnhash=();
 3262:    foreach my $item (@pairs) {
 3263:        my ($key,$value)=split(/=/,$item,2);
 3264:        next if ($key =~ /^error: 2 /);
 3265:        $returnhash{$key}=&thaw_unescape($value);
 3266:    }
 3267:    return %returnhash;
 3268: }
 3269: 
 3270: # -------------------------------------------------------------- keys interface
 3271: 
 3272: sub getkeys {
 3273:    my ($namespace,$udomain,$uname)=@_;
 3274:    if (!$udomain) { $udomain=$env{'user.domain'}; }
 3275:    if (!$uname) { $uname=$env{'user.name'}; }
 3276:    my $uhome=&homeserver($uname,$udomain);
 3277:    my $rep=reply("keys:$udomain:$uname:$namespace",$uhome);
 3278:    my @keyarray=();
 3279:    foreach my $key (split(/\&/,$rep)) {
 3280:       next if ($key =~ /^error: 2 /);
 3281:       push(@keyarray,&unescape($key));
 3282:    }
 3283:    return @keyarray;
 3284: }
 3285: 
 3286: # --------------------------------------------------------------- currentdump
 3287: sub currentdump {
 3288:    my ($courseid,$sdom,$sname)=@_;
 3289:    $courseid = $env{'request.course.id'} if (! defined($courseid));
 3290:    $sdom     = $env{'user.domain'}       if (! defined($sdom));
 3291:    $sname    = $env{'user.name'}         if (! defined($sname));
 3292:    my $uhome = &homeserver($sname,$sdom);
 3293:    my $rep=reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome);
 3294:    return if ($rep =~ /^(error:|no_such_host)/);
 3295:    #
 3296:    my %returnhash=();
 3297:    #
 3298:    if ($rep eq "unknown_cmd") { 
 3299:        # an old lond will not know currentdump
 3300:        # Do a dump and make it look like a currentdump
 3301:        my @tmp = &dumpstore($courseid,$sdom,$sname,'.');
 3302:        return if ($tmp[0] =~ /^(error:|no_such_host)/);
 3303:        my %hash = @tmp;
 3304:        @tmp=();
 3305:        %returnhash = %{&convert_dump_to_currentdump(\%hash)};
 3306:    } else {
 3307:        my @pairs=split(/\&/,$rep);
 3308:        foreach my $pair (@pairs) {
 3309:            my ($key,$value)=split(/=/,$pair,2);
 3310:            my ($symb,$param) = split(/:/,$key);
 3311:            $returnhash{&unescape($symb)}->{&unescape($param)} = 
 3312:                                                         &thaw_unescape($value);
 3313:        }
 3314:    }
 3315:    return %returnhash;
 3316: }
 3317: 
 3318: sub convert_dump_to_currentdump{
 3319:     my %hash = %{shift()};
 3320:     my %returnhash;
 3321:     # Code ripped from lond, essentially.  The only difference
 3322:     # here is the unescaping done by lonnet::dump().  Conceivably
 3323:     # we might run in to problems with parameter names =~ /^v\./
 3324:     while (my ($key,$value) = each(%hash)) {
 3325:         my ($v,$symb,$param) = split(/:/,$key);
 3326: 	$symb  = &unescape($symb);
 3327: 	$param = &unescape($param);
 3328:         next if ($v eq 'version' || $symb eq 'keys');
 3329:         next if (exists($returnhash{$symb}) &&
 3330:                  exists($returnhash{$symb}->{$param}) &&
 3331:                  $returnhash{$symb}->{'v.'.$param} > $v);
 3332:         $returnhash{$symb}->{$param}=$value;
 3333:         $returnhash{$symb}->{'v.'.$param}=$v;
 3334:     }
 3335:     #
 3336:     # Remove all of the keys in the hashes which keep track of
 3337:     # the version of the parameter.
 3338:     while (my ($symb,$param_hash) = each(%returnhash)) {
 3339:         # use a foreach because we are going to delete from the hash.
 3340:         foreach my $key (keys(%$param_hash)) {
 3341:             delete($param_hash->{$key}) if ($key =~ /^v\./);
 3342:         }
 3343:     }
 3344:     return \%returnhash;
 3345: }
 3346: 
 3347: # ------------------------------------------------------ critical inc interface
 3348: 
 3349: sub cinc {
 3350:     return &inc(@_,'critical');
 3351: }
 3352: 
 3353: # --------------------------------------------------------------- inc interface
 3354: 
 3355: sub inc {
 3356:     my ($namespace,$store,$udomain,$uname,$critical) = @_;
 3357:     if (!$udomain) { $udomain=$env{'user.domain'}; }
 3358:     if (!$uname) { $uname=$env{'user.name'}; }
 3359:     my $uhome=&homeserver($uname,$udomain);
 3360:     my $items='';
 3361:     if (! ref($store)) {
 3362:         # got a single value, so use that instead
 3363:         $items = &escape($store).'=&';
 3364:     } elsif (ref($store) eq 'SCALAR') {
 3365:         $items = &escape($$store).'=&';        
 3366:     } elsif (ref($store) eq 'ARRAY') {
 3367:         $items = join('=&',map {&escape($_);} @{$store});
 3368:     } elsif (ref($store) eq 'HASH') {
 3369:         while (my($key,$value) = each(%{$store})) {
 3370:             $items.= &escape($key).'='.&escape($value).'&';
 3371:         }
 3372:     }
 3373:     $items=~s/\&$//;
 3374:     if ($critical) {
 3375: 	return &critical("inc:$udomain:$uname:$namespace:$items",$uhome);
 3376:     } else {
 3377: 	return &reply("inc:$udomain:$uname:$namespace:$items",$uhome);
 3378:     }
 3379: }
 3380: 
 3381: # --------------------------------------------------------------- put interface
 3382: 
 3383: sub put {
 3384:    my ($namespace,$storehash,$udomain,$uname)=@_;
 3385:    if (!$udomain) { $udomain=$env{'user.domain'}; }
 3386:    if (!$uname) { $uname=$env{'user.name'}; }
 3387:    my $uhome=&homeserver($uname,$udomain);
 3388:    my $items='';
 3389:    foreach my $item (keys(%$storehash)) {
 3390:        $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
 3391:    }
 3392:    $items=~s/\&$//;
 3393:    return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
 3394: }
 3395: 
 3396: # ------------------------------------------------------------ newput interface
 3397: 
 3398: sub newput {
 3399:    my ($namespace,$storehash,$udomain,$uname)=@_;
 3400:    if (!$udomain) { $udomain=$env{'user.domain'}; }
 3401:    if (!$uname) { $uname=$env{'user.name'}; }
 3402:    my $uhome=&homeserver($uname,$udomain);
 3403:    my $items='';
 3404:    foreach my $key (keys(%$storehash)) {
 3405:        $items.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
 3406:    }
 3407:    $items=~s/\&$//;
 3408:    return &reply("newput:$udomain:$uname:$namespace:$items",$uhome);
 3409: }
 3410: 
 3411: # ---------------------------------------------------------  putstore interface
 3412: 
 3413: sub putstore {
 3414:    my ($namespace,$symb,$version,$storehash,$udomain,$uname)=@_;
 3415:    if (!$udomain) { $udomain=$env{'user.domain'}; }
 3416:    if (!$uname) { $uname=$env{'user.name'}; }
 3417:    my $uhome=&homeserver($uname,$udomain);
 3418:    my $items='';
 3419:    foreach my $key (keys(%$storehash)) {
 3420:        $items.= &escape($key).'='.&freeze_escape($storehash->{$key}).'&';
 3421:    }
 3422:    $items=~s/\&$//;
 3423:    my $esc_symb=&escape($symb);
 3424:    my $esc_v=&escape($version);
 3425:    my $reply =
 3426:        &reply("putstore:$udomain:$uname:$namespace:$esc_symb:$esc_v:$items",
 3427: 	      $uhome);
 3428:    if ($reply eq 'unknown_cmd') {
 3429:        # gfall back to way things use to be done
 3430:        return &old_putstore($namespace,$symb,$version,$storehash,$udomain,
 3431: 			    $uname);
 3432:    }
 3433:    return $reply;
 3434: }
 3435: 
 3436: sub old_putstore {
 3437:     my ($namespace,$symb,$version,$storehash,$udomain,$uname)=@_;
 3438:     if (!$udomain) { $udomain=$env{'user.domain'}; }
 3439:     if (!$uname) { $uname=$env{'user.name'}; }
 3440:     my $uhome=&homeserver($uname,$udomain);
 3441:     my %newstorehash;
 3442:     foreach my $item (keys(%$storehash)) {
 3443: 	my $key = $version.':'.&escape($symb).':'.$item;
 3444: 	$newstorehash{$key} = $storehash->{$item};
 3445:     }
 3446:     my $items='';
 3447:     my %allitems = ();
 3448:     foreach my $item (keys(%newstorehash)) {
 3449: 	if ($item =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) {
 3450: 	    my $key = $1.':keys:'.$2;
 3451: 	    $allitems{$key} .= $3.':';
 3452: 	}
 3453: 	$items.=$item.'='.&freeze_escape($newstorehash{$item}).'&';
 3454:     }
 3455:     foreach my $item (keys(%allitems)) {
 3456: 	$allitems{$item} =~ s/\:$//;
 3457: 	$items.= $item.'='.$allitems{$item}.'&';
 3458:     }
 3459:     $items=~s/\&$//;
 3460:     return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
 3461: }
 3462: 
 3463: # ------------------------------------------------------ critical put interface
 3464: 
 3465: sub cput {
 3466:    my ($namespace,$storehash,$udomain,$uname)=@_;
 3467:    if (!$udomain) { $udomain=$env{'user.domain'}; }
 3468:    if (!$uname) { $uname=$env{'user.name'}; }
 3469:    my $uhome=&homeserver($uname,$udomain);
 3470:    my $items='';
 3471:    foreach my $item (keys(%$storehash)) {
 3472:        $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
 3473:    }
 3474:    $items=~s/\&$//;
 3475:    return &critical("put:$udomain:$uname:$namespace:$items",$uhome);
 3476: }
 3477: 
 3478: # -------------------------------------------------------------- eget interface
 3479: 
 3480: sub eget {
 3481:    my ($namespace,$storearr,$udomain,$uname)=@_;
 3482:    my $items='';
 3483:    foreach my $item (@$storearr) {
 3484:        $items.=&escape($item).'&';
 3485:    }
 3486:    $items=~s/\&$//;
 3487:    if (!$udomain) { $udomain=$env{'user.domain'}; }
 3488:    if (!$uname) { $uname=$env{'user.name'}; }
 3489:    my $uhome=&homeserver($uname,$udomain);
 3490:    my $rep=&reply("eget:$udomain:$uname:$namespace:$items",$uhome);
 3491:    my @pairs=split(/\&/,$rep);
 3492:    my %returnhash=();
 3493:    my $i=0;
 3494:    foreach my $item (@$storearr) {
 3495:       $returnhash{$item}=&thaw_unescape($pairs[$i]);
 3496:       $i++;
 3497:    }
 3498:    return %returnhash;
 3499: }
 3500: 
 3501: # ------------------------------------------------------------ tmpput interface
 3502: sub tmpput {
 3503:     my ($storehash,$server,$context)=@_;
 3504:     my $items='';
 3505:     foreach my $item (keys(%$storehash)) {
 3506: 	$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
 3507:     }
 3508:     $items=~s/\&$//;
 3509:     if (defined($context)) {
 3510:         $items .= ':'.&escape($context);
 3511:     }
 3512:     return &reply("tmpput:$items",$server);
 3513: }
 3514: 
 3515: # ------------------------------------------------------------ tmpget interface
 3516: sub tmpget {
 3517:     my ($token,$server)=@_;
 3518:     if (!defined($server)) { $server = $perlvar{'lonHostID'}; }
 3519:     my $rep=&reply("tmpget:$token",$server);
 3520:     my %returnhash;
 3521:     foreach my $item (split(/\&/,$rep)) {
 3522: 	my ($key,$value)=split(/=/,$item);
 3523: 	$returnhash{&unescape($key)}=&thaw_unescape($value);
 3524:     }
 3525:     return %returnhash;
 3526: }
 3527: 
 3528: # ------------------------------------------------------------ tmpget interface
 3529: sub tmpdel {
 3530:     my ($token,$server)=@_;
 3531:     if (!defined($server)) { $server = $perlvar{'lonHostID'}; }
 3532:     return &reply("tmpdel:$token",$server);
 3533: }
 3534: 
 3535: # -------------------------------------------------- portfolio access checking
 3536: 
 3537: sub portfolio_access {
 3538:     my ($requrl) = @_;
 3539:     my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl);
 3540:     my $result = &get_portfolio_access($udom,$unum,$file_name,$group);
 3541:     if ($result) {
 3542:         my %setters;
 3543:         if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
 3544:             my ($startblock,$endblock) =
 3545:                 &Apache::loncommon::blockcheck(\%setters,'port',$unum,$udom);
 3546:             if ($startblock && $endblock) {
 3547:                 return 'B';
 3548:             }
 3549:         } else {
 3550:             my ($startblock,$endblock) =
 3551:                 &Apache::loncommon::blockcheck(\%setters,'port');
 3552:             if ($startblock && $endblock) {
 3553:                 return 'B';
 3554:             }
 3555:         }
 3556:     }
 3557:     if ($result eq 'ok') {
 3558:        return 'F';
 3559:     } elsif ($result =~ /^[^:]+:guest_/) {
 3560:        return 'A';
 3561:     }
 3562:     return '';
 3563: }
 3564: 
 3565: sub get_portfolio_access {
 3566:     my ($udom,$unum,$file_name,$group,$access_hash) = @_;
 3567: 
 3568:     if (!ref($access_hash)) {
 3569: 	my $current_perms = &get_portfile_permissions($udom,$unum);
 3570: 	my %access_controls = &get_access_controls($current_perms,$group,
 3571: 						   $file_name);
 3572: 	$access_hash = $access_controls{$file_name};
 3573:     }
 3574: 
 3575:     my ($public,$guest,@domains,@users,@courses,@groups);
 3576:     my $now = time;
 3577:     if (ref($access_hash) eq 'HASH') {
 3578:         foreach my $key (keys(%{$access_hash})) {
 3579:             my ($num,$scope,$end,$start) = ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/);
 3580:             if ($start > $now) {
 3581:                 next;
 3582:             }
 3583:             if ($end && $end<$now) {
 3584:                 next;
 3585:             }
 3586:             if ($scope eq 'public') {
 3587:                 $public = $key;
 3588:                 last;
 3589:             } elsif ($scope eq 'guest') {
 3590:                 $guest = $key;
 3591:             } elsif ($scope eq 'domains') {
 3592:                 push(@domains,$key);
 3593:             } elsif ($scope eq 'users') {
 3594:                 push(@users,$key);
 3595:             } elsif ($scope eq 'course') {
 3596:                 push(@courses,$key);
 3597:             } elsif ($scope eq 'group') {
 3598:                 push(@groups,$key);
 3599:             }
 3600:         }
 3601:         if ($public) {
 3602:             return 'ok';
 3603:         }
 3604:         if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
 3605:             if ($guest) {
 3606:                 return $guest;
 3607:             }
 3608:         } else {
 3609:             if (@domains > 0) {
 3610:                 foreach my $domkey (@domains) {
 3611:                     if (ref($access_hash->{$domkey}{'dom'}) eq 'ARRAY') {
 3612:                         if (grep(/^\Q$env{'user.domain'}\E$/,@{$access_hash->{$domkey}{'dom'}})) {
 3613:                             return 'ok';
 3614:                         }
 3615:                     }
 3616:                 }
 3617:             }
 3618:             if (@users > 0) {
 3619:                 foreach my $userkey (@users) {
 3620:                     if (ref($access_hash->{$userkey}{'users'}) eq 'ARRAY') {
 3621:                         foreach my $item (@{$access_hash->{$userkey}{'users'}}) {
 3622:                             if (ref($item) eq 'HASH') {
 3623:                                 if (($item->{'uname'} eq $env{'user.name'}) &&
 3624:                                     ($item->{'udom'} eq $env{'user.domain'})) {
 3625:                                     return 'ok';
 3626:                                 }
 3627:                             }
 3628:                         }
 3629:                     } 
 3630:                 }
 3631:             }
 3632:             my %roleshash;
 3633:             my @courses_and_groups = @courses;
 3634:             push(@courses_and_groups,@groups); 
 3635:             if (@courses_and_groups > 0) {
 3636:                 my (%allgroups,%allroles); 
 3637:                 my ($start,$end,$role,$sec,$group);
 3638:                 foreach my $envkey (%env) {
 3639:                     if ($envkey =~ m-^user\.role\.(gr|cc|in|ta|ep|st)\./($match_domain)/($match_courseid)/?([^/]*)$-) {
 3640:                         my $cid = $2.'_'.$3; 
 3641:                         if ($1 eq 'gr') {
 3642:                             $group = $4;
 3643:                             $allgroups{$cid}{$group} = $env{$envkey};
 3644:                         } else {
 3645:                             if ($4 eq '') {
 3646:                                 $sec = 'none';
 3647:                             } else {
 3648:                                 $sec = $4;
 3649:                             }
 3650:                             $allroles{$cid}{$1}{$sec} = $env{$envkey};
 3651:                         }
 3652:                     } elsif ($envkey =~ m-^user\.role\./cr/($match_domain/$match_username/\w*)./($match_domain)/($match_courseid)/?([^/]*)$-) {
 3653:                         my $cid = $2.'_'.$3;
 3654:                         if ($4 eq '') {
 3655:                             $sec = 'none';
 3656:                         } else {
 3657:                             $sec = $4;
 3658:                         }
 3659:                         $allroles{$cid}{$1}{$sec} = $env{$envkey};
 3660:                     }
 3661:                 }
 3662:                 if (keys(%allroles) == 0) {
 3663:                     return;
 3664:                 }
 3665:                 foreach my $key (@courses_and_groups) {
 3666:                     my %content = %{$$access_hash{$key}};
 3667:                     my $cnum = $content{'number'};
 3668:                     my $cdom = $content{'domain'};
 3669:                     my $cid = $cdom.'_'.$cnum;
 3670:                     if (!exists($allroles{$cid})) {
 3671:                         next;
 3672:                     }    
 3673:                     foreach my $role_id (keys(%{$content{'roles'}})) {
 3674:                         my @sections = @{$content{'roles'}{$role_id}{'section'}};
 3675:                         my @groups = @{$content{'roles'}{$role_id}{'group'}};
 3676:                         my @status = @{$content{'roles'}{$role_id}{'access'}};
 3677:                         my @roles = @{$content{'roles'}{$role_id}{'role'}};
 3678:                         foreach my $role (keys(%{$allroles{$cid}})) {
 3679:                             if ((grep/^all$/,@roles) || (grep/^\Q$role\E$/,@roles)) {
 3680:                                 foreach my $sec (keys(%{$allroles{$cid}{$role}})) {
 3681:                                     if (&course_group_datechecker($allroles{$cid}{$role}{$sec},$now,\@status) eq 'ok') {
 3682:                                         if (grep/^all$/,@sections) {
 3683:                                             return 'ok';
 3684:                                         } else {
 3685:                                             if (grep/^$sec$/,@sections) {
 3686:                                                 return 'ok';
 3687:                                             }
 3688:                                         }
 3689:                                     }
 3690:                                 }
 3691:                                 if (keys(%{$allgroups{$cid}}) == 0) {
 3692:                                     if (grep/^none$/,@groups) {
 3693:                                         return 'ok';
 3694:                                     }
 3695:                                 } else {
 3696:                                     if (grep/^all$/,@groups) {
 3697:                                         return 'ok';
 3698:                                     } 
 3699:                                     foreach my $group (keys(%{$allgroups{$cid}})) {
 3700:                                         if (grep/^$group$/,@groups) {
 3701:                                             return 'ok';
 3702:                                         }
 3703:                                     }
 3704:                                 } 
 3705:                             }
 3706:                         }
 3707:                     }
 3708:                 }
 3709:             }
 3710:             if ($guest) {
 3711:                 return $guest;
 3712:             }
 3713:         }
 3714:     }
 3715:     return;
 3716: }
 3717: 
 3718: sub course_group_datechecker {
 3719:     my ($dates,$now,$status) = @_;
 3720:     my ($start,$end) = split(/\./,$dates);
 3721:     if (!$start && !$end) {
 3722:         return 'ok';
 3723:     }
 3724:     if (grep/^active$/,@{$status}) {
 3725:         if (((!$start) || ($start && $start <= $now)) && ((!$end) || ($end && $end >= $now))) {
 3726:             return 'ok';
 3727:         }
 3728:     }
 3729:     if (grep/^previous$/,@{$status}) {
 3730:         if ($end > $now ) {
 3731:             return 'ok';
 3732:         }
 3733:     }
 3734:     if (grep/^future$/,@{$status}) {
 3735:         if ($start > $now) {
 3736:             return 'ok';
 3737:         }
 3738:     }
 3739:     return; 
 3740: }
 3741: 
 3742: sub parse_portfolio_url {
 3743:     my ($url) = @_;
 3744: 
 3745:     my ($type,$udom,$unum,$group,$file_name);
 3746:     
 3747:     if ($url =~  m-^/*(?:uploaded|editupload)/($match_domain)/($match_username)/portfolio(/.+)$-) {
 3748: 	$type = 1;
 3749:         $udom = $1;
 3750:         $unum = $2;
 3751:         $file_name = $3;
 3752:     } elsif ($url =~ m-^/*(?:uploaded|editupload)/($match_domain)/($match_courseid)/groups/([^/]+)/portfolio/(.+)$-) {
 3753: 	$type = 2;
 3754:         $udom = $1;
 3755:         $unum = $2;
 3756:         $group = $3;
 3757:         $file_name = $3.'/'.$4;
 3758:     }
 3759:     if (wantarray) {
 3760: 	return ($type,$udom,$unum,$file_name,$group);
 3761:     }
 3762:     return $type;
 3763: }
 3764: 
 3765: sub is_portfolio_url {
 3766:     my ($url) = @_;
 3767:     return scalar(&parse_portfolio_url($url));
 3768: }
 3769: 
 3770: sub is_portfolio_file {
 3771:     my ($file) = @_;
 3772:     if (($file =~ /^portfolio/) || ($file =~ /^groups\/\w+\/portfolio/)) {
 3773:         return 1;
 3774:     }
 3775:     return;
 3776: }
 3777: 
 3778: 
 3779: # ---------------------------------------------- Custom access rule evaluation
 3780: 
 3781: sub customaccess {
 3782:     my ($priv,$uri)=@_;
 3783:     my ($urole,$urealm)=split(/\./,$env{'request.role'},2);
 3784:     my (undef,$udom,$ucrs,$usec)=split(/\//,$urealm);
 3785:     $udom = &LONCAPA::clean_domain($udom);
 3786:     $ucrs = &LONCAPA::clean_username($ucrs);
 3787:     my $access=0;
 3788:     foreach my $right (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) {
 3789: 	my ($effect,$realm,$role)=split(/\:/,$right);
 3790:         if ($role) {
 3791: 	   if ($role ne $urole) { next; }
 3792:         }
 3793:         foreach my $scope (split(/\s*\,\s*/,$realm)) {
 3794:             my ($tdom,$tcrs,$tsec)=split(/\_/,$scope);
 3795:             if ($tdom) {
 3796: 		if ($tdom ne $udom) { next; }
 3797:             }
 3798:             if ($tcrs) {
 3799: 		if ($tcrs ne $ucrs) { next; }
 3800:             }
 3801:             if ($tsec) {
 3802: 		if ($tsec ne $usec) { next; }
 3803:             }
 3804:             $access=($effect eq 'allow');
 3805:             last;
 3806:         }
 3807: 	if ($realm eq '' && $role eq '') {
 3808:             $access=($effect eq 'allow');
 3809: 	}
 3810:     }
 3811:     return $access;
 3812: }
 3813: 
 3814: # ------------------------------------------------- Check for a user privilege
 3815: 
 3816: sub allowed {
 3817:     my ($priv,$uri,$symb,$role)=@_;
 3818:     my $ver_orguri=$uri;
 3819:     $uri=&deversion($uri);
 3820:     my $orguri=$uri;
 3821:     $uri=&declutter($uri);
 3822: 
 3823:     if ($priv eq 'evb') {
 3824: # Evade communication block restrictions for specified role in a course
 3825:         if ($env{'user.priv.'.$role} =~/evb\&([^\:]*)/) {
 3826:             return $1;
 3827:         } else {
 3828:             return;
 3829:         }
 3830:     }
 3831: 
 3832:     if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }
 3833: # Free bre access to adm and meta resources
 3834:     if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard)$})) 
 3835: 	 || (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) )) 
 3836: 	&& ($priv eq 'bre')) {
 3837: 	return 'F';
 3838:     }
 3839: 
 3840: # Free bre access to user's own portfolio contents
 3841:     my ($space,$domain,$name,@dir)=split('/',$uri);
 3842:     if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) && 
 3843: 	($env{'user.domain'} eq $domain) && ('portfolio' eq $dir[0])) {
 3844:         my %setters;
 3845:         my ($startblock,$endblock) = 
 3846:             &Apache::loncommon::blockcheck(\%setters,'port');
 3847:         if ($startblock && $endblock) {
 3848:             return 'B';
 3849:         } else {
 3850:             return 'F';
 3851:         }
 3852:     }
 3853: 
 3854: # bre access to group portfolio for rgf priv in group, or mdg or vcg in course.
 3855:     if (($space=~/^(uploaded|editupload)$/) && ($dir[0] eq 'groups') 
 3856:          && ($dir[2] eq 'portfolio') && ($priv eq 'bre')) {
 3857:         if (exists($env{'request.course.id'})) {
 3858:             my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
 3859:             my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
 3860:             if (($domain eq $cdom) && ($name eq $cnum)) {
 3861:                 my $courseprivid=$env{'request.course.id'};
 3862:                 $courseprivid=~s/\_/\//;
 3863:                 if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid
 3864:                     .'/'.$dir[1]} =~/rgf\&([^\:]*)/) {
 3865:                     return $1; 
 3866:                 } else {
 3867:                     if ($env{'request.course.sec'}) {
 3868:                         $courseprivid.='/'.$env{'request.course.sec'};
 3869:                     }
 3870:                     if ($env{'user.priv.'.$env{'request.role'}.'./'.
 3871:                         $courseprivid} =~/(mdg|vcg)\&([^\:]*)/) {
 3872:                         return $2;
 3873:                     }
 3874:                 }
 3875:             }
 3876:         }
 3877:     }
 3878: 
 3879: # Free bre to public access
 3880: 
 3881:     if ($priv eq 'bre') {
 3882:         my $copyright=&metadata($uri,'copyright');
 3883: 	if (($copyright eq 'public') && (!$env{'request.course.id'})) { 
 3884:            return 'F'; 
 3885:         }
 3886:         if ($copyright eq 'priv') {
 3887:             $uri=~/([^\/]+)\/([^\/]+)\//;
 3888: 	    unless (($env{'user.name'} eq $2) && ($env{'user.domain'} eq $1)) {
 3889: 		return '';
 3890:             }
 3891:         }
 3892:         if ($copyright eq 'domain') {
 3893:             $uri=~/([^\/]+)\/([^\/]+)\//;
 3894: 	    unless (($env{'user.domain'} eq $1) ||
 3895:                  ($env{'course.'.$env{'request.course.id'}.'.domain'} eq $1)) {
 3896: 		return '';
 3897:             }
 3898:         }
 3899:         if ($env{'request.role'}=~ /li\.\//) {
 3900:             # Library role, so allow browsing of resources in this domain.
 3901:             return 'F';
 3902:         }
 3903:         if ($copyright eq 'custom') {
 3904: 	    unless (&customaccess($priv,$uri)) { return ''; }
 3905:         }
 3906:     }
 3907:     # Domain coordinator is trying to create a course
 3908:     if (($priv eq 'ccc') && ($env{'request.role'} =~ /^dc\./)) {
 3909:         # uri is the requested domain in this case.
 3910:         # comparison to 'request.role.domain' shows if the user has selected
 3911:         # a role of dc for the domain in question.
 3912:         return 'F' if ($uri eq $env{'request.role.domain'});
 3913:     }
 3914: 
 3915:     my $thisallowed='';
 3916:     my $statecond=0;
 3917:     my $courseprivid='';
 3918: 
 3919: # Course
 3920: 
 3921:     if ($env{'user.priv.'.$env{'request.role'}.'./'}=~/\Q$priv\E\&([^\:]*)/) {
 3922:        $thisallowed.=$1;
 3923:     }
 3924: 
 3925: # Domain
 3926: 
 3927:     if ($env{'user.priv.'.$env{'request.role'}.'./'.(split(/\//,$uri))[0].'/'}
 3928:        =~/\Q$priv\E\&([^\:]*)/) {
 3929:        $thisallowed.=$1;
 3930:     }
 3931: 
 3932: # Course: uri itself is a course
 3933:     my $courseuri=$uri;
 3934:     $courseuri=~s/\_(\d)/\/$1/;
 3935:     $courseuri=~s/^([^\/])/\/$1/;
 3936: 
 3937:     if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseuri}
 3938:        =~/\Q$priv\E\&([^\:]*)/) {
 3939:        $thisallowed.=$1;
 3940:     }
 3941: 
 3942: # URI is an uploaded document for this course, default permissions don't matter
 3943: # not allowing 'edit' access (editupload) to uploaded course docs
 3944:     if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) {
 3945: 	$thisallowed='';
 3946:         my ($match)=&is_on_map($uri);
 3947:         if ($match) {
 3948:             if ($env{'user.priv.'.$env{'request.role'}.'./'}
 3949:                   =~/\Q$priv\E\&([^\:]*)/) {
 3950:                 $thisallowed.=$1;
 3951:             }
 3952:         } else {
 3953:             my $refuri = $env{'httpref.'.$orguri} || $env{'httpref.'.$ver_orguri};
 3954:             if ($refuri) {
 3955:                 if ($refuri =~ m|^/adm/|) {
 3956:                     $thisallowed='F';
 3957:                 } else {
 3958:                     $refuri=&declutter($refuri);
 3959:                     my ($match) = &is_on_map($refuri);
 3960:                     if ($match) {
 3961:                         $thisallowed='F';
 3962:                     }
 3963:                 }
 3964:             }
 3965:         }
 3966:     }
 3967: 
 3968:     if ($priv eq 'bre'
 3969: 	&& $thisallowed ne 'F' 
 3970: 	&& $thisallowed ne '2'
 3971: 	&& &is_portfolio_url($uri)) {
 3972: 	$thisallowed = &portfolio_access($uri);
 3973:     }
 3974:     
 3975: # Full access at system, domain or course-wide level? Exit.
 3976: 
 3977:     if ($thisallowed=~/F/) {
 3978: 	return 'F';
 3979:     }
 3980: 
 3981: # If this is generating or modifying users, exit with special codes
 3982: 
 3983:     if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:caa:'=~/\:\Q$priv\E\:/) {
 3984: 	if (($priv eq 'cca') || ($priv eq 'caa')) {
 3985: 	    my ($audom,$auname)=split('/',$uri);
 3986: # no author name given, so this just checks on the general right to make a co-author in this domain
 3987: 	    unless ($auname) { return $thisallowed; }
 3988: # an author name is given, so we are about to actually make a co-author for a certain account
 3989: 	    if (($auname ne $env{'user.name'} && $env{'request.role'} !~ /^dc\./) ||
 3990: 		(($audom ne $env{'user.domain'} && $env{'request.role'} !~ /^dc\./) &&
 3991: 		 ($audom ne $env{'request.role.domain'}))) { return ''; }
 3992: 	}
 3993: 	return $thisallowed;
 3994:     }
 3995: #
 3996: # Gathered so far: system, domain and course wide privileges
 3997: #
 3998: # Course: See if uri or referer is an individual resource that is part of 
 3999: # the course
 4000: 
 4001:     if ($env{'request.course.id'}) {
 4002: 
 4003:        $courseprivid=$env{'request.course.id'};
 4004:        if ($env{'request.course.sec'}) {
 4005:           $courseprivid.='/'.$env{'request.course.sec'};
 4006:        }
 4007:        $courseprivid=~s/\_/\//;
 4008:        my $checkreferer=1;
 4009:        my ($match,$cond)=&is_on_map($uri);
 4010:        if ($match) {
 4011:            $statecond=$cond;
 4012:            if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid}
 4013:                =~/\Q$priv\E\&([^\:]*)/) {
 4014:                $thisallowed.=$1;
 4015:                $checkreferer=0;
 4016:            }
 4017:        }
 4018:        
 4019:        if ($checkreferer) {
 4020: 	  my $refuri=$env{'httpref.'.$orguri};
 4021:             unless ($refuri) {
 4022:                 foreach my $key (keys(%env)) {
 4023: 		    if ($key=~/^httpref\..*\*/) {
 4024: 			my $pattern=$key;
 4025:                         $pattern=~s/^httpref\.\/res\///;
 4026:                         $pattern=~s/\*/\[\^\/\]\+/g;
 4027:                         $pattern=~s/\//\\\//g;
 4028:                         if ($orguri=~/$pattern/) {
 4029: 			    $refuri=$env{$key};
 4030:                         }
 4031:                     }
 4032:                 }
 4033:             }
 4034: 
 4035:          if ($refuri) { 
 4036: 	  $refuri=&declutter($refuri);
 4037:           my ($match,$cond)=&is_on_map($refuri);
 4038:             if ($match) {
 4039:               my $refstatecond=$cond;
 4040:               if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid}
 4041:                   =~/\Q$priv\E\&([^\:]*)/) {
 4042:                   $thisallowed.=$1;
 4043:                   $uri=$refuri;
 4044:                   $statecond=$refstatecond;
 4045:               }
 4046:           }
 4047:         }
 4048:        }
 4049:    }
 4050: 
 4051: #
 4052: # Gathered now: all privileges that could apply, and condition number
 4053: # 
 4054: #
 4055: # Full or no access?
 4056: #
 4057: 
 4058:     if ($thisallowed=~/F/) {
 4059: 	return 'F';
 4060:     }
 4061: 
 4062:     unless ($thisallowed) {
 4063:         return '';
 4064:     }
 4065: 
 4066: # Restrictions exist, deal with them
 4067: #
 4068: #   C:according to course preferences
 4069: #   R:according to resource settings
 4070: #   L:unless locked
 4071: #   X:according to user session state
 4072: #
 4073: 
 4074: # Possibly locked functionality, check all courses
 4075: # Locks might take effect only after 10 minutes cache expiration for other
 4076: # courses, and 2 minutes for current course
 4077: 
 4078:     my $envkey;
 4079:     if ($thisallowed=~/L/) {
 4080:         foreach $envkey (keys %env) {
 4081:            if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) {
 4082:                my $courseid=$2;
 4083:                my $roleid=$1.'.'.$2;
 4084:                $courseid=~s/^\///;
 4085:                my $expiretime=600;
 4086:                if ($env{'request.role'} eq $roleid) {
 4087: 		  $expiretime=120;
 4088:                }
 4089: 	       my ($cdom,$cnum,$csec)=split(/\//,$courseid);
 4090:                my $prefix='course.'.$cdom.'_'.$cnum.'.';
 4091:                if ((time-$env{$prefix.'last_cache'})>$expiretime) {
 4092: 		   &coursedescription($courseid,{'freshen_cache' => 1});
 4093:                }
 4094:                if (($env{$prefix.'res.'.$uri.'.lock.sections'}=~/\,\Q$csec\E\,/)
 4095:                 || ($env{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) {
 4096: 		   if ($env{$prefix.'res.'.$uri.'.lock.expire'}>time) {
 4097:                        &log($env{'user.domain'},$env{'user.name'},
 4098:                             $env{'user.home'},
 4099:                             'Locked by res: '.$priv.' for '.$uri.' due to '.
 4100:                             $cdom.'/'.$cnum.'/'.$csec.' expire '.
 4101:                             $env{$prefix.'priv.'.$priv.'.lock.expire'});
 4102: 		       return '';
 4103:                    }
 4104:                }
 4105:                if (($env{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,\Q$csec\E\,/)
 4106:                 || ($env{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) {
 4107: 		   if ($env{'priv.'.$priv.'.lock.expire'}>time) {
 4108:                        &log($env{'user.domain'},$env{'user.name'},
 4109:                             $env{'user.home'},
 4110:                             'Locked by priv: '.$priv.' for '.$uri.' due to '.
 4111:                             $cdom.'/'.$cnum.'/'.$csec.' expire '.
 4112:                             $env{$prefix.'priv.'.$priv.'.lock.expire'});
 4113: 		       return '';
 4114:                    }
 4115:                }
 4116: 	   }
 4117:        }
 4118:     }
 4119:    
 4120: #
 4121: # Rest of the restrictions depend on selected course
 4122: #
 4123: 
 4124:     unless ($env{'request.course.id'}) {
 4125: 	if ($thisallowed eq 'A') {
 4126: 	    return 'A';
 4127:         } elsif ($thisallowed eq 'B') {
 4128:             return 'B';
 4129: 	} else {
 4130: 	    return '1';
 4131: 	}
 4132:     }
 4133: 
 4134: #
 4135: # Now user is definitely in a course
 4136: #
 4137: 
 4138: 
 4139: # Course preferences
 4140: 
 4141:    if ($thisallowed=~/C/) {
 4142:        my $rolecode=(split(/\./,$env{'request.role'}))[0];
 4143:        my $unamedom=$env{'user.name'}.':'.$env{'user.domain'};
 4144:        if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'}
 4145: 	   =~/\Q$rolecode\E/) {
 4146: 	   if ($priv ne 'pch') { 
 4147: 	       &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
 4148: 			'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
 4149: 			$env{'request.course.id'});
 4150: 	   }
 4151:            return '';
 4152:        }
 4153: 
 4154:        if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'}
 4155: 	   =~/\Q$unamedom\E/) {
 4156: 	   if ($priv ne 'pch') { 
 4157: 	       &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.
 4158: 			'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.
 4159: 			$env{'request.course.id'});
 4160: 	   }
 4161:            return '';
 4162:        }
 4163:    }
 4164: 
 4165: # Resource preferences
 4166: 
 4167:    if ($thisallowed=~/R/) {
 4168:        my $rolecode=(split(/\./,$env{'request.role'}))[0];
 4169:        if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) {
 4170: 	   if ($priv ne 'pch') { 
 4171: 	       &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
 4172: 			'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
 4173: 	   }
 4174: 	   return '';
 4175:        }
 4176:    }
 4177: 
 4178: # Restricted by state or randomout?
 4179: 
 4180:    if ($thisallowed=~/X/) {
 4181:       if ($env{'acc.randomout'}) {
 4182: 	 if (!$symb) { $symb=&symbread($uri,1); }
 4183:          if (($symb) && ($env{'acc.randomout'}=~/\&\Q$symb\E\&/)) { 
 4184:             return ''; 
 4185:          }
 4186:       }
 4187:       if (&condval($statecond)) {
 4188: 	 return '2';
 4189:       } else {
 4190:          return '';
 4191:       }
 4192:    }
 4193: 
 4194:     if ($thisallowed eq 'A') {
 4195: 	return 'A';
 4196:     } elsif ($thisallowed eq 'B') {
 4197:         return 'B';
 4198:     }
 4199:    return 'F';
 4200: }
 4201: 
 4202: sub split_uri_for_cond {
 4203:     my $uri=&deversion(&declutter(shift));
 4204:     my @uriparts=split(/\//,$uri);
 4205:     my $filename=pop(@uriparts);
 4206:     my $pathname=join('/',@uriparts);
 4207:     return ($pathname,$filename);
 4208: }
 4209: # --------------------------------------------------- Is a resource on the map?
 4210: 
 4211: sub is_on_map {
 4212:     my ($pathname,$filename) = &split_uri_for_cond(shift);
 4213:     #Trying to find the conditional for the file
 4214:     my $match=($env{'acc.res.'.$env{'request.course.id'}.'.'.$pathname}=~
 4215: 	       /\&\Q$filename\E\:([\d\|]+)\&/);
 4216:     if ($match) {
 4217: 	return (1,$1);
 4218:     } else {
 4219: 	return (0,0);
 4220:     }
 4221: }
 4222: 
 4223: # --------------------------------------------------------- Get symb from alias
 4224: 
 4225: sub get_symb_from_alias {
 4226:     my $symb=shift;
 4227:     my ($map,$resid,$url)=&decode_symb($symb);
 4228: # Already is a symb
 4229:     if ($url) { return $symb; }
 4230: # Must be an alias
 4231:     my $aliassymb='';
 4232:     my %bighash;
 4233:     if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
 4234:                             &GDBM_READER(),0640)) {
 4235:         my $rid=$bighash{'mapalias_'.$symb};
 4236: 	if ($rid) {
 4237: 	    my ($mapid,$resid)=split(/\./,$rid);
 4238: 	    $aliassymb=&encode_symb($bighash{'map_id_'.$mapid},
 4239: 				    $resid,$bighash{'src_'.$rid});
 4240: 	}
 4241:         untie %bighash;
 4242:     }
 4243:     return $aliassymb;
 4244: }
 4245: 
 4246: # ----------------------------------------------------------------- Define Role
 4247: 
 4248: sub definerole {
 4249:   if (allowed('mcr','/')) {
 4250:     my ($rolename,$sysrole,$domrole,$courole)=@_;
 4251:     foreach my $role (split(':',$sysrole)) {
 4252: 	my ($crole,$cqual)=split(/\&/,$role);
 4253:         if ($pr{'cr:s'}!~/\Q$crole\E/) { return "refused:s:$crole"; }
 4254:         if ($pr{'cr:s'}=~/\Q$crole\E\&/) {
 4255: 	    if ($pr{'cr:s'}!~/\Q$crole\E\&\w*\Q$cqual\E/) { 
 4256:                return "refused:s:$crole&$cqual"; 
 4257:             }
 4258:         }
 4259:     }
 4260:     foreach my $role (split(':',$domrole)) {
 4261: 	my ($crole,$cqual)=split(/\&/,$role);
 4262:         if ($pr{'cr:d'}!~/\Q$crole\E/) { return "refused:d:$crole"; }
 4263:         if ($pr{'cr:d'}=~/\Q$crole\E\&/) {
 4264: 	    if ($pr{'cr:d'}!~/\Q$crole\W\&\w*\Q$cqual\E/) { 
 4265:                return "refused:d:$crole&$cqual"; 
 4266:             }
 4267:         }
 4268:     }
 4269:     foreach my $role (split(':',$courole)) {
 4270: 	my ($crole,$cqual)=split(/\&/,$role);
 4271:         if ($pr{'cr:c'}!~/\Q$crole\E/) { return "refused:c:$crole"; }
 4272:         if ($pr{'cr:c'}=~/\Q$crole\E\&/) {
 4273: 	    if ($pr{'cr:c'}!~/\Q$crole\E\&\w*\Q$cqual\E/) { 
 4274:                return "refused:c:$crole&$cqual"; 
 4275:             }
 4276:         }
 4277:     }
 4278:     my $command="encrypt:rolesput:$env{'user.domain'}:$env{'user.name'}:".
 4279:                 "$env{'user.domain'}:$env{'user.name'}:".
 4280: 	        "rolesdef_$rolename=".
 4281:                 escape($sysrole.'_'.$domrole.'_'.$courole);
 4282:     return reply($command,$env{'user.home'});
 4283:   } else {
 4284:     return 'refused';
 4285:   }
 4286: }
 4287: 
 4288: # ---------------- Make a metadata query against the network of library servers
 4289: 
 4290: sub metadata_query {
 4291:     my ($query,$custom,$customshow,$server_array)=@_;
 4292:     my %rhash;
 4293:     my %libserv = &all_library();
 4294:     my @server_list = (defined($server_array) ? @$server_array
 4295:                                               : keys(%libserv) );
 4296:     for my $server (@server_list) {
 4297: 	unless ($custom or $customshow) {
 4298: 	    my $reply=&reply("querysend:".&escape($query),$server);
 4299: 	    $rhash{$server}=$reply;
 4300: 	}
 4301: 	else {
 4302: 	    my $reply=&reply("querysend:".&escape($query).':'.
 4303: 			     &escape($custom).':'.&escape($customshow),
 4304: 			     $server);
 4305: 	    $rhash{$server}=$reply;
 4306: 	}
 4307:     }
 4308:     return \%rhash;
 4309: }
 4310: 
 4311: # ----------------------------------------- Send log queries and wait for reply
 4312: 
 4313: sub log_query {
 4314:     my ($uname,$udom,$query,%filters)=@_;
 4315:     my $uhome=&homeserver($uname,$udom);
 4316:     if ($uhome eq 'no_host') { return 'error: no_host'; }
 4317:     my $uhost=&hostname($uhome);
 4318:     my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys(%filters)));
 4319:     my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command,
 4320:                        $uhome);
 4321:     unless ($queryid=~/^\Q$uhost\E\_/) { return 'error: '.$queryid; }
 4322:     return get_query_reply($queryid);
 4323: }
 4324: 
 4325: # -------------------------- Update MySQL table for portfolio file
 4326: 
 4327: sub update_portfolio_table {
 4328:     my ($uname,$udom,$file_name,$query,$group,$action) = @_;
 4329:     my $homeserver = &homeserver($uname,$udom);
 4330:     my $queryid=
 4331:         &reply("querysend:".$query.':'.&escape($uname.':'.$udom.':'.$group).
 4332:                ':'.&escape($file_name).':'.$action,$homeserver);
 4333:     my $reply = &get_query_reply($queryid);
 4334:     return $reply;
 4335: }
 4336: 
 4337: # ------- Request retrieval of institutional classlists for course(s)
 4338: 
 4339: sub fetch_enrollment_query {
 4340:     my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_;
 4341:     my $homeserver;
 4342:     my $maxtries = 1;
 4343:     if ($context eq 'automated') {
 4344:         $homeserver = $perlvar{'lonHostID'};
 4345:         $maxtries = 10; # will wait for up to 2000s for retrieval of classlist data before timeout
 4346:     } else {
 4347:         $homeserver = &homeserver($cnum,$dom);
 4348:     }
 4349:     my $host=&hostname($homeserver);
 4350:     my $cmd = '';
 4351:     foreach my $affiliate (keys %{$affiliatesref}) {
 4352:         $cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';
 4353:     }
 4354:     $cmd =~ s/%%$//;
 4355:     $cmd = &escape($cmd);
 4356:     my $query = 'fetchenrollment';
 4357:     my $queryid=&reply("querysend:".$query.':'.$dom.':'.$env{'user.name'}.':'.$cmd,$homeserver);
 4358:     unless ($queryid=~/^\Q$host\E\_/) { 
 4359:         &logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum); 
 4360:         return 'error: '.$queryid;
 4361:     }
 4362:     my $reply = &get_query_reply($queryid);
 4363:     my $tries = 1;
 4364:     while (($reply=~/^timeout/) && ($tries < $maxtries)) {
 4365:         $reply = &get_query_reply($queryid);
 4366:         $tries ++;
 4367:     }
 4368:     if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
 4369:         &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);
 4370:     } else {
 4371:         my @responses = split/:/,$reply;
 4372:         if ($homeserver eq $perlvar{'lonHostID'}) {
 4373:             foreach my $line (@responses) {
 4374:                 my ($key,$value) = split(/=/,$line,2);
 4375:                 $$replyref{$key} = $value;
 4376:             }
 4377:         } else {
 4378:             my $pathname = $perlvar{'lonDaemons'}.'/tmp';
 4379:             foreach my $line (@responses) {
 4380:                 my ($key,$value) = split(/=/,$line);
 4381:                 $$replyref{$key} = $value;
 4382:                 if ($value > 0) {
 4383:                     foreach my $item (@{$$affiliatesref{$key}}) {
 4384:                         my $filename = $dom.'_'.$key.'_'.$item.'_classlist.xml';
 4385:                         my $destname = $pathname.'/'.$filename;
 4386:                         my $xml_classlist = &reply("autoretrieve:".$filename,$homeserver);
 4387:                         if ($xml_classlist =~ /^error/) {
 4388:                             &logthis('fetch_enrollment_query - autoretrieve error: '.$xml_classlist.' for '.$filename.' from server: '.$homeserver.' '.$context.' '.$cnum);
 4389:                         } else {
 4390:                             if ( open(FILE,">$destname") ) {
 4391:                                 print FILE &unescape($xml_classlist);
 4392:                                 close(FILE);
 4393:                             } else {
 4394:                                 &logthis('fetch_enrollment_query - error opening classlist file '.$destname.' '.$context.' '.$cnum);
 4395:                             }
 4396:                         }
 4397:                     }
 4398:                 }
 4399:             }
 4400:         }
 4401:         return 'ok';
 4402:     }
 4403:     return 'error';
 4404: }
 4405: 
 4406: sub get_query_reply {
 4407:     my $queryid=shift;
 4408:     my $replyfile=$perlvar{'lonDaemons'}.'/tmp/'.$queryid;
 4409:     my $reply='';
 4410:     for (1..100) {
 4411: 	sleep 2;
 4412:         if (-e $replyfile.'.end') {
 4413: 	    if (open(my $fh,$replyfile)) {
 4414:                $reply.=<$fh>;
 4415:                close($fh);
 4416: 	   } else { return 'error: reply_file_error'; }
 4417:            return &unescape($reply);
 4418: 	}
 4419:     }
 4420:     return 'timeout:'.$queryid;
 4421: }
 4422: 
 4423: sub courselog_query {
 4424: #
 4425: # possible filters:
 4426: # url: url or symb
 4427: # username
 4428: # domain
 4429: # action: view, submit, grade
 4430: # start: timestamp
 4431: # end: timestamp
 4432: #
 4433:     my (%filters)=@_;
 4434:     unless ($env{'request.course.id'}) { return 'no_course'; }
 4435:     if ($filters{'url'}) {
 4436: 	$filters{'url'}=&symbclean(&declutter($filters{'url'}));
 4437:         $filters{'url'}=~s/\.(\w+)$/(\\.\\d+)*\\.$1/;
 4438:         $filters{'url'}=~s/\.(\w+)\_\_\_/(\\.\\d+)*\\.$1/;
 4439:     }
 4440:     my $cname=$env{'course.'.$env{'request.course.id'}.'.num'};
 4441:     my $cdom=$env{'course.'.$env{'request.course.id'}.'.domain'};
 4442:     return &log_query($cname,$cdom,'courselog',%filters);
 4443: }
 4444: 
 4445: sub userlog_query {
 4446: #
 4447: # possible filters:
 4448: # action: log check role
 4449: # start: timestamp
 4450: # end: timestamp
 4451: #
 4452:     my ($uname,$udom,%filters)=@_;
 4453:     return &log_query($uname,$udom,'userlog',%filters);
 4454: }
 4455: 
 4456: #--------- Call auto-enrollment subs in localenroll.pm for homeserver for course 
 4457: 
 4458: sub auto_run {
 4459:     my ($cnum,$cdom) = @_;
 4460:     my $response = 0;
 4461:     my $settings;
 4462:     my %domconfig = &get_dom('configuration',['autoenroll'],$cdom);
 4463:     if (ref($domconfig{'autoenroll'}) eq 'HASH') {
 4464:         $settings = $domconfig{'autoenroll'};
 4465:         if ($settings->{'run'} eq '1') {
 4466:             $response = 1;
 4467:         }
 4468:     } else {
 4469:         my $homeserver = &homeserver($cnum,$cdom);
 4470:         $response = &reply('autorun:'.$cdom,$homeserver);
 4471:     }
 4472:     return $response;
 4473: }
 4474: 
 4475: sub auto_get_sections {
 4476:     my ($cnum,$cdom,$inst_coursecode) = @_;
 4477:     my $homeserver = &homeserver($cnum,$cdom);
 4478:     my @secs = ();
 4479:     my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver));
 4480:     unless ($response eq 'refused') {
 4481:         @secs = split/:/,$response;
 4482:     }
 4483:     return @secs;
 4484: }
 4485: 
 4486: sub auto_new_course {
 4487:     my ($cnum,$cdom,$inst_course_id,$owner) = @_;
 4488:     my $homeserver = &homeserver($cnum,$cdom);
 4489:     my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.$owner.':'.$cdom,$homeserver));
 4490:     return $response;
 4491: }
 4492: 
 4493: sub auto_validate_courseID {
 4494:     my ($cnum,$cdom,$inst_course_id) = @_;
 4495:     my $homeserver = &homeserver($cnum,$cdom);
 4496:     my $response=&unescape(&reply('autovalidatecourse:'.$inst_course_id.':'.$cdom,$homeserver));
 4497:     return $response;
 4498: }
 4499: 
 4500: sub auto_create_password {
 4501:     my ($cnum,$cdom,$authparam,$udom) = @_;
 4502:     my ($homeserver,$response);
 4503:     my $create_passwd = 0;
 4504:     my $authchk = '';
 4505:     if ($udom =~ /^$match_domain$/) {
 4506:         $homeserver = &domain($udom,'primary');
 4507:     }
 4508:     if ($homeserver eq '') {
 4509:         if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) {
 4510:             $homeserver = &homeserver($cnum,$cdom);
 4511:         }
 4512:     }
 4513:     if ($homeserver eq '') {
 4514:         $authchk = 'nodomain';
 4515:     } else {
 4516:         $response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver));
 4517:         if ($response eq 'refused') {
 4518:             $authchk = 'refused';
 4519:         } else {
 4520:             ($authparam,$create_passwd,$authchk) = split/:/,$response;
 4521:         }
 4522:     }
 4523:     return ($authparam,$create_passwd,$authchk);
 4524: }
 4525: 
 4526: sub auto_photo_permission {
 4527:     my ($cnum,$cdom,$students) = @_;
 4528:     my $homeserver = &homeserver($cnum,$cdom);
 4529:     my ($outcome,$perm_reqd,$conditions) = 
 4530: 	split(/:/,&unescape(&reply('autophotopermission:'.$cdom,$homeserver)),3);
 4531:     if ($outcome =~ /^(con_lost|unknown_cmd|no_such_host)$/) {
 4532: 	return (undef,undef);
 4533:     }
 4534:     return ($outcome,$perm_reqd,$conditions);
 4535: }
 4536: 
 4537: sub auto_checkphotos {
 4538:     my ($uname,$udom,$pid) = @_;
 4539:     my $homeserver = &homeserver($uname,$udom);
 4540:     my ($result,$resulttype);
 4541:     my $outcome = &unescape(&reply('autophotocheck:'.&escape($udom).':'.
 4542: 				   &escape($uname).':'.&escape($pid),
 4543: 				   $homeserver));
 4544:     if ($outcome =~ /^(con_lost|unknown_cmd|no_such_host)$/) {
 4545: 	return (undef,undef);
 4546:     }
 4547:     if ($outcome) {
 4548:         ($result,$resulttype) = split(/:/,$outcome);
 4549:     } 
 4550:     return ($result,$resulttype);
 4551: }
 4552: 
 4553: sub auto_photochoice {
 4554:     my ($cnum,$cdom) = @_;
 4555:     my $homeserver = &homeserver($cnum,$cdom);
 4556:     my ($update,$comment) = split(/:/,&unescape(&reply('autophotochoice:'.
 4557: 						       &escape($cdom),
 4558: 						       $homeserver)));
 4559:     if ($update =~ /^(con_lost|unknown_cmd|no_such_host)$/) {
 4560: 	return (undef,undef);
 4561:     }
 4562:     return ($update,$comment);
 4563: }
 4564: 
 4565: sub auto_photoupdate {
 4566:     my ($affiliatesref,$dom,$cnum,$photo) = @_;
 4567:     my $homeserver = &homeserver($cnum,$dom);
 4568:     my $host=&hostname($homeserver);
 4569:     my $cmd = '';
 4570:     my $maxtries = 1;
 4571:     foreach my $affiliate (keys(%{$affiliatesref})) {
 4572:         $cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';
 4573:     }
 4574:     $cmd =~ s/%%$//;
 4575:     $cmd = &escape($cmd);
 4576:     my $query = 'institutionalphotos';
 4577:     my $queryid=&reply("querysend:".$query.':'.$dom.':'.$cnum.':'.$cmd,$homeserver);
 4578:     unless ($queryid=~/^\Q$host\E\_/) {
 4579:         &logthis('institutionalphotos: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' and course: '.$cnum);
 4580:         return 'error: '.$queryid;
 4581:     }
 4582:     my $reply = &get_query_reply($queryid);
 4583:     my $tries = 1;
 4584:     while (($reply=~/^timeout/) && ($tries < $maxtries)) {
 4585:         $reply = &get_query_reply($queryid);
 4586:         $tries ++;
 4587:     }
 4588:     if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
 4589:         &logthis('institutionalphotos error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' course: '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);
 4590:     } else {
 4591:         my @responses = split(/:/,$reply);
 4592:         my $outcome = shift(@responses); 
 4593:         foreach my $item (@responses) {
 4594:             my ($key,$value) = split(/=/,$item);
 4595:             $$photo{$key} = $value;
 4596:         }
 4597:         return $outcome;
 4598:     }
 4599:     return 'error';
 4600: }
 4601: 
 4602: sub auto_instcode_format {
 4603:     my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,
 4604: 	$cat_order) = @_;
 4605:     my $courses = '';
 4606:     my @homeservers;
 4607:     if ($caller eq 'global') {
 4608: 	my %servers = &get_servers($codedom,'library');
 4609: 	foreach my $tryserver (keys(%servers)) {
 4610: 	    if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
 4611: 		push(@homeservers,$tryserver);
 4612: 	    }
 4613:         }
 4614:     } else {
 4615:         push(@homeservers,&homeserver($caller,$codedom));
 4616:     }
 4617:     foreach my $code (keys(%{$instcodes})) {
 4618:         $courses .= &escape($code).'='.&escape($$instcodes{$code}).'&';
 4619:     }
 4620:     chop($courses);
 4621:     my $ok_response = 0;
 4622:     my $response;
 4623:     while (@homeservers > 0 && $ok_response == 0) {
 4624:         my $server = shift(@homeservers); 
 4625:         $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$server);
 4626:         if ($response !~ /(con_lost|error|no_such_host|refused)/) {
 4627:             my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = 
 4628: 		split/:/,$response;
 4629:             %{$codes} = (%{$codes},&str2hash($codes_str));
 4630:             push(@{$codetitles},&str2array($codetitles_str));
 4631:             %{$cat_titles} = (%{$cat_titles},&str2hash($cat_titles_str));
 4632:             %{$cat_order} = (%{$cat_order},&str2hash($cat_order_str));
 4633:             $ok_response = 1;
 4634:         }
 4635:     }
 4636:     if ($ok_response) {
 4637:         return 'ok';
 4638:     } else {
 4639:         return $response;
 4640:     }
 4641: }
 4642: 
 4643: sub auto_instcode_defaults {
 4644:     my ($domain,$returnhash,$code_order) = @_;
 4645:     my @homeservers;
 4646: 
 4647:     my %servers = &get_servers($domain,'library');
 4648:     foreach my $tryserver (keys(%servers)) {
 4649: 	if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
 4650: 	    push(@homeservers,$tryserver);
 4651: 	}
 4652:     }
 4653: 
 4654:     my $response;
 4655:     foreach my $server (@homeservers) {
 4656:         $response=&reply('autoinstcodedefaults:'.$domain,$server);
 4657:         next if ($response =~ /(con_lost|error|no_such_host|refused)/);
 4658: 	
 4659: 	foreach my $pair (split(/\&/,$response)) {
 4660: 	    my ($name,$value)=split(/\=/,$pair);
 4661: 	    if ($name eq 'code_order') {
 4662: 		@{$code_order} = split(/\&/,&unescape($value));
 4663: 	    } else {
 4664: 		$returnhash->{&unescape($name)}=&unescape($value);
 4665: 	    }
 4666: 	}
 4667: 	return 'ok';
 4668:     }
 4669: 
 4670:     return $response;
 4671: } 
 4672: 
 4673: sub auto_validate_class_sec {
 4674:     my ($cdom,$cnum,$owner,$inst_class) = @_;
 4675:     my $homeserver = &homeserver($cnum,$cdom);
 4676:     my $response=&reply('autovalidateclass_sec:'.$inst_class.':'.
 4677:                         &escape($owner).':'.$cdom,$homeserver);
 4678:     return $response;
 4679: }
 4680: 
 4681: # ------------------------------------------------------- Course Group routines
 4682: 
 4683: sub get_coursegroups {
 4684:     my ($cdom,$cnum,$group,$namespace) = @_;
 4685:     return(&dump($namespace,$cdom,$cnum,$group));
 4686: }
 4687: 
 4688: sub modify_coursegroup {
 4689:     my ($cdom,$cnum,$groupsettings) = @_;
 4690:     return(&put('coursegroups',$groupsettings,$cdom,$cnum));
 4691: }
 4692: 
 4693: sub toggle_coursegroup_status {
 4694:     my ($cdom,$cnum,$group,$action) = @_;
 4695:     my ($from_namespace,$to_namespace);
 4696:     if ($action eq 'delete') {
 4697:         $from_namespace = 'coursegroups';
 4698:         $to_namespace = 'deleted_groups';
 4699:     } else {
 4700:         $from_namespace = 'deleted_groups';
 4701:         $to_namespace = 'coursegroups';
 4702:     }
 4703:     my %curr_group = &get_coursegroups($cdom,$cnum,$group,$from_namespace);
 4704:     if (my $tmp = &error(%curr_group)) {
 4705:         &Apache::lonnet::logthis('Error retrieving group: '.$tmp.' in '.$cnum.':'.$cdom);
 4706:         return ('read error',$tmp);
 4707:     } else {
 4708:         my %savedsettings = %curr_group; 
 4709:         my $result = &put($to_namespace,\%savedsettings,$cdom,$cnum);
 4710:         my $deloutcome;
 4711:         if ($result eq 'ok') {
 4712:             $deloutcome = &del($from_namespace,[$group],$cdom,$cnum);
 4713:         } else {
 4714:             return ('write error',$result);
 4715:         }
 4716:         if ($deloutcome eq 'ok') {
 4717:             return 'ok';
 4718:         } else {
 4719:             return ('delete error',$deloutcome);
 4720:         }
 4721:     }
 4722: }
 4723: 
 4724: sub modify_group_roles {
 4725:     my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs) = @_;
 4726:     my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id;
 4727:     my $role = 'gr/'.&escape($userprivs);
 4728:     my ($uname,$udom) = split(/:/,$user);
 4729:     my $result = &assignrole($udom,$uname,$url,$role,$end,$start);
 4730:     if ($result eq 'ok') {
 4731:         &devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);
 4732:     }
 4733:     return $result;
 4734: }
 4735: 
 4736: sub modify_coursegroup_membership {
 4737:     my ($cdom,$cnum,$membership) = @_;
 4738:     my $result = &put('groupmembership',$membership,$cdom,$cnum);
 4739:     return $result;
 4740: }
 4741: 
 4742: sub get_active_groups {
 4743:     my ($udom,$uname,$cdom,$cnum) = @_;
 4744:     my $now = time;
 4745:     my %groups = ();
 4746:     foreach my $key (keys(%env)) {
 4747:         if ($key =~ m-user\.role\.gr\./($match_domain)/($match_courseid)/(\w+)$-) {
 4748:             my ($start,$end) = split(/\./,$env{$key});
 4749:             if (($end!=0) && ($end<$now)) { next; }
 4750:             if (($start!=0) && ($start>$now)) { next; }
 4751:             if ($1 eq $cdom && $2 eq $cnum) {
 4752:                 $groups{$3} = $env{$key} ;
 4753:             }
 4754:         }
 4755:     }
 4756:     return %groups;
 4757: }
 4758: 
 4759: sub get_group_membership {
 4760:     my ($cdom,$cnum,$group) = @_;
 4761:     return(&dump('groupmembership',$cdom,$cnum,$group));
 4762: }
 4763: 
 4764: sub get_users_groups {
 4765:     my ($udom,$uname,$courseid) = @_;
 4766:     my @usersgroups;
 4767:     my $cachetime=1800;
 4768: 
 4769:     my $hashid="$udom:$uname:$courseid";
 4770:     my ($grouplist,$cached)=&is_cached_new('getgroups',$hashid);
 4771:     if (defined($cached)) {
 4772:         @usersgroups = split(/:/,$grouplist);
 4773:     } else {  
 4774:         $grouplist = '';
 4775:         my $courseurl = &courseid_to_courseurl($courseid);
 4776:         my %roleshash = &dump('roles',$udom,$uname,$courseurl);
 4777:         my $access_end = $env{'course.'.$courseid.
 4778:                               '.default_enrollment_end_date'};
 4779:         my $now = time;
 4780:         foreach my $key (keys(%roleshash)) {
 4781:             if ($key =~ /^\Q$courseurl\E\/(\w+)\_gr$/) {
 4782:                 my $group = $1;
 4783:                 if ($roleshash{$key} =~ /_(\d+)_(\d+)$/) {
 4784:                     my $start = $2;
 4785:                     my $end = $1;
 4786:                     if ($start == -1) { next; } # deleted from group
 4787:                     if (($start!=0) && ($start>$now)) { next; }
 4788:                     if (($end!=0) && ($end<$now)) {
 4789:                         if ($access_end && $access_end < $now) {
 4790:                             if ($access_end - $end < 86400) {
 4791:                                 push(@usersgroups,$group);
 4792:                             }
 4793:                         }
 4794:                         next;
 4795:                     }
 4796:                     push(@usersgroups,$group);
 4797:                 }
 4798:             }
 4799:         }
 4800:         @usersgroups = &sort_course_groups($courseid,@usersgroups);
 4801:         $grouplist = join(':',@usersgroups);
 4802:         &do_cache_new('getgroups',$hashid,$grouplist,$cachetime);
 4803:     }
 4804:     return @usersgroups;
 4805: }
 4806: 
 4807: sub devalidate_getgroups_cache {
 4808:     my ($udom,$uname,$cdom,$cnum)=@_;
 4809:     my $courseid = $cdom.'_'.$cnum;
 4810: 
 4811:     my $hashid="$udom:$uname:$courseid";
 4812:     &devalidate_cache_new('getgroups',$hashid);
 4813: }
 4814: 
 4815: # ------------------------------------------------------------------ Plain Text
 4816: 
 4817: sub plaintext {
 4818:     my ($short,$type,$cid) = @_;
 4819:     if ($short =~ /^cr/) {
 4820: 	return (split('/',$short))[-1];
 4821:     }
 4822:     if (!defined($cid)) {
 4823:         $cid = $env{'request.course.id'};
 4824:     }
 4825:     if (defined($cid) && defined($env{'course.'.$cid.'.'.$short.'.plaintext'})) {
 4826:         return &Apache::lonlocal::mt($env{'course.'.$cid.'.'.$short.
 4827:                                           '.plaintext'});
 4828:     }
 4829:     my %rolenames = (
 4830:                       Course => 'std',
 4831:                       Group => 'alt1',
 4832:                     );
 4833:     if (defined($type) && 
 4834:          defined($rolenames{$type}) && 
 4835:          defined($prp{$short}{$rolenames{$type}})) {
 4836:         return &Apache::lonlocal::mt($prp{$short}{$rolenames{$type}});
 4837:     } else {
 4838:         return &Apache::lonlocal::mt($prp{$short}{'std'});
 4839:     }
 4840: }
 4841: 
 4842: # ----------------------------------------------------------------- Assign Role
 4843: 
 4844: sub assignrole {
 4845:     my ($udom,$uname,$url,$role,$end,$start,$deleteflag)=@_;
 4846:     my $mrole;
 4847:     if ($role =~ /^cr\//) {
 4848:         my $cwosec=$url;
 4849:         $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
 4850: 	unless (&allowed('ccr',$cwosec)) {
 4851:            &logthis('Refused custom assignrole: '.
 4852:              $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
 4853: 		    $env{'user.name'}.' at '.$env{'user.domain'});
 4854:            return 'refused'; 
 4855:         }
 4856:         $mrole='cr';
 4857:     } elsif ($role =~ /^gr\//) {
 4858:         my $cwogrp=$url;
 4859:         $cwogrp=~s{^/($match_domain)/($match_courseid)/.*}{$1/$2};
 4860:         unless (&allowed('mdg',$cwogrp)) {
 4861:             &logthis('Refused group assignrole: '.
 4862:               $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
 4863:                     $env{'user.name'}.' at '.$env{'user.domain'});
 4864:             return 'refused';
 4865:         }
 4866:         $mrole='gr';
 4867:     } else {
 4868:         my $cwosec=$url;
 4869:         $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
 4870:         unless ((&allowed('c'.$role,$cwosec)) || &allowed('c'.$role,$udom)) { 
 4871:            &logthis('Refused assignrole: '.
 4872:              $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
 4873: 		    $env{'user.name'}.' at '.$env{'user.domain'});
 4874:            return 'refused'; 
 4875:         }
 4876:         $mrole=$role;
 4877:     }
 4878:     my $command="encrypt:rolesput:$env{'user.domain'}:$env{'user.name'}:".
 4879:                 "$udom:$uname:$url".'_'."$mrole=$role";
 4880:     if ($end) { $command.='_'.$end; }
 4881:     if ($start) {
 4882: 	if ($end) { 
 4883:            $command.='_'.$start; 
 4884:         } else {
 4885:            $command.='_0_'.$start;
 4886:         }
 4887:     }
 4888:     my $origstart = $start;
 4889:     my $origend = $end;
 4890: # actually delete
 4891:     if ($deleteflag) {
 4892: 	if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) {
 4893: # modify command to delete the role
 4894:            $command="encrypt:rolesdel:$env{'user.domain'}:$env{'user.name'}:".
 4895:                 "$udom:$uname:$url".'_'."$mrole";
 4896: 	   &logthis("$env{'user.name'} at $env{'user.domain'} deletes $mrole in $url for $uname at $udom"); 
 4897: # set start and finish to negative values for userrolelog
 4898:            $start=-1;
 4899:            $end=-1;
 4900:         }
 4901:     }
 4902: # send command
 4903:     my $answer=&reply($command,&homeserver($uname,$udom));
 4904: # log new user role if status is ok
 4905:     if ($answer eq 'ok') {
 4906: 	&userrolelog($role,$uname,$udom,$url,$start,$end);
 4907: # for course roles, perform group memberships changes triggered by role change.
 4908:         unless ($role =~ /^gr/) {
 4909:             &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend,
 4910:                                              $origstart);
 4911:         }
 4912:     }
 4913:     return $answer;
 4914: }
 4915: 
 4916: # -------------------------------------------------- Modify user authentication
 4917: # Overrides without validation
 4918: 
 4919: sub modifyuserauth {
 4920:     my ($udom,$uname,$umode,$upass)=@_;
 4921:     my $uhome=&homeserver($uname,$udom);
 4922:     unless (&allowed('mau',$udom)) { return 'refused'; }
 4923:     &logthis('Call to modify user authentication '.$udom.', '.$uname.', '.
 4924:              $umode.' by '.$env{'user.name'}.' at '.$env{'user.domain'}.
 4925:              ' in domain '.$env{'request.role.domain'});  
 4926:     my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'.
 4927: 		     &escape($upass),$uhome);
 4928:     &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},
 4929:         'Authentication changed for '.$udom.', '.$uname.', '.$umode.
 4930:          '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply);
 4931:     &log($udom,,$uname,$uhome,
 4932:         'Authentication changed by '.$env{'user.domain'}.', '.
 4933:                                      $env{'user.name'}.', '.$umode.
 4934:          '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply);
 4935:     unless ($reply eq 'ok') {
 4936:         &logthis('Authentication mode error: '.$reply);
 4937: 	return 'error: '.$reply;
 4938:     }   
 4939:     return 'ok';
 4940: }
 4941: 
 4942: # --------------------------------------------------------------- Modify a user
 4943: 
 4944: sub modifyuser {
 4945:     my ($udom,    $uname, $uid,
 4946:         $umode,   $upass, $first,
 4947:         $middle,  $last,  $gene,
 4948:         $forceid, $desiredhome, $email)=@_;
 4949:     $udom= &LONCAPA::clean_domain($udom);
 4950:     $uname=&LONCAPA::clean_username($uname);
 4951:     &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
 4952:              $umode.', '.$first.', '.$middle.', '.
 4953: 	     $last.', '.$gene.'(forceid: '.$forceid.')'.
 4954:              (defined($desiredhome) ? ' desiredhome = '.$desiredhome :
 4955:                                      ' desiredhome not specified'). 
 4956:              ' by '.$env{'user.name'}.' at '.$env{'user.domain'}.
 4957:              ' in domain '.$env{'request.role.domain'});
 4958:     my $uhome=&homeserver($uname,$udom,'true');
 4959: # ----------------------------------------------------------------- Create User
 4960:     if (($uhome eq 'no_host') && 
 4961: 	(($umode && $upass) || ($umode eq 'localauth'))) {
 4962:         my $unhome='';
 4963:         if (defined($desiredhome) && &host_domain($desiredhome) eq $udom) { 
 4964:             $unhome = $desiredhome;
 4965: 	} elsif($env{'course.'.$env{'request.course.id'}.'.domain'} eq $udom) {
 4966: 	    $unhome=$env{'course.'.$env{'request.course.id'}.'.home'};
 4967:         } else { # load balancing routine for determining $unhome
 4968:             my $loadm=10000000;
 4969: 	    my %servers = &get_servers($udom,'library');
 4970: 	    foreach my $tryserver (keys(%servers)) {
 4971: 		my $answer=reply('load',$tryserver);
 4972: 		if (($answer=~/\d+/) && ($answer<$loadm)) {
 4973: 		    $loadm=$answer;
 4974: 		    $unhome=$tryserver;
 4975: 		}
 4976: 	    }
 4977:         }
 4978:         if (($unhome eq '') || ($unhome eq 'no_host')) {
 4979: 	    return 'error: unable to find a home server for '.$uname.
 4980:                    ' in domain '.$udom;
 4981:         }
 4982:         my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':'.$umode.':'.
 4983:                          &escape($upass),$unhome);
 4984: 	unless ($reply eq 'ok') {
 4985:             return 'error: '.$reply;
 4986:         }   
 4987:         $uhome=&homeserver($uname,$udom,'true');
 4988:         if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) {
 4989: 	    return 'error: unable verify users home machine.';
 4990:         }
 4991:     }   # End of creation of new user
 4992: # ---------------------------------------------------------------------- Add ID
 4993:     if ($uid) {
 4994:        $uid=~tr/A-Z/a-z/;
 4995:        my %uidhash=&idrget($udom,$uname);
 4996:        if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/) 
 4997:          && (!$forceid)) {
 4998: 	  unless ($uid eq $uidhash{$uname}) {
 4999: 	      return 'error: user id "'.$uid.'" does not match '.
 5000:                   'current user id "'.$uidhash{$uname}.'".';
 5001:           }
 5002:        } else {
 5003: 	  &idput($udom,($uname => $uid));
 5004:        }
 5005:     }
 5006: # -------------------------------------------------------------- Add names, etc
 5007:     my @tmp=&get('environment',
 5008: 		   ['firstname','middlename','lastname','generation'],
 5009: 		   $udom,$uname);
 5010:     my %names;
 5011:     if ($tmp[0] =~ m/^error:.*/) { 
 5012:         %names=(); 
 5013:     } else {
 5014:         %names = @tmp;
 5015:     }
 5016: #
 5017: # Make sure to not trash student environment if instructor does not bother
 5018: # to supply name and email information
 5019: #
 5020:     if ($first)  { $names{'firstname'}  = $first; }
 5021:     if (defined($middle)) { $names{'middlename'} = $middle; }
 5022:     if ($last)   { $names{'lastname'}   = $last; }
 5023:     if (defined($gene))   { $names{'generation'} = $gene; }
 5024:     if ($email) {
 5025:        $email=~s/[^\w\@\.\-\,]//gs;
 5026:        if ($email=~/\@/) { $names{'notification'} = $email;
 5027: 			   $names{'critnotification'} = $email;
 5028: 			   $names{'permanentemail'} = $email; }
 5029:     }
 5030:     my $reply = &put('environment', \%names, $udom,$uname);
 5031:     if ($reply ne 'ok') { return 'error: '.$reply; }
 5032:     &devalidate_cache_new('namescache',$uname.':'.$udom);
 5033:     &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
 5034:              $umode.', '.$first.', '.$middle.', '.
 5035: 	     $last.', '.$gene.' by '.
 5036:              $env{'user.name'}.' at '.$env{'user.domain'});
 5037:     return 'ok';
 5038: }
 5039: 
 5040: # -------------------------------------------------------------- Modify student
 5041: 
 5042: sub modifystudent {
 5043:     my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
 5044:         $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid)=@_;
 5045:     if (!$cid) {
 5046: 	unless ($cid=$env{'request.course.id'}) {
 5047: 	    return 'not_in_class';
 5048: 	}
 5049:     }
 5050: # --------------------------------------------------------------- Make the user
 5051:     my $reply=&modifyuser
 5052: 	($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid,
 5053:          $desiredhome,$email);
 5054:     unless ($reply eq 'ok') { return $reply; }
 5055:     # This will cause &modify_student_enrollment to get the uid from the
 5056:     # students environment
 5057:     $uid = undef if (!$forceid);
 5058:     $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,
 5059: 					$gene,$usec,$end,$start,$type,$locktype,$cid);
 5060:     return $reply;
 5061: }
 5062: 
 5063: sub modify_student_enrollment {
 5064:     my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid) = @_;
 5065:     my ($cdom,$cnum,$chome);
 5066:     if (!$cid) {
 5067: 	unless ($cid=$env{'request.course.id'}) {
 5068: 	    return 'not_in_class';
 5069: 	}
 5070: 	$cdom=$env{'course.'.$cid.'.domain'};
 5071: 	$cnum=$env{'course.'.$cid.'.num'};
 5072:     } else {
 5073: 	($cdom,$cnum)=split(/_/,$cid);
 5074:     }
 5075:     $chome=$env{'course.'.$cid.'.home'};
 5076:     if (!$chome) {
 5077: 	$chome=&homeserver($cnum,$cdom);
 5078:     }
 5079:     if (!$chome) { return 'unknown_course'; }
 5080:     # Make sure the user exists
 5081:     my $uhome=&homeserver($uname,$udom);
 5082:     if (($uhome eq '') || ($uhome eq 'no_host')) { 
 5083: 	return 'error: no such user';
 5084:     }
 5085:     # Get student data if we were not given enough information
 5086:     if (!defined($first)  || $first  eq '' || 
 5087:         !defined($last)   || $last   eq '' || 
 5088:         !defined($uid)    || $uid    eq '' || 
 5089:         !defined($middle) || $middle eq '' || 
 5090:         !defined($gene)   || $gene   eq '') {
 5091:         # They did not supply us with enough data to enroll the student, so
 5092:         # we need to pick up more information.
 5093:         my %tmp = &get('environment',
 5094:                        ['firstname','middlename','lastname', 'generation','id']
 5095:                        ,$udom,$uname);
 5096: 
 5097:         #foreach my $key (keys(%tmp)) {
 5098:         #    &logthis("key $key = ".$tmp{$key});
 5099:         #}
 5100:         $first  = $tmp{'firstname'}  if (!defined($first)  || $first  eq '');
 5101:         $middle = $tmp{'middlename'} if (!defined($middle) || $middle eq '');
 5102:         $last   = $tmp{'lastname'}   if (!defined($last)   || $last eq '');
 5103:         $gene   = $tmp{'generation'} if (!defined($gene)   || $gene eq '');
 5104:         $uid    = $tmp{'id'}         if (!defined($uid)    || $uid  eq '');
 5105:     }
 5106:     my $fullname = &format_name($first,$middle,$last,$gene,'lastname');
 5107:     my $reply=cput('classlist',
 5108: 		   {"$uname:$udom" => 
 5109: 			join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) },
 5110: 		   $cdom,$cnum);
 5111:     unless (($reply eq 'ok') || ($reply eq 'delayed')) {
 5112: 	return 'error: '.$reply;
 5113:     } else {
 5114: 	&devalidate_getsection_cache($udom,$uname,$cid);
 5115:     }
 5116:     # Add student role to user
 5117:     my $uurl='/'.$cid;
 5118:     $uurl=~s/\_/\//g;
 5119:     if ($usec) {
 5120: 	$uurl.='/'.$usec;
 5121:     }
 5122:     return &assignrole($udom,$uname,$uurl,'st',$end,$start);
 5123: }
 5124: 
 5125: sub format_name {
 5126:     my ($firstname,$middlename,$lastname,$generation,$first)=@_;
 5127:     my $name;
 5128:     if ($first ne 'lastname') {
 5129: 	$name=$firstname.' '.$middlename.' '.$lastname.' '.$generation;
 5130:     } else {
 5131: 	if ($lastname=~/\S/) {
 5132: 	    $name.= $lastname.' '.$generation.', '.$firstname.' '.$middlename;
 5133: 	    $name=~s/\s+,/,/;
 5134: 	} else {
 5135: 	    $name.= $firstname.' '.$middlename.' '.$generation;
 5136: 	}
 5137:     }
 5138:     $name=~s/^\s+//;
 5139:     $name=~s/\s+$//;
 5140:     $name=~s/\s+/ /g;
 5141:     return $name;
 5142: }
 5143: 
 5144: # ------------------------------------------------- Write to course preferences
 5145: 
 5146: sub writecoursepref {
 5147:     my ($courseid,%prefs)=@_;
 5148:     $courseid=~s/^\///;
 5149:     $courseid=~s/\_/\//g;
 5150:     my ($cdomain,$cnum)=split(/\//,$courseid);
 5151:     my $chome=homeserver($cnum,$cdomain);
 5152:     if (($chome eq '') || ($chome eq 'no_host')) { 
 5153: 	return 'error: no such course';
 5154:     }
 5155:     my $cstring='';
 5156:     foreach my $pref (keys(%prefs)) {
 5157: 	$cstring.=&escape($pref).'='.&escape($prefs{$pref}).'&';
 5158:     }
 5159:     $cstring=~s/\&$//;
 5160:     return reply('put:'.$cdomain.':'.$cnum.':environment:'.$cstring,$chome);
 5161: }
 5162: 
 5163: # ---------------------------------------------------------- Make/modify course
 5164: 
 5165: sub createcourse {
 5166:     my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,
 5167:         $course_owner,$crstype)=@_;
 5168:     $url=&declutter($url);
 5169:     my $cid='';
 5170:     unless (&allowed('ccc',$udom)) {
 5171:         return 'refused';
 5172:     }
 5173: # ------------------------------------------------------------------- Create ID
 5174:    my $uname=int(1+rand(9)).
 5175:        ('a'..'z','A'..'Z','0'..'9')[int(rand(62))].
 5176:        substr($$.time,0,5).unpack("H8",pack("I32",time)).
 5177:        unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
 5178: # ----------------------------------------------- Make sure that does not exist
 5179:    my $uhome=&homeserver($uname,$udom,'true');
 5180:    unless (($uhome eq '') || ($uhome eq 'no_host')) {
 5181:        $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).
 5182:         unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
 5183:        $uhome=&homeserver($uname,$udom,'true');       
 5184:        unless (($uhome eq '') || ($uhome eq 'no_host')) {
 5185:            return 'error: unable to generate unique course-ID';
 5186:        } 
 5187:    }
 5188: # ------------------------------------------------ Check supplied server name
 5189:     $course_server = $env{'user.homeserver'} if (! defined($course_server));
 5190:     if (! &is_library($course_server)) {
 5191:         return 'error:bad server name '.$course_server;
 5192:     }
 5193: # ------------------------------------------------------------- Make the course
 5194:     my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',
 5195:                       $course_server);
 5196:     unless ($reply eq 'ok') { return 'error: '.$reply; }
 5197:     $uhome=&homeserver($uname,$udom,'true');
 5198:     if (($uhome eq '') || ($uhome eq 'no_host')) { 
 5199: 	return 'error: no such course';
 5200:     }
 5201: # ----------------------------------------------------------------- Course made
 5202: # log existence
 5203:     &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description).
 5204:                  ':'.&escape($inst_code).':'.&escape($course_owner).':'.
 5205:                   &escape($crstype),$uhome);
 5206:     &flushcourselogs();
 5207: # set toplevel url
 5208:     my $topurl=$url;
 5209:     unless ($nonstandard) {
 5210: # ------------------------------------------ For standard courses, make top url
 5211:         my $mapurl=&clutter($url);
 5212:         if ($mapurl eq '/res/') { $mapurl=''; }
 5213:         $env{'form.initmap'}=(<<ENDINITMAP);
 5214: <map>
 5215: <resource id="1" type="start"></resource>
 5216: <resource id="2" src="$mapurl"></resource>
 5217: <resource id="3" type="finish"></resource>
 5218: <link index="1" from="1" to="2"></link>
 5219: <link index="2" from="2" to="3"></link>
 5220: </map>
 5221: ENDINITMAP
 5222:         $topurl=&declutter(
 5223:         &finishuserfileupload($uname,$udom,'initmap','default.sequence')
 5224:                           );
 5225:     }
 5226: # ----------------------------------------------------------- Write preferences
 5227:     &writecoursepref($udom.'_'.$uname,
 5228:                      ('description' => $description,
 5229:                       'url'         => $topurl));
 5230:     return '/'.$udom.'/'.$uname;
 5231: }
 5232: 
 5233: sub is_course {
 5234:     my ($cdom,$cnum) = @_;
 5235:     my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,
 5236: 				undef,'.');
 5237:     if (exists($courses{$cdom.'_'.$cnum})) {
 5238:         return 1;
 5239:     }
 5240:     return 0;
 5241: }
 5242: 
 5243: # ---------------------------------------------------------- Assign Custom Role
 5244: 
 5245: sub assigncustomrole {
 5246:     my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag)=@_;
 5247:     return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename,
 5248:                        $end,$start,$deleteflag);
 5249: }
 5250: 
 5251: # ----------------------------------------------------------------- Revoke Role
 5252: 
 5253: sub revokerole {
 5254:     my ($udom,$uname,$url,$role,$deleteflag)=@_;
 5255:     my $now=time;
 5256:     return &assignrole($udom,$uname,$url,$role,$now,$deleteflag);
 5257: }
 5258: 
 5259: # ---------------------------------------------------------- Revoke Custom Role
 5260: 
 5261: sub revokecustomrole {
 5262:     my ($udom,$uname,$url,$rdom,$rnam,$rolename,$deleteflag)=@_;
 5263:     my $now=time;
 5264:     return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now,
 5265:            $deleteflag);
 5266: }
 5267: 
 5268: # ------------------------------------------------------------ Disk usage
 5269: sub diskusage {
 5270:     my ($udom,$uname,$directoryRoot)=@_;
 5271:     $directoryRoot =~ s/\/$//;
 5272:     my $listing=&reply('du:'.$directoryRoot,homeserver($uname,$udom));
 5273:     return $listing;
 5274: }
 5275: 
 5276: sub is_locked {
 5277:     my ($file_name, $domain, $user) = @_;
 5278:     my @check;
 5279:     my $is_locked;
 5280:     push @check, $file_name;
 5281:     my %locked = &get('file_permissions',\@check,
 5282: 		      $env{'user.domain'},$env{'user.name'});
 5283:     my ($tmp)=keys(%locked);
 5284:     if ($tmp=~/^error:/) { undef(%locked); }
 5285:     
 5286:     if (ref($locked{$file_name}) eq 'ARRAY') {
 5287:         $is_locked = 'false';
 5288:         foreach my $entry (@{$locked{$file_name}}) {
 5289:            if (ref($entry) eq 'ARRAY') { 
 5290:                $is_locked = 'true';
 5291:                last;
 5292:            }
 5293:        }
 5294:     } else {
 5295:         $is_locked = 'false';
 5296:     }
 5297: }
 5298: 
 5299: sub declutter_portfile {
 5300:     my ($file) = @_;
 5301:     $file =~ s{^(/portfolio/|portfolio/)}{/};
 5302:     return $file;
 5303: }
 5304: 
 5305: # ------------------------------------------------------------- Mark as Read Only
 5306: 
 5307: sub mark_as_readonly {
 5308:     my ($domain,$user,$files,$what) = @_;
 5309:     my %current_permissions = &dump('file_permissions',$domain,$user);
 5310:     my ($tmp)=keys(%current_permissions);
 5311:     if ($tmp=~/^error:/) { undef(%current_permissions); }
 5312:     foreach my $file (@{$files}) {
 5313: 	$file = &declutter_portfile($file);
 5314:         push(@{$current_permissions{$file}},$what);
 5315:     }
 5316:     &put('file_permissions',\%current_permissions,$domain,$user);
 5317:     return;
 5318: }
 5319: 
 5320: # ------------------------------------------------------------Save Selected Files
 5321: 
 5322: sub save_selected_files {
 5323:     my ($user, $path, @files) = @_;
 5324:     my $filename = $user."savedfiles";
 5325:     my @other_files = &files_not_in_path($user, $path);
 5326:     open (OUT, '>'.$tmpdir.$filename);
 5327:     foreach my $file (@files) {
 5328:         print (OUT $env{'form.currentpath'}.$file."\n");
 5329:     }
 5330:     foreach my $file (@other_files) {
 5331:         print (OUT $file."\n");
 5332:     }
 5333:     close (OUT);
 5334:     return 'ok';
 5335: }
 5336: 
 5337: sub clear_selected_files {
 5338:     my ($user) = @_;
 5339:     my $filename = $user."savedfiles";
 5340:     open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
 5341:     print (OUT undef);
 5342:     close (OUT);
 5343:     return ("ok");    
 5344: }
 5345: 
 5346: sub files_in_path {
 5347:     my ($user, $path) = @_;
 5348:     my $filename = $user."savedfiles";
 5349:     my %return_files;
 5350:     open (IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
 5351:     while (my $line_in = <IN>) {
 5352:         chomp ($line_in);
 5353:         my @paths_and_file = split (m!/!, $line_in);
 5354:         my $file_part = pop (@paths_and_file);
 5355:         my $path_part = join ('/', @paths_and_file);
 5356:         $path_part.='/';
 5357:         my $path_and_file = $path_part.$file_part;
 5358:         if ($path_part eq $path) {
 5359:             $return_files{$file_part}= 'selected';
 5360:         }
 5361:     }
 5362:     close (IN);
 5363:     return (\%return_files);
 5364: }
 5365: 
 5366: # called in portfolio select mode, to show files selected NOT in current directory
 5367: sub files_not_in_path {
 5368:     my ($user, $path) = @_;
 5369:     my $filename = $user."savedfiles";
 5370:     my @return_files;
 5371:     my $path_part;
 5372:     open(IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
 5373:     while (my $line = <IN>) {
 5374:         #ok, I know it's clunky, but I want it to work
 5375:         my @paths_and_file = split(m|/|, $line);
 5376:         my $file_part = pop(@paths_and_file);
 5377:         chomp($file_part);
 5378:         my $path_part = join('/', @paths_and_file);
 5379:         $path_part .= '/';
 5380:         my $path_and_file = $path_part.$file_part;
 5381:         if ($path_part ne $path) {
 5382:             push(@return_files, ($path_and_file));
 5383:         }
 5384:     }
 5385:     close(OUT);
 5386:     return (@return_files);
 5387: }
 5388: 
 5389: #----------------------------------------------Get portfolio file permissions
 5390: 
 5391: sub get_portfile_permissions {
 5392:     my ($domain,$user) = @_;
 5393:     my %current_permissions = &dump('file_permissions',$domain,$user);
 5394:     my ($tmp)=keys(%current_permissions);
 5395:     if ($tmp=~/^error:/) { undef(%current_permissions); }
 5396:     return \%current_permissions;
 5397: }
 5398: 
 5399: #---------------------------------------------Get portfolio file access controls
 5400: 
 5401: sub get_access_controls {
 5402:     my ($current_permissions,$group,$file) = @_;
 5403:     my %access;
 5404:     my $real_file = $file;
 5405:     $file =~ s/\.meta$//;
 5406:     if (defined($file)) {
 5407:         if (ref($$current_permissions{$file."\0".'accesscontrol'}) eq 'HASH') {
 5408:             foreach my $control (keys(%{$$current_permissions{$file."\0".'accesscontrol'}})) {
 5409:                 $access{$real_file}{$control} = $$current_permissions{$file."\0".$control};
 5410:             }
 5411:         }
 5412:     } else {
 5413:         foreach my $key (keys(%{$current_permissions})) {
 5414:             if ($key =~ /\0accesscontrol$/) {
 5415:                 if (defined($group)) {
 5416:                     if ($key !~ m-^\Q$group\E/-) {
 5417:                         next;
 5418:                     }
 5419:                 }
 5420:                 my ($fullpath) = split(/\0/,$key);
 5421:                 if (ref($$current_permissions{$key}) eq 'HASH') {
 5422:                     foreach my $control (keys(%{$$current_permissions{$key}})) {
 5423:                         $access{$fullpath}{$control}=$$current_permissions{$fullpath."\0".$control};
 5424:                     }
 5425:                 }
 5426:             }
 5427:         }
 5428:     }
 5429:     return %access;
 5430: }
 5431: 
 5432: sub modify_access_controls {
 5433:     my ($file_name,$changes,$domain,$user)=@_;
 5434:     my ($outcome,$deloutcome);
 5435:     my %store_permissions;
 5436:     my %new_values;
 5437:     my %new_control;
 5438:     my %translation;
 5439:     my @deletions = ();
 5440:     my $now = time;
 5441:     if (exists($$changes{'activate'})) {
 5442:         if (ref($$changes{'activate'}) eq 'HASH') {
 5443:             my @newitems = sort(keys(%{$$changes{'activate'}}));
 5444:             my $numnew = scalar(@newitems);
 5445:             for (my $i=0; $i<$numnew; $i++) {
 5446:                 my $newkey = $newitems[$i];
 5447:                 my $newid = &Apache::loncommon::get_cgi_id();
 5448:                 if ($newkey =~ /^\d+:/) { 
 5449:                     $newkey =~ s/^(\d+)/$newid/;
 5450:                     $translation{$1} = $newid;
 5451:                 } elsif ($newkey =~ /^\d+_\d+_\d+:/) {
 5452:                     $newkey =~ s/^(\d+_\d+_\d+)/$newid/;
 5453:                     $translation{$1} = $newid;
 5454:                 }
 5455:                 $new_values{$file_name."\0".$newkey} = 
 5456:                                           $$changes{'activate'}{$newitems[$i]};
 5457:                 $new_control{$newkey} = $now;
 5458:             }
 5459:         }
 5460:     }
 5461:     my %todelete;
 5462:     my %changed_items;
 5463:     foreach my $action ('delete','update') {
 5464:         if (exists($$changes{$action})) {
 5465:             if (ref($$changes{$action}) eq 'HASH') {
 5466:                 foreach my $key (keys(%{$$changes{$action}})) {
 5467:                     my ($itemnum) = ($key =~ /^([^:]+):/);
 5468:                     if ($action eq 'delete') { 
 5469:                         $todelete{$itemnum} = 1;
 5470:                     } else {
 5471:                         $changed_items{$itemnum} = $key;
 5472:                     }
 5473:                 }
 5474:             }
 5475:         }
 5476:     }
 5477:     # get lock on access controls for file.
 5478:     my $lockhash = {
 5479:                   $file_name."\0".'locked_access_records' => $env{'user.name'}.
 5480:                                                        ':'.$env{'user.domain'},
 5481:                    }; 
 5482:     my $tries = 0;
 5483:     my $gotlock = &newput('file_permissions',$lockhash,$domain,$user);
 5484:    
 5485:     while (($gotlock ne 'ok') && $tries <3) {
 5486:         $tries ++;
 5487:         sleep 1;
 5488:         $gotlock = &newput('file_permissions',$lockhash,$domain,$user);
 5489:     }
 5490:     if ($gotlock eq 'ok') {
 5491:         my %curr_permissions = &dump('file_permissions',$domain,$user,$file_name);
 5492:         my ($tmp)=keys(%curr_permissions);
 5493:         if ($tmp=~/^error:/) { undef(%curr_permissions); }
 5494:         if (exists($curr_permissions{$file_name."\0".'accesscontrol'})) {
 5495:             my $curr_controls = $curr_permissions{$file_name."\0".'accesscontrol'};
 5496:             if (ref($curr_controls) eq 'HASH') {
 5497:                 foreach my $control_item (keys(%{$curr_controls})) {
 5498:                     my ($itemnum) = ($control_item =~ /^([^:]+):/);
 5499:                     if (defined($todelete{$itemnum})) {
 5500:                         push(@deletions,$file_name."\0".$control_item);
 5501:                     } else {
 5502:                         if (defined($changed_items{$itemnum})) {
 5503:                             $new_control{$changed_items{$itemnum}} = $now;
 5504:                             push(@deletions,$file_name."\0".$control_item);
 5505:                             $new_values{$file_name."\0".$changed_items{$itemnum}} = $$changes{'update'}{$changed_items{$itemnum}};
 5506:                         } else {
 5507:                             $new_control{$control_item} = $$curr_controls{$control_item};
 5508:                         }
 5509:                     }
 5510:                 }
 5511:             }
 5512:         }
 5513:         $deloutcome = &del('file_permissions',\@deletions,$domain,$user);
 5514:         $new_values{$file_name."\0".'accesscontrol'} = \%new_control;
 5515:         $outcome = &put('file_permissions',\%new_values,$domain,$user);
 5516:         #  remove lock
 5517:         my @del_lock = ($file_name."\0".'locked_access_records');
 5518:         my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user);
 5519:         my ($file,$group);
 5520:         if (&is_course($domain,$user)) {
 5521:             ($group,$file) = split(/\//,$file_name,2);
 5522:         } else {
 5523:             $file = $file_name;
 5524:         }
 5525:         my $sqlresult =
 5526:             &update_portfolio_table($user,$domain,$file,'portfolio_access',
 5527:                                     $group);
 5528:     } else {
 5529:         $outcome = "error: could not obtain lockfile\n";  
 5530:     }
 5531:     return ($outcome,$deloutcome,\%new_values,\%translation);
 5532: }
 5533: 
 5534: sub make_public_indefinitely {
 5535:     my ($requrl) = @_;
 5536:     my $now = time;
 5537:     my $action = 'activate';
 5538:     my $aclnum = 0;
 5539:     if (&is_portfolio_url($requrl)) {
 5540:         my (undef,$udom,$unum,$file_name,$group) =
 5541:             &parse_portfolio_url($requrl);
 5542:         my $current_perms = &get_portfile_permissions($udom,$unum);
 5543:         my %access_controls = &get_access_controls($current_perms,
 5544:                                                    $group,$file_name);
 5545:         foreach my $key (keys(%{$access_controls{$file_name}})) {
 5546:             my ($num,$scope,$end,$start) = 
 5547:                 ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/);
 5548:             if ($scope eq 'public') {
 5549:                 if ($start <= $now && $end == 0) {
 5550:                     $action = 'none';
 5551:                 } else {
 5552:                     $action = 'update';
 5553:                     $aclnum = $num;
 5554:                 }
 5555:                 last;
 5556:             }
 5557:         }
 5558:         if ($action eq 'none') {
 5559:              return 'ok';
 5560:         } else {
 5561:             my %changes;
 5562:             my $newend = 0;
 5563:             my $newstart = $now;
 5564:             my $newkey = $aclnum.':public_'.$newend.'_'.$newstart;
 5565:             $changes{$action}{$newkey} = {
 5566:                 type => 'public',
 5567:                 time => {
 5568:                     start => $newstart,
 5569:                     end   => $newend,
 5570:                 },
 5571:             };
 5572:             my ($outcome,$deloutcome,$new_values,$translation) =
 5573:                 &modify_access_controls($file_name,\%changes,$udom,$unum);
 5574:             return $outcome;
 5575:         }
 5576:     } else {
 5577:         return 'invalid';
 5578:     }
 5579: }
 5580: 
 5581: #------------------------------------------------------Get Marked as Read Only
 5582: 
 5583: sub get_marked_as_readonly {
 5584:     my ($domain,$user,$what,$group) = @_;
 5585:     my $current_permissions = &get_portfile_permissions($domain,$user);
 5586:     my @readonly_files;
 5587:     my $cmp1=$what;
 5588:     if (ref($what)) { $cmp1=join('',@{$what}) };
 5589:     while (my ($file_name,$value) = each(%{$current_permissions})) {
 5590:         if (defined($group)) {
 5591:             if ($file_name !~ m-^\Q$group\E/-) {
 5592:                 next;
 5593:             }
 5594:         }
 5595:         if (ref($value) eq "ARRAY"){
 5596:             foreach my $stored_what (@{$value}) {
 5597:                 my $cmp2=$stored_what;
 5598:                 if (ref($stored_what) eq 'ARRAY') {
 5599:                     $cmp2=join('',@{$stored_what});
 5600:                 }
 5601:                 if ($cmp1 eq $cmp2) {
 5602:                     push(@readonly_files, $file_name);
 5603:                     last;
 5604:                 } elsif (!defined($what)) {
 5605:                     push(@readonly_files, $file_name);
 5606:                     last;
 5607:                 }
 5608:             }
 5609:         }
 5610:     }
 5611:     return @readonly_files;
 5612: }
 5613: #-----------------------------------------------------------Get Marked as Read Only Hash
 5614: 
 5615: sub get_marked_as_readonly_hash {
 5616:     my ($current_permissions,$group,$what) = @_;
 5617:     my %readonly_files;
 5618:     while (my ($file_name,$value) = each(%{$current_permissions})) {
 5619:         if (defined($group)) {
 5620:             if ($file_name !~ m-^\Q$group\E/-) {
 5621:                 next;
 5622:             }
 5623:         }
 5624:         if (ref($value) eq "ARRAY"){
 5625:             foreach my $stored_what (@{$value}) {
 5626:                 if (ref($stored_what) eq 'ARRAY') {
 5627:                     foreach my $lock_descriptor(@{$stored_what}) {
 5628:                         if ($lock_descriptor eq 'graded') {
 5629:                             $readonly_files{$file_name} = 'graded';
 5630:                         } elsif ($lock_descriptor eq 'handback') {
 5631:                             $readonly_files{$file_name} = 'handback';
 5632:                         } else {
 5633:                             if (!exists($readonly_files{$file_name})) {
 5634:                                 $readonly_files{$file_name} = 'locked';
 5635:                             }
 5636:                         }
 5637:                     }
 5638:                 } 
 5639:             }
 5640:         } 
 5641:     }
 5642:     return %readonly_files;
 5643: }
 5644: # ------------------------------------------------------------ Unmark as Read Only
 5645: 
 5646: sub unmark_as_readonly {
 5647:     # unmarks $file_name (if $file_name is defined), or all files locked by $what 
 5648:     # for portfolio submissions, $what contains [$symb,$crsid] 
 5649:     my ($domain,$user,$what,$file_name,$group) = @_;
 5650:     $file_name = &declutter_portfile($file_name);
 5651:     my $symb_crs = $what;
 5652:     if (ref($what)) { $symb_crs=join('',@$what); }
 5653:     my %current_permissions = &dump('file_permissions',$domain,$user,$group);
 5654:     my ($tmp)=keys(%current_permissions);
 5655:     if ($tmp=~/^error:/) { undef(%current_permissions); }
 5656:     my @readonly_files = &get_marked_as_readonly($domain,$user,$what,$group);
 5657:     foreach my $file (@readonly_files) {
 5658: 	my $clean_file = &declutter_portfile($file);
 5659: 	if (defined($file_name) && ($file_name ne $clean_file)) { next; }
 5660: 	my $current_locks = $current_permissions{$file};
 5661:         my @new_locks;
 5662:         my @del_keys;
 5663:         if (ref($current_locks) eq "ARRAY"){
 5664:             foreach my $locker (@{$current_locks}) {
 5665:                 my $compare=$locker;
 5666:                 if (ref($locker) eq 'ARRAY') {
 5667:                     $compare=join('',@{$locker});
 5668:                     if ($compare ne $symb_crs) {
 5669:                         push(@new_locks, $locker);
 5670:                     }
 5671:                 }
 5672:             }
 5673:             if (scalar(@new_locks) > 0) {
 5674:                 $current_permissions{$file} = \@new_locks;
 5675:             } else {
 5676:                 push(@del_keys, $file);
 5677:                 &del('file_permissions',\@del_keys, $domain, $user);
 5678:                 delete($current_permissions{$file});
 5679:             }
 5680:         }
 5681:     }
 5682:     &put('file_permissions',\%current_permissions,$domain,$user);
 5683:     return;
 5684: }
 5685: 
 5686: # ------------------------------------------------------------ Directory lister
 5687: 
 5688: sub dirlist {
 5689:     my ($uri,$userdomain,$username,$alternateDirectoryRoot)=@_;
 5690: 
 5691:     $uri=~s/^\///;
 5692:     $uri=~s/\/$//;
 5693:     my ($udom, $uname);
 5694:     (undef,$udom,$uname)=split(/\//,$uri);
 5695:     if(defined($userdomain)) {
 5696:         $udom = $userdomain;
 5697:     }
 5698:     if(defined($username)) {
 5699:         $uname = $username;
 5700:     }
 5701: 
 5702:     my $dirRoot = $perlvar{'lonDocRoot'};
 5703:     if(defined($alternateDirectoryRoot)) {
 5704:         $dirRoot = $alternateDirectoryRoot;
 5705:         $dirRoot =~ s/\/$//;
 5706:     }
 5707: 
 5708:     if($udom) {
 5709:         if($uname) {
 5710:             my $listing = &reply('ls2:'.$dirRoot.'/'.$uri,
 5711: 				 &homeserver($uname,$udom));
 5712:             my @listing_results;
 5713:             if ($listing eq 'unknown_cmd') {
 5714:                 $listing = &reply('ls:'.$dirRoot.'/'.$uri,
 5715: 				  &homeserver($uname,$udom));
 5716:                 @listing_results = split(/:/,$listing);
 5717:             } else {
 5718:                 @listing_results = map { &unescape($_); } split(/:/,$listing);
 5719:             }
 5720:             return @listing_results;
 5721:         } elsif(!defined($alternateDirectoryRoot)) {
 5722:             my %allusers;
 5723: 	    my %servers = &get_servers($udom,'library');
 5724: 	    foreach my $tryserver (keys(%servers)) {
 5725: 		my $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'.
 5726: 				     $udom, $tryserver);
 5727: 		my @listing_results;
 5728: 		if ($listing eq 'unknown_cmd') {
 5729: 		    $listing = &reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.
 5730: 				      $udom, $tryserver);
 5731: 		    @listing_results = split(/:/,$listing);
 5732: 		} else {
 5733: 		    @listing_results =
 5734: 			map { &unescape($_); } split(/:/,$listing);
 5735: 		}
 5736: 		if ($listing_results[0] ne 'no_such_dir' && 
 5737: 		    $listing_results[0] ne 'empty'       &&
 5738: 		    $listing_results[0] ne 'con_lost') {
 5739: 		    foreach my $line (@listing_results) {
 5740: 			my ($entry) = split(/&/,$line,2);
 5741: 			$allusers{$entry} = 1;
 5742: 		    }
 5743: 		}
 5744:             }
 5745:             my $alluserstr='';
 5746:             foreach my $user (sort(keys(%allusers))) {
 5747:                 $alluserstr.=$user.'&user:';
 5748:             }
 5749:             $alluserstr=~s/:$//;
 5750:             return split(/:/,$alluserstr);
 5751:         } else {
 5752:             return ('missing user name');
 5753:         }
 5754:     } elsif(!defined($alternateDirectoryRoot)) {
 5755:         my @all_domains = sort(&all_domains());
 5756:          foreach my $domain (@all_domains) {
 5757:              $domain = $perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain';
 5758:          }
 5759:          return @all_domains;
 5760:      } else {
 5761:         return ('missing domain');
 5762:     }
 5763: }
 5764: 
 5765: # --------------------------------------------- GetFileTimestamp
 5766: # This function utilizes dirlist and returns the date stamp for
 5767: # when it was last modified.  It will also return an error of -1
 5768: # if an error occurs
 5769: 
 5770: ##
 5771: ## FIXME: This subroutine assumes its caller knows something about the
 5772: ## directory structure of the home server for the student ($root).
 5773: ## Not a good assumption to make.  Since this is for looking up files
 5774: ## in user directories, the full path should be constructed by lond, not
 5775: ## whatever machine we request data from.
 5776: ##
 5777: sub GetFileTimestamp {
 5778:     my ($studentDomain,$studentName,$filename,$root)=@_;
 5779:     $studentDomain = &LONCAPA::clean_domain($studentDomain);
 5780:     $studentName   = &LONCAPA::clean_username($studentName);
 5781:     my $subdir=$studentName.'__';
 5782:     $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
 5783:     my $proname="$studentDomain/$subdir/$studentName";
 5784:     $proname .= '/'.$filename;
 5785:     my ($fileStat) = &Apache::lonnet::dirlist($proname, $studentDomain, 
 5786:                                               $studentName, $root);
 5787:     my @stats = split('&', $fileStat);
 5788:     if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {
 5789:         # @stats contains first the filename, then the stat output
 5790:         return $stats[10]; # so this is 10 instead of 9.
 5791:     } else {
 5792:         return -1;
 5793:     }
 5794: }
 5795: 
 5796: sub stat_file {
 5797:     my ($uri) = @_;
 5798:     $uri = &clutter_with_no_wrapper($uri);
 5799: 
 5800:     my ($udom,$uname,$file,$dir);
 5801:     if ($uri =~ m-^/(uploaded|editupload)/-) {
 5802: 	($udom,$uname,$file) =
 5803: 	    ($uri =~ m-/(?:uploaded|editupload)/?($match_domain)/?($match_name)/?(.*)-);
 5804: 	$file = 'userfiles/'.$file;
 5805: 	$dir = &propath($udom,$uname);
 5806:     }
 5807:     if ($uri =~ m-^/res/-) {
 5808: 	($udom,$uname) = 
 5809: 	    ($uri =~ m-/(?:res)/?($match_domain)/?($match_username)/-);
 5810: 	$file = $uri;
 5811:     }
 5812: 
 5813:     if (!$udom || !$uname || !$file) {
 5814: 	# unable to handle the uri
 5815: 	return ();
 5816:     }
 5817: 
 5818:     my ($result) = &dirlist($file,$udom,$uname,$dir);
 5819:     my @stats = split('&', $result);
 5820:     
 5821:     if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {
 5822: 	shift(@stats); #filename is first
 5823: 	return @stats;
 5824:     }
 5825:     return ();
 5826: }
 5827: 
 5828: # -------------------------------------------------------- Value of a Condition
 5829: 
 5830: # gets the value of a specific preevaluated condition
 5831: #    stored in the string  $env{user.state.<cid>}
 5832: # or looks up a condition reference in the bighash and if if hasn't
 5833: # already been evaluated recurses into docondval to get the value of
 5834: # the condition, then memoizing it to 
 5835: #   $env{user.state.<cid>.<condition>}
 5836: sub directcondval {
 5837:     my $number=shift;
 5838:     if (!defined($env{'user.state.'.$env{'request.course.id'}})) {
 5839: 	&Apache::lonuserstate::evalstate();
 5840:     }
 5841:     if (exists($env{'user.state.'.$env{'request.course.id'}.".$number"})) {
 5842: 	return $env{'user.state.'.$env{'request.course.id'}.".$number"};
 5843:     } elsif ($number =~ /^_/) {
 5844: 	my $sub_condition;
 5845: 	if (tie(my %bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
 5846: 		&GDBM_READER(),0640)) {
 5847: 	    $sub_condition=$bighash{'conditions'.$number};
 5848: 	    untie(%bighash);
 5849: 	}
 5850: 	my $value = &docondval($sub_condition);
 5851: 	&appenv('user.state.'.$env{'request.course.id'}.".$number" => $value);
 5852: 	return $value;
 5853:     }
 5854:     if ($env{'user.state.'.$env{'request.course.id'}}) {
 5855:        return substr($env{'user.state.'.$env{'request.course.id'}},$number,1);
 5856:     } else {
 5857:        return 2;
 5858:     }
 5859: }
 5860: 
 5861: # get the collection of conditions for this resource
 5862: sub condval {
 5863:     my $condidx=shift;
 5864:     my $allpathcond='';
 5865:     foreach my $cond (split(/\|/,$condidx)) {
 5866: 	if (defined($env{'acc.cond.'.$env{'request.course.id'}.'.'.$cond})) {
 5867: 	    $allpathcond.=
 5868: 		'('.$env{'acc.cond.'.$env{'request.course.id'}.'.'.$cond}.')|';
 5869: 	}
 5870:     }
 5871:     $allpathcond=~s/\|$//;
 5872:     return &docondval($allpathcond);
 5873: }
 5874: 
 5875: #evaluates an expression of conditions
 5876: sub docondval {
 5877:     my ($allpathcond) = @_;
 5878:     my $result=0;
 5879:     if ($env{'request.course.id'}
 5880: 	&& defined($allpathcond)) {
 5881: 	my $operand='|';
 5882: 	my @stack;
 5883: 	foreach my $chunk ($allpathcond=~/(\d+|_\d+\.\d+|\(|\)|\&|\|)/g) {
 5884: 	    if ($chunk eq '(') {
 5885: 		push @stack,($operand,$result);
 5886: 	    } elsif ($chunk eq ')') {
 5887: 		my $before=pop @stack;
 5888: 		if (pop @stack eq '&') {
 5889: 		    $result=$result>$before?$before:$result;
 5890: 		} else {
 5891: 		    $result=$result>$before?$result:$before;
 5892: 		}
 5893: 	    } elsif (($chunk eq '&') || ($chunk eq '|')) {
 5894: 		$operand=$chunk;
 5895: 	    } else {
 5896: 		my $new=directcondval($chunk);
 5897: 		if ($operand eq '&') {
 5898: 		    $result=$result>$new?$new:$result;
 5899: 		} else {
 5900: 		    $result=$result>$new?$result:$new;
 5901: 		}
 5902: 	    }
 5903: 	}
 5904:     }
 5905:     return $result;
 5906: }
 5907: 
 5908: # ---------------------------------------------------- Devalidate courseresdata
 5909: 
 5910: sub devalidatecourseresdata {
 5911:     my ($coursenum,$coursedomain)=@_;
 5912:     my $hashid=$coursenum.':'.$coursedomain;
 5913:     &devalidate_cache_new('courseres',$hashid);
 5914: }
 5915: 
 5916: 
 5917: # --------------------------------------------------- Course Resourcedata Query
 5918: #
 5919: #  Parameters:
 5920: #      $coursenum    - Number of the course.
 5921: #      $coursedomain - Domain at which the course was created.
 5922: #  Returns:
 5923: #     A hash of the course parameters along (I think) with timestamps
 5924: #     and version info.
 5925: 
 5926: sub get_courseresdata {
 5927:     my ($coursenum,$coursedomain)=@_;
 5928:     my $coursehom=&homeserver($coursenum,$coursedomain);
 5929:     my $hashid=$coursenum.':'.$coursedomain;
 5930:     my ($result,$cached)=&is_cached_new('courseres',$hashid);
 5931:     my %dumpreply;
 5932:     unless (defined($cached)) {
 5933: 	%dumpreply=&dump('resourcedata',$coursedomain,$coursenum);
 5934: 	$result=\%dumpreply;
 5935: 	my ($tmp) = keys(%dumpreply);
 5936: 	if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
 5937: 	    &do_cache_new('courseres',$hashid,$result,600);
 5938: 	} elsif ($tmp =~ /^(con_lost|no_such_host)/) {
 5939: 	    return $tmp;
 5940: 	} elsif ($tmp =~ /^(error)/) {
 5941: 	    $result=undef;
 5942: 	    &do_cache_new('courseres',$hashid,$result,600);
 5943: 	}
 5944:     }
 5945:     return $result;
 5946: }
 5947: 
 5948: sub devalidateuserresdata {
 5949:     my ($uname,$udom)=@_;
 5950:     my $hashid="$udom:$uname";
 5951:     &devalidate_cache_new('userres',$hashid);
 5952: }
 5953: 
 5954: sub get_userresdata {
 5955:     my ($uname,$udom)=@_;
 5956:     #most student don\'t have any data set, check if there is some data
 5957:     if (&EXT_cache_status($udom,$uname)) { return undef; }
 5958: 
 5959:     my $hashid="$udom:$uname";
 5960:     my ($result,$cached)=&is_cached_new('userres',$hashid);
 5961:     if (!defined($cached)) {
 5962: 	my %resourcedata=&dump('resourcedata',$udom,$uname);
 5963: 	$result=\%resourcedata;
 5964: 	&do_cache_new('userres',$hashid,$result,600);
 5965:     }
 5966:     my ($tmp)=keys(%$result);
 5967:     if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) {
 5968: 	return $result;
 5969:     }
 5970:     #error 2 occurs when the .db doesn't exist
 5971:     if ($tmp!~/error: 2 /) {
 5972: 	&logthis("<font color=\"blue\">WARNING:".
 5973: 		 " Trying to get resource data for ".
 5974: 		 $uname." at ".$udom.": ".
 5975: 		 $tmp."</font>");
 5976:     } elsif ($tmp=~/error: 2 /) {
 5977: 	#&EXT_cache_set($udom,$uname);
 5978: 	&do_cache_new('userres',$hashid,undef,600);
 5979: 	undef($tmp); # not really an error so don't send it back
 5980:     }
 5981:     return $tmp;
 5982: }
 5983: #----------------------------------------------- resdata - return resource data
 5984: #  Purpose:
 5985: #    Return resource data for either users or for a course.
 5986: #  Parameters:
 5987: #     $name      - Course/user name.
 5988: #     $domain    - Name of the domain the user/course is registered on.
 5989: #     $type      - Type of thing $name is (must be 'course' or 'user'
 5990: #     @which     - Array of names of resources desired.
 5991: #  Returns:
 5992: #     The value of the first reasource in @which that is found in the
 5993: #     resource hash.
 5994: #  Exceptional Conditions:
 5995: #     If the $type passed in is not valid (not the string 'course' or 
 5996: #     'user', an undefined  reference is returned.
 5997: #     If none of the resources are found, an undef is returned
 5998: sub resdata {
 5999:     my ($name,$domain,$type,@which)=@_;
 6000:     my $result;
 6001:     if ($type eq 'course') {
 6002: 	$result=&get_courseresdata($name,$domain);
 6003:     } elsif ($type eq 'user') {
 6004: 	$result=&get_userresdata($name,$domain);
 6005:     }
 6006:     if (!ref($result)) { return $result; }    
 6007:     foreach my $item (@which) {
 6008: 	if (defined($result->{$item})) {
 6009: 	    return $result->{$item};
 6010: 	}
 6011:     }
 6012:     return undef;
 6013: }
 6014: 
 6015: #
 6016: # EXT resource caching routines
 6017: #
 6018: 
 6019: sub clear_EXT_cache_status {
 6020:     &delenv('cache.EXT.');
 6021: }
 6022: 
 6023: sub EXT_cache_status {
 6024:     my ($target_domain,$target_user) = @_;
 6025:     my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain;
 6026:     if (exists($env{$cachename}) && ($env{$cachename}+600) > time) {
 6027:         # We know already the user has no data
 6028:         return 1;
 6029:     } else {
 6030:         return 0;
 6031:     }
 6032: }
 6033: 
 6034: sub EXT_cache_set {
 6035:     my ($target_domain,$target_user) = @_;
 6036:     my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain;
 6037:     #&appenv($cachename => time);
 6038: }
 6039: 
 6040: # --------------------------------------------------------- Value of a Variable
 6041: sub EXT {
 6042: 
 6043:     my ($varname,$symbparm,$udom,$uname,$usection,$recurse)=@_;
 6044:     unless ($varname) { return ''; }
 6045:     #get real user name/domain, courseid and symb
 6046:     my $courseid;
 6047:     my $publicuser;
 6048:     if ($symbparm) {
 6049: 	$symbparm=&get_symb_from_alias($symbparm);
 6050:     }
 6051:     if (!($uname && $udom)) {
 6052:       (my $cursymb,$courseid,$udom,$uname,$publicuser)= &whichuser($symbparm);
 6053:       if (!$symbparm) {	$symbparm=$cursymb; }
 6054:     } else {
 6055: 	$courseid=$env{'request.course.id'};
 6056:     }
 6057:     my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);
 6058:     my $rest;
 6059:     if (defined($therest[0])) {
 6060:        $rest=join('.',@therest);
 6061:     } else {
 6062:        $rest='';
 6063:     }
 6064: 
 6065:     my $qualifierrest=$qualifier;
 6066:     if ($rest) { $qualifierrest.='.'.$rest; }
 6067:     my $spacequalifierrest=$space;
 6068:     if ($qualifierrest) { $spacequalifierrest.='.'.$qualifierrest; }
 6069:     if ($realm eq 'user') {
 6070: # --------------------------------------------------------------- user.resource
 6071: 	if ($space eq 'resource') {
 6072: 	    if ( (defined($Apache::lonhomework::parsing_a_problem)
 6073: 		  || defined($Apache::lonhomework::parsing_a_task))
 6074: 		 &&
 6075: 		 ($symbparm eq &symbread()) ) {	
 6076: 		# if we are in the middle of processing the resource the
 6077: 		# get the value we are planning on committing
 6078:                 if (defined($Apache::lonhomework::results{$qualifierrest})) {
 6079:                     return $Apache::lonhomework::results{$qualifierrest};
 6080:                 } else {
 6081:                     return $Apache::lonhomework::history{$qualifierrest};
 6082:                 }
 6083: 	    } else {
 6084: 		my %restored;
 6085: 		if ($publicuser || $env{'request.state'} eq 'construct') {
 6086: 		    %restored=&tmprestore($symbparm,$courseid,$udom,$uname);
 6087: 		} else {
 6088: 		    %restored=&restore($symbparm,$courseid,$udom,$uname);
 6089: 		}
 6090: 		return $restored{$qualifierrest};
 6091: 	    }
 6092: # ----------------------------------------------------------------- user.access
 6093:         } elsif ($space eq 'access') {
 6094: 	    # FIXME - not supporting calls for a specific user
 6095:             return &allowed($qualifier,$rest);
 6096: # ------------------------------------------ user.preferences, user.environment
 6097:         } elsif (($space eq 'preferences') || ($space eq 'environment')) {
 6098: 	    if (($uname eq $env{'user.name'}) &&
 6099: 		($udom eq $env{'user.domain'})) {
 6100: 		return $env{join('.',('environment',$qualifierrest))};
 6101: 	    } else {
 6102: 		my %returnhash;
 6103: 		if (!$publicuser) {
 6104: 		    %returnhash=&userenvironment($udom,$uname,
 6105: 						 $qualifierrest);
 6106: 		}
 6107: 		return $returnhash{$qualifierrest};
 6108: 	    }
 6109: # ----------------------------------------------------------------- user.course
 6110:         } elsif ($space eq 'course') {
 6111: 	    # FIXME - not supporting calls for a specific user
 6112:             return $env{join('.',('request.course',$qualifier))};
 6113: # ------------------------------------------------------------------- user.role
 6114:         } elsif ($space eq 'role') {
 6115: 	    # FIXME - not supporting calls for a specific user
 6116:             my ($role,$where)=split(/\./,$env{'request.role'});
 6117:             if ($qualifier eq 'value') {
 6118: 		return $role;
 6119:             } elsif ($qualifier eq 'extent') {
 6120:                 return $where;
 6121:             }
 6122: # ----------------------------------------------------------------- user.domain
 6123:         } elsif ($space eq 'domain') {
 6124:             return $udom;
 6125: # ------------------------------------------------------------------- user.name
 6126:         } elsif ($space eq 'name') {
 6127:             return $uname;
 6128: # ---------------------------------------------------- Any other user namespace
 6129:         } else {
 6130: 	    my %reply;
 6131: 	    if (!$publicuser) {
 6132: 		%reply=&get($space,[$qualifierrest],$udom,$uname);
 6133: 	    }
 6134: 	    return $reply{$qualifierrest};
 6135:         }
 6136:     } elsif ($realm eq 'query') {
 6137: # ---------------------------------------------- pull stuff out of query string
 6138:         &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'},
 6139: 						[$spacequalifierrest]);
 6140: 	return $env{'form.'.$spacequalifierrest}; 
 6141:    } elsif ($realm eq 'request') {
 6142: # ------------------------------------------------------------- request.browser
 6143:         if ($space eq 'browser') {
 6144: 	    if ($qualifier eq 'textremote') {
 6145: 		if (&Apache::lonlocal::mt('textual_remote_display') eq 'on') {
 6146: 		    return 1;
 6147: 		} else {
 6148: 		    return 0;
 6149: 		}
 6150: 	    } else {
 6151: 		return $env{'browser.'.$qualifier};
 6152: 	    }
 6153: # ------------------------------------------------------------ request.filename
 6154:         } else {
 6155:             return $env{'request.'.$spacequalifierrest};
 6156:         }
 6157:     } elsif ($realm eq 'course') {
 6158: # ---------------------------------------------------------- course.description
 6159:         return $env{'course.'.$courseid.'.'.$spacequalifierrest};
 6160:     } elsif ($realm eq 'resource') {
 6161: 
 6162: 	if (defined($courseid) && $courseid eq $env{'request.course.id'}) {
 6163: 	    if (!$symbparm) { $symbparm=&symbread(); }
 6164: 	}
 6165: 
 6166: 	if ($space eq 'title') {
 6167: 	    if (!$symbparm) { $symbparm = $env{'request.filename'}; }
 6168: 	    return &gettitle($symbparm);
 6169: 	}
 6170: 	
 6171: 	if ($space eq 'map') {
 6172: 	    my ($map) = &decode_symb($symbparm);
 6173: 	    return &symbread($map);
 6174: 	}
 6175: 
 6176: 	my ($section, $group, @groups);
 6177: 	my ($courselevelm,$courselevel);
 6178: 	if ($symbparm && defined($courseid) && 
 6179: 	    $courseid eq $env{'request.course.id'}) {
 6180: 
 6181: 	    #print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;
 6182: 
 6183: # ----------------------------------------------------- Cascading lookup scheme
 6184: 	    my $symbp=$symbparm;
 6185: 	    my $mapp=&deversion((&decode_symb($symbp))[0]);
 6186: 
 6187: 	    my $symbparm=$symbp.'.'.$spacequalifierrest;
 6188: 	    my $mapparm=$mapp.'___(all).'.$spacequalifierrest;
 6189: 
 6190: 	    if (($env{'user.name'} eq $uname) &&
 6191: 		($env{'user.domain'} eq $udom)) {
 6192: 		$section=$env{'request.course.sec'};
 6193:                 @groups = split(/:/,$env{'request.course.groups'});  
 6194:                 @groups=&sort_course_groups($courseid,@groups); 
 6195: 	    } else {
 6196: 		if (! defined($usection)) {
 6197: 		    $section=&getsection($udom,$uname,$courseid);
 6198: 		} else {
 6199: 		    $section = $usection;
 6200: 		}
 6201:                 @groups = &get_users_groups($udom,$uname,$courseid);
 6202: 	    }
 6203: 
 6204: 	    my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
 6205: 	    my $seclevelr=$courseid.'.['.$section.'].'.$symbparm;
 6206: 	    my $seclevelm=$courseid.'.['.$section.'].'.$mapparm;
 6207: 
 6208: 	    $courselevel=$courseid.'.'.$spacequalifierrest;
 6209: 	    my $courselevelr=$courseid.'.'.$symbparm;
 6210: 	    $courselevelm=$courseid.'.'.$mapparm;
 6211: 
 6212: # ----------------------------------------------------------- first, check user
 6213: 
 6214: 	    my $userreply=&resdata($uname,$udom,'user',
 6215: 				       ($courselevelr,$courselevelm,
 6216: 					$courselevel));
 6217: 	    if (defined($userreply)) { return $userreply; }
 6218: 
 6219: # ------------------------------------------------ second, check some of course
 6220:             my $coursereply;
 6221:             if (@groups > 0) {
 6222:                 $coursereply = &check_group_parms($courseid,\@groups,$symbparm,
 6223:                                        $mapparm,$spacequalifierrest);
 6224:                 if (defined($coursereply)) { return $coursereply; }
 6225:             }
 6226: 
 6227: 	    $coursereply=&resdata($env{'course.'.$courseid.'.num'},
 6228: 				     $env{'course.'.$courseid.'.domain'},
 6229: 				     'course',
 6230: 				     ($seclevelr,$seclevelm,$seclevel,
 6231: 				      $courselevelr));
 6232: 	    if (defined($coursereply)) { return $coursereply; }
 6233: 
 6234: # ------------------------------------------------------ third, check map parms
 6235: 	    my %parmhash=();
 6236: 	    my $thisparm='';
 6237: 	    if (tie(%parmhash,'GDBM_File',
 6238: 		    $env{'request.course.fn'}.'_parms.db',
 6239: 		    &GDBM_READER(),0640)) {
 6240: 		$thisparm=$parmhash{$symbparm};
 6241: 		untie(%parmhash);
 6242: 	    }
 6243: 	    if ($thisparm) { return $thisparm; }
 6244: 	}
 6245: # ------------------------------------------ fourth, look in resource metadata
 6246: 
 6247: 	$spacequalifierrest=~s/\./\_/;
 6248: 	my $filename;
 6249: 	if (!$symbparm) { $symbparm=&symbread(); }
 6250: 	if ($symbparm) {
 6251: 	    $filename=(&decode_symb($symbparm))[2];
 6252: 	} else {
 6253: 	    $filename=$env{'request.filename'};
 6254: 	}
 6255: 	my $metadata=&metadata($filename,$spacequalifierrest);
 6256: 	if (defined($metadata)) { return $metadata; }
 6257: 	$metadata=&metadata($filename,'parameter_'.$spacequalifierrest);
 6258: 	if (defined($metadata)) { return $metadata; }
 6259: 
 6260: # ---------------------------------------------- fourth, look in rest pf course
 6261: 	if ($symbparm && defined($courseid) && 
 6262: 	    $courseid eq $env{'request.course.id'}) {
 6263: 	    my $coursereply=&resdata($env{'course.'.$courseid.'.num'},
 6264: 				     $env{'course.'.$courseid.'.domain'},
 6265: 				     'course',
 6266: 				     ($courselevelm,$courselevel));
 6267: 	    if (defined($coursereply)) { return $coursereply; }
 6268: 	}
 6269: # ------------------------------------------------------------------ Cascade up
 6270: 	unless ($space eq '0') {
 6271: 	    my @parts=split(/_/,$space);
 6272: 	    my $id=pop(@parts);
 6273: 	    my $part=join('_',@parts);
 6274: 	    if ($part eq '') { $part='0'; }
 6275: 	    my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,
 6276: 				 $symbparm,$udom,$uname,$section,1);
 6277: 	    if (defined($partgeneral)) { return $partgeneral; }
 6278: 	}
 6279: 	if ($recurse) { return undef; }
 6280: 	my $pack_def=&packages_tab_default($filename,$varname);
 6281: 	if (defined($pack_def)) { return $pack_def; }
 6282: 
 6283: # ---------------------------------------------------- Any other user namespace
 6284:     } elsif ($realm eq 'environment') {
 6285: # ----------------------------------------------------------------- environment
 6286: 	if (($uname eq $env{'user.name'})&&($udom eq $env{'user.domain'})) {
 6287: 	    return $env{'environment.'.$spacequalifierrest};
 6288: 	} else {
 6289: 	    if ($uname eq 'anonymous' && $udom eq '') {
 6290: 		return '';
 6291: 	    }
 6292: 	    my %returnhash=&userenvironment($udom,$uname,
 6293: 					    $spacequalifierrest);
 6294: 	    return $returnhash{$spacequalifierrest};
 6295: 	}
 6296:     } elsif ($realm eq 'system') {
 6297: # ----------------------------------------------------------------- system.time
 6298: 	if ($space eq 'time') {
 6299: 	    return time;
 6300:         }
 6301:     } elsif ($realm eq 'server') {
 6302: # ----------------------------------------------------------------- system.time
 6303: 	if ($space eq 'name') {
 6304: 	    return $ENV{'SERVER_NAME'};
 6305:         }
 6306:     }
 6307:     return '';
 6308: }
 6309: 
 6310: sub check_group_parms {
 6311:     my ($courseid,$groups,$symbparm,$mapparm,$what) = @_;
 6312:     my @groupitems = ();
 6313:     my $resultitem;
 6314:     my @levels = ($symbparm,$mapparm,$what);
 6315:     foreach my $group (@{$groups}) {
 6316:         foreach my $level (@levels) {
 6317:              my $item = $courseid.'.['.$group.'].'.$level;
 6318:              push(@groupitems,$item);
 6319:         }
 6320:     }
 6321:     my $coursereply = &resdata($env{'course.'.$courseid.'.num'},
 6322:                             $env{'course.'.$courseid.'.domain'},
 6323:                                      'course',@groupitems);
 6324:     return $coursereply;
 6325: }
 6326: 
 6327: sub sort_course_groups { # Sort groups based on defined rankings. Default is sort().
 6328:     my ($courseid,@groups) = @_;
 6329:     @groups = sort(@groups);
 6330:     return @groups;
 6331: }
 6332: 
 6333: sub packages_tab_default {
 6334:     my ($uri,$varname)=@_;
 6335:     my (undef,$part,$name)=split(/\./,$varname);
 6336: 
 6337:     my (@extension,@specifics,$do_default);
 6338:     foreach my $package (split(/,/,&metadata($uri,'packages'))) {
 6339: 	my ($pack_type,$pack_part)=split(/_/,$package,2);
 6340: 	if ($pack_type eq 'default') {
 6341: 	    $do_default=1;
 6342: 	} elsif ($pack_type eq 'extension') {
 6343: 	    push(@extension,[$package,$pack_type,$pack_part]);
 6344: 	} elsif ($pack_part eq $part || $pack_type eq 'part') {
 6345: 	    # only look at packages defaults for packages that this id is
 6346: 	    push(@specifics,[$package,$pack_type,$pack_part]);
 6347: 	}
 6348:     }
 6349:     # first look for a package that matches the requested part id
 6350:     foreach my $package (@specifics) {
 6351: 	my (undef,$pack_type,$pack_part)=@{$package};
 6352: 	next if ($pack_part ne $part);
 6353: 	if (defined($packagetab{"$pack_type&$name&default"})) {
 6354: 	    return $packagetab{"$pack_type&$name&default"};
 6355: 	}
 6356:     }
 6357:     # look for any possible matching non extension_ package
 6358:     foreach my $package (@specifics) {
 6359: 	my (undef,$pack_type,$pack_part)=@{$package};
 6360: 	if (defined($packagetab{"$pack_type&$name&default"})) {
 6361: 	    return $packagetab{"$pack_type&$name&default"};
 6362: 	}
 6363: 	if ($pack_type eq 'part') { $pack_part='0'; }
 6364: 	if (defined($packagetab{$pack_type."_".$pack_part."&$name&default"})) {
 6365: 	    return $packagetab{$pack_type."_".$pack_part."&$name&default"};
 6366: 	}
 6367:     }
 6368:     # look for any posible extension_ match
 6369:     foreach my $package (@extension) {
 6370: 	my ($package,$pack_type)=@{$package};
 6371: 	if (defined($packagetab{"$pack_type&$name&default"})) {
 6372: 	    return $packagetab{"$pack_type&$name&default"};
 6373: 	}
 6374: 	if (defined($packagetab{$package."&$name&default"})) {
 6375: 	    return $packagetab{$package."&$name&default"};
 6376: 	}
 6377:     }
 6378:     # look for a global default setting
 6379:     if ($do_default && defined($packagetab{"default&$name&default"})) {
 6380: 	return $packagetab{"default&$name&default"};
 6381:     }
 6382:     return undef;
 6383: }
 6384: 
 6385: sub add_prefix_and_part {
 6386:     my ($prefix,$part)=@_;
 6387:     my $keyroot;
 6388:     if (defined($prefix) && $prefix !~ /^__/) {
 6389: 	# prefix that has a part already
 6390: 	$keyroot=$prefix;
 6391:     } elsif (defined($prefix)) {
 6392: 	# prefix that is missing a part
 6393: 	if (defined($part)) { $keyroot='_'.$part.substr($prefix,1); }
 6394:     } else {
 6395: 	# no prefix at all
 6396: 	if (defined($part)) { $keyroot='_'.$part; }
 6397:     }
 6398:     return $keyroot;
 6399: }
 6400: 
 6401: # ---------------------------------------------------------------- Get metadata
 6402: 
 6403: my %metaentry;
 6404: sub metadata {
 6405:     my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
 6406:     $uri=&declutter($uri);
 6407:     # if it is a non metadata possible uri return quickly
 6408:     if (($uri eq '') || 
 6409: 	(($uri =~ m|^/*adm/|) && 
 6410: 	     ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) ||
 6411:         ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) ||
 6412: 	($uri =~ m|home/$match_username/public_html/|)) {
 6413: 	return undef;
 6414:     }
 6415:     my $filename=$uri;
 6416:     $uri=~s/\.meta$//;
 6417: #
 6418: # Is the metadata already cached?
 6419: # Look at timestamp of caching
 6420: # Everything is cached by the main uri, libraries are never directly cached
 6421: #
 6422:     if (!defined($liburi)) {
 6423: 	my ($result,$cached)=&is_cached_new('meta',$uri);
 6424: 	if (defined($cached)) { return $result->{':'.$what}; }
 6425:     }
 6426:     {
 6427: #
 6428: # Is this a recursive call for a library?
 6429: #
 6430: #	if (! exists($metacache{$uri})) {
 6431: #	    $metacache{$uri}={};
 6432: #	}
 6433:         if ($liburi) {
 6434: 	    $liburi=&declutter($liburi);
 6435:             $filename=$liburi;
 6436:         } else {
 6437: 	    &devalidate_cache_new('meta',$uri);
 6438: 	    undef(%metaentry);
 6439: 	}
 6440:         my %metathesekeys=();
 6441:         unless ($filename=~/\.meta$/) { $filename.='.meta'; }
 6442: 	my $metastring;
 6443: 	if ($uri !~ m -^(editupload)/-) {
 6444: 	    my $file=&filelocation('',&clutter($filename));
 6445: 	    #push(@{$metaentry{$uri.'.file'}},$file);
 6446: 	    $metastring=&getfile($file);
 6447: 	}
 6448:         my $parser=HTML::LCParser->new(\$metastring);
 6449:         my $token;
 6450:         undef %metathesekeys;
 6451:         while ($token=$parser->get_token) {
 6452: 	    if ($token->[0] eq 'S') {
 6453: 		if (defined($token->[2]->{'package'})) {
 6454: #
 6455: # This is a package - get package info
 6456: #
 6457: 		    my $package=$token->[2]->{'package'};
 6458: 		    my $keyroot=&add_prefix_and_part($prefix,$token->[2]->{'part'});
 6459: 		    if (defined($token->[2]->{'id'})) { 
 6460: 			$keyroot.='_'.$token->[2]->{'id'}; 
 6461: 		    }
 6462: 		    if ($metaentry{':packages'}) {
 6463: 			$metaentry{':packages'}.=','.$package.$keyroot;
 6464: 		    } else {
 6465: 			$metaentry{':packages'}=$package.$keyroot;
 6466: 		    }
 6467: 		    foreach my $pack_entry (keys(%packagetab)) {
 6468: 			my $part=$keyroot;
 6469: 			$part=~s/^\_//;
 6470: 			if ($pack_entry=~/^\Q$package\E\&/ || 
 6471: 			    $pack_entry=~/^\Q$package\E_0\&/) {
 6472: 			    my ($pack,$name,$subp)=split(/\&/,$pack_entry);
 6473: 			    # ignore package.tab specified default values
 6474:                             # here &package_tab_default() will fetch those
 6475: 			    if ($subp eq 'default') { next; }
 6476: 			    my $value=$packagetab{$pack_entry};
 6477: 			    my $unikey;
 6478: 			    if ($pack =~ /_0$/) {
 6479: 				$unikey='parameter_0_'.$name;
 6480: 				$part=0;
 6481: 			    } else {
 6482: 				$unikey='parameter'.$keyroot.'_'.$name;
 6483: 			    }
 6484: 			    if ($subp eq 'display') {
 6485: 				$value.=' [Part: '.$part.']';
 6486: 			    }
 6487: 			    $metaentry{':'.$unikey.'.part'}=$part;
 6488: 			    $metathesekeys{$unikey}=1;
 6489: 			    unless (defined($metaentry{':'.$unikey.'.'.$subp})) {
 6490: 				$metaentry{':'.$unikey.'.'.$subp}=$value;
 6491: 			    }
 6492: 			    if (defined($metaentry{':'.$unikey.'.default'})) {
 6493: 				$metaentry{':'.$unikey}=
 6494: 				    $metaentry{':'.$unikey.'.default'};
 6495: 			    }
 6496: 			}
 6497: 		    }
 6498: 		} else {
 6499: #
 6500: # This is not a package - some other kind of start tag
 6501: #
 6502: 		    my $entry=$token->[1];
 6503: 		    my $unikey;
 6504: 		    if ($entry eq 'import') {
 6505: 			$unikey='';
 6506: 		    } else {
 6507: 			$unikey=$entry;
 6508: 		    }
 6509: 		    $unikey.=&add_prefix_and_part($prefix,$token->[2]->{'part'});
 6510: 
 6511: 		    if (defined($token->[2]->{'id'})) { 
 6512: 			$unikey.='_'.$token->[2]->{'id'}; 
 6513: 		    }
 6514: 
 6515: 		    if ($entry eq 'import') {
 6516: #
 6517: # Importing a library here
 6518: #
 6519: 			if ($depthcount<20) {
 6520: 			    my $location=$parser->get_text('/import');
 6521: 			    my $dir=$filename;
 6522: 			    $dir=~s|[^/]*$||;
 6523: 			    $location=&filelocation($dir,$location);
 6524: 			    my $metadata = 
 6525: 				&metadata($uri,'keys', $location,$unikey,
 6526: 					  $depthcount+1);
 6527: 			    foreach my $meta (split(',',$metadata)) {
 6528: 				$metaentry{':'.$meta}=$metaentry{':'.$meta};
 6529: 				$metathesekeys{$meta}=1;
 6530: 			    }
 6531: 			}
 6532: 		    } else { 
 6533: 			
 6534: 			if (defined($token->[2]->{'name'})) { 
 6535: 			    $unikey.='_'.$token->[2]->{'name'}; 
 6536: 			}
 6537: 			$metathesekeys{$unikey}=1;
 6538: 			foreach my $param (@{$token->[3]}) {
 6539: 			    $metaentry{':'.$unikey.'.'.$param} =
 6540: 				$token->[2]->{$param};
 6541: 			}
 6542: 			my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));
 6543: 			my $default=$metaentry{':'.$unikey.'.default'};
 6544: 			if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) {
 6545: 		 # only ws inside the tag, and not in default, so use default
 6546: 		 # as value
 6547: 			    $metaentry{':'.$unikey}=$default;
 6548: 			} else {
 6549: 		  # either something interesting inside the tag or default
 6550:                   # uninteresting
 6551: 			    $metaentry{':'.$unikey}=$internaltext;
 6552: 			}
 6553: # end of not-a-package not-a-library import
 6554: 		    }
 6555: # end of not-a-package start tag
 6556: 		}
 6557: # the next is the end of "start tag"
 6558: 	    }
 6559: 	}
 6560: 	my ($extension) = ($uri =~ /\.(\w+)$/);
 6561: 	$extension = lc($extension);
 6562: 	if ($extension eq 'htm') { $extension='html'; }
 6563: 
 6564: 	foreach my $key (keys(%packagetab)) {
 6565: 	    #no specific packages #how's our extension
 6566: 	    if ($key!~/^extension_\Q$extension\E&/) { next; }
 6567: 	    &metadata_create_package_def($uri,$key,'extension_'.$extension,
 6568: 					 \%metathesekeys);
 6569: 	}
 6570: 
 6571: 	if (!exists($metaentry{':packages'})
 6572: 	    || $packagetab{"import_defaults&extension_$extension"}) {
 6573: 	    foreach my $key (keys(%packagetab)) {
 6574: 		#no specific packages well let's get default then
 6575: 		if ($key!~/^default&/) { next; }
 6576: 		&metadata_create_package_def($uri,$key,'default',
 6577: 					     \%metathesekeys);
 6578: 	    }
 6579: 	}
 6580: # are there custom rights to evaluate
 6581: 	if ($metaentry{':copyright'} eq 'custom') {
 6582: 
 6583:     #
 6584:     # Importing a rights file here
 6585:     #
 6586: 	    unless ($depthcount) {
 6587: 		my $location=$metaentry{':customdistributionfile'};
 6588: 		my $dir=$filename;
 6589: 		$dir=~s|[^/]*$||;
 6590: 		$location=&filelocation($dir,$location);
 6591: 		my $rights_metadata =
 6592: 		    &metadata($uri,'keys',$location,'_rights',
 6593: 			      $depthcount+1);
 6594: 		foreach my $rights (split(',',$rights_metadata)) {
 6595: 		    #$metaentry{':'.$rights}=$metacache{$uri}->{':'.$rights};
 6596: 		    $metathesekeys{$rights}=1;
 6597: 		}
 6598: 	    }
 6599: 	}
 6600: 	# uniqifiy package listing
 6601: 	my %seen;
 6602: 	my @uniq_packages =
 6603: 	    grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'}));
 6604: 	$metaentry{':packages'} = join(',',@uniq_packages);
 6605: 
 6606: 	$metaentry{':keys'} = join(',',keys(%metathesekeys));
 6607: 	&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
 6608: 	$metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);
 6609: 	&do_cache_new('meta',$uri,\%metaentry,60*60);
 6610: # this is the end of "was not already recently cached
 6611:     }
 6612:     return $metaentry{':'.$what};
 6613: }
 6614: 
 6615: sub metadata_create_package_def {
 6616:     my ($uri,$key,$package,$metathesekeys)=@_;
 6617:     my ($pack,$name,$subp)=split(/\&/,$key);
 6618:     if ($subp eq 'default') { next; }
 6619:     
 6620:     if (defined($metaentry{':packages'})) {
 6621: 	$metaentry{':packages'}.=','.$package;
 6622:     } else {
 6623: 	$metaentry{':packages'}=$package;
 6624:     }
 6625:     my $value=$packagetab{$key};
 6626:     my $unikey;
 6627:     $unikey='parameter_0_'.$name;
 6628:     $metaentry{':'.$unikey.'.part'}=0;
 6629:     $$metathesekeys{$unikey}=1;
 6630:     unless (defined($metaentry{':'.$unikey.'.'.$subp})) {
 6631: 	$metaentry{':'.$unikey.'.'.$subp}=$value;
 6632:     }
 6633:     if (defined($metaentry{':'.$unikey.'.default'})) {
 6634: 	$metaentry{':'.$unikey}=
 6635: 	    $metaentry{':'.$unikey.'.default'};
 6636:     }
 6637: }
 6638: 
 6639: sub metadata_generate_part0 {
 6640:     my ($metadata,$metacache,$uri) = @_;
 6641:     my %allnames;
 6642:     foreach my $metakey (keys(%$metadata)) {
 6643: 	if ($metakey=~/^parameter\_(.*)/) {
 6644: 	  my $part=$$metacache{':'.$metakey.'.part'};
 6645: 	  my $name=$$metacache{':'.$metakey.'.name'};
 6646: 	  if (! exists($$metadata{'parameter_0_'.$name.'.name'})) {
 6647: 	    $allnames{$name}=$part;
 6648: 	  }
 6649: 	}
 6650:     }
 6651:     foreach my $name (keys(%allnames)) {
 6652:       $$metadata{"parameter_0_$name"}=1;
 6653:       my $key=":parameter_0_$name";
 6654:       $$metacache{"$key.part"}='0';
 6655:       $$metacache{"$key.name"}=$name;
 6656:       $$metacache{"$key.type"}=$$metacache{':parameter_'.
 6657: 					   $allnames{$name}.'_'.$name.
 6658: 					   '.type'};
 6659:       my $olddis=$$metacache{':parameter_'.$allnames{$name}.'_'.$name.
 6660: 			     '.display'};
 6661:       my $expr='[Part: '.$allnames{$name}.']';
 6662:       $olddis=~s/\Q$expr\E/\[Part: 0\]/;
 6663:       $$metacache{"$key.display"}=$olddis;
 6664:     }
 6665: }
 6666: 
 6667: # ------------------------------------------------------ Devalidate title cache
 6668: 
 6669: sub devalidate_title_cache {
 6670:     my ($url)=@_;
 6671:     if (!$env{'request.course.id'}) { return; }
 6672:     my $symb=&symbread($url);
 6673:     if (!$symb) { return; }
 6674:     my $key=$env{'request.course.id'}."\0".$symb;
 6675:     &devalidate_cache_new('title',$key);
 6676: }
 6677: 
 6678: # ------------------------------------------------- Get the title of a resource
 6679: 
 6680: sub gettitle {
 6681:     my $urlsymb=shift;
 6682:     my $symb=&symbread($urlsymb);
 6683:     if ($symb) {
 6684: 	my $key=$env{'request.course.id'}."\0".$symb;
 6685: 	my ($result,$cached)=&is_cached_new('title',$key);
 6686: 	if (defined($cached)) { 
 6687: 	    return $result;
 6688: 	}
 6689: 	my ($map,$resid,$url)=&decode_symb($symb);
 6690: 	my $title='';
 6691: 	my %bighash;
 6692: 	if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
 6693: 		&GDBM_READER(),0640)) {
 6694: 	    my $mapid=$bighash{'map_pc_'.&clutter($map)};
 6695: 	    $title=$bighash{'title_'.$mapid.'.'.$resid};
 6696: 	    untie %bighash;
 6697: 	}
 6698: 	$title=~s/\&colon\;/\:/gs;
 6699: 	if ($title) {
 6700: 	    return &do_cache_new('title',$key,$title,600);
 6701: 	}
 6702: 	$urlsymb=$url;
 6703:     }
 6704:     my $title=&metadata($urlsymb,'title');
 6705:     if (!$title) { $title=(split('/',$urlsymb))[-1]; }    
 6706:     return $title;
 6707: }
 6708: 
 6709: sub get_slot {
 6710:     my ($which,$cnum,$cdom)=@_;
 6711:     if (!$cnum || !$cdom) {
 6712: 	(undef,my $courseid)=&whichuser();
 6713: 	$cdom=$env{'course.'.$courseid.'.domain'};
 6714: 	$cnum=$env{'course.'.$courseid.'.num'};
 6715:     }
 6716:     my $key=join("\0",'slots',$cdom,$cnum,$which);
 6717:     my %slotinfo;
 6718:     if (exists($remembered{$key})) {
 6719: 	$slotinfo{$which} = $remembered{$key};
 6720:     } else {
 6721: 	%slotinfo=&get('slots',[$which],$cdom,$cnum);
 6722: 	&Apache::lonhomework::showhash(%slotinfo);
 6723: 	my ($tmp)=keys(%slotinfo);
 6724: 	if ($tmp=~/^error:/) { return (); }
 6725: 	$remembered{$key} = $slotinfo{$which};
 6726:     }
 6727:     if (ref($slotinfo{$which}) eq 'HASH') {
 6728: 	return %{$slotinfo{$which}};
 6729:     }
 6730:     return $slotinfo{$which};
 6731: }
 6732: # ------------------------------------------------- Update symbolic store links
 6733: 
 6734: sub symblist {
 6735:     my ($mapname,%newhash)=@_;
 6736:     $mapname=&deversion(&declutter($mapname));
 6737:     my %hash;
 6738:     if (($env{'request.course.fn'}) && (%newhash)) {
 6739:         if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
 6740:                       &GDBM_WRCREAT(),0640)) {
 6741: 	    foreach my $url (keys %newhash) {
 6742: 		next if ($url eq 'last_known'
 6743: 			 && $env{'form.no_update_last_known'});
 6744: 		$hash{declutter($url)}=&encode_symb($mapname,
 6745: 						    $newhash{$url}->[1],
 6746: 						    $newhash{$url}->[0]);
 6747:             }
 6748:             if (untie(%hash)) {
 6749: 		return 'ok';
 6750:             }
 6751:         }
 6752:     }
 6753:     return 'error';
 6754: }
 6755: 
 6756: # --------------------------------------------------------------- Verify a symb
 6757: 
 6758: sub symbverify {
 6759:     my ($symb,$thisurl)=@_;
 6760:     my $thisfn=$thisurl;
 6761:     $thisfn=&declutter($thisfn);
 6762: # direct jump to resource in page or to a sequence - will construct own symbs
 6763:     if ($thisfn=~/\.(page|sequence)$/) { return 1; }
 6764: # check URL part
 6765:     my ($map,$resid,$url)=&decode_symb($symb);
 6766: 
 6767:     unless ($url eq $thisfn) { return 0; }
 6768: 
 6769:     $symb=&symbclean($symb);
 6770:     $thisurl=&deversion($thisurl);
 6771:     $thisfn=&deversion($thisfn);
 6772: 
 6773:     my %bighash;
 6774:     my $okay=0;
 6775: 
 6776:     if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
 6777:                             &GDBM_READER(),0640)) {
 6778:         my $ids=$bighash{'ids_'.&clutter($thisurl)};
 6779:         unless ($ids) { 
 6780:            $ids=$bighash{'ids_/'.$thisurl};
 6781:         }
 6782:         if ($ids) {
 6783: # ------------------------------------------------------------------- Has ID(s)
 6784: 	    foreach my $id (split(/\,/,$ids)) {
 6785: 	       my ($mapid,$resid)=split(/\./,$id);
 6786:                if (
 6787:   &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)
 6788:    eq $symb) { 
 6789: 		   if (($env{'request.role.adv'}) ||
 6790: 		       $bighash{'encrypted_'.$id} eq $env{'request.enc'}) {
 6791: 		       $okay=1; 
 6792: 		   }
 6793: 	       }
 6794: 	   }
 6795:         }
 6796: 	untie(%bighash);
 6797:     }
 6798:     return $okay;
 6799: }
 6800: 
 6801: # --------------------------------------------------------------- Clean-up symb
 6802: 
 6803: sub symbclean {
 6804:     my $symb=shift;
 6805:     if ($symb=~m|^/enc/|) { $symb=&Apache::lonenc::unencrypted($symb); }
 6806: # remove version from map
 6807:     $symb=~s/\.(\d+)\.(\w+)\_\_\_/\.$2\_\_\_/;
 6808: 
 6809: # remove version from URL
 6810:     $symb=~s/\.(\d+)\.(\w+)$/\.$2/;
 6811: 
 6812: # remove wrapper
 6813: 
 6814:     $symb=~s/(\_\_\_\d+\_\_\_)adm\/wrapper\/(res\/)*/$1/;
 6815:     $symb=~s/(\_\_\_\d+\_\_\_)adm\/coursedocs\/showdoc\/(res\/)*/$1/;
 6816:     return $symb;
 6817: }
 6818: 
 6819: # ---------------------------------------------- Split symb to find map and url
 6820: 
 6821: sub encode_symb {
 6822:     my ($map,$resid,$url)=@_;
 6823:     return &symbclean(&declutter($map).'___'.$resid.'___'.&declutter($url));
 6824: }
 6825: 
 6826: sub decode_symb {
 6827:     my $symb=shift;
 6828:     if ($symb=~m|^/enc/|) { $symb=&Apache::lonenc::unencrypted($symb); }
 6829:     my ($map,$resid,$url)=split(/___/,$symb);
 6830:     return (&fixversion($map),$resid,&fixversion($url));
 6831: }
 6832: 
 6833: sub fixversion {
 6834:     my $fn=shift;
 6835:     if ($fn=~/^(adm|uploaded|editupload|public)/) { return $fn; }
 6836:     my %bighash;
 6837:     my $uri=&clutter($fn);
 6838:     my $key=$env{'request.course.id'}.'_'.$uri;
 6839: # is this cached?
 6840:     my ($result,$cached)=&is_cached_new('courseresversion',$key);
 6841:     if (defined($cached)) { return $result; }
 6842: # unfortunately not cached, or expired
 6843:     if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
 6844: 	    &GDBM_READER(),0640)) {
 6845:  	if ($bighash{'version_'.$uri}) {
 6846:  	    my $version=$bighash{'version_'.$uri};
 6847:  	    unless (($version eq 'mostrecent') || 
 6848: 		    ($version==&getversion($uri))) {
 6849:  		$uri=~s/\.(\w+)$/\.$version\.$1/;
 6850:  	    }
 6851:  	}
 6852:  	untie %bighash;
 6853:     }
 6854:     return &do_cache_new('courseresversion',$key,&declutter($uri),600);
 6855: }
 6856: 
 6857: sub deversion {
 6858:     my $url=shift;
 6859:     $url=~s/\.\d+\.(\w+)$/\.$1/;
 6860:     return $url;
 6861: }
 6862: 
 6863: # ------------------------------------------------------ Return symb list entry
 6864: 
 6865: sub symbread {
 6866:     my ($thisfn,$donotrecurse)=@_;
 6867:     my $cache_str='request.symbread.cached.'.$thisfn;
 6868:     if (defined($env{$cache_str})) { return $env{$cache_str}; }
 6869: # no filename provided? try from environment
 6870:     unless ($thisfn) {
 6871:         if ($env{'request.symb'}) {
 6872: 	    return $env{$cache_str}=&symbclean($env{'request.symb'});
 6873: 	}
 6874: 	$thisfn=$env{'request.filename'};
 6875:     }
 6876:     if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }
 6877: # is that filename actually a symb? Verify, clean, and return
 6878:     if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) {
 6879: 	if (&symbverify($thisfn,$1)) {
 6880: 	    return $env{$cache_str}=&symbclean($thisfn);
 6881: 	}
 6882:     }
 6883:     $thisfn=declutter($thisfn);
 6884:     my %hash;
 6885:     my %bighash;
 6886:     my $syval='';
 6887:     if (($env{'request.course.fn'}) && ($thisfn)) {
 6888:         my $targetfn = $thisfn;
 6889:         if ( ($thisfn =~ m/^(uploaded|editupload)\//) && ($thisfn !~ m/\.(page|sequence)$/) ) {
 6890:             $targetfn = 'adm/wrapper/'.$thisfn;
 6891:         }
 6892: 	if ($targetfn =~ m|^adm/wrapper/(ext/.*)|) {
 6893: 	    $targetfn=$1;
 6894: 	}
 6895:         if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
 6896:                       &GDBM_READER(),0640)) {
 6897: 	    $syval=$hash{$targetfn};
 6898:             untie(%hash);
 6899:         }
 6900: # ---------------------------------------------------------- There was an entry
 6901:         if ($syval) {
 6902: 	    #unless ($syval=~/\_\d+$/) {
 6903: 		#unless ($env{'form.request.prefix'}=~/\.(\d+)\_$/) {
 6904: 		    #&appenv('request.ambiguous' => $thisfn);
 6905: 		    #return $env{$cache_str}='';
 6906: 		#}    
 6907: 		#$syval.=$1;
 6908: 	    #}
 6909:         } else {
 6910: # ------------------------------------------------------- Was not in symb table
 6911:            if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
 6912:                             &GDBM_READER(),0640)) {
 6913: # ---------------------------------------------- Get ID(s) for current resource
 6914:               my $ids=$bighash{'ids_'.&clutter($thisfn)};
 6915:               unless ($ids) { 
 6916:                  $ids=$bighash{'ids_/'.$thisfn};
 6917:               }
 6918:               unless ($ids) {
 6919: # alias?
 6920: 		  $ids=$bighash{'mapalias_'.$thisfn};
 6921:               }
 6922:               if ($ids) {
 6923: # ------------------------------------------------------------------- Has ID(s)
 6924:                  my @possibilities=split(/\,/,$ids);
 6925:                  if ($#possibilities==0) {
 6926: # ----------------------------------------------- There is only one possibility
 6927: 		     my ($mapid,$resid)=split(/\./,$ids);
 6928: 		     $syval=&encode_symb($bighash{'map_id_'.$mapid},
 6929: 						    $resid,$thisfn);
 6930:                  } elsif (!$donotrecurse) {
 6931: # ------------------------------------------ There is more than one possibility
 6932:                      my $realpossible=0;
 6933:                      foreach my $id (@possibilities) {
 6934: 			 my $file=$bighash{'src_'.$id};
 6935:                          if (&allowed('bre',$file)) {
 6936:          		    my ($mapid,$resid)=split(/\./,$id);
 6937:                             if ($bighash{'map_type_'.$mapid} ne 'page') {
 6938: 				$realpossible++;
 6939:                                 $syval=&encode_symb($bighash{'map_id_'.$mapid},
 6940: 						    $resid,$thisfn);
 6941:                             }
 6942: 			 }
 6943:                      }
 6944: 		     if ($realpossible!=1) { $syval=''; }
 6945:                  } else {
 6946:                      $syval='';
 6947:                  }
 6948: 	      }
 6949:               untie(%bighash)
 6950:            }
 6951:         }
 6952:         if ($syval) {
 6953: 	    return $env{$cache_str}=$syval;
 6954:         }
 6955:     }
 6956:     &appenv('request.ambiguous' => $thisfn);
 6957:     return $env{$cache_str}='';
 6958: }
 6959: 
 6960: # ---------------------------------------------------------- Return random seed
 6961: 
 6962: sub numval {
 6963:     my $txt=shift;
 6964:     $txt=~tr/A-J/0-9/;
 6965:     $txt=~tr/a-j/0-9/;
 6966:     $txt=~tr/K-T/0-9/;
 6967:     $txt=~tr/k-t/0-9/;
 6968:     $txt=~tr/U-Z/0-5/;
 6969:     $txt=~tr/u-z/0-5/;
 6970:     $txt=~s/\D//g;
 6971:     if ($_64bit) { if ($txt > 2**32) { return -1; } }
 6972:     return int($txt);
 6973: }
 6974: 
 6975: sub numval2 {
 6976:     my $txt=shift;
 6977:     $txt=~tr/A-J/0-9/;
 6978:     $txt=~tr/a-j/0-9/;
 6979:     $txt=~tr/K-T/0-9/;
 6980:     $txt=~tr/k-t/0-9/;
 6981:     $txt=~tr/U-Z/0-5/;
 6982:     $txt=~tr/u-z/0-5/;
 6983:     $txt=~s/\D//g;
 6984:     my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt);
 6985:     my $total;
 6986:     foreach my $val (@txts) { $total+=$val; }
 6987:     if ($_64bit) { if ($total > 2**32) { return -1; } }
 6988:     return int($total);
 6989: }
 6990: 
 6991: sub numval3 {
 6992:     use integer;
 6993:     my $txt=shift;
 6994:     $txt=~tr/A-J/0-9/;
 6995:     $txt=~tr/a-j/0-9/;
 6996:     $txt=~tr/K-T/0-9/;
 6997:     $txt=~tr/k-t/0-9/;
 6998:     $txt=~tr/U-Z/0-5/;
 6999:     $txt=~tr/u-z/0-5/;
 7000:     $txt=~s/\D//g;
 7001:     my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt);
 7002:     my $total;
 7003:     foreach my $val (@txts) { $total+=$val; }
 7004:     if ($_64bit) { $total=(($total<<32)>>32); }
 7005:     return $total;
 7006: }
 7007: 
 7008: sub digest {
 7009:     my ($data)=@_;
 7010:     my $digest=&Digest::MD5::md5($data);
 7011:     my ($a,$b,$c,$d)=unpack("iiii",$digest);
 7012:     my ($e,$f);
 7013:     {
 7014:         use integer;
 7015:         $e=($a+$b);
 7016:         $f=($c+$d);
 7017:         if ($_64bit) {
 7018:             $e=(($e<<32)>>32);
 7019:             $f=(($f<<32)>>32);
 7020:         }
 7021:     }
 7022:     if (wantarray) {
 7023: 	return ($e,$f);
 7024:     } else {
 7025: 	my $g;
 7026: 	{
 7027: 	    use integer;
 7028: 	    $g=($e+$f);
 7029: 	    if ($_64bit) {
 7030: 		$g=(($g<<32)>>32);
 7031: 	    }
 7032: 	}
 7033: 	return $g;
 7034:     }
 7035: }
 7036: 
 7037: sub latest_rnd_algorithm_id {
 7038:     return '64bit5';
 7039: }
 7040: 
 7041: sub get_rand_alg {
 7042:     my ($courseid)=@_;
 7043:     if (!$courseid) { $courseid=(&whichuser())[1]; }
 7044:     if ($courseid) {
 7045: 	return $env{"course.$courseid.rndseed"};
 7046:     }
 7047:     return &latest_rnd_algorithm_id();
 7048: }
 7049: 
 7050: sub validCODE {
 7051:     my ($CODE)=@_;
 7052:     if (defined($CODE) && $CODE ne '' && $CODE =~ /^\w+$/) { return 1; }
 7053:     return 0;
 7054: }
 7055: 
 7056: sub getCODE {
 7057:     if (&validCODE($env{'form.CODE'})) { return $env{'form.CODE'}; }
 7058:     if ( (defined($Apache::lonhomework::parsing_a_problem) ||
 7059: 	  defined($Apache::lonhomework::parsing_a_task) ) &&
 7060: 	 &validCODE($Apache::lonhomework::history{'resource.CODE'})) {
 7061: 	return $Apache::lonhomework::history{'resource.CODE'};
 7062:     }
 7063:     return undef;
 7064: }
 7065: 
 7066: sub rndseed {
 7067:     my ($symb,$courseid,$domain,$username)=@_;
 7068:     my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser();
 7069:     if (!$symb) {
 7070: 	unless ($symb=$wsymb) { return time; }
 7071:     }
 7072:     if (!$courseid) { $courseid=$wcourseid; }
 7073:     if (!$domain) { $domain=$wdomain; }
 7074:     if (!$username) { $username=$wusername }
 7075:     my $which=&get_rand_alg();
 7076: 
 7077:     if (defined(&getCODE())) {
 7078: 	if ($which eq '64bit5') {
 7079: 	    return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username);
 7080: 	} elsif ($which eq '64bit4') {
 7081: 	    return &rndseed_CODE_64bit4($symb,$courseid,$domain,$username);
 7082: 	} else {
 7083: 	    return &rndseed_CODE_64bit($symb,$courseid,$domain,$username);
 7084: 	}
 7085:     } elsif ($which eq '64bit5') {
 7086: 	return &rndseed_64bit5($symb,$courseid,$domain,$username);
 7087:     } elsif ($which eq '64bit4') {
 7088: 	return &rndseed_64bit4($symb,$courseid,$domain,$username);
 7089:     } elsif ($which eq '64bit3') {
 7090: 	return &rndseed_64bit3($symb,$courseid,$domain,$username);
 7091:     } elsif ($which eq '64bit2') {
 7092: 	return &rndseed_64bit2($symb,$courseid,$domain,$username);
 7093:     } elsif ($which eq '64bit') {
 7094: 	return &rndseed_64bit($symb,$courseid,$domain,$username);
 7095:     }
 7096:     return &rndseed_32bit($symb,$courseid,$domain,$username);
 7097: }
 7098: 
 7099: sub rndseed_32bit {
 7100:     my ($symb,$courseid,$domain,$username)=@_;
 7101:     {
 7102: 	use integer;
 7103: 	my $symbchck=unpack("%32C*",$symb) << 27;
 7104: 	my $symbseed=numval($symb) << 22;
 7105: 	my $namechck=unpack("%32C*",$username) << 17;
 7106: 	my $nameseed=numval($username) << 12;
 7107: 	my $domainseed=unpack("%32C*",$domain) << 7;
 7108: 	my $courseseed=unpack("%32C*",$courseid);
 7109: 	my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;
 7110: 	#&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
 7111: 	#&logthis("rndseed :$num:$symb");
 7112: 	if ($_64bit) { $num=(($num<<32)>>32); }
 7113: 	return $num;
 7114:     }
 7115: }
 7116: 
 7117: sub rndseed_64bit {
 7118:     my ($symb,$courseid,$domain,$username)=@_;
 7119:     {
 7120: 	use integer;
 7121: 	my $symbchck=unpack("%32S*",$symb) << 21;
 7122: 	my $symbseed=numval($symb) << 10;
 7123: 	my $namechck=unpack("%32S*",$username);
 7124: 	
 7125: 	my $nameseed=numval($username) << 21;
 7126: 	my $domainseed=unpack("%32S*",$domain) << 10;
 7127: 	my $courseseed=unpack("%32S*",$courseid);
 7128: 	
 7129: 	my $num1=$symbchck+$symbseed+$namechck;
 7130: 	my $num2=$nameseed+$domainseed+$courseseed;
 7131: 	#&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
 7132: 	#&logthis("rndseed :$num:$symb");
 7133: 	if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
 7134: 	return "$num1,$num2";
 7135:     }
 7136: }
 7137: 
 7138: sub rndseed_64bit2 {
 7139:     my ($symb,$courseid,$domain,$username)=@_;
 7140:     {
 7141: 	use integer;
 7142: 	# strings need to be an even # of cahracters long, it it is odd the
 7143:         # last characters gets thrown away
 7144: 	my $symbchck=unpack("%32S*",$symb.' ') << 21;
 7145: 	my $symbseed=numval($symb) << 10;
 7146: 	my $namechck=unpack("%32S*",$username.' ');
 7147: 	
 7148: 	my $nameseed=numval($username) << 21;
 7149: 	my $domainseed=unpack("%32S*",$domain.' ') << 10;
 7150: 	my $courseseed=unpack("%32S*",$courseid.' ');
 7151: 	
 7152: 	my $num1=$symbchck+$symbseed+$namechck;
 7153: 	my $num2=$nameseed+$domainseed+$courseseed;
 7154: 	#&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
 7155: 	#&logthis("rndseed :$num:$symb");
 7156: 	if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
 7157: 	return "$num1,$num2";
 7158:     }
 7159: }
 7160: 
 7161: sub rndseed_64bit3 {
 7162:     my ($symb,$courseid,$domain,$username)=@_;
 7163:     {
 7164: 	use integer;
 7165: 	# strings need to be an even # of cahracters long, it it is odd the
 7166:         # last characters gets thrown away
 7167: 	my $symbchck=unpack("%32S*",$symb.' ') << 21;
 7168: 	my $symbseed=numval2($symb) << 10;
 7169: 	my $namechck=unpack("%32S*",$username.' ');
 7170: 	
 7171: 	my $nameseed=numval2($username) << 21;
 7172: 	my $domainseed=unpack("%32S*",$domain.' ') << 10;
 7173: 	my $courseseed=unpack("%32S*",$courseid.' ');
 7174: 	
 7175: 	my $num1=$symbchck+$symbseed+$namechck;
 7176: 	my $num2=$nameseed+$domainseed+$courseseed;
 7177: 	#&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
 7178: 	#&logthis("rndseed :$num1:$num2:$_64bit");
 7179: 	if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
 7180: 	
 7181: 	return "$num1:$num2";
 7182:     }
 7183: }
 7184: 
 7185: sub rndseed_64bit4 {
 7186:     my ($symb,$courseid,$domain,$username)=@_;
 7187:     {
 7188: 	use integer;
 7189: 	# strings need to be an even # of cahracters long, it it is odd the
 7190:         # last characters gets thrown away
 7191: 	my $symbchck=unpack("%32S*",$symb.' ') << 21;
 7192: 	my $symbseed=numval3($symb) << 10;
 7193: 	my $namechck=unpack("%32S*",$username.' ');
 7194: 	
 7195: 	my $nameseed=numval3($username) << 21;
 7196: 	my $domainseed=unpack("%32S*",$domain.' ') << 10;
 7197: 	my $courseseed=unpack("%32S*",$courseid.' ');
 7198: 	
 7199: 	my $num1=$symbchck+$symbseed+$namechck;
 7200: 	my $num2=$nameseed+$domainseed+$courseseed;
 7201: 	#&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
 7202: 	#&logthis("rndseed :$num1:$num2:$_64bit");
 7203: 	if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
 7204: 	
 7205: 	return "$num1:$num2";
 7206:     }
 7207: }
 7208: 
 7209: sub rndseed_64bit5 {
 7210:     my ($symb,$courseid,$domain,$username)=@_;
 7211:     my ($num1,$num2)=&digest("$symb,$courseid,$domain,$username");
 7212:     return "$num1:$num2";
 7213: }
 7214: 
 7215: sub rndseed_CODE_64bit {
 7216:     my ($symb,$courseid,$domain,$username)=@_;
 7217:     {
 7218: 	use integer;
 7219: 	my $symbchck=unpack("%32S*",$symb.' ') << 16;
 7220: 	my $symbseed=numval2($symb);
 7221: 	my $CODEchck=unpack("%32S*",&getCODE().' ') << 16;
 7222: 	my $CODEseed=numval(&getCODE());
 7223: 	my $courseseed=unpack("%32S*",$courseid.' ');
 7224: 	my $num1=$symbseed+$CODEchck;
 7225: 	my $num2=$CODEseed+$courseseed+$symbchck;
 7226: 	#&logthis("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck");
 7227: 	#&logthis("rndseed :$num1:$num2:$symb");
 7228: 	if ($_64bit) { $num1=(($num1<<32)>>32); }
 7229: 	if ($_64bit) { $num2=(($num2<<32)>>32); }
 7230: 	return "$num1:$num2";
 7231:     }
 7232: }
 7233: 
 7234: sub rndseed_CODE_64bit4 {
 7235:     my ($symb,$courseid,$domain,$username)=@_;
 7236:     {
 7237: 	use integer;
 7238: 	my $symbchck=unpack("%32S*",$symb.' ') << 16;
 7239: 	my $symbseed=numval3($symb);
 7240: 	my $CODEchck=unpack("%32S*",&getCODE().' ') << 16;
 7241: 	my $CODEseed=numval3(&getCODE());
 7242: 	my $courseseed=unpack("%32S*",$courseid.' ');
 7243: 	my $num1=$symbseed+$CODEchck;
 7244: 	my $num2=$CODEseed+$courseseed+$symbchck;
 7245: 	#&logthis("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck");
 7246: 	#&logthis("rndseed :$num1:$num2:$symb");
 7247: 	if ($_64bit) { $num1=(($num1<<32)>>32); }
 7248: 	if ($_64bit) { $num2=(($num2<<32)>>32); }
 7249: 	return "$num1:$num2";
 7250:     }
 7251: }
 7252: 
 7253: sub rndseed_CODE_64bit5 {
 7254:     my ($symb,$courseid,$domain,$username)=@_;
 7255:     my $code = &getCODE();
 7256:     my ($num1,$num2)=&digest("$symb,$courseid,$code");
 7257:     return "$num1:$num2";
 7258: }
 7259: 
 7260: sub setup_random_from_rndseed {
 7261:     my ($rndseed)=@_;
 7262:     if ($rndseed =~/([,:])/) {
 7263: 	my ($num1,$num2)=split(/[,:]/,$rndseed);
 7264: 	&Math::Random::random_set_seed(abs($num1),abs($num2));
 7265:     } else {
 7266: 	&Math::Random::random_set_seed_from_phrase($rndseed);
 7267:     }
 7268: }
 7269: 
 7270: sub latest_receipt_algorithm_id {
 7271:     return 'receipt3';
 7272: }
 7273: 
 7274: sub recunique {
 7275:     my $fucourseid=shift;
 7276:     my $unique;
 7277:     if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' ||
 7278: 	$env{"course.$fucourseid.receiptalg"} eq 'receipt3' ) {
 7279: 	$unique=$env{"course.$fucourseid.internal.encseed"};
 7280:     } else {
 7281: 	$unique=$perlvar{'lonReceipt'};
 7282:     }
 7283:     return unpack("%32C*",$unique);
 7284: }
 7285: 
 7286: sub recprefix {
 7287:     my $fucourseid=shift;
 7288:     my $prefix;
 7289:     if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2'||
 7290: 	$env{"course.$fucourseid.receiptalg"} eq 'receipt3' ) {
 7291: 	$prefix=$env{"course.$fucourseid.internal.encpref"};
 7292:     } else {
 7293: 	$prefix=$perlvar{'lonHostID'};
 7294:     }
 7295:     return unpack("%32C*",$prefix);
 7296: }
 7297: 
 7298: sub ireceipt {
 7299:     my ($funame,$fudom,$fucourseid,$fusymb,$part)=@_;
 7300: 
 7301:     my $return =&recprefix($fucourseid).'-';
 7302: 
 7303:     if ($env{"course.$fucourseid.receiptalg"} eq 'receipt3' ||
 7304: 	$env{'request.state'} eq 'construct') {
 7305: 	$return .= (&digest("$funame,$fudom,$fucourseid,$fusymb,$part")%10000);
 7306: 	return $return;
 7307:     }
 7308: 
 7309:     my $cuname=unpack("%32C*",$funame);
 7310:     my $cudom=unpack("%32C*",$fudom);
 7311:     my $cucourseid=unpack("%32C*",$fucourseid);
 7312:     my $cusymb=unpack("%32C*",$fusymb);
 7313:     my $cunique=&recunique($fucourseid);
 7314:     my $cpart=unpack("%32S*",$part);
 7315:     if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') {
 7316: 
 7317: 	#&logthis("doing receipt2  using parts $cpart, uname $cuname and udom $cudom gets  ".($cpart%$cuname)." and ".($cpart%$cudom));
 7318: 			       
 7319: 	$return.= ($cunique%$cuname+
 7320: 		   $cunique%$cudom+
 7321: 		   $cusymb%$cuname+
 7322: 		   $cusymb%$cudom+
 7323: 		   $cucourseid%$cuname+
 7324: 		   $cucourseid%$cudom+
 7325: 		   $cpart%$cuname+
 7326: 		   $cpart%$cudom);
 7327:     } else {
 7328: 	$return.= ($cunique%$cuname+
 7329: 		   $cunique%$cudom+
 7330: 		   $cusymb%$cuname+
 7331: 		   $cusymb%$cudom+
 7332: 		   $cucourseid%$cuname+
 7333: 		   $cucourseid%$cudom);
 7334:     }
 7335:     return $return;
 7336: }
 7337: 
 7338: sub receipt {
 7339:     my ($part)=@_;
 7340:     my ($symb,$courseid,$domain,$name) = &whichuser();
 7341:     return &ireceipt($name,$domain,$courseid,$symb,$part);
 7342: }
 7343: 
 7344: sub whichuser {
 7345:     my ($passedsymb)=@_;
 7346:     my ($symb,$courseid,$domain,$name,$publicuser);
 7347:     if (defined($env{'form.grade_symb'})) {
 7348: 	my ($tmp_courseid)=&get_env_multiple('form.grade_courseid');
 7349: 	my $allowed=&allowed('vgr',$tmp_courseid);
 7350: 	if (!$allowed &&
 7351: 	    exists($env{'request.course.sec'}) &&
 7352: 	    $env{'request.course.sec'} !~ /^\s*$/) {
 7353: 	    $allowed=&allowed('vgr',$tmp_courseid.
 7354: 			      '/'.$env{'request.course.sec'});
 7355: 	}
 7356: 	if ($allowed) {
 7357: 	    ($symb)=&get_env_multiple('form.grade_symb');
 7358: 	    $courseid=$tmp_courseid;
 7359: 	    ($domain)=&get_env_multiple('form.grade_domain');
 7360: 	    ($name)=&get_env_multiple('form.grade_username');
 7361: 	    return ($symb,$courseid,$domain,$name,$publicuser);
 7362: 	}
 7363:     }
 7364:     if (!$passedsymb) {
 7365: 	$symb=&symbread();
 7366:     } else {
 7367: 	$symb=$passedsymb;
 7368:     }
 7369:     $courseid=$env{'request.course.id'};
 7370:     $domain=$env{'user.domain'};
 7371:     $name=$env{'user.name'};
 7372:     if ($name eq 'public' && $domain eq 'public') {
 7373: 	if (!defined($env{'form.username'})) {
 7374: 	    $env{'form.username'}.=time.rand(10000000);
 7375: 	}
 7376: 	$name.=$env{'form.username'};
 7377:     }
 7378:     return ($symb,$courseid,$domain,$name,$publicuser);
 7379: 
 7380: }
 7381: 
 7382: # ------------------------------------------------------------ Serves up a file
 7383: # returns either the contents of the file or 
 7384: # -1 if the file doesn't exist
 7385: #
 7386: # if the target is a file that was uploaded via DOCS, 
 7387: # a check will be made to see if a current copy exists on the local server,
 7388: # if it does this will be served, otherwise a copy will be retrieved from
 7389: # the home server for the course and stored in /home/httpd/html/userfiles on
 7390: # the local server.   
 7391: 
 7392: sub getfile {
 7393:     my ($file) = @_;
 7394:     if ($file =~ m -^/*(uploaded|editupload)/-) { $file=&filelocation("",$file); }
 7395:     &repcopy($file);
 7396:     return &readfile($file);
 7397: }
 7398: 
 7399: sub repcopy_userfile {
 7400:     my ($file)=@_;
 7401:     if ($file =~ m -^/*(uploaded|editupload)/-) { $file=&filelocation("",$file); }
 7402:     if ($file =~ m|^/home/httpd/html/lonUsers/|) { return 'ok'; }
 7403:     my ($cdom,$cnum,$filename) = 
 7404: 	($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_name)/+(.*)|);
 7405:     my $uri="/uploaded/$cdom/$cnum/$filename";
 7406:     if (-e "$file") {
 7407: # we already have a local copy, check it out
 7408: 	my @fileinfo = stat($file);
 7409: 	my $rtncode;
 7410: 	my $info;
 7411: 	my $lwpresp = &getuploaded('HEAD',$uri,$cdom,$cnum,\$info,\$rtncode);
 7412: 	if ($lwpresp ne 'ok') {
 7413: # there is no such file anymore, even though we had a local copy
 7414: 	    if ($rtncode eq '404') {
 7415: 		unlink($file);
 7416: 	    }
 7417: 	    return -1;
 7418: 	}
 7419: 	if ($info < $fileinfo[9]) {
 7420: # nice, the file we have is up-to-date, just say okay
 7421: 	    return 'ok';
 7422: 	} else {
 7423: # the file is outdated, get rid of it
 7424: 	    unlink($file);
 7425: 	}
 7426:     }
 7427: # one way or the other, at this point, we don't have the file
 7428: # construct the correct path for the file
 7429:     my @parts = ($cdom,$cnum); 
 7430:     if ($filename =~ m|^(.+)/[^/]+$|) {
 7431: 	push @parts, split(/\//,$1);
 7432:     }
 7433:     my $path = $perlvar{'lonDocRoot'}.'/userfiles';
 7434:     foreach my $part (@parts) {
 7435: 	$path .= '/'.$part;
 7436: 	if (!-e $path) {
 7437: 	    mkdir($path,0770);
 7438: 	}
 7439:     }
 7440: # now the path exists for sure
 7441: # get a user agent
 7442:     my $ua=new LWP::UserAgent;
 7443:     my $transferfile=$file.'.in.transfer';
 7444: # FIXME: this should flock
 7445:     if (-e $transferfile) { return 'ok'; }
 7446:     my $request;
 7447:     $uri=~s/^\///;
 7448:     $request=new HTTP::Request('GET','http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri);
 7449:     my $response=$ua->request($request,$transferfile);
 7450: # did it work?
 7451:     if ($response->is_error()) {
 7452: 	unlink($transferfile);
 7453: 	&logthis("Userfile repcopy failed for $uri");
 7454: 	return -1;
 7455:     }
 7456: # worked, rename the transfer file
 7457:     rename($transferfile,$file);
 7458:     return 'ok';
 7459: }
 7460: 
 7461: sub tokenwrapper {
 7462:     my $uri=shift;
 7463:     $uri=~s|^http\://([^/]+)||;
 7464:     $uri=~s|^/||;
 7465:     $env{'user.environment'}=~/\/([^\/]+)\.id/;
 7466:     my $token=$1;
 7467:     my (undef,$udom,$uname,$file)=split('/',$uri,4);
 7468:     if ($udom && $uname && $file) {
 7469: 	$file=~s|(\?\.*)*$||;
 7470:         &appenv("userfile.$udom/$uname/$file" => $env{'request.course.id'});
 7471:         return 'http://'.&hostname(&homeserver($uname,$udom)).'/'.$uri.
 7472:                (($uri=~/\?/)?'&':'?').'token='.$token.
 7473:                                '&tokenissued='.$perlvar{'lonHostID'};
 7474:     } else {
 7475:         return '/adm/notfound.html';
 7476:     }
 7477: }
 7478: 
 7479: # call with reqtype HEAD: get last modification time
 7480: # call with reqtype GET: get the file contents
 7481: # Do not call this with reqtype GET for large files! It loads everything into memory
 7482: #
 7483: sub getuploaded {
 7484:     my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
 7485:     $uri=~s/^\///;
 7486:     $uri = 'http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri;
 7487:     my $ua=new LWP::UserAgent;
 7488:     my $request=new HTTP::Request($reqtype,$uri);
 7489:     my $response=$ua->request($request);
 7490:     $$rtncode = $response->code;
 7491:     if (! $response->is_success()) {
 7492: 	return 'failed';
 7493:     }      
 7494:     if ($reqtype eq 'HEAD') {
 7495: 	$$info = &HTTP::Date::str2time( $response->header('Last-modified') );
 7496:     } elsif ($reqtype eq 'GET') {
 7497: 	$$info = $response->content;
 7498:     }
 7499:     return 'ok';
 7500: }
 7501: 
 7502: sub readfile {
 7503:     my $file = shift;
 7504:     if ( (! -e $file ) || ($file eq '') ) { return -1; };
 7505:     my $fh;
 7506:     open($fh,"<$file");
 7507:     my $a='';
 7508:     while (my $line = <$fh>) { $a .= $line; }
 7509:     return $a;
 7510: }
 7511: 
 7512: sub filelocation {
 7513:     my ($dir,$file) = @_;
 7514:     my $location;
 7515:     $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces
 7516: 
 7517:     if ($file =~ m-^/adm/-) {
 7518: 	$file=~s-^/adm/wrapper/-/-;
 7519: 	$file=~s-^/adm/coursedocs/showdoc/-/-;
 7520:     }
 7521: 
 7522:     if ($file=~m:^/~:) { # is a contruction space reference
 7523:         $location = $file;
 7524:         $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;
 7525:     } elsif ($file=~m{^/home/$match_username/public_html/}) {
 7526: 	# is a correct contruction space reference
 7527:         $location = $file;
 7528:     } elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file
 7529:         my ($udom,$uname,$filename)=
 7530:   	    ($file=~m -^/+(?:uploaded|editupload)/+($match_domain)/+($match_name)/+(.*)$-);
 7531:         my $home=&homeserver($uname,$udom);
 7532:         my $is_me=0;
 7533:         my @ids=&current_machine_ids();
 7534:         foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }
 7535:         if ($is_me) {
 7536:   	    $location=&propath($udom,$uname).
 7537:   	      '/userfiles/'.$filename;
 7538:         } else {
 7539:   	  $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.
 7540:   	      $udom.'/'.$uname.'/'.$filename;
 7541:         }
 7542:     } elsif ($file =~ m-^/adm/-) {
 7543: 	$location = $perlvar{'lonDocRoot'}.'/'.$file;
 7544:     } else {
 7545:         $file=~s/^\Q$perlvar{'lonDocRoot'}\E//;
 7546:         $file=~s:^/res/:/:;
 7547:         if ( !( $file =~ m:^/:) ) {
 7548:             $location = $dir. '/'.$file;
 7549:         } else {
 7550:             $location = '/home/httpd/html/res'.$file;
 7551:         }
 7552:     }
 7553:     $location=~s://+:/:g; # remove duplicate /
 7554:     while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..
 7555:     while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./
 7556:     return $location;
 7557: }
 7558: 
 7559: sub hreflocation {
 7560:     my ($dir,$file)=@_;
 7561:     unless (($file=~m-^http://-i) || ($file=~m-^/-)) {
 7562: 	$file=filelocation($dir,$file);
 7563:     } elsif ($file=~m-^/adm/-) {
 7564: 	$file=~s-^/adm/wrapper/-/-;
 7565: 	$file=~s-^/adm/coursedocs/showdoc/-/-;
 7566:     }
 7567:     if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) {
 7568: 	$file=~s-^\Q$perlvar{'lonDocRoot'}\E--;
 7569:     } elsif ($file=~m-/home/($match_username)/public_html/-) {
 7570: 	$file=~s-^/home/($match_username)/public_html/-/~$1/-;
 7571:     } elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) {
 7572: 	$file=~s-^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/
 7573: 	    -/uploaded/$1/$2/-x;
 7574:     }
 7575:     return $file;
 7576: }
 7577: 
 7578: sub current_machine_domains {
 7579:     return &machine_domains(&hostname($perlvar{'lonHostID'}));
 7580: }
 7581: 
 7582: sub machine_domains {
 7583:     my ($hostname) = @_;
 7584:     my @domains;
 7585:     my %hostname = &all_hostnames();
 7586:     while( my($id, $name) = each(%hostname)) {
 7587: #	&logthis("-$id-$name-$hostname-");
 7588: 	if ($hostname eq $name) {
 7589: 	    push(@domains,&host_domain($id));
 7590: 	}
 7591:     }
 7592:     return @domains;
 7593: }
 7594: 
 7595: sub current_machine_ids {
 7596:     return &machine_ids(&hostname($perlvar{'lonHostID'}));
 7597: }
 7598: 
 7599: sub machine_ids {
 7600:     my ($hostname) = @_;
 7601:     $hostname ||= &hostname($perlvar{'lonHostID'});
 7602:     my @ids;
 7603:     my %name_to_host = &all_names();
 7604:     if (ref($name_to_host{$hostname}) eq 'ARRAY') {
 7605: 	return @{ $name_to_host{$hostname} };
 7606:     }
 7607:     return;
 7608: }
 7609: 
 7610: sub additional_machine_domains {
 7611:     my @domains;
 7612:     open(my $fh,"<$perlvar{'lonTabDir'}/expected_domains.tab");
 7613:     while( my $line = <$fh>) {
 7614:         $line =~ s/\s//g;
 7615:         push(@domains,$line);
 7616:     }
 7617:     return @domains;
 7618: }
 7619: 
 7620: sub default_login_domain {
 7621:     my $domain = $perlvar{'lonDefDomain'};
 7622:     my $testdomain=(split(/\./,$ENV{'HTTP_HOST'}))[0];
 7623:     foreach my $posdom (&current_machine_domains(),
 7624:                         &additional_machine_domains()) {
 7625:         if (lc($posdom) eq lc($testdomain)) {
 7626:             $domain=$posdom;
 7627:             last;
 7628:         }
 7629:     }
 7630:     return $domain;
 7631: }
 7632: 
 7633: # ------------------------------------------------------------- Declutters URLs
 7634: 
 7635: sub declutter {
 7636:     my $thisfn=shift;
 7637:     if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }
 7638:     $thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//;
 7639:     $thisfn=~s/^\///;
 7640:     $thisfn=~s|^adm/wrapper/||;
 7641:     $thisfn=~s|^adm/coursedocs/showdoc/||;
 7642:     $thisfn=~s/^res\///;
 7643:     $thisfn=~s/\?.+$//;
 7644:     return $thisfn;
 7645: }
 7646: 
 7647: # ------------------------------------------------------------- Clutter up URLs
 7648: 
 7649: sub clutter {
 7650:     my $thisfn='/'.&declutter(shift);
 7651:     if ($thisfn !~ m{^/(uploaded|editupload|adm|userfiles|ext|raw|priv|public)/}
 7652: 	|| $thisfn =~ m{^/adm/(includes|pages)} ) { 
 7653:        $thisfn='/res'.$thisfn; 
 7654:     }
 7655:     if ($thisfn !~m|/adm|) {
 7656: 	if ($thisfn =~ m|/ext/|) {
 7657: 	    $thisfn='/adm/wrapper'.$thisfn;
 7658: 	} else {
 7659: 	    my ($ext) = ($thisfn =~ /\.(\w+)$/);
 7660: 	    my $embstyle=&Apache::loncommon::fileembstyle($ext);
 7661: 	    if ($embstyle eq 'ssi'
 7662: 		|| ($embstyle eq 'hdn')
 7663: 		|| ($embstyle eq 'rat')
 7664: 		|| ($embstyle eq 'prv')
 7665: 		|| ($embstyle eq 'ign')) {
 7666: 		#do nothing with these
 7667: 	    } elsif (($embstyle eq 'img') 
 7668: 		|| ($embstyle eq 'emb')
 7669: 		|| ($embstyle eq 'wrp')) {
 7670: 		$thisfn='/adm/wrapper'.$thisfn;
 7671: 	    } elsif ($embstyle eq 'unk'
 7672: 		     && $thisfn!~/\.(sequence|page)$/) {
 7673: 		$thisfn='/adm/coursedocs/showdoc'.$thisfn;
 7674: 	    } else {
 7675: #		&logthis("Got a blank emb style");
 7676: 	    }
 7677: 	}
 7678:     }
 7679:     return $thisfn;
 7680: }
 7681: 
 7682: sub clutter_with_no_wrapper {
 7683:     my $uri = &clutter(shift);
 7684:     if ($uri =~ m-^/adm/-) {
 7685: 	$uri =~ s-^/adm/wrapper/-/-;
 7686: 	$uri =~ s-^/adm/coursedocs/showdoc/-/-;
 7687:     }
 7688:     return $uri;
 7689: }
 7690: 
 7691: sub freeze_escape {
 7692:     my ($value)=@_;
 7693:     if (ref($value)) {
 7694: 	$value=&nfreeze($value);
 7695: 	return '__FROZEN__'.&escape($value);
 7696:     }
 7697:     return &escape($value);
 7698: }
 7699: 
 7700: 
 7701: sub thaw_unescape {
 7702:     my ($value)=@_;
 7703:     if ($value =~ /^__FROZEN__/) {
 7704: 	substr($value,0,10,undef);
 7705: 	$value=&unescape($value);
 7706: 	return &thaw($value);
 7707:     }
 7708:     return &unescape($value);
 7709: }
 7710: 
 7711: sub correct_line_ends {
 7712:     my ($result)=@_;
 7713:     $$result =~s/\r\n/\n/mg;
 7714:     $$result =~s/\r/\n/mg;
 7715: }
 7716: # ================================================================ Main Program
 7717: 
 7718: sub goodbye {
 7719:    &logthis("Starting Shut down");
 7720: #not converted to using infrastruture and probably shouldn't be
 7721:    &logthis(sprintf("%-20s is %s",'%badServerCache',length(&nfreeze(\%badServerCache))));
 7722: #converted
 7723: #   &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));
 7724:    &logthis(sprintf("%-20s is %s",'%homecache',length(&nfreeze(\%homecache))));
 7725: #   &logthis(sprintf("%-20s is %s",'%titlecache',length(&nfreeze(\%titlecache))));
 7726: #   &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&nfreeze(\%courseresdatacache))));
 7727: #1.1 only
 7728: #   &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&nfreeze(\%userresdatacache))));
 7729: #   &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&nfreeze(\%getsectioncache))));
 7730: #   &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&nfreeze(\%courseresversioncache))));
 7731: #   &logthis(sprintf("%-20s is %s",'%resversioncache',length(&nfreeze(\%resversioncache))));
 7732:    &logthis(sprintf("%-20s is %s",'%remembered',length(&nfreeze(\%remembered))));
 7733:    &logthis(sprintf("%-20s is %s",'kicks',$kicks));
 7734:    &logthis(sprintf("%-20s is %s",'hits',$hits));
 7735:    &flushcourselogs();
 7736:    &logthis("Shutting down");
 7737: }
 7738: 
 7739: sub get_dns {
 7740:     my ($url,$func,$ignore_cache) = @_;
 7741:     if (!$ignore_cache) {
 7742: 	my ($content,$cached)=
 7743: 	    &Apache::lonnet::is_cached_new('dns',$url);
 7744: 	if ($cached) {
 7745: 	    &$func($content);
 7746: 	    return;
 7747: 	}
 7748:     }
 7749: 
 7750:     my %alldns;
 7751:     open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
 7752:     foreach my $dns (<$config>) {
 7753: 	next if ($dns !~ /^\^(\S*)/x);
 7754: 	$alldns{$1} = 1;
 7755:     }
 7756:     while (%alldns) {
 7757: 	my ($dns) = keys(%alldns);
 7758: 	delete($alldns{$dns});
 7759: 	my $ua=new LWP::UserAgent;
 7760: 	my $request=new HTTP::Request('GET',"http://$dns$url");
 7761: 	my $response=$ua->request($request);
 7762: 	next if ($response->is_error());
 7763: 	my @content = split("\n",$response->content);
 7764: 	&Apache::lonnet::do_cache_new('dns',$url,\@content,30*24*60*60);
 7765: 	&$func(\@content);
 7766: 	return;
 7767:     }
 7768:     close($config);
 7769:     my $which = (split('/',$url))[3];
 7770:     &logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n");
 7771:     open($config,"<$perlvar{'lonTabDir'}/dns_$which.tab");
 7772:     my @content = <$config>;
 7773:     &$func(\@content);
 7774:     return;
 7775: }
 7776: # ------------------------------------------------------------ Read domain file
 7777: {
 7778:     my $loaded;
 7779:     my %domain;
 7780: 
 7781:     sub parse_domain_tab {
 7782: 	my ($lines) = @_;
 7783: 	foreach my $line (@$lines) {
 7784: 	    next if ($line =~ /^(\#|\s*$ )/x);
 7785: 
 7786: 	    chomp($line);
 7787: 	    my ($name,@elements) = split(/:/,$line,9);
 7788: 	    my %this_domain;
 7789: 	    foreach my $field ('description', 'auth_def', 'auth_arg_def',
 7790: 			       'lang_def', 'city', 'longi', 'lati',
 7791: 			       'primary') {
 7792: 		$this_domain{$field} = shift(@elements);
 7793: 	    }
 7794: 	    $domain{$name} = \%this_domain;
 7795: 	}
 7796:     }
 7797: 
 7798:     sub reset_domain_info {
 7799: 	undef($loaded);
 7800: 	undef(%domain);
 7801:     }
 7802: 
 7803:     sub load_domain_tab {
 7804: 	my ($ignore_cache) = @_;
 7805: 	&get_dns('/adm/dns/domain',\&parse_domain_tab,$ignore_cache);
 7806: 	my $fh;
 7807: 	if (open($fh,"<".$perlvar{'lonTabDir'}.'/domain.tab')) {
 7808: 	    my @lines = <$fh>;
 7809: 	    &parse_domain_tab(\@lines);
 7810: 	}
 7811: 	close($fh);
 7812: 	$loaded = 1;
 7813:     }
 7814: 
 7815:     sub domain {
 7816: 	&load_domain_tab() if (!$loaded);
 7817: 
 7818: 	my ($name,$what) = @_;
 7819: 	return if ( !exists($domain{$name}) );
 7820: 
 7821: 	if (!$what) {
 7822: 	    return $domain{$name}{'description'};
 7823: 	}
 7824: 	return $domain{$name}{$what};
 7825:     }
 7826: }
 7827: 
 7828: 
 7829: # ------------------------------------------------------------- Read hosts file
 7830: {
 7831:     my %hostname;
 7832:     my %hostdom;
 7833:     my %libserv;
 7834:     my $loaded;
 7835:     my %name_to_host;
 7836: 
 7837:     sub parse_hosts_tab {
 7838: 	my ($file) = @_;
 7839: 	foreach my $configline (@$file) {
 7840: 	    next if ($configline =~ /^(\#|\s*$ )/x);
 7841: 	    next if ($configline =~ /^\^/);
 7842: 	    chomp($configline);
 7843: 	    my ($id,$domain,$role,$name)=split(/:/,$configline);
 7844: 	    $name=~s/\s//g;
 7845: 	    if ($id && $domain && $role && $name) {
 7846: 		$hostname{$id}=$name;
 7847: 		push(@{$name_to_host{$name}}, $id);
 7848: 		$hostdom{$id}=$domain;
 7849: 		if ($role eq 'library') { $libserv{$id}=$name; }
 7850: 	    }
 7851: 	}
 7852:     }
 7853:     
 7854:     sub reset_hosts_info {
 7855: 	&reset_domain_info();
 7856: 	&reset_hosts_ip_info();
 7857: 	undef(%name_to_host);
 7858: 	undef(%hostname);
 7859: 	undef(%hostdom);
 7860: 	undef(%libserv);
 7861: 	undef($loaded);
 7862:     }
 7863: 
 7864:     sub load_hosts_tab {
 7865: 	my ($ignore_cache) = @_;
 7866: 	&get_dns('/adm/dns/hosts',\&parse_hosts_tab,$ignore_cache);
 7867: 	open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
 7868: 	my @config = <$config>;
 7869: 	&parse_hosts_tab(\@config);
 7870: 	close($config);
 7871: 	$loaded=1;
 7872:     }
 7873: 
 7874:     sub hostname {
 7875: 	&load_hosts_tab() if (!$loaded);
 7876: 
 7877: 	my ($lonid) = @_;
 7878: 	return $hostname{$lonid};
 7879:     }
 7880: 
 7881:     sub all_hostnames {
 7882: 	&load_hosts_tab() if (!$loaded);
 7883: 
 7884: 	return %hostname;
 7885:     }
 7886: 
 7887:     sub all_names {
 7888: 	&load_hosts_tab() if (!$loaded);
 7889: 
 7890: 	return %name_to_host;
 7891:     }
 7892: 
 7893:     sub is_library {
 7894: 	&load_hosts_tab() if (!$loaded);
 7895: 
 7896: 	return exists($libserv{$_[0]});
 7897:     }
 7898: 
 7899:     sub all_library {
 7900: 	&load_hosts_tab() if (!$loaded);
 7901: 
 7902: 	return %libserv;
 7903:     }
 7904: 
 7905:     sub get_servers {
 7906: 	&load_hosts_tab() if (!$loaded);
 7907: 
 7908: 	my ($domain,$type) = @_;
 7909: 	my %possible_hosts = ($type eq 'library') ? %libserv
 7910: 	                                          : %hostname;
 7911: 	my %result;
 7912: 	if (ref($domain) eq 'ARRAY') {
 7913: 	    while ( my ($host,$hostname) = each(%possible_hosts)) {
 7914: 		if (grep(/^\Q$hostdom{$host}\E$/,@$domain)) {
 7915: 		    $result{$host} = $hostname;
 7916: 		}
 7917: 	    }
 7918: 	} else {
 7919: 	    while ( my ($host,$hostname) = each(%possible_hosts)) {
 7920: 		if ($hostdom{$host} eq $domain) {
 7921: 		    $result{$host} = $hostname;
 7922: 		}
 7923: 	    }
 7924: 	}
 7925: 	return %result;
 7926:     }
 7927: 
 7928:     sub host_domain {
 7929: 	&load_hosts_tab() if (!$loaded);
 7930: 
 7931: 	my ($lonid) = @_;
 7932: 	return $hostdom{$lonid};
 7933:     }
 7934: 
 7935:     sub all_domains {
 7936: 	&load_hosts_tab() if (!$loaded);
 7937: 
 7938: 	my %seen;
 7939: 	my @uniq = grep(!$seen{$_}++, values(%hostdom));
 7940: 	return @uniq;
 7941:     }
 7942: }
 7943: 
 7944: { 
 7945:     my %iphost;
 7946:     my %name_to_ip;
 7947:     my %lonid_to_ip;
 7948: 
 7949:     sub get_hosts_from_ip {
 7950: 	my ($ip) = @_;
 7951: 	my %iphosts = &get_iphost();
 7952: 	if (ref($iphosts{$ip})) {
 7953: 	    return @{$iphosts{$ip}};
 7954: 	}
 7955: 	return;
 7956:     }
 7957:     
 7958:     sub reset_hosts_ip_info {
 7959: 	undef(%iphost);
 7960: 	undef(%name_to_ip);
 7961: 	undef(%lonid_to_ip);
 7962:     }
 7963: 
 7964:     sub get_host_ip {
 7965: 	my ($lonid) = @_;
 7966: 	if (exists($lonid_to_ip{$lonid})) {
 7967: 	    return $lonid_to_ip{$lonid};
 7968: 	}
 7969: 	my $name=&hostname($lonid);
 7970:    	my $ip = gethostbyname($name);
 7971: 	return if (!$ip || length($ip) ne 4);
 7972: 	$ip=inet_ntoa($ip);
 7973: 	$name_to_ip{$name}   = $ip;
 7974: 	$lonid_to_ip{$lonid} = $ip;
 7975: 	return $ip;
 7976:     }
 7977:     
 7978:     sub get_iphost {
 7979: 	my ($ignore_cache) = @_;
 7980: 
 7981: 	if (!$ignore_cache) {
 7982: 	    if (%iphost) {
 7983: 		return %iphost;
 7984: 	    }
 7985: 	    my ($ip_info,$cached)=
 7986: 		&Apache::lonnet::is_cached_new('iphost','iphost');
 7987: 	    if ($cached) {
 7988: 		%iphost      = %{$ip_info->[0]};
 7989: 		%name_to_ip  = %{$ip_info->[1]};
 7990: 		%lonid_to_ip = %{$ip_info->[2]};
 7991: 		return %iphost;
 7992: 	    }
 7993: 	}
 7994: 
 7995: 	# get yesterday's info for fallback
 7996: 	my %old_name_to_ip;
 7997: 	my ($ip_info,$cached)=
 7998: 	    &Apache::lonnet::is_cached_new('iphost','iphost');
 7999: 	if ($cached) {
 8000: 	    %old_name_to_ip = %{$ip_info->[1]};
 8001: 	}
 8002: 
 8003: 	my %name_to_host = &all_names();
 8004: 	foreach my $name (keys(%name_to_host)) {
 8005: 	    my $ip;
 8006: 	    if (!exists($name_to_ip{$name})) {
 8007: 		$ip = gethostbyname($name);
 8008: 		if (!$ip || length($ip) ne 4) {
 8009: 		    if (defined($old_name_to_ip{$name})) {
 8010: 			$ip = $old_name_to_ip{$name};
 8011: 			&logthis("Can't find $name defaulting to old $ip");
 8012: 		    } else {
 8013: 			&logthis("Name $name no IP found");
 8014: 			next;
 8015: 		    }
 8016: 		} else {
 8017: 		    $ip=inet_ntoa($ip);
 8018: 		}
 8019: 		$name_to_ip{$name} = $ip;
 8020: 	    } else {
 8021: 		$ip = $name_to_ip{$name};
 8022: 	    }
 8023: 	    foreach my $id (@{ $name_to_host{$name} }) {
 8024: 		$lonid_to_ip{$id} = $ip;
 8025: 	    }
 8026: 	    push(@{$iphost{$ip}},@{$name_to_host{$name}});
 8027: 	}
 8028: 	&Apache::lonnet::do_cache_new('iphost','iphost',
 8029: 				      [\%iphost,\%name_to_ip,\%lonid_to_ip],
 8030: 				      48*60*60);
 8031: 
 8032: 	return %iphost;
 8033:     }
 8034: }
 8035: 
 8036: BEGIN {
 8037: 
 8038: # ----------------------------------- Read loncapa.conf and loncapa_apache.conf
 8039:     unless ($readit) {
 8040: {
 8041:     my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf');
 8042:     %perlvar = (%perlvar,%{$configvars});
 8043: }
 8044: 
 8045: 
 8046: # ------------------------------------------------------ Read spare server file
 8047: {
 8048:     open(my $config,"<$perlvar{'lonTabDir'}/spare.tab");
 8049: 
 8050:     while (my $configline=<$config>) {
 8051:        chomp($configline);
 8052:        if ($configline) {
 8053: 	   my ($host,$type) = split(':',$configline,2);
 8054: 	   if (!defined($type) || $type eq '') { $type = 'default' };
 8055: 	   push(@{ $spareid{$type} }, $host);
 8056:        }
 8057:     }
 8058:     close($config);
 8059: }
 8060: # ------------------------------------------------------------ Read permissions
 8061: {
 8062:     open(my $config,"<$perlvar{'lonTabDir'}/roles.tab");
 8063: 
 8064:     while (my $configline=<$config>) {
 8065: 	chomp($configline);
 8066: 	if ($configline) {
 8067: 	    my ($role,$perm)=split(/ /,$configline);
 8068: 	    if ($perm ne '') { $pr{$role}=$perm; }
 8069: 	}
 8070:     }
 8071:     close($config);
 8072: }
 8073: 
 8074: # -------------------------------------------- Read plain texts for permissions
 8075: {
 8076:     open(my $config,"<$perlvar{'lonTabDir'}/rolesplain.tab");
 8077: 
 8078:     while (my $configline=<$config>) {
 8079: 	chomp($configline);
 8080: 	if ($configline) {
 8081: 	    my ($short,@plain)=split(/:/,$configline);
 8082:             %{$prp{$short}} = ();
 8083: 	    if (@plain > 0) {
 8084:                 $prp{$short}{'std'} = $plain[0];
 8085:                 for (my $i=1; $i<@plain; $i++) {
 8086:                     $prp{$short}{'alt'.$i} = $plain[$i];  
 8087:                 }
 8088:             }
 8089: 	}
 8090:     }
 8091:     close($config);
 8092: }
 8093: 
 8094: # ---------------------------------------------------------- Read package table
 8095: {
 8096:     open(my $config,"<$perlvar{'lonTabDir'}/packages.tab");
 8097: 
 8098:     while (my $configline=<$config>) {
 8099: 	if ($configline !~ /\S/ || $configline=~/^#/) { next; }
 8100: 	chomp($configline);
 8101: 	my ($short,$plain)=split(/:/,$configline);
 8102: 	my ($pack,$name)=split(/\&/,$short);
 8103: 	if ($plain ne '') {
 8104: 	    $packagetab{$pack.'&'.$name.'&name'}=$name; 
 8105: 	    $packagetab{$short}=$plain; 
 8106: 	}
 8107:     }
 8108:     close($config);
 8109: }
 8110: 
 8111: # ------------- set up temporary directory
 8112: {
 8113:     $tmpdir = $perlvar{'lonDaemons'}.'/tmp/';
 8114: 
 8115: }
 8116: 
 8117: $memcache=new Cache::Memcached({'servers'           => ['127.0.0.1:11211'],
 8118: 				'compress_threshold'=> 20_000,
 8119:  			        });
 8120: 
 8121: $processmarker='_'.time.'_'.$perlvar{'lonHostID'};
 8122: $dumpcount=0;
 8123: 
 8124: &logtouch();
 8125: &logthis('<font color="yellow">INFO: Read configuration</font>');
 8126: $readit=1;
 8127:     {
 8128: 	use integer;
 8129: 	my $test=(2**32)+1;
 8130: 	if ($test != 0) { $_64bit=1; } else { $_64bit=0; }
 8131: 	&logthis(" Detected 64bit platform ($_64bit)");
 8132:     }
 8133: }
 8134: }
 8135: 
 8136: 1;
 8137: __END__
 8138: 
 8139: =pod
 8140: 
 8141: =head1 NAME
 8142: 
 8143: Apache::lonnet - Subroutines to ask questions about things in the network.
 8144: 
 8145: =head1 SYNOPSIS
 8146: 
 8147: Invoked by other LON-CAPA modules, when they need to talk to or about objects in the network.
 8148: 
 8149:  &Apache::lonnet::SUBROUTINENAME(ARGUMENTS);
 8150: 
 8151: Common parameters:
 8152: 
 8153: =over 4
 8154: 
 8155: =item *
 8156: 
 8157: $uname : an internal username (if $cname expecting a course Id specifically)
 8158: 
 8159: =item *
 8160: 
 8161: $udom : a domain (if $cdom expecting a course's domain specifically)
 8162: 
 8163: =item *
 8164: 
 8165: $symb : a resource instance identifier
 8166: 
 8167: =item *
 8168: 
 8169: $namespace : the name of a .db file that contains the data needed or
 8170: being set.
 8171: 
 8172: =back
 8173: 
 8174: =head1 OVERVIEW
 8175: 
 8176: lonnet provides subroutines which interact with the
 8177: lonc/lond (TCP) network layer of LON-CAPA. They can be used to ask
 8178: about classes, users, and resources.
 8179: 
 8180: For many of these objects you can also use this to store data about
 8181: them or modify them in various ways.
 8182: 
 8183: =head2 Symbs
 8184: 
 8185: To identify a specific instance of a resource, LON-CAPA uses symbols
 8186: or "symbs"X<symb>. These identifiers are built from the URL of the
 8187: map, the resource number of the resource in the map, and the URL of
 8188: the resource itself. The latter is somewhat redundant, but might help
 8189: if maps change.
 8190: 
 8191: An example is
 8192: 
 8193:  msu/korte/parts/part1.sequence___19___msu/korte/tests/part12.problem
 8194: 
 8195: The respective map entry is
 8196: 
 8197:  <resource id="19" src="/res/msu/korte/tests/part12.problem"
 8198:   title="Problem 2">
 8199:  </resource>
 8200: 
 8201: Symbs are used by the random number generator, as well as to store and
 8202: restore data specific to a certain instance of for example a problem.
 8203: 
 8204: =head2 Storing And Retrieving Data
 8205: 
 8206: X<store()>X<cstore()>X<restore()>Three of the most important functions
 8207: in C<lonnet.pm> are C<&Apache::lonnet::cstore()>,
 8208: C<&Apache::lonnet:restore()>, and C<&Apache::lonnet::store()>, which
 8209: is is the non-critical message twin of cstore. These functions are for
 8210: handlers to store a perl hash to a user's permanent data space in an
 8211: easy manner, and to retrieve it again on another call. It is expected
 8212: that a handler would use this once at the beginning to retrieve data,
 8213: and then again once at the end to send only the new data back.
 8214: 
 8215: The data is stored in the user's data directory on the user's
 8216: homeserver under the ID of the course.
 8217: 
 8218: The hash that is returned by restore will have all of the previous
 8219: value for all of the elements of the hash.
 8220: 
 8221: Example:
 8222: 
 8223:  #creating a hash
 8224:  my %hash;
 8225:  $hash{'foo'}='bar';
 8226: 
 8227:  #storing it
 8228:  &Apache::lonnet::cstore(\%hash);
 8229: 
 8230:  #changing a value
 8231:  $hash{'foo'}='notbar';
 8232: 
 8233:  #adding a new value
 8234:  $hash{'bar'}='foo';
 8235:  &Apache::lonnet::cstore(\%hash);
 8236: 
 8237:  #retrieving the hash
 8238:  my %history=&Apache::lonnet::restore();
 8239: 
 8240:  #print the hash
 8241:  foreach my $key (sort(keys(%history))) {
 8242:    print("\%history{$key} = $history{$key}");
 8243:  }
 8244: 
 8245: Will print out:
 8246: 
 8247:  %history{1:foo} = bar
 8248:  %history{1:keys} = foo:timestamp
 8249:  %history{1:timestamp} = 990455579
 8250:  %history{2:bar} = foo
 8251:  %history{2:foo} = notbar
 8252:  %history{2:keys} = foo:bar:timestamp
 8253:  %history{2:timestamp} = 990455580
 8254:  %history{bar} = foo
 8255:  %history{foo} = notbar
 8256:  %history{timestamp} = 990455580
 8257:  %history{version} = 2
 8258: 
 8259: Note that the special hash entries C<keys>, C<version> and
 8260: C<timestamp> were added to the hash. C<version> will be equal to the
 8261: total number of versions of the data that have been stored. The
 8262: C<timestamp> attribute will be the UNIX time the hash was
 8263: stored. C<keys> is available in every historical section to list which
 8264: keys were added or changed at a specific historical revision of a
 8265: hash.
 8266: 
 8267: B<Warning>: do not store the hash that restore returns directly. This
 8268: will cause a mess since it will restore the historical keys as if the
 8269: were new keys. I.E. 1:foo will become 1:1:foo etc.
 8270: 
 8271: Calling convention:
 8272: 
 8273:  my %record=&Apache::lonnet::restore($symb,$courseid,$domain,$uname,$home);
 8274:  &Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname,$home);
 8275: 
 8276: For more detailed information, see lonnet specific documentation.
 8277: 
 8278: =head1 RETURN MESSAGES
 8279: 
 8280: =over 4
 8281: 
 8282: =item * B<con_lost>: unable to contact remote host
 8283: 
 8284: =item * B<con_delayed>: unable to contact remote host, message will be delivered
 8285: when the connection is brought back up
 8286: 
 8287: =item * B<con_failed>: unable to contact remote host and unable to save message
 8288: for later delivery
 8289: 
 8290: =item * B<error:>: an error a occured, a description of the error follows the :
 8291: 
 8292: =item * B<no_such_host>: unable to fund a host associated with the user/domain
 8293: that was requested
 8294: 
 8295: =back
 8296: 
 8297: =head1 PUBLIC SUBROUTINES
 8298: 
 8299: =head2 Session Environment Functions
 8300: 
 8301: =over 4
 8302: 
 8303: =item * 
 8304: X<appenv()>
 8305: B<appenv(%hash)>: the value of %hash is written to
 8306: the user envirnoment file, and will be restored for each access this
 8307: user makes during this session, also modifies the %env for the current
 8308: process
 8309: 
 8310: =item *
 8311: X<delenv()>
 8312: B<delenv($regexp)>: removes all items from the session
 8313: environment file that matches the regular expression in $regexp. The
 8314: values are also delted from the current processes %env.
 8315: 
 8316: =item * get_env_multiple($name) 
 8317: 
 8318: gets $name from the %env hash, it seemlessly handles the cases where multiple
 8319: values may be defined and end up as an array ref.
 8320: 
 8321: returns an array of values
 8322: 
 8323: =back
 8324: 
 8325: =head2 User Information
 8326: 
 8327: =over 4
 8328: 
 8329: =item *
 8330: X<queryauthenticate()>
 8331: B<queryauthenticate($uname,$udom)>: try to determine user's current 
 8332: authentication scheme
 8333: 
 8334: =item *
 8335: X<authenticate()>
 8336: B<authenticate($uname,$upass,$udom)>: try to
 8337: authenticate user from domain's lib servers (first use the current
 8338: one). C<$upass> should be the users password.
 8339: 
 8340: =item *
 8341: X<homeserver()>
 8342: B<homeserver($uname,$udom)>: find the server which has
 8343: the user's directory and files (there must be only one), this caches
 8344: the answer, and also caches if there is a borken connection.
 8345: 
 8346: =item *
 8347: X<idget()>
 8348: B<idget($udom,@ids)>: find the usernames behind a list of IDs
 8349: (IDs are a unique resource in a domain, there must be only 1 ID per
 8350: username, and only 1 username per ID in a specific domain) (returns
 8351: hash: id=>name,id=>name)
 8352: 
 8353: =item *
 8354: X<idrget()>
 8355: B<idrget($udom,@unames)>: find the IDs behind a list of
 8356: usernames (returns hash: name=>id,name=>id)
 8357: 
 8358: =item *
 8359: X<idput()>
 8360: B<idput($udom,%ids)>: store away a list of names and associated IDs
 8361: 
 8362: =item *
 8363: X<rolesinit()>
 8364: B<rolesinit($udom,$username,$authhost)>: get user privileges
 8365: 
 8366: =item *
 8367: X<getsection()>
 8368: B<getsection($udom,$uname,$cname)>: finds the section of student in the
 8369: course $cname, return section name/number or '' for "not in course"
 8370: and '-1' for "no section"
 8371: 
 8372: =item *
 8373: X<userenvironment()>
 8374: B<userenvironment($udom,$uname,@what)>: gets the values of the keys
 8375: passed in @what from the requested user's environment, returns a hash
 8376: 
 8377: =item * 
 8378: X<userlog_query()>
 8379: B<userlog_query($uname,$udom,%filters)>: retrieves data from a user's
 8380: activity.log file. %filters defines filters applied when parsing the
 8381: log file. These can be start or end timestamps, or the type of action
 8382: - log to look for Login or Logout events, check for Checkin or
 8383: Checkout, role for role selection. The response is in the form
 8384: timestamp1:hostid1:event1&timestamp2:hostid2:event2 where events are
 8385: escaped strings of the action recorded in the activity.log file.
 8386: 
 8387: =back
 8388: 
 8389: =head2 User Roles
 8390: 
 8391: =over 4
 8392: 
 8393: =item *
 8394: 
 8395: allowed($priv,$uri,$symb,$role) : check for a user privilege; returns codes for allowed actions
 8396:  F: full access
 8397:  U,I,K: authentication modes (cxx only)
 8398:  '': forbidden
 8399:  1: user needs to choose course
 8400:  2: browse allowed
 8401:  A: passphrase authentication needed
 8402: 
 8403: =item *
 8404: 
 8405: definerole($rolename,$sysrole,$domrole,$courole) : define role; define a custom
 8406: role rolename set privileges in format of lonTabs/roles.tab for system, domain,
 8407: and course level
 8408: 
 8409: =item *
 8410: 
 8411: plaintext($short) : return value in %prp hash (rolesplain.tab); plain text
 8412: explanation of a user role term
 8413: 
 8414: =item *
 8415: 
 8416: get_my_roles($uname,$udom,$context,$types,$roles,$roledoms) :
 8417: All arguments are optional. Returns a hash of a roles, either for
 8418: co-author/assistant author roles for a user's Construction Space
 8419: (default), or if $context is 'user', roles for the user himself,
 8420: In the hash, keys are set to colon-sparated $uname,$udom,and $role,
 8421: and value is set to colon-separated start and end times for the role.
 8422: If no username and domain are specified, will default to current
 8423: user/domain. Types, roles, and roledoms are references to arrays,
 8424: of role statuses (active, future or previous), roles 
 8425: (e.g., cc,in, st etc.) and domains of the roles which can be used
 8426: to restrict the list of roles reported. If no array ref is 
 8427: provided for types, will default to return only active roles.
 8428: 
 8429: =back
 8430: 
 8431: =head2 User Modification
 8432: 
 8433: =over 4
 8434: 
 8435: =item *
 8436: 
 8437: assignrole($udom,$uname,$url,$role,$end,$start) : assign role; give a role to a
 8438: user for the level given by URL.  Optional start and end dates (leave empty
 8439: string or zero for "no date")
 8440: 
 8441: =item *
 8442: 
 8443: changepass($uname,$udom,$currentpass,$newpass,$server) : attempts to
 8444: change a users, password, possible return values are: ok,
 8445: pwchange_failure, non_authorized, auth_mode_error, unknown_user,
 8446: refused
 8447: 
 8448: =item *
 8449: 
 8450: modifyuserauth($udom,$uname,$umode,$upass) : modify user authentication
 8451: 
 8452: =item *
 8453: 
 8454: modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene) : 
 8455: modify user
 8456: 
 8457: =item *
 8458: 
 8459: modifystudent
 8460: 
 8461: modify a students enrollment and identification information.
 8462: The course id is resolved based on the current users environment.  
 8463: This means the envoking user must be a course coordinator or otherwise
 8464: associated with a course.
 8465: 
 8466: This call is essentially a wrapper for lonnet::modifyuser and
 8467: lonnet::modify_student_enrollment
 8468: 
 8469: Inputs: 
 8470: 
 8471: =over 4
 8472: 
 8473: =item B<$udom> Students loncapa domain
 8474: 
 8475: =item B<$uname> Students loncapa login name
 8476: 
 8477: =item B<$uid> Students id/student number
 8478: 
 8479: =item B<$umode> Students authentication mode
 8480: 
 8481: =item B<$upass> Students password
 8482: 
 8483: =item B<$first> Students first name
 8484: 
 8485: =item B<$middle> Students middle name
 8486: 
 8487: =item B<$last> Students last name
 8488: 
 8489: =item B<$gene> Students generation
 8490: 
 8491: =item B<$usec> Students section in course
 8492: 
 8493: =item B<$end> Unix time of the roles expiration
 8494: 
 8495: =item B<$start> Unix time of the roles start date
 8496: 
 8497: =item B<$forceid> If defined, allow $uid to be changed
 8498: 
 8499: =item B<$desiredhome> server to use as home server for student
 8500: 
 8501: =back
 8502: 
 8503: =item *
 8504: 
 8505: modify_student_enrollment
 8506: 
 8507: Change a students enrollment status in a class.  The environment variable
 8508: 'role.request.course' must be defined for this function to proceed.
 8509: 
 8510: Inputs:
 8511: 
 8512: =over 4
 8513: 
 8514: =item $udom, students domain
 8515: 
 8516: =item $uname, students name
 8517: 
 8518: =item $uid, students user id
 8519: 
 8520: =item $first, students first name
 8521: 
 8522: =item $middle
 8523: 
 8524: =item $last
 8525: 
 8526: =item $gene
 8527: 
 8528: =item $usec
 8529: 
 8530: =item $end
 8531: 
 8532: =item $start
 8533: 
 8534: =back
 8535: 
 8536: 
 8537: =item *
 8538: 
 8539: assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start) : assign
 8540: custom role; give a custom role to a user for the level given by URL.  Specify
 8541: name and domain of role author, and role name
 8542: 
 8543: =item *
 8544: 
 8545: revokerole($udom,$uname,$url,$role) : revoke a role for url
 8546: 
 8547: =item *
 8548: 
 8549: revokecustomrole($udom,$uname,$url,$role) : revoke a custom role
 8550: 
 8551: =back
 8552: 
 8553: =head2 Course Infomation
 8554: 
 8555: =over 4
 8556: 
 8557: =item *
 8558: 
 8559: coursedescription($courseid) : returns a hash of information about the
 8560: specified course id, including all environment settings for the
 8561: course, the description of the course will be in the hash under the
 8562: key 'description'
 8563: 
 8564: =item *
 8565: 
 8566: resdata($name,$domain,$type,@which) : request for current parameter
 8567: setting for a specific $type, where $type is either 'course' or 'user',
 8568: @what should be a list of parameters to ask about. This routine caches
 8569: answers for 5 minutes.
 8570: 
 8571: =item *
 8572: 
 8573: get_courseresdata($courseid, $domain) : dump the entire course resource
 8574: data base, returning a hash that is keyed by the resource name and has
 8575: values that are the resource value.  I believe that the timestamps and
 8576: versions are also returned.
 8577: 
 8578: 
 8579: =back
 8580: 
 8581: =head2 Course Modification
 8582: 
 8583: =over 4
 8584: 
 8585: =item *
 8586: 
 8587: writecoursepref($courseid,%prefs) : write preferences (environment
 8588: database) for a course
 8589: 
 8590: =item *
 8591: 
 8592: createcourse($udom,$description,$url) : make/modify course
 8593: 
 8594: =back
 8595: 
 8596: =head2 Resource Subroutines
 8597: 
 8598: =over 4
 8599: 
 8600: =item *
 8601: 
 8602: subscribe($fname) : subscribe to a resource, returns URL if possible (probably should use repcopy instead)
 8603: 
 8604: =item *
 8605: 
 8606: repcopy($filename) : subscribes to the requested file, and attempts to
 8607: replicate from the owning library server, Might return
 8608: 'unavailable', 'not_found', 'forbidden', 'ok', or
 8609: 'bad_request', also attempts to grab the metadata for the
 8610: resource. Expects the local filesystem pathname
 8611: (/home/httpd/html/res/....)
 8612: 
 8613: =back
 8614: 
 8615: =head2 Resource Information
 8616: 
 8617: =over 4
 8618: 
 8619: =item *
 8620: 
 8621: EXT($varname,$symb,$udom,$uname) : evaluates and returns the value of
 8622: a vairety of different possible values, $varname should be a request
 8623: string, and the other parameters can be used to specify who and what
 8624: one is asking about.
 8625: 
 8626: Possible values for $varname are environment.lastname (or other item
 8627: from the envirnment hash), user.name (or someother aspect about the
 8628: user), resource.0.maxtries (or some other part and parameter of a
 8629: resource)
 8630: 
 8631: =item *
 8632: 
 8633: directcondval($number) : get current value of a condition; reads from a state
 8634: string
 8635: 
 8636: =item *
 8637: 
 8638: condval($condidx) : value of condition index based on state
 8639: 
 8640: =item *
 8641: 
 8642: metadata($uri,$what,$liburi,$prefix,$depthcount) : request a
 8643: resource's metadata, $what should be either a specific key, or either
 8644: 'keys' (to get a list of possible keys) or 'packages' to get a list of
 8645: packages that this resource currently uses, the last 3 arguments are only used internally for recursive metadata.
 8646: 
 8647: this function automatically caches all requests
 8648: 
 8649: =item *
 8650: 
 8651: metadata_query($query,$custom,$customshow) : make a metadata query against the
 8652: network of library servers; returns file handle of where SQL and regex results
 8653: will be stored for query
 8654: 
 8655: =item *
 8656: 
 8657: symbread($filename) : return symbolic list entry (filename argument optional);
 8658: returns the data handle
 8659: 
 8660: =item *
 8661: 
 8662: symbverify($symb,$thisfn) : verifies that $symb actually exists and is
 8663: a possible symb for the URL in $thisfn, and if is an encryypted
 8664: resource that the user accessed using /enc/ returns a 1 on success, 0
 8665: on failure, user must be in a course, as it assumes the existance of
 8666: the course initial hash, and uses $env('request.course.id'}
 8667: 
 8668: 
 8669: =item *
 8670: 
 8671: symbclean($symb) : removes versions numbers from a symb, returns the
 8672: cleaned symb
 8673: 
 8674: =item *
 8675: 
 8676: is_on_map($uri) : checks if the $uri is somewhere on the current
 8677: course map, user must be in a course for it to work.
 8678: 
 8679: =item *
 8680: 
 8681: numval($salt) : return random seed value (addend for rndseed)
 8682: 
 8683: =item *
 8684: 
 8685: rndseed($symb,$courseid,$udom,$uname) : create a random sum; returns
 8686: a random seed, all arguments are optional, if they aren't sent it uses the
 8687: environment to derive them. Note: if symb isn't sent and it can't get one
 8688: from &symbread it will use the current time as its return value
 8689: 
 8690: =item *
 8691: 
 8692: ireceipt($funame,$fudom,$fucourseid,$fusymb) : return unique,
 8693: unfakeable, receipt
 8694: 
 8695: =item *
 8696: 
 8697: receipt() : API to ireceipt working off of env values; given out to users
 8698: 
 8699: =item *
 8700: 
 8701: countacc($url) : count the number of accesses to a given URL
 8702: 
 8703: =item *
 8704: 
 8705: checkout($symb,$tuname,$tudom,$tcrsid) :  creates a record of a user having looked at an item, most likely printed out or otherwise using a resource
 8706: 
 8707: =item *
 8708: 
 8709: checkin($token) : updates that a resource has beeen returned (a hard copy version for instance) and returns the data that $token was Checkout with ($symb, $tuname, $tudom, and $tcrsid)
 8710: 
 8711: =item *
 8712: 
 8713: expirespread($uname,$udom,$stype,$usymb) : set expire date for spreadsheet
 8714: 
 8715: =item *
 8716: 
 8717: devalidate($symb) : devalidate temporary spreadsheet calculations,
 8718: forcing spreadsheet to reevaluate the resource scores next time.
 8719: 
 8720: =back
 8721: 
 8722: =head2 Storing/Retreiving Data
 8723: 
 8724: =over 4
 8725: 
 8726: =item *
 8727: 
 8728: store($storehash,$symb,$namespace,$udom,$uname) : stores hash permanently
 8729: for this url; hashref needs to be given and should be a \%hashname; the
 8730: remaining args aren't required and if they aren't passed or are '' they will
 8731: be derived from the env
 8732: 
 8733: =item *
 8734: 
 8735: cstore($storehash,$symb,$namespace,$udom,$uname) : same as store but
 8736: uses critical subroutine
 8737: 
 8738: =item *
 8739: 
 8740: restore($symb,$namespace,$udom,$uname) : returns hash for this symb;
 8741: all args are optional
 8742: 
 8743: =item *
 8744: 
 8745: dumpstore($namespace,$udom,$uname,$regexp,$range) : 
 8746: dumps the complete (or key matching regexp) namespace into a hash
 8747: ($udom, $uname, $regexp, $range are optional) for a namespace that is
 8748: normally &store()ed into
 8749: 
 8750: $range should be either an integer '100' (give me the first 100
 8751:                                            matching records)
 8752:               or be  two integers sperated by a - with no spaces
 8753:                  '30-50' (give me the 30th through the 50th matching
 8754:                           records)
 8755: 
 8756: 
 8757: =item *
 8758: 
 8759: putstore($namespace,$symb,$version,$storehash,$udomain,$uname) :
 8760: replaces a &store() version of data with a replacement set of data
 8761: for a particular resource in a namespace passed in the $storehash hash 
 8762: reference
 8763: 
 8764: =item *
 8765: 
 8766: tmpstore($storehash,$symb,$namespace,$udom,$uname) : storage that
 8767: works very similar to store/cstore, but all data is stored in a
 8768: temporary location and can be reset using tmpreset, $storehash should
 8769: be a hash reference, returns nothing on success
 8770: 
 8771: =item *
 8772: 
 8773: tmprestore($symb,$namespace,$udom,$uname) : storage that works very
 8774: similar to restore, but all data is stored in a temporary location and
 8775: can be reset using tmpreset. Returns a hash of values on success,
 8776: error string otherwise.
 8777: 
 8778: =item *
 8779: 
 8780: tmpreset($symb,$namespace,$udom,$uname) : temporary storage reset,
 8781: deltes all keys for $symb form the temporary storage hash.
 8782: 
 8783: =item *
 8784: 
 8785: get($namespace,$storearr,$udom,$uname) : returns hash with keys from array
 8786: reference filled in from namesp ($udom and $uname are optional)
 8787: 
 8788: =item *
 8789: 
 8790: del($namespace,$storearr,$udom,$uname) : deletes keys out of array from
 8791: namesp ($udom and $uname are optional)
 8792: 
 8793: =item *
 8794: 
 8795: dump($namespace,$udom,$uname,$regexp,$range) : 
 8796: dumps the complete (or key matching regexp) namespace into a hash
 8797: ($udom, $uname, $regexp, $range are optional)
 8798: 
 8799: $range should be either an integer '100' (give me the first 100
 8800:                                            matching records)
 8801:               or be  two integers sperated by a - with no spaces
 8802:                  '30-50' (give me the 30th through the 50th matching
 8803:                           records)
 8804: =item *
 8805: 
 8806: inc($namespace,$store,$udom,$uname) : increments $store in $namespace.
 8807: $store can be a scalar, an array reference, or if the amount to be 
 8808: incremented is > 1, a hash reference.
 8809: 
 8810: ($udom and $uname are optional)
 8811: 
 8812: =item *
 8813: 
 8814: put($namespace,$storehash,$udom,$uname) : stores hash in namesp
 8815: ($udom and $uname are optional)
 8816: 
 8817: =item *
 8818: 
 8819: cput($namespace,$storehash,$udom,$uname) : critical put
 8820: ($udom and $uname are optional)
 8821: 
 8822: =item *
 8823: 
 8824: newput($namespace,$storehash,$udom,$uname) :
 8825: 
 8826: Attempts to store the items in the $storehash, but only if they don't
 8827: currently exist, if this succeeds you can be certain that you have 
 8828: successfully created a new key value pair in the $namespace db.
 8829: 
 8830: 
 8831: Args:
 8832:  $namespace: name of database to store values to
 8833:  $storehash: hashref to store to the db
 8834:  $udom: (optional) domain of user containing the db
 8835:  $uname: (optional) name of user caontaining the db
 8836: 
 8837: Returns:
 8838:  'ok' -> succeeded in storing all keys of $storehash
 8839:  'key_exists: <key>' -> failed to anything out of $storehash, as at
 8840:                         least <key> already existed in the db (other
 8841:                         requested keys may also already exist)
 8842:  'error: <msg>' -> unable to tie the DB or other erorr occured
 8843:  'con_lost' -> unable to contact request server
 8844:  'refused' -> action was not allowed by remote machine
 8845: 
 8846: 
 8847: =item *
 8848: 
 8849: eget($namespace,$storearr,$udom,$uname) : returns hash with keys from array
 8850: reference filled in from namesp (encrypts the return communication)
 8851: ($udom and $uname are optional)
 8852: 
 8853: =item *
 8854: 
 8855: log($udom,$name,$home,$message) : write to permanent log for user; use
 8856: critical subroutine
 8857: 
 8858: =item *
 8859: 
 8860: get_dom($namespace,$storearr,$udom,$uhome) : returns hash with keys from
 8861: array reference filled in from namespace found in domain level on either
 8862: specified domain server ($uhome) or primary domain server ($udom and $uhome are optional).
 8863: 
 8864: =item *
 8865: 
 8866: put_dom($namespace,$storehash,$udom,$uhome) :  stores hash in namespace at 
 8867: domain level either on specified domain server ($uhome) or primary domain 
 8868: server ($udom and $uhome are optional)
 8869: 
 8870: =back
 8871: 
 8872: =head2 Network Status Functions
 8873: 
 8874: =over 4
 8875: 
 8876: =item *
 8877: 
 8878: dirlist($uri) : return directory list based on URI
 8879: 
 8880: =item *
 8881: 
 8882: spareserver() : find server with least workload from spare.tab
 8883: 
 8884: =back
 8885: 
 8886: =head2 Apache Request
 8887: 
 8888: =over 4
 8889: 
 8890: =item *
 8891: 
 8892: ssi($url,%hash) : server side include, does a complete request cycle on url to
 8893: localhost, posts hash
 8894: 
 8895: =back
 8896: 
 8897: =head2 Data to String to Data
 8898: 
 8899: =over 4
 8900: 
 8901: =item *
 8902: 
 8903: hash2str(%hash) : convert a hash into a string complete with escaping and '='
 8904: and '&' separators, supports elements that are arrayrefs and hashrefs
 8905: 
 8906: =item *
 8907: 
 8908: hashref2str($hashref) : convert a hashref into a string complete with
 8909: escaping and '=' and '&' separators, supports elements that are
 8910: arrayrefs and hashrefs
 8911: 
 8912: =item *
 8913: 
 8914: arrayref2str($arrayref) : convert an arrayref into a string complete
 8915: with escaping and '&' separators, supports elements that are arrayrefs
 8916: and hashrefs
 8917: 
 8918: =item *
 8919: 
 8920: str2hash($string) : convert string to hash using unescaping and
 8921: splitting on '=' and '&', supports elements that are arrayrefs and
 8922: hashrefs
 8923: 
 8924: =item *
 8925: 
 8926: str2array($string) : convert string to hash using unescaping and
 8927: splitting on '&', supports elements that are arrayrefs and hashrefs
 8928: 
 8929: =back
 8930: 
 8931: =head2 Logging Routines
 8932: 
 8933: =over 4
 8934: 
 8935: These routines allow one to make log messages in the lonnet.log and
 8936: lonnet.perm logfiles.
 8937: 
 8938: =item *
 8939: 
 8940: logtouch() : make sure the logfile, lonnet.log, exists
 8941: 
 8942: =item *
 8943: 
 8944: logthis() : append message to the normal lonnet.log file, it gets
 8945: preiodically rolled over and deleted.
 8946: 
 8947: =item *
 8948: 
 8949: logperm() : append a permanent message to lonnet.perm.log, this log
 8950: file never gets deleted by any automated portion of the system, only
 8951: messages of critical importance should go in here.
 8952: 
 8953: =back
 8954: 
 8955: =head2 General File Helper Routines
 8956: 
 8957: =over 4
 8958: 
 8959: =item *
 8960: 
 8961: getfile($file,$caller) : two cases - requests for files in /res or in /uploaded.
 8962: (a) files in /uploaded
 8963:   (i) If a local copy of the file exists - 
 8964:       compares modification date of local copy with last-modified date for 
 8965:       definitive version stored on home server for course. If local copy is 
 8966:       stale, requests a new version from the home server and stores it. 
 8967:       If the original has been removed from the home server, then local copy 
 8968:       is unlinked.
 8969:   (ii) If local copy does not exist -
 8970:       requests the file from the home server and stores it. 
 8971:   
 8972:   If $caller is 'uploadrep':  
 8973:     This indicates a call from lonuploadrep.pm (PerlHeaderParserHandler phase)
 8974:     for request for files originally uploaded via DOCS. 
 8975:      - returns 'ok' if fresh local copy now available, -1 otherwise.
 8976:   
 8977:   Otherwise:
 8978:      This indicates a call from the content generation phase of the request.
 8979:      -  returns the entire contents of the file or -1.
 8980:      
 8981: (b) files in /res
 8982:    - returns the entire contents of a file or -1; 
 8983:    it properly subscribes to and replicates the file if neccessary.
 8984: 
 8985: 
 8986: =item *
 8987: 
 8988: stat_file($url) : $url is expected to be a /res/ or /uploaded/ style file
 8989:                   reference
 8990: 
 8991: returns either a stat() list of data about the file or an empty list
 8992: if the file doesn't exist or couldn't find out about it (connection
 8993: problems or user unknown)
 8994: 
 8995: =item *
 8996: 
 8997: filelocation($dir,$file) : returns file system location of a file
 8998: based on URI; meant to be "fairly clean" absolute reference, $dir is a
 8999: directory that relative $file lookups are to looked in ($dir of /a/dir
 9000: and a file of ../bob will become /a/bob)
 9001: 
 9002: =item *
 9003: 
 9004: hreflocation($dir,$file) : returns file system location or a URL; same as
 9005: filelocation except for hrefs
 9006: 
 9007: =item *
 9008: 
 9009: declutter() : declutters URLs (remove docroot, beginning slashes, 'res' etc)
 9010: 
 9011: =back
 9012: 
 9013: =head2 Usererfile file routines (/uploaded*)
 9014: 
 9015: =over 4
 9016: 
 9017: =item *
 9018: 
 9019: userfileupload(): main rotine for putting a file in a user or course's
 9020:                   filespace, arguments are,
 9021: 
 9022:  formname - required - this is the name of the element in $env where the
 9023:            filename, and the contents of the file to create/modifed exist
 9024:            the filename is in $env{'form.'.$formname.'.filename'} and the
 9025:            contents of the file is located in $env{'form.'.$formname}
 9026:  coursedoc - if true, store the file in the course of the active role
 9027:              of the current user
 9028:  subdir - required - subdirectory to put the file in under ../userfiles/
 9029:          if undefined, it will be placed in "unknown"
 9030: 
 9031:  (This routine calls clean_filename() to remove any dangerous
 9032:  characters from the filename, and then calls finuserfileupload() to
 9033:  complete the transaction)
 9034: 
 9035:  returns either the url of the uploaded file (/uploaded/....) if successful
 9036:  and /adm/notfound.html if unsuccessful
 9037: 
 9038: =item *
 9039: 
 9040: clean_filename(): routine for cleaing a filename up for storage in
 9041:                  userfile space, argument is:
 9042: 
 9043:  filename - proposed filename
 9044: 
 9045: returns: the new clean filename
 9046: 
 9047: =item *
 9048: 
 9049: finishuserfileupload(): routine that creaes and sends the file to
 9050: userspace, probably shouldn't be called directly
 9051: 
 9052:   docuname: username or courseid of destination for the file
 9053:   docudom: domain of user/course of destination for the file
 9054:   formname: same as for userfileupload()
 9055:   fname: filename (inculding subdirectories) for the file
 9056: 
 9057:  returns either the url of the uploaded file (/uploaded/....) if successful
 9058:  and /adm/notfound.html if unsuccessful
 9059: 
 9060: =item *
 9061: 
 9062: renameuserfile(): renames an existing userfile to a new name
 9063: 
 9064:   Args:
 9065:    docuname: username or courseid of destination for the file
 9066:    docudom: domain of user/course of destination for the file
 9067:    old: current file name (including any subdirs under userfiles)
 9068:    new: desired file name (including any subdirs under userfiles)
 9069: 
 9070: =item *
 9071: 
 9072: mkdiruserfile(): creates a directory is a userfiles dir
 9073: 
 9074:   Args:
 9075:    docuname: username or courseid of destination for the file
 9076:    docudom: domain of user/course of destination for the file
 9077:    dir: dir to create (including any subdirs under userfiles)
 9078: 
 9079: =item *
 9080: 
 9081: removeuserfile(): removes a file that exists in userfiles
 9082: 
 9083:   Args:
 9084:    docuname: username or courseid of destination for the file
 9085:    docudom: domain of user/course of destination for the file
 9086:    fname: filname to delete (including any subdirs under userfiles)
 9087: 
 9088: =item *
 9089: 
 9090: removeuploadedurl(): convience function for removeuserfile()
 9091: 
 9092:   Args:
 9093:    url:  a full /uploaded/... url to delete
 9094: 
 9095: =item * 
 9096: 
 9097: get_portfile_permissions():
 9098:   Args:
 9099:     domain: domain of user or course contain the portfolio files
 9100:     user: name of user or num of course contain the portfolio files
 9101:   Returns:
 9102:     hashref of a dump of the proper file_permissions.db
 9103:    
 9104: 
 9105: =item * 
 9106: 
 9107: get_access_controls():
 9108: 
 9109: Args:
 9110:   current_permissions: the hash ref returned from get_portfile_permissions()
 9111:   group: (optional) the group you want the files associated with
 9112:   file: (optional) the file you want access info on
 9113: 
 9114: Returns:
 9115:     a hash (keys are file names) of hashes containing
 9116:         keys are: path to file/file_name\0uniqueID:scope_end_start (see below)
 9117:         values are XML containing access control settings (see below) 
 9118: 
 9119: Internal notes:
 9120: 
 9121:  access controls are stored in file_permissions.db as key=value pairs.
 9122:     key -> path to file/file_name\0uniqueID:scope_end_start
 9123:         where scope -> public,guest,course,group,domains or users.
 9124:               end -> UNIX time for end of access (0 -> no end date)
 9125:               start -> UNIX time for start of access
 9126: 
 9127:     value -> XML description of access control
 9128:            <scope type=""> (type =1 of: public,guest,course,group,domains,users">
 9129:             <start></start>
 9130:             <end></end>
 9131: 
 9132:             <password></password>  for scope type = guest
 9133: 
 9134:             <domain></domain>     for scope type = course or group
 9135:             <number></number>
 9136:             <roles id="">
 9137:              <role></role>
 9138:              <access></access>
 9139:              <section></section>
 9140:              <group></group>
 9141:             </roles>
 9142: 
 9143:             <dom></dom>         for scope type = domains
 9144: 
 9145:             <users>             for scope type = users
 9146:              <user>
 9147:               <uname></uname>
 9148:               <udom></udom>
 9149:              </user>
 9150:             </users>
 9151:            </scope> 
 9152:               
 9153:  Access data is also aggregated for each file in an additional key=value pair:
 9154:  key -> path to file/file_name\0accesscontrol 
 9155:  value -> reference to hash
 9156:           hash contains key = value pairs
 9157:           where key = uniqueID:scope_end_start
 9158:                 value = UNIX time record was last updated
 9159: 
 9160:           Used to improve speed of look-ups of access controls for each file.  
 9161:  
 9162:  Locks on files (resulting from submission of portfolio file to a homework problem stored in array of arrays.
 9163: 
 9164: modify_access_controls():
 9165: 
 9166: Modifies access controls for a portfolio file
 9167: Args
 9168: 1. file name
 9169: 2. reference to hash of required changes,
 9170: 3. domain
 9171: 4. username
 9172:   where domain,username are the domain of the portfolio owner 
 9173:   (either a user or a course) 
 9174: 
 9175: Returns:
 9176: 1. result of additions or updates ('ok' or 'error', with error message). 
 9177: 2. result of deletions ('ok' or 'error', with error message).
 9178: 3. reference to hash of any new or updated access controls.
 9179: 4. reference to hash used to map incoming IDs to uniqueIDs assigned to control.
 9180:    key = integer (inbound ID)
 9181:    value = uniqueID  
 9182: 
 9183: =back
 9184: 
 9185: =head2 HTTP Helper Routines
 9186: 
 9187: =over 4
 9188: 
 9189: =item *
 9190: 
 9191: escape() : unpack non-word characters into CGI-compatible hex codes
 9192: 
 9193: =item *
 9194: 
 9195: unescape() : pack CGI-compatible hex codes into actual non-word ASCII character
 9196: 
 9197: =back
 9198: 
 9199: =head1 PRIVATE SUBROUTINES
 9200: 
 9201: =head2 Underlying communication routines (Shouldn't call)
 9202: 
 9203: =over 4
 9204: 
 9205: =item *
 9206: 
 9207: subreply() : tries to pass a message to lonc, returns con_lost if incapable
 9208: 
 9209: =item *
 9210: 
 9211: reply() : uses subreply to send a message to remote machine, logs all failures
 9212: 
 9213: =item *
 9214: 
 9215: critical() : passes a critical message to another server; if cannot
 9216: get through then place message in connection buffer directory and
 9217: returns con_delayed, if incapable of saving message, returns
 9218: con_failed
 9219: 
 9220: =item *
 9221: 
 9222: reconlonc() : tries to reconnect lonc client processes.
 9223: 
 9224: =back
 9225: 
 9226: =head2 Resource Access Logging
 9227: 
 9228: =over 4
 9229: 
 9230: =item *
 9231: 
 9232: flushcourselogs() : flush (save) buffer logs and access logs
 9233: 
 9234: =item *
 9235: 
 9236: courselog($what) : save message for course in hash
 9237: 
 9238: =item *
 9239: 
 9240: courseacclog($what) : save message for course using &courselog().  Perform
 9241: special processing for specific resource types (problems, exams, quizzes, etc).
 9242: 
 9243: =item *
 9244: 
 9245: goodbye() : flush course logs and log shutting down; it is called in srm.conf
 9246: as a PerlChildExitHandler
 9247: 
 9248: =back
 9249: 
 9250: =head2 Other
 9251: 
 9252: =over 4
 9253: 
 9254: =item *
 9255: 
 9256: symblist($mapname,%newhash) : update symbolic storage links
 9257: 
 9258: =back
 9259: 
 9260: =cut
 9261: