Return to lonnet.pm CVS log

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

&get_my_roles() extended to accept three optional arguments -  types, roles, and roledoms which are references to arrays, of role statuses (active,
future or previous), roles (e.g., cc,in, st etc.) and domains of the roles.  These arguments filter which roles appear in the hash returned to the caller.

- Documentation updated.

    1: # The LearningOnline Network
    2: # TCP networking package
    3: #
    4: # $Id: lonnet.pm,v 1.832 2007/02/16 01:04:19 raeburn 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::Headers;
   35: use HTTP::Date;
   36: # use Date::Parse;
   37: use vars 
   38: qw(%perlvar %hostname %badServerCache %iphost %spareid %hostdom 
   39:    %libserv %pr %prp $memcache %packagetab 
   40:    %courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount 
   41:    %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %coursetypebuf
   42:    %domaindescription %domain_auth_def %domain_auth_arg_def 
   43:    %domain_lang_def %domain_city %domain_longi %domain_lati %domain_primary
   44:    $tmpdir $_64bit %env);
   45: 
   46: use IO::Socket;
   47: use GDBM_File;
   48: use HTML::LCParser;
   49: use HTML::Parser;
   50: use Fcntl qw(:flock);
   51: use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze);
   52: use Time::HiRes qw( gettimeofday tv_interval );
   53: use Cache::Memcached;
   54: use Digest::MD5;
   55: use Math::Random;
   56: use LONCAPA qw(:DEFAULT :match);
   57: use LONCAPA::Configuration;
   58: 
   59: my $readit;
   60: my $max_connection_retries = 10;     # Or some such value.
   61: 
   62: require Exporter;
   63: 
   64: our @ISA = qw (Exporter);
   65: our @EXPORT = qw(%env);
   66: 
   67: =pod
   68: 
   69: =head1 Package Variables
   70: 
   71: These are largely undocumented, so if you decipher one please note it here.
   72: 
   73: =over 4
   74: 
   75: =item $processmarker
   76: 
   77: Contains the time this process was started and this servers host id.
   78: 
   79: =item $dumpcount
   80: 
   81: Counts the number of times a message log flush has been attempted (regardless
   82: of success) by this process.  Used as part of the filename when messages are
   83: delayed.
   84: 
   85: =back
   86: 
   87: =cut
   88: 
   89: 
   90: # --------------------------------------------------------------------- Logging
   91: {
   92:     my $logid;
   93:     sub instructor_log {
   94: 	my ($hash_name,$storehash,$delflag,$uname,$udom)=@_;
   95: 	$logid++;
   96: 	my $id=time().'00000'.$$.'00000'.$logid;
   97: 	return &Apache::lonnet::put('nohist_'.$hash_name,
   98: 				    { $id => {
   99: 					'exe_uname' => $env{'user.name'},
  100: 					'exe_udom'  => $env{'user.domain'},
  101: 					'exe_time'  => time(),
  102: 					'exe_ip'    => $ENV{'REMOTE_ADDR'},
  103: 					'delflag'   => $delflag,
  104: 					'logentry'  => $storehash,
  105: 					'uname'     => $uname,
  106: 					'udom'      => $udom,
  107: 				    }
  108: 				  },
  109: 				    $env{'course.'.$env{'request.course.id'}.'.domain'},
  110: 				    $env{'course.'.$env{'request.course.id'}.'.num'}
  111: 				    );
  112:     }
  113: }
  114: 
  115: sub logtouch {
  116:     my $execdir=$perlvar{'lonDaemons'};
  117:     unless (-e "$execdir/logs/lonnet.log") {	
  118: 	open(my $fh,">>$execdir/logs/lonnet.log");
  119: 	close $fh;
  120:     }
  121:     my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3];
  122:     chown($wwwuid,$wwwgid,$execdir.'/logs/lonnet.log');
  123: }
  124: 
  125: sub logthis {
  126:     my $message=shift;
  127:     my $execdir=$perlvar{'lonDaemons'};
  128:     my $now=time;
  129:     my $local=localtime($now);
  130:     if (open(my $fh,">>$execdir/logs/lonnet.log")) {
  131: 	print $fh "$local ($$): $message\n";
  132: 	close($fh);
  133:     }
  134:     return 1;
  135: }
  136: 
  137: sub logperm {
  138:     my $message=shift;
  139:     my $execdir=$perlvar{'lonDaemons'};
  140:     my $now=time;
  141:     my $local=localtime($now);
  142:     if (open(my $fh,">>$execdir/logs/lonnet.perm.log")) {
  143: 	print $fh "$now:$message:$local\n";
  144: 	close($fh);
  145:     }
  146:     return 1;
  147: }
  148: 
  149: # -------------------------------------------------- Non-critical communication
  150: sub subreply {
  151:     my ($cmd,$server)=@_;
  152:     my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$server};
  153:     #
  154:     #  With loncnew process trimming, there's a timing hole between lonc server
  155:     #  process exit and the master server picking up the listen on the AF_UNIX
  156:     #  socket.  In that time interval, a lock file will exist:
  157: 
  158:     my $lockfile=$peerfile.".lock";
  159:     while (-e $lockfile) {	# Need to wait for the lockfile to disappear.
  160: 	sleep(1);
  161:     }
  162:     # At this point, either a loncnew parent is listening or an old lonc
  163:     # or loncnew child is listening so we can connect or everything's dead.
  164:     #
  165:     #   We'll give the connection a few tries before abandoning it.  If
  166:     #   connection is not possible, we'll con_lost back to the client.
  167:     #   
  168:     my $client;
  169:     for (my $retries = 0; $retries < $max_connection_retries; $retries++) {
  170: 	$client=IO::Socket::UNIX->new(Peer    =>"$peerfile",
  171: 				      Type    => SOCK_STREAM,
  172: 				      Timeout => 10);
  173: 	if($client) {
  174: 	    last;		# Connected!
  175: 	}
  176: 	sleep(1);		# Try again later if failed connection.
  177:     }
  178:     my $answer;
  179:     if ($client) {
  180: 	print $client "sethost:$server:$cmd\n";
  181: 	$answer=<$client>;
  182: 	if (!$answer) { $answer="con_lost"; }
  183: 	chomp($answer);
  184:     } else {
  185: 	$answer = 'con_lost';	# Failed connection.
  186:     }
  187:     return $answer;
  188: }
  189: 
  190: sub reply {
  191:     my ($cmd,$server)=@_;
  192:     unless (defined($hostname{$server})) { return 'no_such_host'; }
  193:     my $answer=subreply($cmd,$server);
  194:     if (($answer=~/^refused/) || ($answer=~/^rejected/)) {
  195:        &logthis("<font color=\"blue\">WARNING:".
  196:                 " $cmd to $server returned $answer</font>");
  197:     }
  198:     return $answer;
  199: }
  200: 
  201: # ----------------------------------------------------------- Send USR1 to lonc
  202: 
  203: sub reconlonc {
  204:     my $peerfile=shift;
  205:     &logthis("Trying to reconnect for $peerfile");
  206:     my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
  207:     if (open(my $fh,"<$loncfile")) {
  208: 	my $loncpid=<$fh>;
  209:         chomp($loncpid);
  210:         if (kill 0 => $loncpid) {
  211: 	    &logthis("lonc at pid $loncpid responding, sending USR1");
  212:             kill USR1 => $loncpid;
  213:             sleep 1;
  214:             if (-e "$peerfile") { return; }
  215:             &logthis("$peerfile still not there, give it another try");
  216:             sleep 5;
  217:             if (-e "$peerfile") { return; }
  218:             &logthis(
  219:   "<font color=\"blue\">WARNING: $peerfile still not there, giving up</font>");
  220:         } else {
  221: 	    &logthis(
  222:                "<font color=\"blue\">WARNING:".
  223:                " lonc at pid $loncpid not responding, giving up</font>");
  224:         }
  225:     } else {
  226:      &logthis('<font color="blue">WARNING: lonc not running, giving up</font>');
  227:     }
  228: }
  229: 
  230: # ------------------------------------------------------ Critical communication
  231: 
  232: sub critical {
  233:     my ($cmd,$server)=@_;
  234:     unless ($hostname{$server}) {
  235:         &logthis("<font color=\"blue\">WARNING:".
  236:                " Critical message to unknown server ($server)</font>");
  237:         return 'no_such_host';
  238:     }
  239:     my $answer=reply($cmd,$server);
  240:     if ($answer eq 'con_lost') {
  241: 	&reconlonc("$perlvar{'lonSockDir'}/$server");
  242: 	my $answer=reply($cmd,$server);
  243:         if ($answer eq 'con_lost') {
  244:             my $now=time;
  245:             my $middlename=$cmd;
  246:             $middlename=substr($middlename,0,16);
  247:             $middlename=~s/\W//g;
  248:             my $dfilename=
  249:       "$perlvar{'lonSockDir'}/delayed/$now.$dumpcount.$$.$middlename.$server";
  250:             $dumpcount++;
  251:             {
  252: 		my $dfh;
  253: 		if (open($dfh,">$dfilename")) {
  254: 		    print $dfh "$cmd\n"; 
  255: 		    close($dfh);
  256: 		}
  257:             }
  258:             sleep 2;
  259:             my $wcmd='';
  260:             {
  261: 		my $dfh;
  262: 		if (open($dfh,"<$dfilename")) {
  263: 		    $wcmd=<$dfh>; 
  264: 		    close($dfh);
  265: 		}
  266:             }
  267:             chomp($wcmd);
  268:             if ($wcmd eq $cmd) {
  269: 		&logthis("<font color=\"blue\">WARNING: ".
  270:                          "Connection buffer $dfilename: $cmd</font>");
  271:                 &logperm("D:$server:$cmd");
  272: 	        return 'con_delayed';
  273:             } else {
  274:                 &logthis("<font color=\"red\">CRITICAL:"
  275:                         ." Critical connection failed: $server $cmd</font>");
  276:                 &logperm("F:$server:$cmd");
  277:                 return 'con_failed';
  278:             }
  279:         }
  280:     }
  281:     return $answer;
  282: }
  283: 
  284: # ------------------------------------------- check if return value is an error
  285: 
  286: sub error {
  287:     my ($result) = @_;
  288:     if ($result =~ /^(con_lost|no_such_host|error: (\d+) (.*))/) {
  289: 	if ($2 == 2) { return undef; }
  290: 	return $1;
  291:     }
  292:     return undef;
  293: }
  294: 
  295: sub convert_and_load_session_env {
  296:     my ($lonidsdir,$handle)=@_;
  297:     my @profile;
  298:     {
  299: 	open(my $idf,"$lonidsdir/$handle.id");
  300: 	flock($idf,LOCK_SH);
  301: 	@profile=<$idf>;
  302: 	close($idf);
  303:     }
  304:     my %temp_env;
  305:     foreach my $line (@profile) {
  306: 	if ($line !~ m/=/) {
  307: 	    return 0;
  308: 	}
  309: 	chomp($line);
  310: 	my ($envname,$envvalue)=split(/=/,$line,2);
  311: 	$temp_env{&unescape($envname)} = &unescape($envvalue);
  312:     }
  313:     unlink("$lonidsdir/$handle.id");
  314:     if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",&GDBM_WRCREAT(),
  315: 	    0640)) {
  316: 	%disk_env = %temp_env;
  317: 	@env{keys(%temp_env)} = @disk_env{keys(%temp_env)};
  318: 	untie(%disk_env);
  319:     }
  320:     return 1;
  321: }
  322: 
  323: # ------------------------------------------- Transfer profile into environment
  324: my $env_loaded;
  325: sub transfer_profile_to_env {
  326:     my ($lonidsdir,$handle,$force_transfer) = @_;
  327:     if (!$force_transfer && $env_loaded) { return; } 
  328: 
  329:     if (!defined($lonidsdir)) {
  330: 	$lonidsdir = $perlvar{'lonIDsDir'};
  331:     }
  332:     if (!defined($handle)) {
  333:         ($handle) = ($env{'user.environment'} =~m|/([^/]+)\.id$| );
  334:     }
  335: 
  336:     my $convert;
  337:     {
  338:     	open(my $idf,"$lonidsdir/$handle.id");
  339: 	flock($idf,LOCK_SH);
  340: 	if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",
  341: 		&GDBM_READER(),0640)) {
  342: 	    @env{keys(%disk_env)} = @disk_env{keys(%disk_env)};
  343: 	    untie(%disk_env);
  344: 	} else {
  345: 	    $convert = 1;
  346: 	}
  347:     }
  348:     if ($convert) {
  349: 	if (!&convert_and_load_session_env($lonidsdir,$handle)) {
  350: 	    &logthis("Failed to load session, or convert session.");
  351: 	}
  352:     }
  353: 
  354:     my %remove;
  355:     while ( my $envname = each(%env) ) {
  356:         if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {
  357:             if ($time < time-300) {
  358:                 $remove{$key}++;
  359:             }
  360:         }
  361:     }
  362: 
  363:     $env{'user.environment'} = "$lonidsdir/$handle.id";
  364:     $env_loaded=1;
  365:     foreach my $expired_key (keys(%remove)) {
  366:         &delenv($expired_key);
  367:     }
  368: }
  369: 
  370: sub timed_flock {
  371:     my ($file,$lock_type) = @_;
  372:     my $failed=0;
  373:     eval {
  374: 	local $SIG{__DIE__}='DEFAULT';
  375: 	local $SIG{ALRM}=sub {
  376: 	    $failed=1;
  377: 	    die("failed lock");
  378: 	};
  379: 	alarm(13);
  380: 	flock($file,$lock_type);
  381: 	alarm(0);
  382:     };
  383:     if ($failed) {
  384: 	return undef;
  385:     } else {
  386: 	return 1;
  387:     }
  388: }
  389: 
  390: # ---------------------------------------------------------- Append Environment
  391: 
  392: sub appenv {
  393:     my %newenv=@_;
  394:     foreach my $key (keys(%newenv)) {
  395: 	if (($newenv{$key}=~/^user\.role/) || ($newenv{$key}=~/^user\.priv/)) {
  396:             &logthis("<font color=\"blue\">WARNING: ".
  397:                 "Attempt to modify environment ".$key." to ".$newenv{$key}
  398:                 .'</font>');
  399: 	    delete($newenv{$key});
  400:         } else {
  401:             $env{$key}=$newenv{$key};
  402:         }
  403:     }
  404:     open(my $env_file,$env{'user.environment'});
  405:     if (&timed_flock($env_file,LOCK_EX)
  406: 	&&
  407: 	tie(my %disk_env,'GDBM_File',$env{'user.environment'},
  408: 	    (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
  409: 	while (my ($key,$value) = each(%newenv)) {
  410: 	    $disk_env{$key} = $value;
  411: 	}
  412: 	untie(%disk_env);
  413:     }
  414:     return 'ok';
  415: }
  416: # ----------------------------------------------------- Delete from Environment
  417: 
  418: sub delenv {
  419:     my $delthis=shift;
  420:     if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {
  421:         &logthis("<font color=\"blue\">WARNING: ".
  422:                 "Attempt to delete from environment ".$delthis);
  423:         return 'error';
  424:     }
  425:     open(my $env_file,$env{'user.environment'});
  426:     if (&timed_flock($env_file,LOCK_EX)
  427: 	&&
  428: 	tie(my %disk_env,'GDBM_File',$env{'user.environment'},
  429: 	    (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
  430: 	foreach my $key (keys(%disk_env)) {
  431: 	    if ($key=~/^$delthis/) { 
  432:                 delete($env{$key});
  433:                 delete($disk_env{$key});
  434:             }
  435: 	}
  436: 	untie(%disk_env);
  437:     }
  438:     return 'ok';
  439: }
  440: 
  441: sub get_env_multiple {
  442:     my ($name) = @_;
  443:     my @values;
  444:     if (defined($env{$name})) {
  445:         # exists is it an array
  446:         if (ref($env{$name})) {
  447:             @values=@{ $env{$name} };
  448:         } else {
  449:             $values[0]=$env{$name};
  450:         }
  451:     }
  452:     return(@values);
  453: }
  454: 
  455: # ------------------------------------------ Find out current server userload
  456: # there is a copy in lond
  457: sub userload {
  458:     my $numusers=0;
  459:     {
  460: 	opendir(LONIDS,$perlvar{'lonIDsDir'});
  461: 	my $filename;
  462: 	my $curtime=time;
  463: 	while ($filename=readdir(LONIDS)) {
  464: 	    if ($filename eq '.' || $filename eq '..') {next;}
  465: 	    my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];
  466: 	    if ($curtime-$mtime < 1800) { $numusers++; }
  467: 	}
  468: 	closedir(LONIDS);
  469:     }
  470:     my $userloadpercent=0;
  471:     my $maxuserload=$perlvar{'lonUserLoadLim'};
  472:     if ($maxuserload) {
  473: 	$userloadpercent=100*$numusers/$maxuserload;
  474:     }
  475:     $userloadpercent=sprintf("%.2f",$userloadpercent);
  476:     return $userloadpercent;
  477: }
  478: 
  479: # ------------------------------------------ Fight off request when overloaded
  480: 
  481: sub overloaderror {
  482:     my ($r,$checkserver)=@_;
  483:     unless ($checkserver) { $checkserver=$perlvar{'lonHostID'}; }
  484:     my $loadavg;
  485:     if ($checkserver eq $perlvar{'lonHostID'}) {
  486:        open(my $loadfile,'/proc/loadavg');
  487:        $loadavg=<$loadfile>;
  488:        $loadavg =~ s/\s.*//g;
  489:        $loadavg = 100*$loadavg/$perlvar{'lonLoadLim'};
  490:        close($loadfile);
  491:     } else {
  492:        $loadavg=&reply('load',$checkserver);
  493:     }
  494:     my $overload=$loadavg-100;
  495:     if ($overload>0) {
  496: 	$r->err_headers_out->{'Retry-After'}=$overload;
  497:         $r->log_error('Overload of '.$overload.' on '.$checkserver);
  498:         return 413;
  499:     }    
  500:     return '';
  501: }
  502: 
  503: # ------------------------------ Find server with least workload from spare.tab
  504: 
  505: sub spareserver {
  506:     my ($loadpercent,$userloadpercent,$want_server_name) = @_;
  507:     my $spare_server;
  508:     if ($userloadpercent !~ /\d/) { $userloadpercent=0; }
  509:     my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent 
  510:                                                      :  $userloadpercent;
  511:     
  512:     foreach my $try_server (@{ $spareid{'primary'} }) {
  513: 	($spare_server, $lowest_load) =
  514: 	    &compare_server_load($try_server, $spare_server, $lowest_load);
  515:     }
  516: 
  517:     my $found_server = ($spare_server ne '' && $lowest_load < 100);
  518: 
  519:     if (!$found_server) {
  520: 	foreach my $try_server (@{ $spareid{'default'} }) {
  521: 	    ($spare_server, $lowest_load) =
  522: 		&compare_server_load($try_server, $spare_server, $lowest_load);
  523: 	}
  524:     }
  525: 
  526:     if (!$want_server_name) {
  527: 	$spare_server="http://$hostname{$spare_server}";
  528:     }
  529:     return $spare_server;
  530: }
  531: 
  532: sub compare_server_load {
  533:     my ($try_server, $spare_server, $lowest_load) = @_;
  534: 
  535:     my $loadans     = &reply('load',    $try_server);
  536:     my $userloadans = &reply('userload',$try_server);
  537: 
  538:     if ($loadans !~ /\d/ && $userloadans !~ /\d/) {
  539: 	next; #didn't get a number from the server
  540:     }
  541: 
  542:     my $load;
  543:     if ($loadans =~ /\d/) {
  544: 	if ($userloadans =~ /\d/) {
  545: 	    #both are numbers, pick the bigger one
  546: 	    $load = ($loadans > $userloadans) ? $loadans 
  547: 		                              : $userloadans;
  548: 	} else {
  549: 	    $load = $loadans;
  550: 	}
  551:     } else {
  552: 	$load = $userloadans;
  553:     }
  554: 
  555:     if (($load =~ /\d/) && ($load < $lowest_load)) {
  556: 	$spare_server = $try_server;
  557: 	$lowest_load  = $load;
  558:     }
  559:     return ($spare_server,$lowest_load);
  560: }
  561: # --------------------------------------------- Try to change a user's password
  562: 
  563: sub changepass {
  564:     my ($uname,$udom,$currentpass,$newpass,$server,$context)=@_;
  565:     $currentpass = &escape($currentpass);
  566:     $newpass     = &escape($newpass);
  567:     my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass:$context",
  568: 		       $server);
  569:     if (! $answer) {
  570: 	&logthis("No reply on password change request to $server ".
  571: 		 "by $uname in domain $udom.");
  572:     } elsif ($answer =~ "^ok") {
  573:         &logthis("$uname in $udom successfully changed their password ".
  574: 		 "on $server.");
  575:     } elsif ($answer =~ "^pwchange_failure") {
  576: 	&logthis("$uname in $udom was unable to change their password ".
  577: 		 "on $server.  The action was blocked by either lcpasswd ".
  578: 		 "or pwchange");
  579:     } elsif ($answer =~ "^non_authorized") {
  580:         &logthis("$uname in $udom did not get their password correct when ".
  581: 		 "attempting to change it on $server.");
  582:     } elsif ($answer =~ "^auth_mode_error") {
  583:         &logthis("$uname in $udom attempted to change their password despite ".
  584: 		 "not being locally or internally authenticated on $server.");
  585:     } elsif ($answer =~ "^unknown_user") {
  586:         &logthis("$uname in $udom attempted to change their password ".
  587: 		 "on $server but were unable to because $server is not ".
  588: 		 "their home server.");
  589:     } elsif ($answer =~ "^refused") {
  590: 	&logthis("$server refused to change $uname in $udom password because ".
  591: 		 "it was sent an unencrypted request to change the password.");
  592:     }
  593:     return $answer;
  594: }
  595: 
  596: # ----------------------- Try to determine user's current authentication scheme
  597: 
  598: sub queryauthenticate {
  599:     my ($uname,$udom)=@_;
  600:     my $uhome=&homeserver($uname,$udom);
  601:     if (!$uhome) {
  602: 	&logthis("User $uname at $udom is unknown when looking for authentication mechanism");
  603: 	return 'no_host';
  604:     }
  605:     my $answer=reply("encrypt:currentauth:$udom:$uname",$uhome);
  606:     if ($answer =~ /^(unknown_user|refused|con_lost)/) {
  607: 	&logthis("User $uname at $udom threw error $answer when checking authentication mechanism");
  608:     }
  609:     return $answer;
  610: }
  611: 
  612: # --------- Try to authenticate user from domain's lib servers (first this one)
  613: 
  614: sub authenticate {
  615:     my ($uname,$upass,$udom)=@_;
  616:     $upass=&escape($upass);
  617:     $uname= &LONCAPA::clean_username($uname);
  618:     my $uhome=&homeserver($uname,$udom);
  619:     if (!$uhome) {
  620: 	&logthis("User $uname at $udom is unknown in authenticate");
  621: 	return 'no_host';
  622:     }
  623:     my $answer=reply("encrypt:auth:$udom:$uname:$upass",$uhome);
  624:     if ($answer eq 'authorized') {
  625: 	&logthis("User $uname at $udom authorized by $uhome"); 
  626: 	return $uhome; 
  627:     }
  628:     if ($answer eq 'non_authorized') {
  629: 	&logthis("User $uname at $udom rejected by $uhome");
  630: 	return 'no_host'; 
  631:     }
  632:     &logthis("User $uname at $udom threw error $answer when checking authentication mechanism");
  633:     return 'no_host';
  634: }
  635: 
  636: # ---------------------- Find the homebase for a user from domain's lib servers
  637: 
  638: my %homecache;
  639: sub homeserver {
  640:     my ($uname,$udom,$ignoreBadCache)=@_;
  641:     my $index="$uname:$udom";
  642: 
  643:     if (exists($homecache{$index})) { return $homecache{$index}; }
  644:     my $tryserver;
  645:     foreach $tryserver (keys %libserv) {
  646:         next if ($ignoreBadCache ne 'true' && 
  647: 		 exists($badServerCache{$tryserver}));
  648: 	if ($hostdom{$tryserver} eq $udom) {
  649:            my $answer=reply("home:$udom:$uname",$tryserver);
  650:            if ($answer eq 'found') { 
  651: 	       return $homecache{$index}=$tryserver;
  652:            } elsif ($answer eq 'no_host') {
  653: 	       $badServerCache{$tryserver}=1;
  654:            }
  655:        }
  656:     }    
  657:     return 'no_host';
  658: }
  659: 
  660: # ------------------------------------- Find the usernames behind a list of IDs
  661: 
  662: sub idget {
  663:     my ($udom,@ids)=@_;
  664:     my %returnhash=();
  665:     
  666:     my $tryserver;
  667:     foreach $tryserver (keys %libserv) {
  668:        if ($hostdom{$tryserver} eq $udom) {
  669: 	  my $idlist=join('&',@ids);
  670:           $idlist=~tr/A-Z/a-z/; 
  671: 	  my $reply=&reply("idget:$udom:".$idlist,$tryserver);
  672:           my @answer=();
  673:           if (($reply ne 'con_lost') && ($reply!~/^error\:/)) {
  674: 	      @answer=split(/\&/,$reply);
  675:           }                    ;
  676:           my $i;
  677:           for ($i=0;$i<=$#ids;$i++) {
  678:               if ($answer[$i]) {
  679: 		  $returnhash{$ids[$i]}=$answer[$i];
  680:               } 
  681:           }
  682:        }
  683:     }    
  684:     return %returnhash;
  685: }
  686: 
  687: # ------------------------------------- Find the IDs behind a list of usernames
  688: 
  689: sub idrget {
  690:     my ($udom,@unames)=@_;
  691:     my %returnhash=();
  692:     foreach my $uname (@unames) {
  693:         $returnhash{$uname}=(&userenvironment($udom,$uname,'id'))[1];
  694:     }
  695:     return %returnhash;
  696: }
  697: 
  698: # ------------------------------- Store away a list of names and associated IDs
  699: 
  700: sub idput {
  701:     my ($udom,%ids)=@_;
  702:     my %servers=();
  703:     foreach my $uname (keys(%ids)) {
  704: 	&cput('environment',{'id'=>$ids{$uname}},$udom,$uname);
  705:         my $uhom=&homeserver($uname,$udom);
  706:         if ($uhom ne 'no_host') {
  707:             my $id=&escape($ids{$uname});
  708:             $id=~tr/A-Z/a-z/;
  709:             my $esc_unam=&escape($uname);
  710: 	    if ($servers{$uhom}) {
  711: 		$servers{$uhom}.='&'.$id.'='.$esc_unam;
  712:             } else {
  713:                 $servers{$uhom}=$id.'='.$esc_unam;
  714:             }
  715:         }
  716:     }
  717:     foreach my $server (keys(%servers)) {
  718:         &critical('idput:'.$udom.':'.$servers{$server},$server);
  719:     }
  720: }
  721: 
  722: # ------------------------------------------- get items from domain db files   
  723: 
  724: sub get_dom {
  725:     my ($namespace,$storearr,$udom)=@_;
  726:     my $items='';
  727:     foreach my $item (@$storearr) {
  728:         $items.=&escape($item).'&';
  729:     }
  730:     $items=~s/\&$//;
  731:     if (!$udom) { $udom=$env{'user.domain'}; }
  732:     if (exists($domain_primary{$udom})) {
  733:         my $uhome=$domain_primary{$udom};
  734:         my $rep=&reply("getdom:$udom:$namespace:$items",$uhome);
  735:         my @pairs=split(/\&/,$rep);
  736:         if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) {
  737:             return @pairs;
  738:         }
  739:         my %returnhash=();
  740:         my $i=0;
  741:         foreach my $item (@$storearr) {
  742:             $returnhash{$item}=&thaw_unescape($pairs[$i]);
  743:             $i++;
  744:         }
  745:         return %returnhash;
  746:     } else {
  747:         &logthis("get_dom failed - no primary domain server for $udom");
  748:     }
  749: }
  750: 
  751: # -------------------------------------------- put items in domain db files 
  752: 
  753: sub put_dom {
  754:     my ($namespace,$storehash,$udom)=@_;
  755:     if (!$udom) { $udom=$env{'user.domain'}; }
  756:     if (exists($domain_primary{$udom})) {
  757:         my $uhome=$domain_primary{$udom};
  758:         my $items='';
  759:         foreach my $item (keys(%$storehash)) {
  760:             $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
  761:         }
  762:         $items=~s/\&$//;
  763:         return &reply("putdom:$udom:$namespace:$items",$uhome);
  764:     } else {
  765:         &logthis("put_dom failed - no primary domain server for $udom");
  766:     }
  767: }
  768: 
  769: # --------------------------------------------------- Assign a key to a student
  770: 
  771: sub assign_access_key {
  772: #
  773: # a valid key looks like uname:udom#comments
  774: # comments are being appended
  775: #
  776:     my ($ckey,$kdom,$knum,$cdom,$cnum,$udom,$uname,$logentry)=@_;
  777:     $kdom=
  778:    $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($kdom));
  779:     $knum=
  780:    $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($knum));
  781:     $cdom=
  782:    $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($cdom));
  783:     $cnum=
  784:    $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($cnum));
  785:     $udom=$env{'user.name'} unless (defined($udom));
  786:     $uname=$env{'user.domain'} unless (defined($uname));
  787:     my %existing=&get('accesskeys',[$ckey],$kdom,$knum);
  788:     if (($existing{$ckey}=~/^\#(.*)$/) || # - new key
  789:         ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#(.*)$/)) { 
  790:                                                   # assigned to this person
  791:                                                   # - this should not happen,
  792:                                                   # unless something went wrong
  793:                                                   # the first time around
  794: # ready to assign
  795:         $logentry=$1.'; '.$logentry;
  796:         if (&put('accesskeys',{$ckey=>$uname.':'.$udom.'#'.$logentry},
  797:                                                  $kdom,$knum) eq 'ok') {
  798: # key now belongs to user
  799: 	    my $envkey='key.'.$cdom.'_'.$cnum;
  800:             if (&put('environment',{$envkey => $ckey}) eq 'ok') {
  801:                 &appenv('environment.'.$envkey => $ckey);
  802:                 return 'ok';
  803:             } else {
  804:                 return 
  805:   'error: Count not permanently assign key, will need to be re-entered later.';
  806: 	    }
  807:         } else {
  808:             return 'error: Could not assign key, try again later.';
  809:         }
  810:     } elsif (!$existing{$ckey}) {
  811: # the key does not exist
  812: 	return 'error: The key does not exist';
  813:     } else {
  814: # the key is somebody else's
  815: 	return 'error: The key is already in use';
  816:     }
  817: }
  818: 
  819: # ------------------------------------------ put an additional comment on a key
  820: 
  821: sub comment_access_key {
  822: #
  823: # a valid key looks like uname:udom#comments
  824: # comments are being appended
  825: #
  826:     my ($ckey,$cdom,$cnum,$logentry)=@_;
  827:     $cdom=
  828:    $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($cdom));
  829:     $cnum=
  830:    $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($cnum));
  831:     my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
  832:     if ($existing{$ckey}) {
  833:         $existing{$ckey}.='; '.$logentry;
  834: # ready to assign
  835:         if (&put('accesskeys',{$ckey=>$existing{$ckey}},
  836:                                                  $cdom,$cnum) eq 'ok') {
  837: 	    return 'ok';
  838:         } else {
  839: 	    return 'error: Count not store comment.';
  840:         }
  841:     } else {
  842: # the key does not exist
  843: 	return 'error: The key does not exist';
  844:     }
  845: }
  846: 
  847: # ------------------------------------------------------ Generate a set of keys
  848: 
  849: sub generate_access_keys {
  850:     my ($number,$cdom,$cnum,$logentry)=@_;
  851:     $cdom=
  852:    $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($cdom));
  853:     $cnum=
  854:    $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($cnum));
  855:     unless (&allowed('mky',$cdom)) { return 0; }
  856:     unless (($cdom) && ($cnum)) { return 0; }
  857:     if ($number>10000) { return 0; }
  858:     sleep(2); # make sure don't get same seed twice
  859:     srand(time()^($$+($$<<15))); # from "Programming Perl"
  860:     my $total=0;
  861:     for (my $i=1;$i<=$number;$i++) {
  862:        my $newkey=sprintf("%lx",int(100000*rand)).'-'.
  863:                   sprintf("%lx",int(100000*rand)).'-'.
  864:                   sprintf("%lx",int(100000*rand));
  865:        $newkey=~s/1/g/g; # folks mix up 1 and l
  866:        $newkey=~s/0/h/g; # and also 0 and O
  867:        my %existing=&get('accesskeys',[$newkey],$cdom,$cnum);
  868:        if ($existing{$newkey}) {
  869:            $i--;
  870:        } else {
  871: 	  if (&put('accesskeys',
  872:               { $newkey => '# generated '.localtime().
  873:                            ' by '.$env{'user.name'}.'@'.$env{'user.domain'}.
  874:                            '; '.$logentry },
  875: 		   $cdom,$cnum) eq 'ok') {
  876:               $total++;
  877: 	  }
  878:        }
  879:     }
  880:     &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},
  881:          'Generated '.$total.' keys for '.$cnum.' at '.$cdom);
  882:     return $total;
  883: }
  884: 
  885: # ------------------------------------------------------- Validate an accesskey
  886: 
  887: sub validate_access_key {
  888:     my ($ckey,$cdom,$cnum,$udom,$uname)=@_;
  889:     $cdom=
  890:    $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($cdom));
  891:     $cnum=
  892:    $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($cnum));
  893:     $udom=$env{'user.domain'} unless (defined($udom));
  894:     $uname=$env{'user.name'} unless (defined($uname));
  895:     my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
  896:     return ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#/);
  897: }
  898: 
  899: # ------------------------------------- Find the section of student in a course
  900: sub devalidate_getsection_cache {
  901:     my ($udom,$unam,$courseid)=@_;
  902:     my $hashid="$udom:$unam:$courseid";
  903:     &devalidate_cache_new('getsection',$hashid);
  904: }
  905: 
  906: sub courseid_to_courseurl {
  907:     my ($courseid) = @_;
  908:     #already url style courseid
  909:     return $courseid if ($courseid =~ m{^/});
  910: 
  911:     if (exists($env{'course.'.$courseid.'.num'})) {
  912: 	my $cnum = $env{'course.'.$courseid.'.num'};
  913: 	my $cdom = $env{'course.'.$courseid.'.domain'};
  914: 	return "/$cdom/$cnum";
  915:     }
  916: 
  917:     my %courseinfo=&Apache::lonnet::coursedescription($courseid);
  918:     if (exists($courseinfo{'num'})) {
  919: 	return "/$courseinfo{'domain'}/$courseinfo{'num'}";
  920:     }
  921: 
  922:     return undef;
  923: }
  924: 
  925: sub getsection {
  926:     my ($udom,$unam,$courseid)=@_;
  927:     my $cachetime=1800;
  928: 
  929:     my $hashid="$udom:$unam:$courseid";
  930:     my ($result,$cached)=&is_cached_new('getsection',$hashid);
  931:     if (defined($cached)) { return $result; }
  932: 
  933:     my %Pending; 
  934:     my %Expired;
  935:     #
  936:     # Each role can either have not started yet (pending), be active, 
  937:     #    or have expired.
  938:     #
  939:     # If there is an active role, we are done.
  940:     #
  941:     # If there is more than one role which has not started yet, 
  942:     #     choose the one which will start sooner
  943:     # If there is one role which has not started yet, return it.
  944:     #
  945:     # If there is more than one expired role, choose the one which ended last.
  946:     # If there is a role which has expired, return it.
  947:     #
  948:     $courseid = &courseid_to_courseurl($courseid);
  949:     my %roleshash = &dump('roles',$udom,$unam,$courseid);
  950:     foreach my $key (keys(%roleshash)) {
  951:         next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/);
  952:         my $section=$1;
  953:         if ($key eq $courseid.'_st') { $section=''; }
  954:         my ($dummy,$end,$start)=split(/\_/,&unescape($roleshash{$key}));
  955:         my $now=time;
  956:         if (defined($end) && $end && ($now > $end)) {
  957:             $Expired{$end}=$section;
  958:             next;
  959:         }
  960:         if (defined($start) && $start && ($now < $start)) {
  961:             $Pending{$start}=$section;
  962:             next;
  963:         }
  964:         return &do_cache_new('getsection',$hashid,$section,$cachetime);
  965:     }
  966:     #
  967:     # Presumedly there will be few matching roles from the above
  968:     # loop and the sorting time will be negligible.
  969:     if (scalar(keys(%Pending))) {
  970:         my ($time) = sort {$a <=> $b} keys(%Pending);
  971:         return &do_cache_new('getsection',$hashid,$Pending{$time},$cachetime);
  972:     } 
  973:     if (scalar(keys(%Expired))) {
  974:         my @sorted = sort {$a <=> $b} keys(%Expired);
  975:         my $time = pop(@sorted);
  976:         return &do_cache_new('getsection',$hashid,$Expired{$time},$cachetime);
  977:     }
  978:     return &do_cache_new('getsection',$hashid,'-1',$cachetime);
  979: }
  980: 
  981: sub save_cache {
  982:     &purge_remembered();
  983:     #&Apache::loncommon::validate_page();
  984:     undef(%env);
  985:     undef($env_loaded);
  986: }
  987: 
  988: my $to_remember=-1;
  989: my %remembered;
  990: my %accessed;
  991: my $kicks=0;
  992: my $hits=0;
  993: sub devalidate_cache_new {
  994:     my ($name,$id,$debug) = @_;
  995:     if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); }
  996:     $id=&escape($name.':'.$id);
  997:     $memcache->delete($id);
  998:     delete($remembered{$id});
  999:     delete($accessed{$id});
 1000: }
 1001: 
 1002: sub is_cached_new {
 1003:     my ($name,$id,$debug) = @_;
 1004:     $id=&escape($name.':'.$id);
 1005:     if (exists($remembered{$id})) {
 1006: 	if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); }
 1007: 	$accessed{$id}=[&gettimeofday()];
 1008: 	$hits++;
 1009: 	return ($remembered{$id},1);
 1010:     }
 1011:     my $value = $memcache->get($id);
 1012:     if (!(defined($value))) {
 1013: 	if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); }
 1014: 	return (undef,undef);
 1015:     }
 1016:     if ($value eq '__undef__') {
 1017: 	if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); }
 1018: 	$value=undef;
 1019:     }
 1020:     &make_room($id,$value,$debug);
 1021:     if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); }
 1022:     return ($value,1);
 1023: }
 1024: 
 1025: sub do_cache_new {
 1026:     my ($name,$id,$value,$time,$debug) = @_;
 1027:     $id=&escape($name.':'.$id);
 1028:     my $setvalue=$value;
 1029:     if (!defined($setvalue)) {
 1030: 	$setvalue='__undef__';
 1031:     }
 1032:     if (!defined($time) ) {
 1033: 	$time=600;
 1034:     }
 1035:     if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); }
 1036:     $memcache->set($id,$setvalue,$time);
 1037:     # need to make a copy of $value
 1038:     #&make_room($id,$value,$debug);
 1039:     return $value;
 1040: }
 1041: 
 1042: sub make_room {
 1043:     my ($id,$value,$debug)=@_;
 1044:     $remembered{$id}=$value;
 1045:     if ($to_remember<0) { return; }
 1046:     $accessed{$id}=[&gettimeofday()];
 1047:     if (scalar(keys(%remembered)) <= $to_remember) { return; }
 1048:     my $to_kick;
 1049:     my $max_time=0;
 1050:     foreach my $other (keys(%accessed)) {
 1051: 	if (&tv_interval($accessed{$other}) > $max_time) {
 1052: 	    $to_kick=$other;
 1053: 	    $max_time=&tv_interval($accessed{$other});
 1054: 	}
 1055:     }
 1056:     delete($remembered{$to_kick});
 1057:     delete($accessed{$to_kick});
 1058:     $kicks++;
 1059:     if ($debug) { &logthis("kicking $to_kick $max_time $kicks\n"); }
 1060:     return;
 1061: }
 1062: 
 1063: sub purge_remembered {
 1064:     #&logthis("Tossing ".scalar(keys(%remembered)));
 1065:     #&logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered))));
 1066:     undef(%remembered);
 1067:     undef(%accessed);
 1068: }
 1069: # ------------------------------------- Read an entry from a user's environment
 1070: 
 1071: sub userenvironment {
 1072:     my ($udom,$unam,@what)=@_;
 1073:     my %returnhash=();
 1074:     my @answer=split(/\&/,
 1075:                 &reply('get:'.$udom.':'.$unam.':environment:'.join('&',@what),
 1076:                       &homeserver($unam,$udom)));
 1077:     my $i;
 1078:     for ($i=0;$i<=$#what;$i++) {
 1079: 	$returnhash{$what[$i]}=&unescape($answer[$i]);
 1080:     }
 1081:     return %returnhash;
 1082: }
 1083: 
 1084: # ---------------------------------------------------------- Get a studentphoto
 1085: sub studentphoto {
 1086:     my ($udom,$unam,$ext) = @_;
 1087:     my $home=&Apache::lonnet::homeserver($unam,$udom);
 1088:     if (defined($env{'request.course.id'})) {
 1089:         if ($env{'course.'.$env{'request.course.id'}.'.internal.showphoto'}) {
 1090:             if ($udom eq $env{'course.'.$env{'request.course.id'}.'.domain'}) {
 1091:                 return(&retrievestudentphoto($udom,$unam,$ext)); 
 1092:             } else {
 1093:                 my ($result,$perm_reqd)=
 1094: 		    &Apache::lonnet::auto_photo_permission($unam,$udom);
 1095:                 if ($result eq 'ok') {
 1096:                     if (!($perm_reqd eq 'yes')) {
 1097:                         return(&retrievestudentphoto($udom,$unam,$ext));
 1098:                     }
 1099:                 }
 1100:             }
 1101:         }
 1102:     } else {
 1103:         my ($result,$perm_reqd) = 
 1104: 	    &Apache::lonnet::auto_photo_permission($unam,$udom);
 1105:         if ($result eq 'ok') {
 1106:             if (!($perm_reqd eq 'yes')) {
 1107:                 return(&retrievestudentphoto($udom,$unam,$ext));
 1108:             }
 1109:         }
 1110:     }
 1111:     return '/adm/lonKaputt/lonlogo_broken.gif';
 1112: }
 1113: 
 1114: sub retrievestudentphoto {
 1115:     my ($udom,$unam,$ext,$type) = @_;
 1116:     my $home=&Apache::lonnet::homeserver($unam,$udom);
 1117:     my $ret=&Apache::lonnet::reply("studentphoto:$udom:$unam:$ext:$type",$home);
 1118:     if ($ret eq 'ok') {
 1119:         my $url="/uploaded/$udom/$unam/internal/studentphoto.$ext";
 1120:         if ($type eq 'thumbnail') {
 1121:             $url="/uploaded/$udom/$unam/internal/studentphoto_tn.$ext"; 
 1122:         }
 1123:         my $tokenurl=&Apache::lonnet::tokenwrapper($url);
 1124:         return $tokenurl;
 1125:     } else {
 1126:         if ($type eq 'thumbnail') {
 1127:             return '/adm/lonKaputt/genericstudent_tn.gif';
 1128:         } else { 
 1129:             return '/adm/lonKaputt/lonlogo_broken.gif';
 1130:         }
 1131:     }
 1132: }
 1133: 
 1134: # -------------------------------------------------------------------- New chat
 1135: 
 1136: sub chatsend {
 1137:     my ($newentry,$anon,$group)=@_;
 1138:     my $cnum=$env{'course.'.$env{'request.course.id'}.'.num'};
 1139:     my $cdom=$env{'course.'.$env{'request.course.id'}.'.domain'};
 1140:     my $chome=$env{'course.'.$env{'request.course.id'}.'.home'};
 1141:     &reply('chatsend:'.$cdom.':'.$cnum.':'.
 1142: 	   &escape($env{'user.domain'}.':'.$env{'user.name'}.':'.$anon.':'.
 1143: 		   &escape($newentry)).':'.$group,$chome);
 1144: }
 1145: 
 1146: # ------------------------------------------ Find current version of a resource
 1147: 
 1148: sub getversion {
 1149:     my $fname=&clutter(shift);
 1150:     unless ($fname=~/^\/res\//) { return -1; }
 1151:     return &currentversion(&filelocation('',$fname));
 1152: }
 1153: 
 1154: sub currentversion {
 1155:     my $fname=shift;
 1156:     my ($result,$cached)=&is_cached_new('resversion',$fname);
 1157:     if (defined($cached)) { return $result; }
 1158:     my $author=$fname;
 1159:     $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
 1160:     my ($udom,$uname)=split(/\//,$author);
 1161:     my $home=homeserver($uname,$udom);
 1162:     if ($home eq 'no_host') { 
 1163:         return -1; 
 1164:     }
 1165:     my $answer=reply("currentversion:$fname",$home);
 1166:     if (($answer eq 'con_lost') || ($answer eq 'rejected')) {
 1167: 	return -1;
 1168:     }
 1169:     return &do_cache_new('resversion',$fname,$answer,600);
 1170: }
 1171: 
 1172: # ----------------------------- Subscribe to a resource, return URL if possible
 1173: 
 1174: sub subscribe {
 1175:     my $fname=shift;
 1176:     if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return ''; }
 1177:     $fname=~s/[\n\r]//g;
 1178:     my $author=$fname;
 1179:     $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
 1180:     my ($udom,$uname)=split(/\//,$author);
 1181:     my $home=homeserver($uname,$udom);
 1182:     if ($home eq 'no_host') {
 1183:         return 'not_found';
 1184:     }
 1185:     my $answer=reply("sub:$fname",$home);
 1186:     if (($answer eq 'con_lost') || ($answer eq 'rejected')) {
 1187: 	$answer.=' by '.$home;
 1188:     }
 1189:     return $answer;
 1190: }
 1191:     
 1192: # -------------------------------------------------------------- Replicate file
 1193: 
 1194: sub repcopy {
 1195:     my $filename=shift;
 1196:     $filename=~s/\/+/\//g;
 1197:     if ($filename=~m|^/home/httpd/html/adm/|) { return 'ok'; }
 1198:     if ($filename=~m|^/home/httpd/html/lonUsers/|) { return 'ok'; }
 1199:     if ($filename=~m|^/home/httpd/html/userfiles/| or
 1200: 	$filename=~m -^/*(uploaded|editupload)/-) { 
 1201: 	return &repcopy_userfile($filename);
 1202:     }
 1203:     $filename=~s/[\n\r]//g;
 1204:     my $transname="$filename.in.transfer";
 1205: # FIXME: this should flock
 1206:     if ((-e $filename) || (-e $transname)) { return 'ok'; }
 1207:     my $remoteurl=subscribe($filename);
 1208:     if ($remoteurl =~ /^con_lost by/) {
 1209: 	   &logthis("Subscribe returned $remoteurl: $filename");
 1210:            return 'unavailable';
 1211:     } elsif ($remoteurl eq 'not_found') {
 1212: 	   #&logthis("Subscribe returned not_found: $filename");
 1213: 	   return 'not_found';
 1214:     } elsif ($remoteurl =~ /^rejected by/) {
 1215: 	   &logthis("Subscribe returned $remoteurl: $filename");
 1216:            return 'forbidden';
 1217:     } elsif ($remoteurl eq 'directory') {
 1218:            return 'ok';
 1219:     } else {
 1220:         my $author=$filename;
 1221:         $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
 1222:         my ($udom,$uname)=split(/\//,$author);
 1223:         my $home=homeserver($uname,$udom);
 1224:         unless ($home eq $perlvar{'lonHostID'}) {
 1225:            my @parts=split(/\//,$filename);
 1226:            my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";
 1227:            if ($path ne "$perlvar{'lonDocRoot'}/res") {
 1228:                &logthis("Malconfiguration for replication: $filename");
 1229: 	       return 'bad_request';
 1230:            }
 1231:            my $count;
 1232:            for ($count=5;$count<$#parts;$count++) {
 1233:                $path.="/$parts[$count]";
 1234:                if ((-e $path)!=1) {
 1235: 		   mkdir($path,0777);
 1236:                }
 1237:            }
 1238:            my $ua=new LWP::UserAgent;
 1239:            my $request=new HTTP::Request('GET',"$remoteurl");
 1240:            my $response=$ua->request($request,$transname);
 1241:            if ($response->is_error()) {
 1242: 	       unlink($transname);
 1243:                my $message=$response->status_line;
 1244:                &logthis("<font color=\"blue\">WARNING:"
 1245:                        ." LWP get: $message: $filename</font>");
 1246:                return 'unavailable';
 1247:            } else {
 1248: 	       if ($remoteurl!~/\.meta$/) {
 1249:                   my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');
 1250:                   my $mresponse=$ua->request($mrequest,$filename.'.meta');
 1251:                   if ($mresponse->is_error()) {
 1252: 		      unlink($filename.'.meta');
 1253:                       &logthis(
 1254:                      "<font color=\"yellow\">INFO: No metadata: $filename</font>");
 1255:                   }
 1256: 	       }
 1257:                rename($transname,$filename);
 1258:                return 'ok';
 1259:            }
 1260:        }
 1261:     }
 1262: }
 1263: 
 1264: # ------------------------------------------------ Get server side include body
 1265: sub ssi_body {
 1266:     my ($filelink,%form)=@_;
 1267:     if (! exists($form{'LONCAPA_INTERNAL_no_discussion'})) {
 1268:         $form{'LONCAPA_INTERNAL_no_discussion'}='true';
 1269:     }
 1270:     my $output=($filelink=~/^http\:/?&externalssi($filelink):
 1271:                                      &ssi($filelink,%form));
 1272:     $output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+?// END LON-CAPA Internal\s*(-->)?\s||gs;
 1273:     $output=~s/^.*?\<body[^\>]*\>//si;
 1274:     $output=~s/(.*)\<\/body\s*\>.*?$/$1/si;
 1275:     return $output;
 1276: }
 1277: 
 1278: # --------------------------------------------------------- Server Side Include
 1279: 
 1280: sub absolute_url {
 1281:     my ($host_name) = @_;
 1282:     my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://');
 1283:     if ($host_name eq '') {
 1284: 	$host_name = $ENV{'SERVER_NAME'};
 1285:     }
 1286:     return $protocol.$host_name;
 1287: }
 1288: 
 1289: sub ssi {
 1290: 
 1291:     my ($fn,%form)=@_;
 1292: 
 1293:     my $ua=new LWP::UserAgent;
 1294:     
 1295:     my $request;
 1296: 
 1297:     $form{'no_update_last_known'}=1;
 1298: 
 1299:     if (%form) {
 1300:       $request=new HTTP::Request('POST',&absolute_url().$fn);
 1301:       $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form));
 1302:     } else {
 1303:       $request=new HTTP::Request('GET',&absolute_url().$fn);
 1304:     }
 1305: 
 1306:     $request->header(Cookie => $ENV{'HTTP_COOKIE'});
 1307:     my $response=$ua->request($request);
 1308: 
 1309:     return $response->content;
 1310: }
 1311: 
 1312: sub externalssi {
 1313:     my ($url)=@_;
 1314:     my $ua=new LWP::UserAgent;
 1315:     my $request=new HTTP::Request('GET',$url);
 1316:     my $response=$ua->request($request);
 1317:     return $response->content;
 1318: }
 1319: 
 1320: # -------------------------------- Allow a /uploaded/ URI to be vouched for
 1321: 
 1322: sub allowuploaded {
 1323:     my ($srcurl,$url)=@_;
 1324:     $url=&clutter(&declutter($url));
 1325:     my $dir=$url;
 1326:     $dir=~s/\/[^\/]+$//;
 1327:     my %httpref=();
 1328:     my $httpurl=&hreflocation('',$url);
 1329:     $httpref{'httpref.'.$httpurl}=$srcurl;
 1330:     &Apache::lonnet::appenv(%httpref);
 1331: }
 1332: 
 1333: # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course
 1334: # input: action, courseID, current domain, intended
 1335: #        path to file, source of file, instruction to parse file for objects,
 1336: #        ref to hash for embedded objects,
 1337: #        ref to hash for codebase of java objects.
 1338: #
 1339: # output: url to file (if action was uploaddoc), 
 1340: #         ok if successful, or diagnostic message otherwise (if action was propagate or copy)
 1341: #
 1342: # Allows directory structure to be used within lonUsers/../userfiles/ for a 
 1343: # course.
 1344: #
 1345: # action = propagate - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
 1346: #          will be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles in
 1347: #          course's home server.
 1348: #
 1349: # action = copy - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file will
 1350: #          be copied from $source (current location) to 
 1351: #          /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
 1352: #         and will then be copied to
 1353: #          /home/httpd/lonUsers/$domain/1/2/3/$course/userfiles/$file in
 1354: #         course's home server.
 1355: #
 1356: # action = uploaddoc - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
 1357: #         will be retrived from $env{form.uploaddoc} (from DOCS interface) to
 1358: #         /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
 1359: #         and will then be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles/$file
 1360: #         in course's home server.
 1361: #
 1362: 
 1363: sub process_coursefile {
 1364:     my ($action,$docuname,$docudom,$file,$source,$parser,$allfiles,$codebase)=@_;
 1365:     my $fetchresult;
 1366:     my $home=&homeserver($docuname,$docudom);
 1367:     if ($action eq 'propagate') {
 1368:         $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
 1369: 			     $home);
 1370:     } else {
 1371:         my $fpath = '';
 1372:         my $fname = $file;
 1373:         ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|);
 1374:         $fpath=$docudom.'/'.$docuname.'/'.$fpath;
 1375:         my $filepath = &build_filepath($fpath);
 1376:         if ($action eq 'copy') {
 1377:             if ($source eq '') {
 1378:                 $fetchresult = 'no source file';
 1379:                 return $fetchresult;
 1380:             } else {
 1381:                 my $destination = $filepath.'/'.$fname;
 1382:                 rename($source,$destination);
 1383:                 $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
 1384:                                  $home);
 1385:             }
 1386:         } elsif ($action eq 'uploaddoc') {
 1387:             open(my $fh,'>'.$filepath.'/'.$fname);
 1388:             print $fh $env{'form.'.$source};
 1389:             close($fh);
 1390:             if ($parser eq 'parse') {
 1391:                 my $parse_result = &extract_embedded_items($filepath,$fname,$allfiles,$codebase);
 1392:                 unless ($parse_result eq 'ok') {
 1393:                     &logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result);
 1394:                 }
 1395:             }
 1396:             $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
 1397:                                  $home);
 1398:             if ($fetchresult eq 'ok') {
 1399:                 return '/uploaded/'.$fpath.'/'.$fname;
 1400:             } else {
 1401:                 &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.
 1402:                         ' to host '.$home.': '.$fetchresult);
 1403:                 return '/adm/notfound.html';
 1404:             }
 1405:         }
 1406:     }
 1407:     unless ( $fetchresult eq 'ok') {
 1408:         &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.
 1409:              ' to host '.$home.': '.$fetchresult);
 1410:     }
 1411:     return $fetchresult;
 1412: }
 1413: 
 1414: sub build_filepath {
 1415:     my ($fpath) = @_;
 1416:     my $filepath=$perlvar{'lonDocRoot'}.'/userfiles';
 1417:     unless ($fpath eq '') {
 1418:         my @parts=split('/',$fpath);
 1419:         foreach my $part (@parts) {
 1420:             $filepath.= '/'.$part;
 1421:             if ((-e $filepath)!=1) {
 1422:                 mkdir($filepath,0777);
 1423:             }
 1424:         }
 1425:     }
 1426:     return $filepath;
 1427: }
 1428: 
 1429: sub store_edited_file {
 1430:     my ($primary_url,$content,$docudom,$docuname,$fetchresult) = @_;
 1431:     my $file = $primary_url;
 1432:     $file =~ s#^/uploaded/$docudom/$docuname/##;
 1433:     my $fpath = '';
 1434:     my $fname = $file;
 1435:     ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|);
 1436:     $fpath=$docudom.'/'.$docuname.'/'.$fpath;
 1437:     my $filepath = &build_filepath($fpath);
 1438:     open(my $fh,'>'.$filepath.'/'.$fname);
 1439:     print $fh $content;
 1440:     close($fh);
 1441:     my $home=&homeserver($docuname,$docudom);
 1442:     $$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
 1443: 			  $home);
 1444:     if ($$fetchresult eq 'ok') {
 1445:         return '/uploaded/'.$fpath.'/'.$fname;
 1446:     } else {
 1447:         &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.
 1448: 		 ' to host '.$home.': '.$$fetchresult);
 1449:         return '/adm/notfound.html';
 1450:     }
 1451: }
 1452: 
 1453: sub clean_filename {
 1454:     my ($fname,$args)=@_;
 1455: # Replace Windows backslashes by forward slashes
 1456:     $fname=~s/\\/\//g;
 1457:     if (!$args->{'keep_path'}) {
 1458:         # Get rid of everything but the actual filename
 1459: 	$fname=~s/^.*\/([^\/]+)$/$1/;
 1460:     }
 1461: # Replace spaces by underscores
 1462:     $fname=~s/\s+/\_/g;
 1463: # Replace all other weird characters by nothing
 1464:     $fname=~s{[^/\w\.\-]}{}g;
 1465: # Replace all .\d. sequences with _\d. so they no longer look like version
 1466: # numbers
 1467:     $fname=~s/\.(\d+)(?=\.)/_$1/g;
 1468:     return $fname;
 1469: }
 1470: 
 1471: # --------------- Take an uploaded file and put it into the userfiles directory
 1472: # input: $formname - the contents of the file are in $env{"form.$formname"}
 1473: #                    the desired filenam is in $env{"form.$formname.filename"}
 1474: #        $coursedoc - if true up to the current course
 1475: #                     if false
 1476: #        $subdir - directory in userfile to store the file into
 1477: #        $parser, $allfiles, $codebase - unknown
 1478: #
 1479: # output: url of file in userspace, or error: <message> 
 1480: #             or /adm/notfound.html if failure to upload occurse
 1481: 
 1482: 
 1483: sub userfileupload {
 1484:     my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname,$destudom)=@_;
 1485:     if (!defined($subdir)) { $subdir='unknown'; }
 1486:     my $fname=$env{'form.'.$formname.'.filename'};
 1487:     $fname=&clean_filename($fname);
 1488: # See if there is anything left
 1489:     unless ($fname) { return 'error: no uploaded file'; }
 1490:     chop($env{'form.'.$formname});
 1491:     if (($formname eq 'screenshot') && ($subdir eq 'helprequests')) { #files uploaded to help request form are handled differently
 1492:         my $now = time;
 1493:         my $filepath = 'tmp/helprequests/'.$now;
 1494:         my @parts=split(/\//,$filepath);
 1495:         my $fullpath = $perlvar{'lonDaemons'};
 1496:         for (my $i=0;$i<@parts;$i++) {
 1497:             $fullpath .= '/'.$parts[$i];
 1498:             if ((-e $fullpath)!=1) {
 1499:                 mkdir($fullpath,0777);
 1500:             }
 1501:         }
 1502:         open(my $fh,'>'.$fullpath.'/'.$fname);
 1503:         print $fh $env{'form.'.$formname};
 1504:         close($fh);
 1505:         return $fullpath.'/'.$fname;
 1506:     } elsif (($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) { #files uploaded to create course page are handled differently
 1507:         my $filepath = 'tmp/addcourse/'.$destudom.'/web/'.$env{'user.name'}.
 1508:                        '_'.$env{'user.domain'}.'/pending';
 1509:         my @parts=split(/\//,$filepath);
 1510:         my $fullpath = $perlvar{'lonDaemons'};
 1511:         for (my $i=0;$i<@parts;$i++) {
 1512:             $fullpath .= '/'.$parts[$i];
 1513:             if ((-e $fullpath)!=1) {
 1514:                 mkdir($fullpath,0777);
 1515:             }
 1516:         }
 1517:         open(my $fh,'>'.$fullpath.'/'.$fname);
 1518:         print $fh $env{'form.'.$formname};
 1519:         close($fh);
 1520:         return $fullpath.'/'.$fname;
 1521:     }
 1522:     
 1523: # Create the directory if not present
 1524:     $fname="$subdir/$fname";
 1525:     if ($coursedoc) {
 1526: 	my $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
 1527: 	my $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
 1528:         if ($env{'form.folder'} =~ m/^(default|supplemental)/) {
 1529:             return &finishuserfileupload($docuname,$docudom,
 1530: 					 $formname,$fname,$parser,$allfiles,
 1531: 					 $codebase);
 1532:         } else {
 1533:             $fname=$env{'form.folder'}.'/'.$fname;
 1534:             return &process_coursefile('uploaddoc',$docuname,$docudom,
 1535: 				       $fname,$formname,$parser,
 1536: 				       $allfiles,$codebase);
 1537:         }
 1538:     } elsif (defined($destuname)) {
 1539:         my $docuname=$destuname;
 1540:         my $docudom=$destudom;
 1541: 	return &finishuserfileupload($docuname,$docudom,$formname,
 1542: 				     $fname,$parser,$allfiles,$codebase);
 1543:         
 1544:     } else {
 1545:         my $docuname=$env{'user.name'};
 1546:         my $docudom=$env{'user.domain'};
 1547:         if (exists($env{'form.group'})) {
 1548:             $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
 1549:             $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
 1550:         }
 1551: 	return &finishuserfileupload($docuname,$docudom,$formname,
 1552: 				     $fname,$parser,$allfiles,$codebase);
 1553:     }
 1554: }
 1555: 
 1556: sub finishuserfileupload {
 1557:     my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase) = @_;
 1558:     my $path=$docudom.'/'.$docuname.'/';
 1559:     my $filepath=$perlvar{'lonDocRoot'};
 1560:     my ($fnamepath,$file);
 1561:     $file=$fname;
 1562:     if ($fname=~m|/|) {
 1563:         ($fnamepath,$file) = ($fname =~ m|^(.*)/([^/]+)$|);
 1564: 	$path.=$fnamepath.'/';
 1565:     }
 1566:     my @parts=split(/\//,$filepath.'/userfiles/'.$path);
 1567:     my $count;
 1568:     for ($count=4;$count<=$#parts;$count++) {
 1569:         $filepath.="/$parts[$count]";
 1570:         if ((-e $filepath)!=1) {
 1571: 	    mkdir($filepath,0777);
 1572:         }
 1573:     }
 1574: # Save the file
 1575:     {
 1576: 	if (!open(FH,'>'.$filepath.'/'.$file)) {
 1577: 	    &logthis('Failed to create '.$filepath.'/'.$file);
 1578: 	    print STDERR ('Failed to create '.$filepath.'/'.$file."\n");
 1579: 	    return '/adm/notfound.html';
 1580: 	}
 1581: 	if (!print FH ($env{'form.'.$formname})) {
 1582: 	    &logthis('Failed to write to '.$filepath.'/'.$file);
 1583: 	    print STDERR ('Failed to write to '.$filepath.'/'.$file."\n");
 1584: 	    return '/adm/notfound.html';
 1585: 	}
 1586: 	close(FH);
 1587:     }
 1588:     if ($parser eq 'parse') {
 1589:         my $parse_result = &extract_embedded_items($filepath,$file,$allfiles,
 1590: 						   $codebase);
 1591:         unless ($parse_result eq 'ok') {
 1592:             &logthis('Failed to parse '.$filepath.$file.
 1593: 		     ' for embedded media: '.$parse_result); 
 1594:         }
 1595:     }
 1596: # Notify homeserver to grep it
 1597: #
 1598:     my $docuhome=&homeserver($docuname,$docudom);
 1599:     my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);
 1600:     if ($fetchresult eq 'ok') {
 1601: #
 1602: # Return the URL to it
 1603:         return '/uploaded/'.$path.$file;
 1604:     } else {
 1605:         &logthis('Failed to transfer '.$path.$file.' to host '.$docuhome.
 1606: 		 ': '.$fetchresult);
 1607:         return '/adm/notfound.html';
 1608:     }    
 1609: }
 1610: 
 1611: sub extract_embedded_items {
 1612:     my ($filepath,$file,$allfiles,$codebase,$content) = @_;
 1613:     my @state = ();
 1614:     my %javafiles = (
 1615:                       codebase => '',
 1616:                       code => '',
 1617:                       archive => ''
 1618:                     );
 1619:     my %mediafiles = (
 1620:                       src => '',
 1621:                       movie => '',
 1622:                      );
 1623:     my $p;
 1624:     if ($content) {
 1625:         $p = HTML::LCParser->new($content);
 1626:     } else {
 1627:         $p = HTML::LCParser->new($filepath.'/'.$file);
 1628:     }
 1629:     while (my $t=$p->get_token()) {
 1630: 	if ($t->[0] eq 'S') {
 1631: 	    my ($tagname, $attr) = ($t->[1],$t->[2]);
 1632: 	    push (@state, $tagname);
 1633:             if (lc($tagname) eq 'allow') {
 1634:                 &add_filetype($allfiles,$attr->{'src'},'src');
 1635:             }
 1636: 	    if (lc($tagname) eq 'img') {
 1637: 		&add_filetype($allfiles,$attr->{'src'},'src');
 1638: 	    }
 1639:             if (lc($tagname) eq 'script') {
 1640:                 if ($attr->{'archive'} =~ /\.jar$/i) {
 1641:                     &add_filetype($allfiles,$attr->{'archive'},'archive');
 1642:                 } else {
 1643:                     &add_filetype($allfiles,$attr->{'src'},'src');
 1644:                 }
 1645:             }
 1646:             if (lc($tagname) eq 'link') {
 1647:                 if (lc($attr->{'rel'}) eq 'stylesheet') { 
 1648:                     &add_filetype($allfiles,$attr->{'href'},'href');
 1649:                 }
 1650:             }
 1651: 	    if (lc($tagname) eq 'object' ||
 1652: 		(lc($tagname) eq 'embed' && lc($state[-2]) ne 'object')) {
 1653: 		foreach my $item (keys(%javafiles)) {
 1654: 		    $javafiles{$item} = '';
 1655: 		}
 1656: 	    }
 1657: 	    if (lc($state[-2]) eq 'object' && lc($tagname) eq 'param') {
 1658: 		my $name = lc($attr->{'name'});
 1659: 		foreach my $item (keys(%javafiles)) {
 1660: 		    if ($name eq $item) {
 1661: 			$javafiles{$item} = $attr->{'value'};
 1662: 			last;
 1663: 		    }
 1664: 		}
 1665: 		foreach my $item (keys(%mediafiles)) {
 1666: 		    if ($name eq $item) {
 1667: 			&add_filetype($allfiles, $attr->{'value'}, 'value');
 1668: 			last;
 1669: 		    }
 1670: 		}
 1671: 	    }
 1672: 	    if (lc($tagname) eq 'embed' || lc($tagname) eq 'applet') {
 1673: 		foreach my $item (keys(%javafiles)) {
 1674: 		    if ($attr->{$item}) {
 1675: 			$javafiles{$item} = $attr->{$item};
 1676: 			last;
 1677: 		    }
 1678: 		}
 1679: 		foreach my $item (keys(%mediafiles)) {
 1680: 		    if ($attr->{$item}) {
 1681: 			&add_filetype($allfiles,$attr->{$item},$item);
 1682: 			last;
 1683: 		    }
 1684: 		}
 1685: 	    }
 1686: 	} elsif ($t->[0] eq 'E') {
 1687: 	    my ($tagname) = ($t->[1]);
 1688: 	    if ($javafiles{'codebase'} ne '') {
 1689: 		$javafiles{'codebase'} .= '/';
 1690: 	    }  
 1691: 	    if (lc($tagname) eq 'applet' ||
 1692: 		lc($tagname) eq 'object' ||
 1693: 		(lc($tagname) eq 'embed' && lc($state[-2]) ne 'object')
 1694: 		) {
 1695: 		foreach my $item (keys(%javafiles)) {
 1696: 		    if ($item ne 'codebase' && $javafiles{$item} ne '') {
 1697: 			my $file=$javafiles{'codebase'}.$javafiles{$item};
 1698: 			&add_filetype($allfiles,$file,$item);
 1699: 		    }
 1700: 		}
 1701: 	    } 
 1702: 	    pop @state;
 1703: 	}
 1704:     }
 1705:     return 'ok';
 1706: }
 1707: 
 1708: sub add_filetype {
 1709:     my ($allfiles,$file,$type)=@_;
 1710:     if (exists($allfiles->{$file})) {
 1711: 	unless (grep/^\Q$type\E$/, @{$allfiles->{$file}}) {
 1712: 	    push(@{$allfiles->{$file}}, &escape($type));
 1713: 	}
 1714:     } else {
 1715: 	@{$allfiles->{$file}} = (&escape($type));
 1716:     }
 1717: }
 1718: 
 1719: sub removeuploadedurl {
 1720:     my ($url)=@_;
 1721:     my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);
 1722:     return &removeuserfile($uname,$udom,$fname);
 1723: }
 1724: 
 1725: sub removeuserfile {
 1726:     my ($docuname,$docudom,$fname)=@_;
 1727:     my $home=&homeserver($docuname,$docudom);
 1728:     my $result = &reply("removeuserfile:$docudom/$docuname/$fname",$home);
 1729:     if ($result eq 'ok') {
 1730:         if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) {
 1731:             my $metafile = $fname.'.meta';
 1732:             my $metaresult = &removeuserfile($docuname,$docudom,$metafile); 
 1733: 	    my $url = "/uploaded/$docudom/$docuname/$fname";
 1734:             my ($file,$group) = (&parse_portfolio_url($url))[3,4];
 1735:             my $sqlresult = 
 1736:                 &update_portfolio_table($docuname,$docudom,$file,
 1737:                                         'portfolio_metadata',$group,
 1738:                                         'delete');
 1739:         }
 1740:     }
 1741:     return $result;
 1742: }
 1743: 
 1744: sub mkdiruserfile {
 1745:     my ($docuname,$docudom,$dir)=@_;
 1746:     my $home=&homeserver($docuname,$docudom);
 1747:     return &reply("mkdiruserfile:".&escape("$docudom/$docuname/$dir"),$home);
 1748: }
 1749: 
 1750: sub renameuserfile {
 1751:     my ($docuname,$docudom,$old,$new)=@_;
 1752:     my $home=&homeserver($docuname,$docudom);
 1753:     my $result = &reply("renameuserfile:$docudom:$docuname:".
 1754:                         &escape("$old").':'.&escape("$new"),$home);
 1755:     if ($result eq 'ok') {
 1756:         if (($old !~ /\.meta$/) && (&is_portfolio_file($old))) {
 1757:             my $oldmeta = $old.'.meta';
 1758:             my $newmeta = $new.'.meta';
 1759:             my $metaresult = 
 1760:                 &renameuserfile($docuname,$docudom,$oldmeta,$newmeta);
 1761: 	    my $url = "/uploaded/$docudom/$docuname/$old";
 1762:             my ($file,$group) = (&parse_portfolio_url($url))[3,4];
 1763:             my $sqlresult = 
 1764:                 &update_portfolio_table($docuname,$docudom,$file,
 1765:                                         'portfolio_metadata',$group,
 1766:                                         'delete');
 1767:         }
 1768:     }
 1769:     return $result;
 1770: }
 1771: 
 1772: # ------------------------------------------------------------------------- Log
 1773: 
 1774: sub log {
 1775:     my ($dom,$nam,$hom,$what)=@_;
 1776:     return critical("log:$dom:$nam:$what",$hom);
 1777: }
 1778: 
 1779: # ------------------------------------------------------------------ Course Log
 1780: #
 1781: # This routine flushes several buffers of non-mission-critical nature
 1782: #
 1783: 
 1784: sub flushcourselogs {
 1785:     &logthis('Flushing log buffers');
 1786: #
 1787: # course logs
 1788: # This is a log of all transactions in a course, which can be used
 1789: # for data mining purposes
 1790: #
 1791: # It also collects the courseid database, which lists last transaction
 1792: # times and course titles for all courseids
 1793: #
 1794:     my %courseidbuffer=();
 1795:     foreach my $crsid (keys %courselogs) {
 1796:         if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$crsid}.':'.
 1797: 		          &escape($courselogs{$crsid}),
 1798: 		          $coursehombuf{$crsid}) eq 'ok') {
 1799: 	    delete $courselogs{$crsid};
 1800:         } else {
 1801:             &logthis('Failed to flush log buffer for '.$crsid);
 1802:             if (length($courselogs{$crsid})>40000) {
 1803:                &logthis("<font color=\"blue\">WARNING: Buffer for ".$crsid.
 1804:                         " exceeded maximum size, deleting.</font>");
 1805:                delete $courselogs{$crsid};
 1806:             }
 1807:         }
 1808:         if ($courseidbuffer{$coursehombuf{$crsid}}) {
 1809:            $courseidbuffer{$coursehombuf{$crsid}}.='&'.
 1810: 			 &escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
 1811:                          ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}).':'.&escape($coursetypebuf{$crsid});
 1812:         } else {
 1813:            $courseidbuffer{$coursehombuf{$crsid}}=
 1814: 			 &escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
 1815:                          ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}).':'.&escape($coursetypebuf{$crsid});
 1816:         }
 1817:     }
 1818: #
 1819: # Write course id database (reverse lookup) to homeserver of courses 
 1820: # Is used in pickcourse
 1821: #
 1822:     foreach my $crsid (keys(%courseidbuffer)) {
 1823:         &courseidput($hostdom{$crsid},$courseidbuffer{$crsid},$crsid);
 1824:     }
 1825: #
 1826: # File accesses
 1827: # Writes to the dynamic metadata of resources to get hit counts, etc.
 1828: #
 1829:     foreach my $entry (keys(%accesshash)) {
 1830:         if ($entry =~ /___count$/) {
 1831:             my ($dom,$name);
 1832:             ($dom,$name,undef)=
 1833: 		($entry=~m{___($match_domain)/($match_name)/(.*)___count$});
 1834:             if (! defined($dom) || $dom eq '' || 
 1835:                 ! defined($name) || $name eq '') {
 1836:                 my $cid = $env{'request.course.id'};
 1837:                 $dom  = $env{'request.'.$cid.'.domain'};
 1838:                 $name = $env{'request.'.$cid.'.num'};
 1839:             }
 1840:             my $value = $accesshash{$entry};
 1841:             my (undef,$url,undef) = ($entry =~ /^(.*)___(.*)___count$/);
 1842:             my %temphash=($url => $value);
 1843:             my $result = &inc('nohist_accesscount',\%temphash,$dom,$name);
 1844:             if ($result eq 'ok') {
 1845:                 delete $accesshash{$entry};
 1846:             } elsif ($result eq 'unknown_cmd') {
 1847:                 # Target server has old code running on it.
 1848:                 my %temphash=($entry => $value);
 1849:                 if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {
 1850:                     delete $accesshash{$entry};
 1851:                 }
 1852:             }
 1853:         } else {
 1854:             my ($dom,$name) = ($entry=~m{___($match_domain)/($match_name)/(.*)___(\w+)$});
 1855:             my %temphash=($entry => $accesshash{$entry});
 1856:             if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {
 1857:                 delete $accesshash{$entry};
 1858:             }
 1859:         }
 1860:     }
 1861: #
 1862: # Roles
 1863: # Reverse lookup of user roles for course faculty/staff and co-authorship
 1864: #
 1865:     foreach my $entry (keys(%userrolehash)) {
 1866:         my ($role,$uname,$udom,$runame,$rudom,$rsec)=
 1867: 	    split(/\:/,$entry);
 1868:         if (&Apache::lonnet::put('nohist_userroles',
 1869:              { $role.':'.$uname.':'.$udom.':'.$rsec => $userrolehash{$entry} },
 1870:                 $rudom,$runame) eq 'ok') {
 1871: 	    delete $userrolehash{$entry};
 1872:         }
 1873:     }
 1874: #
 1875: # Reverse lookup of domain roles (dc, ad, li, sc, au)
 1876: #
 1877:     my %domrolebuffer = ();
 1878:     foreach my $entry (keys %domainrolehash) {
 1879:         my ($role,$uname,$udom,$runame,$rudom,$rsec)=split/:/,$entry;
 1880:         if ($domrolebuffer{$rudom}) {
 1881:             $domrolebuffer{$rudom}.='&'.&escape($entry).
 1882:                       '='.&escape($domainrolehash{$entry});
 1883:         } else {
 1884:             $domrolebuffer{$rudom}.=&escape($entry).
 1885:                       '='.&escape($domainrolehash{$entry});
 1886:         }
 1887:         delete $domainrolehash{$entry};
 1888:     }
 1889:     foreach my $dom (keys(%domrolebuffer)) {
 1890:         foreach my $tryserver (keys %libserv) {
 1891:             if ($hostdom{$tryserver} eq $dom) {
 1892:                 unless (&reply('domroleput:'.$dom.':'.
 1893:                   $domrolebuffer{$dom},$tryserver) eq 'ok') {
 1894:                     &logthis('Put of domain roles failed for '.$dom.' and  '.$tryserver);
 1895:                 }
 1896:             }
 1897:         }
 1898:     }
 1899:     $dumpcount++;
 1900: }
 1901: 
 1902: sub courselog {
 1903:     my $what=shift;
 1904:     $what=time.':'.$what;
 1905:     unless ($env{'request.course.id'}) { return ''; }
 1906:     $coursedombuf{$env{'request.course.id'}}=
 1907:        $env{'course.'.$env{'request.course.id'}.'.domain'};
 1908:     $coursenumbuf{$env{'request.course.id'}}=
 1909:        $env{'course.'.$env{'request.course.id'}.'.num'};
 1910:     $coursehombuf{$env{'request.course.id'}}=
 1911:        $env{'course.'.$env{'request.course.id'}.'.home'};
 1912:     $coursedescrbuf{$env{'request.course.id'}}=
 1913:        $env{'course.'.$env{'request.course.id'}.'.description'};
 1914:     $courseinstcodebuf{$env{'request.course.id'}}=
 1915:        $env{'course.'.$env{'request.course.id'}.'.internal.coursecode'};
 1916:     $courseownerbuf{$env{'request.course.id'}}=
 1917:        $env{'course.'.$env{'request.course.id'}.'.internal.courseowner'};
 1918:     $coursetypebuf{$env{'request.course.id'}}=
 1919:        $env{'course.'.$env{'request.course.id'}.'.type'};
 1920:     if (defined $courselogs{$env{'request.course.id'}}) {
 1921: 	$courselogs{$env{'request.course.id'}}.='&'.$what;
 1922:     } else {
 1923: 	$courselogs{$env{'request.course.id'}}.=$what;
 1924:     }
 1925:     if (length($courselogs{$env{'request.course.id'}})>4048) {
 1926: 	&flushcourselogs();
 1927:     }
 1928: }
 1929: 
 1930: sub courseacclog {
 1931:     my $fnsymb=shift;
 1932:     unless ($env{'request.course.id'}) { return ''; }
 1933:     my $what=$fnsymb.':'.$env{'user.name'}.':'.$env{'user.domain'};
 1934:     if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|task|page)$/) {
 1935:         $what.=':POST';
 1936:         # FIXME: Probably ought to escape things....
 1937: 	foreach my $key (keys(%env)) {
 1938:             if ($key=~/^form\.(.*)/) {
 1939: 		$what.=':'.$1.'='.$env{$key};
 1940:             }
 1941:         }
 1942:     } elsif ($fnsymb =~ m:^/adm/searchcat:) {
 1943:         # FIXME: We should not be depending on a form parameter that someone
 1944:         # editing lonsearchcat.pm might change in the future.
 1945:         if ($env{'form.phase'} eq 'course_search') {
 1946:             $what.= ':POST';
 1947:             # FIXME: Probably ought to escape things....
 1948:             foreach my $element ('courseexp','crsfulltext','crsrelated',
 1949:                                  'crsdiscuss') {
 1950:                 $what.=':'.$element.'='.$env{'form.'.$element};
 1951:             }
 1952:         }
 1953:     }
 1954:     &courselog($what);
 1955: }
 1956: 
 1957: sub countacc {
 1958:     my $url=&declutter(shift);
 1959:     return if (! defined($url) || $url eq '');
 1960:     unless ($env{'request.course.id'}) { return ''; }
 1961:     $accesshash{$env{'request.course.id'}.'___'.$url.'___course'}=1;
 1962:     my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count';
 1963:     $accesshash{$key}++;
 1964: }
 1965: 
 1966: sub linklog {
 1967:     my ($from,$to)=@_;
 1968:     $from=&declutter($from);
 1969:     $to=&declutter($to);
 1970:     $accesshash{$from.'___'.$to.'___comefrom'}=1;
 1971:     $accesshash{$to.'___'.$from.'___goto'}=1;
 1972: }
 1973:   
 1974: sub userrolelog {
 1975:     my ($trole,$username,$domain,$area,$tstart,$tend)=@_;
 1976:     if (($trole=~/^ca/) || ($trole=~/^aa/) ||
 1977:         ($trole=~/^in/) || ($trole=~/^cc/) ||
 1978:         ($trole=~/^ep/) || ($trole=~/^cr/) ||
 1979:         ($trole=~/^ta/)) {
 1980:        my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
 1981:        $userrolehash
 1982:          {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
 1983:                     =$tend.':'.$tstart;
 1984:     }
 1985:     if (($trole=~/^dc/) || ($trole=~/^ad/) ||
 1986:         ($trole=~/^li/) || ($trole=~/^li/) ||
 1987:         ($trole=~/^au/) || ($trole=~/^dg/) ||
 1988:         ($trole=~/^sc/)) {
 1989:        my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
 1990:        $domainrolehash
 1991:          {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
 1992:                     = $tend.':'.$tstart;
 1993:     }
 1994: }
 1995: 
 1996: sub get_course_adv_roles {
 1997:     my $cid=shift;
 1998:     $cid=$env{'request.course.id'} unless (defined($cid));
 1999:     my %coursehash=&coursedescription($cid);
 2000:     my %nothide=();
 2001:     foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
 2002: 	$nothide{join(':',split(/[\@\:]/,$user))}=1;
 2003:     }
 2004:     my %returnhash=();
 2005:     my %dumphash=
 2006:             &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});
 2007:     my $now=time;
 2008:     foreach my $entry (keys %dumphash) {
 2009: 	my ($tend,$tstart)=split(/\:/,$dumphash{$entry});
 2010:         if (($tstart) && ($tstart<0)) { next; }
 2011:         if (($tend) && ($tend<$now)) { next; }
 2012:         if (($tstart) && ($now<$tstart)) { next; }
 2013:         my ($role,$username,$domain,$section)=split(/\:/,$entry);
 2014: 	if ($username eq '' || $domain eq '') { next; }
 2015: 	if ((&privileged($username,$domain)) && 
 2016: 	    (!$nothide{$username.':'.$domain})) { next; }
 2017: 	if ($role eq 'cr') { next; }
 2018:         my $key=&plaintext($role);
 2019:         if ($section) { $key.=' (Sec/Grp '.$section.')'; }
 2020:         if ($returnhash{$key}) {
 2021: 	    $returnhash{$key}.=','.$username.':'.$domain;
 2022:         } else {
 2023:             $returnhash{$key}=$username.':'.$domain;
 2024:         }
 2025:      }
 2026:     return %returnhash;
 2027: }
 2028: 
 2029: sub get_my_roles {
 2030:     my ($uname,$udom,$types,$roles,$roledoms)=@_;
 2031:     unless (defined($uname)) { $uname=$env{'user.name'}; }
 2032:     unless (defined($udom)) { $udom=$env{'user.domain'}; }
 2033:     my %dumphash=
 2034:             &dump('nohist_userroles',$udom,$uname);
 2035:     my %returnhash=();
 2036:     my $now=time;
 2037:     foreach my $entry (keys(%dumphash)) {
 2038: 	my ($tend,$tstart)=split(/\:/,$dumphash{$entry});
 2039:         if (($tstart) && ($tstart<0)) { next; }
 2040:         my $status = 'active';
 2041:         if (($tend) && ($tend<$now)) {
 2042:             $status = 'previous';
 2043:         } 
 2044:         if (($tstart) && ($now<$tstart)) {
 2045:             $status = 'future';
 2046:         }
 2047:         if (ref($types) eq 'ARRAY') {
 2048:             if (!grep(/^\Q$status\E$/,@{$types})) {
 2049:                 next;
 2050:             } 
 2051:         } else {
 2052:             if ($status ne 'active') {
 2053:                 next;
 2054:             }
 2055:         }
 2056:         my ($role,$username,$domain,$section)=split(/\:/,$entry);
 2057:         if (ref($roledoms) eq 'ARRAY') {
 2058:             if (!grep(/^\Q$domain\E$/,@{$roledoms})) {
 2059:                 next;
 2060:             }
 2061:         }
 2062:         if (ref($roles) eq 'ARRAY') {
 2063:             if (!grep(/^\Q$role\E$/,@{$roles})) {
 2064:                 next;
 2065:             }
 2066:         } 
 2067: 	$returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;
 2068:     }
 2069:     return %returnhash;
 2070: }
 2071: 
 2072: # ----------------------------------------------------- Frontpage Announcements
 2073: #
 2074: #
 2075: 
 2076: sub postannounce {
 2077:     my ($server,$text)=@_;
 2078:     unless (&allowed('psa',$hostdom{$server})) { return 'refused'; }
 2079:     unless ($text=~/\w/) { $text=''; }
 2080:     return &reply('setannounce:'.&escape($text),$server);
 2081: }
 2082: 
 2083: sub getannounce {
 2084: 
 2085:     if (open(my $fh,$perlvar{'lonDocRoot'}.'/announcement.txt')) {
 2086: 	my $announcement='';
 2087: 	while (my $line = <$fh>) { $announcement .= $line; }
 2088: 	close($fh);
 2089: 	if ($announcement=~/\w/) { 
 2090: 	    return 
 2091:    '<table bgcolor="#FF5555" cellpadding="5" cellspacing="3">'.
 2092:    '<tr><td bgcolor="#FFFFFF"><tt>'.$announcement.'</tt></td></tr></table>'; 
 2093: 	} else {
 2094: 	    return '';
 2095: 	}
 2096:     } else {
 2097: 	return '';
 2098:     }
 2099: }
 2100: 
 2101: # ---------------------------------------------------------- Course ID routines
 2102: # Deal with domain's nohist_courseid.db files
 2103: #
 2104: 
 2105: sub courseidput {
 2106:     my ($domain,$what,$coursehome)=@_;
 2107:     return &reply('courseidput:'.$domain.':'.$what,$coursehome);
 2108: }
 2109: 
 2110: sub courseiddump {
 2111:     my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_;
 2112:     my %returnhash=();
 2113:     unless ($domfilter) { $domfilter=''; }
 2114:     foreach my $tryserver (keys %libserv) {
 2115:         if ( ($hostidflag == 1 && grep/^$tryserver$/,@{$hostidref}) || (!defined($hostidflag)) ) {
 2116: 	    if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) {
 2117: 	        foreach my $line (
 2118:                  split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'.
 2119: 			       $sincefilter.':'.&escape($descfilter).':'.
 2120:                                &escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter).':'.&escape($typefilter).':'.&escape($regexp_ok),
 2121:                                $tryserver))) {
 2122: 		    my ($key,$value)=split(/\=/,$line,2);
 2123:                     if (($key) && ($value)) {
 2124: 		        $returnhash{&unescape($key)}=$value;
 2125:                     }
 2126:                 }
 2127:             }
 2128:         }
 2129:     }
 2130:     return %returnhash;
 2131: }
 2132: 
 2133: # ---------------------------------------------------------- DC e-mail
 2134: 
 2135: sub dcmailput {
 2136:     my ($domain,$msgid,$message,$server)=@_;
 2137:     my $status = &Apache::lonnet::critical(
 2138:        'dcmailput:'.$domain.':'.&escape($msgid).'='.
 2139:        &escape($message),$server);
 2140:     return $status;
 2141: }
 2142: 
 2143: sub dcmaildump {
 2144:     my ($dom,$startdate,$enddate,$senders) = @_;
 2145:     my %returnhash=();
 2146:     if (exists($domain_primary{$dom})) {
 2147:         my $cmd='dcmaildump:'.$dom.':'.&escape($startdate).':'.
 2148:                                                          &escape($enddate).':';
 2149: 	my @esc_senders=map { &escape($_)} @$senders;
 2150: 	$cmd.=&escape(join('&',@esc_senders));
 2151: 	foreach my $line (split(/\&/,&reply($cmd,$domain_primary{$dom}))) {
 2152:             my ($key,$value) = split(/\=/,$line,2);
 2153:             if (($key) && ($value)) {
 2154:                 $returnhash{&unescape($key)} = &unescape($value);
 2155:             }
 2156:         }
 2157:     }
 2158:     return %returnhash;
 2159: }
 2160: # ---------------------------------------------------------- Domain roles
 2161: 
 2162: sub get_domain_roles {
 2163:     my ($dom,$roles,$startdate,$enddate)=@_;
 2164:     if (undef($startdate) || $startdate eq '') {
 2165:         $startdate = '.';
 2166:     }
 2167:     if (undef($enddate) || $enddate eq '') {
 2168:         $enddate = '.';
 2169:     }
 2170:     my $rolelist = join(':',@{$roles});
 2171:     my %personnel = ();
 2172:     foreach my $tryserver (keys(%libserv)) {
 2173:         if ($hostdom{$tryserver} eq $dom) {
 2174:             %{$personnel{$tryserver}}=();
 2175:             foreach my $line (
 2176:                 split(/\&/,&reply('domrolesdump:'.$dom.':'.
 2177:                    &escape($startdate).':'.&escape($enddate).':'.
 2178:                    &escape($rolelist), $tryserver))) {
 2179:                 my ($key,$value) = split(/\=/,$line,2);
 2180:                 if (($key) && ($value)) {
 2181:                     $personnel{$tryserver}{&unescape($key)} = &unescape($value);
 2182:                 }
 2183:             }
 2184:         }
 2185:     }
 2186:     return %personnel;
 2187: }
 2188: 
 2189: # ----------------------------------------------------------- Check out an item
 2190: 
 2191: sub get_first_access {
 2192:     my ($type,$argsymb)=@_;
 2193:     my ($symb,$courseid,$udom,$uname)=&whichuser();
 2194:     if ($argsymb) { $symb=$argsymb; }
 2195:     my ($map,$id,$res)=&decode_symb($symb);
 2196:     if ($type eq 'map') {
 2197: 	$res=&symbread($map);
 2198:     } else {
 2199: 	$res=$symb;
 2200:     }
 2201:     my %times=&get('firstaccesstimes',["$courseid\0$res"],$udom,$uname);
 2202:     return $times{"$courseid\0$res"};
 2203: }
 2204: 
 2205: sub set_first_access {
 2206:     my ($type)=@_;
 2207:     my ($symb,$courseid,$udom,$uname)=&whichuser();
 2208:     my ($map,$id,$res)=&decode_symb($symb);
 2209:     if ($type eq 'map') {
 2210: 	$res=&symbread($map);
 2211:     } else {
 2212: 	$res=$symb;
 2213:     }
 2214:     my $firstaccess=&get_first_access($type,$symb);
 2215:     if (!$firstaccess) {
 2216: 	return &put('firstaccesstimes',{"$courseid\0$res"=>time},$udom,$uname);
 2217:     }
 2218:     return 'already_set';
 2219: }
 2220: 
 2221: sub checkout {
 2222:     my ($symb,$tuname,$tudom,$tcrsid)=@_;
 2223:     my $now=time;
 2224:     my $lonhost=$perlvar{'lonHostID'};
 2225:     my $infostr=&escape(
 2226:                  'CHECKOUTTOKEN&'.
 2227:                  $tuname.'&'.
 2228:                  $tudom.'&'.
 2229:                  $tcrsid.'&'.
 2230:                  $symb.'&'.
 2231: 		 $now.'&'.$ENV{'REMOTE_ADDR'});
 2232:     my $token=&reply('tmpput:'.$infostr,$lonhost);
 2233:     if ($token=~/^error\:/) { 
 2234:         &logthis("<font color=\"blue\">WARNING: ".
 2235:                 "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.
 2236:                  "</font>");
 2237:         return ''; 
 2238:     }
 2239: 
 2240:     $token=~s/^(\d+)\_.*\_(\d+)$/$1\*$2\*$lonhost/;
 2241:     $token=~tr/a-z/A-Z/;
 2242: 
 2243:     my %infohash=('resource.0.outtoken' => $token,
 2244:                   'resource.0.checkouttime' => $now,
 2245:                   'resource.0.outremote' => $ENV{'REMOTE_ADDR'});
 2246: 
 2247:     unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
 2248:        return '';
 2249:     } else {
 2250:         &logthis("<font color=\"blue\">WARNING: ".
 2251:                 "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.
 2252:                  "</font>");
 2253:     }    
 2254: 
 2255:     if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
 2256:                          &escape('Checkout '.$infostr.' - '.
 2257:                                                  $token)) ne 'ok') {
 2258: 	return '';
 2259:     } else {
 2260:         &logthis("<font color=\"blue\">WARNING: ".
 2261:                 "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.
 2262:                  "</font>");
 2263:     }
 2264:     return $token;
 2265: }
 2266: 
 2267: # ------------------------------------------------------------ Check in an item
 2268: 
 2269: sub checkin {
 2270:     my $token=shift;
 2271:     my $now=time;
 2272:     my ($ta,$tb,$lonhost)=split(/\*/,$token);
 2273:     $lonhost=~tr/A-Z/a-z/;
 2274:     my $dtoken=$ta.'_'.$hostname{$lonhost}.'_'.$tb;
 2275:     $dtoken=~s/\W/\_/g;
 2276:     my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
 2277:                  split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));
 2278: 
 2279:     unless (($tuname) && ($tudom)) {
 2280:         &logthis('Check in '.$token.' ('.$dtoken.') failed');
 2281:         return '';
 2282:     }
 2283:     
 2284:     unless (&allowed('mgr',$tcrsid)) {
 2285:         &logthis('Check in '.$token.' ('.$dtoken.') unauthorized: '.
 2286:                  $env{'user.name'}.' - '.$env{'user.domain'});
 2287:         return '';
 2288:     }
 2289: 
 2290:     my %infohash=('resource.0.intoken' => $token,
 2291:                   'resource.0.checkintime' => $now,
 2292:                   'resource.0.inremote' => $ENV{'REMOTE_ADDR'});
 2293: 
 2294:     unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
 2295:        return '';
 2296:     }    
 2297: 
 2298:     if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
 2299:                          &escape('Checkin - '.$token)) ne 'ok') {
 2300: 	return '';
 2301:     }
 2302: 
 2303:     return ($symb,$tuname,$tudom,$tcrsid);    
 2304: }
 2305: 
 2306: # --------------------------------------------- Set Expire Date for Spreadsheet
 2307: 
 2308: sub expirespread {
 2309:     my ($uname,$udom,$stype,$usymb)=@_;
 2310:     my $cid=$env{'request.course.id'}; 
 2311:     if ($cid) {
 2312:        my $now=time;
 2313:        my $key=$uname.':'.$udom.':'.$stype.':'.$usymb;
 2314:        return &reply('put:'.$env{'course.'.$cid.'.domain'}.':'.
 2315:                             $env{'course.'.$cid.'.num'}.
 2316: 	        	    ':nohist_expirationdates:'.
 2317:                             &escape($key).'='.$now,
 2318:                             $env{'course.'.$cid.'.home'})
 2319:     }
 2320:     return 'ok';
 2321: }
 2322: 
 2323: # ----------------------------------------------------- Devalidate Spreadsheets
 2324: 
 2325: sub devalidate {
 2326:     my ($symb,$uname,$udom)=@_;
 2327:     my $cid=$env{'request.course.id'}; 
 2328:     if ($cid) {
 2329:         # delete the stored spreadsheets for
 2330:         # - the student level sheet of this user in course's homespace
 2331:         # - the assessment level sheet for this resource 
 2332:         #   for this user in user's homespace
 2333: 	# - current conditional state info
 2334: 	my $key=$uname.':'.$udom.':';
 2335:         my $status=
 2336: 	    &del('nohist_calculatedsheets',
 2337: 		 [$key.'studentcalc:'],
 2338: 		 $env{'course.'.$cid.'.domain'},
 2339: 		 $env{'course.'.$cid.'.num'})
 2340: 		.' '.
 2341: 	    &del('nohist_calculatedsheets_'.$cid,
 2342: 		 [$key.'assesscalc:'.$symb],$udom,$uname);
 2343:         unless ($status eq 'ok ok') {
 2344:            &logthis('Could not devalidate spreadsheet '.
 2345:                     $uname.' at '.$udom.' for '.
 2346: 		    $symb.': '.$status);
 2347:         }
 2348: 	&delenv('user.state.'.$cid);
 2349:     }
 2350: }
 2351: 
 2352: sub get_scalar {
 2353:     my ($string,$end) = @_;
 2354:     my $value;
 2355:     if ($$string =~ s/^([^&]*?)($end)/$2/) {
 2356: 	$value = $1;
 2357:     } elsif ($$string =~ s/^([^&]*?)&//) {
 2358: 	$value = $1;
 2359:     }
 2360:     return &unescape($value);
 2361: }
 2362: 
 2363: sub array2str {
 2364:   my (@array) = @_;
 2365:   my $result=&arrayref2str(\@array);
 2366:   $result=~s/^__ARRAY_REF__//;
 2367:   $result=~s/__END_ARRAY_REF__$//;
 2368:   return $result;
 2369: }
 2370: 
 2371: sub arrayref2str {
 2372:   my ($arrayref) = @_;
 2373:   my $result='__ARRAY_REF__';
 2374:   foreach my $elem (@$arrayref) {
 2375:     if(ref($elem) eq 'ARRAY') {
 2376:       $result.=&arrayref2str($elem).'&';
 2377:     } elsif(ref($elem) eq 'HASH') {
 2378:       $result.=&hashref2str($elem).'&';
 2379:     } elsif(ref($elem)) {
 2380:       #print("Got a ref of ".(ref($elem))." skipping.");
 2381:     } else {
 2382:       $result.=&escape($elem).'&';
 2383:     }
 2384:   }
 2385:   $result=~s/\&$//;
 2386:   $result .= '__END_ARRAY_REF__';
 2387:   return $result;
 2388: }
 2389: 
 2390: sub hash2str {
 2391:   my (%hash) = @_;
 2392:   my $result=&hashref2str(\%hash);
 2393:   $result=~s/^__HASH_REF__//;
 2394:   $result=~s/__END_HASH_REF__$//;
 2395:   return $result;
 2396: }
 2397: 
 2398: sub hashref2str {
 2399:   my ($hashref)=@_;
 2400:   my $result='__HASH_REF__';
 2401:   foreach my $key (sort(keys(%$hashref))) {
 2402:     if (ref($key) eq 'ARRAY') {
 2403:       $result.=&arrayref2str($key).'=';
 2404:     } elsif (ref($key) eq 'HASH') {
 2405:       $result.=&hashref2str($key).'=';
 2406:     } elsif (ref($key)) {
 2407:       $result.='=';
 2408:       #print("Got a ref of ".(ref($key))." skipping.");
 2409:     } else {
 2410: 	if ($key) {$result.=&escape($key).'=';} else { last; }
 2411:     }
 2412: 
 2413:     if(ref($hashref->{$key}) eq 'ARRAY') {
 2414:       $result.=&arrayref2str($hashref->{$key}).'&';
 2415:     } elsif(ref($hashref->{$key}) eq 'HASH') {
 2416:       $result.=&hashref2str($hashref->{$key}).'&';
 2417:     } elsif(ref($hashref->{$key})) {
 2418:        $result.='&';
 2419:       #print("Got a ref of ".(ref($hashref->{$key}))." skipping.");
 2420:     } else {
 2421:       $result.=&escape($hashref->{$key}).'&';
 2422:     }
 2423:   }
 2424:   $result=~s/\&$//;
 2425:   $result .= '__END_HASH_REF__';
 2426:   return $result;
 2427: }
 2428: 
 2429: sub str2hash {
 2430:     my ($string)=@_;
 2431:     my ($hash)=&str2hashref('__HASH_REF__'.$string.'__END_HASH_REF__');
 2432:     return %$hash;
 2433: }
 2434: 
 2435: sub str2hashref {
 2436:   my ($string) = @_;
 2437: 
 2438:   my %hash;
 2439: 
 2440:   if($string !~ /^__HASH_REF__/) {
 2441:       if (! ($string eq '' || !defined($string))) {
 2442: 	  $hash{'error'}='Not hash reference';
 2443:       }
 2444:       return (\%hash, $string);
 2445:   }
 2446: 
 2447:   $string =~ s/^__HASH_REF__//;
 2448: 
 2449:   while($string !~ /^__END_HASH_REF__/) {
 2450:       #key
 2451:       my $key='';
 2452:       if($string =~ /^__HASH_REF__/) {
 2453:           ($key, $string)=&str2hashref($string);
 2454:           if(defined($key->{'error'})) {
 2455:               $hash{'error'}='Bad data';
 2456:               return (\%hash, $string);
 2457:           }
 2458:       } elsif($string =~ /^__ARRAY_REF__/) {
 2459:           ($key, $string)=&str2arrayref($string);
 2460:           if($key->[0] eq 'Array reference error') {
 2461:               $hash{'error'}='Bad data';
 2462:               return (\%hash, $string);
 2463:           }
 2464:       } else {
 2465:           $string =~ s/^(.*?)=//;
 2466: 	  $key=&unescape($1);
 2467:       }
 2468:       $string =~ s/^=//;
 2469: 
 2470:       #value
 2471:       my $value='';
 2472:       if($string =~ /^__HASH_REF__/) {
 2473:           ($value, $string)=&str2hashref($string);
 2474:           if(defined($value->{'error'})) {
 2475:               $hash{'error'}='Bad data';
 2476:               return (\%hash, $string);
 2477:           }
 2478:       } elsif($string =~ /^__ARRAY_REF__/) {
 2479:           ($value, $string)=&str2arrayref($string);
 2480:           if($value->[0] eq 'Array reference error') {
 2481:               $hash{'error'}='Bad data';
 2482:               return (\%hash, $string);
 2483:           }
 2484:       } else {
 2485: 	  $value=&get_scalar(\$string,'__END_HASH_REF__');
 2486:       }
 2487:       $string =~ s/^&//;
 2488: 
 2489:       $hash{$key}=$value;
 2490:   }
 2491: 
 2492:   $string =~ s/^__END_HASH_REF__//;
 2493: 
 2494:   return (\%hash, $string);
 2495: }
 2496: 
 2497: sub str2array {
 2498:     my ($string)=@_;
 2499:     my ($array)=&str2arrayref('__ARRAY_REF__'.$string.'__END_ARRAY_REF__');
 2500:     return @$array;
 2501: }
 2502: 
 2503: sub str2arrayref {
 2504:   my ($string) = @_;
 2505:   my @array;
 2506: 
 2507:   if($string !~ /^__ARRAY_REF__/) {
 2508:       if (! ($string eq '' || !defined($string))) {
 2509: 	  $array[0]='Array reference error';
 2510:       }
 2511:       return (\@array, $string);
 2512:   }
 2513: 
 2514:   $string =~ s/^__ARRAY_REF__//;
 2515: 
 2516:   while($string !~ /^__END_ARRAY_REF__/) {
 2517:       my $value='';
 2518:       if($string =~ /^__HASH_REF__/) {
 2519:           ($value, $string)=&str2hashref($string);
 2520:           if(defined($value->{'error'})) {
 2521:               $array[0] ='Array reference error';
 2522:               return (\@array, $string);
 2523:           }
 2524:       } elsif($string =~ /^__ARRAY_REF__/) {
 2525:           ($value, $string)=&str2arrayref($string);
 2526:           if($value->[0] eq 'Array reference error') {
 2527:               $array[0] ='Array reference error';
 2528:               return (\@array, $string);
 2529:           }
 2530:       } else {
 2531: 	  $value=&get_scalar(\$string,'__END_ARRAY_REF__');
 2532:       }
 2533:       $string =~ s/^&//;
 2534: 
 2535:       push(@array, $value);
 2536:   }
 2537: 
 2538:   $string =~ s/^__END_ARRAY_REF__//;
 2539: 
 2540:   return (\@array, $string);
 2541: }
 2542: 
 2543: # -------------------------------------------------------------------Temp Store
 2544: 
 2545: sub tmpreset {
 2546:   my ($symb,$namespace,$domain,$stuname) = @_;
 2547:   if (!$symb) {
 2548:     $symb=&symbread();
 2549:     if (!$symb) { $symb= $env{'request.url'}; }
 2550:   }
 2551:   $symb=escape($symb);
 2552: 
 2553:   if (!$namespace) { $namespace=$env{'request.state'}; }
 2554:   $namespace=~s/\//\_/g;
 2555:   $namespace=~s/\W//g;
 2556: 
 2557:   if (!$domain) { $domain=$env{'user.domain'}; }
 2558:   if (!$stuname) { $stuname=$env{'user.name'}; }
 2559:   if ($domain eq 'public' && $stuname eq 'public') {
 2560:       $stuname=$ENV{'REMOTE_ADDR'};
 2561:   }
 2562:   my $path=$perlvar{'lonDaemons'}.'/tmp';
 2563:   my %hash;
 2564:   if (tie(%hash,'GDBM_File',
 2565: 	  $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
 2566: 	  &GDBM_WRCREAT(),0640)) {
 2567:     foreach my $key (keys %hash) {
 2568:       if ($key=~ /:$symb/) {
 2569: 	delete($hash{$key});
 2570:       }
 2571:     }
 2572:   }
 2573: }
 2574: 
 2575: sub tmpstore {
 2576:   my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
 2577: 
 2578:   if (!$symb) {
 2579:     $symb=&symbread();
 2580:     if (!$symb) { $symb= $env{'request.url'}; }
 2581:   }
 2582:   $symb=escape($symb);
 2583: 
 2584:   if (!$namespace) {
 2585:     # I don't think we would ever want to store this for a course.
 2586:     # it seems this will only be used if we don't have a course.
 2587:     #$namespace=$env{'request.course.id'};
 2588:     #if (!$namespace) {
 2589:       $namespace=$env{'request.state'};
 2590:     #}
 2591:   }
 2592:   $namespace=~s/\//\_/g;
 2593:   $namespace=~s/\W//g;
 2594:   if (!$domain) { $domain=$env{'user.domain'}; }
 2595:   if (!$stuname) { $stuname=$env{'user.name'}; }
 2596:   if ($domain eq 'public' && $stuname eq 'public') {
 2597:       $stuname=$ENV{'REMOTE_ADDR'};
 2598:   }
 2599:   my $now=time;
 2600:   my %hash;
 2601:   my $path=$perlvar{'lonDaemons'}.'/tmp';
 2602:   if (tie(%hash,'GDBM_File',
 2603: 	  $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
 2604: 	  &GDBM_WRCREAT(),0640)) {
 2605:     $hash{"version:$symb"}++;
 2606:     my $version=$hash{"version:$symb"};
 2607:     my $allkeys=''; 
 2608:     foreach my $key (keys(%$storehash)) {
 2609:       $allkeys.=$key.':';
 2610:       $hash{"$version:$symb:$key"}=&freeze_escape($$storehash{$key});
 2611:     }
 2612:     $hash{"$version:$symb:timestamp"}=$now;
 2613:     $allkeys.='timestamp';
 2614:     $hash{"$version:keys:$symb"}=$allkeys;
 2615:     if (untie(%hash)) {
 2616:       return 'ok';
 2617:     } else {
 2618:       return "error:$!";
 2619:     }
 2620:   } else {
 2621:     return "error:$!";
 2622:   }
 2623: }
 2624: 
 2625: # -----------------------------------------------------------------Temp Restore
 2626: 
 2627: sub tmprestore {
 2628:   my ($symb,$namespace,$domain,$stuname) = @_;
 2629: 
 2630:   if (!$symb) {
 2631:     $symb=&symbread();
 2632:     if (!$symb) { $symb= $env{'request.url'}; }
 2633:   }
 2634:   $symb=escape($symb);
 2635: 
 2636:   if (!$namespace) { $namespace=$env{'request.state'}; }
 2637: 
 2638:   if (!$domain) { $domain=$env{'user.domain'}; }
 2639:   if (!$stuname) { $stuname=$env{'user.name'}; }
 2640:   if ($domain eq 'public' && $stuname eq 'public') {
 2641:       $stuname=$ENV{'REMOTE_ADDR'};
 2642:   }
 2643:   my %returnhash;
 2644:   $namespace=~s/\//\_/g;
 2645:   $namespace=~s/\W//g;
 2646:   my %hash;
 2647:   my $path=$perlvar{'lonDaemons'}.'/tmp';
 2648:   if (tie(%hash,'GDBM_File',
 2649: 	  $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
 2650: 	  &GDBM_READER(),0640)) {
 2651:     my $version=$hash{"version:$symb"};
 2652:     $returnhash{'version'}=$version;
 2653:     my $scope;
 2654:     for ($scope=1;$scope<=$version;$scope++) {
 2655:       my $vkeys=$hash{"$scope:keys:$symb"};
 2656:       my @keys=split(/:/,$vkeys);
 2657:       my $key;
 2658:       $returnhash{"$scope:keys"}=$vkeys;
 2659:       foreach $key (@keys) {
 2660: 	$returnhash{"$scope:$key"}=&thaw_unescape($hash{"$scope:$symb:$key"});
 2661: 	$returnhash{"$key"}=&thaw_unescape($hash{"$scope:$symb:$key"});
 2662:       }
 2663:     }
 2664:     if (!(untie(%hash))) {
 2665:       return "error:$!";
 2666:     }
 2667:   } else {
 2668:     return "error:$!";
 2669:   }
 2670:   return %returnhash;
 2671: }
 2672: 
 2673: # ----------------------------------------------------------------------- Store
 2674: 
 2675: sub store {
 2676:     my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
 2677:     my $home='';
 2678: 
 2679:     if ($stuname) { $home=&homeserver($stuname,$domain); }
 2680: 
 2681:     $symb=&symbclean($symb);
 2682:     if (!$symb) { unless ($symb=&symbread()) { return ''; } }
 2683: 
 2684:     if (!$domain) { $domain=$env{'user.domain'}; }
 2685:     if (!$stuname) { $stuname=$env{'user.name'}; }
 2686: 
 2687:     &devalidate($symb,$stuname,$domain);
 2688: 
 2689:     $symb=escape($symb);
 2690:     if (!$namespace) { 
 2691:        unless ($namespace=$env{'request.course.id'}) { 
 2692:           return ''; 
 2693:        } 
 2694:     }
 2695:     if (!$home) { $home=$env{'user.home'}; }
 2696: 
 2697:     $$storehash{'ip'}=$ENV{'REMOTE_ADDR'};
 2698:     $$storehash{'host'}=$perlvar{'lonHostID'};
 2699: 
 2700:     my $namevalue='';
 2701:     foreach my $key (keys(%$storehash)) {
 2702:         $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
 2703:     }
 2704:     $namevalue=~s/\&$//;
 2705:     &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue);
 2706:     return reply("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");
 2707: }
 2708: 
 2709: # -------------------------------------------------------------- Critical Store
 2710: 
 2711: sub cstore {
 2712:     my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
 2713:     my $home='';
 2714: 
 2715:     if ($stuname) { $home=&homeserver($stuname,$domain); }
 2716: 
 2717:     $symb=&symbclean($symb);
 2718:     if (!$symb) { unless ($symb=&symbread()) { return ''; } }
 2719: 
 2720:     if (!$domain) { $domain=$env{'user.domain'}; }
 2721:     if (!$stuname) { $stuname=$env{'user.name'}; }
 2722: 
 2723:     &devalidate($symb,$stuname,$domain);
 2724: 
 2725:     $symb=escape($symb);
 2726:     if (!$namespace) { 
 2727:        unless ($namespace=$env{'request.course.id'}) { 
 2728:           return ''; 
 2729:        } 
 2730:     }
 2731:     if (!$home) { $home=$env{'user.home'}; }
 2732: 
 2733:     $$storehash{'ip'}=$ENV{'REMOTE_ADDR'};
 2734:     $$storehash{'host'}=$perlvar{'lonHostID'};
 2735: 
 2736:     my $namevalue='';
 2737:     foreach my $key (keys(%$storehash)) {
 2738:         $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
 2739:     }
 2740:     $namevalue=~s/\&$//;
 2741:     &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue);
 2742:     return critical
 2743:                 ("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");
 2744: }
 2745: 
 2746: # --------------------------------------------------------------------- Restore
 2747: 
 2748: sub restore {
 2749:     my ($symb,$namespace,$domain,$stuname) = @_;
 2750:     my $home='';
 2751: 
 2752:     if ($stuname) { $home=&homeserver($stuname,$domain); }
 2753: 
 2754:     if (!$symb) {
 2755:       unless ($symb=escape(&symbread())) { return ''; }
 2756:     } else {
 2757:       $symb=&escape(&symbclean($symb));
 2758:     }
 2759:     if (!$namespace) { 
 2760:        unless ($namespace=$env{'request.course.id'}) { 
 2761:           return ''; 
 2762:        } 
 2763:     }
 2764:     if (!$domain) { $domain=$env{'user.domain'}; }
 2765:     if (!$stuname) { $stuname=$env{'user.name'}; }
 2766:     if (!$home) { $home=$env{'user.home'}; }
 2767:     my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home");
 2768: 
 2769:     my %returnhash=();
 2770:     foreach my $line (split(/\&/,$answer)) {
 2771: 	my ($name,$value)=split(/\=/,$line);
 2772:         $returnhash{&unescape($name)}=&thaw_unescape($value);
 2773:     }
 2774:     my $version;
 2775:     for ($version=1;$version<=$returnhash{'version'};$version++) {
 2776:        foreach my $item (split(/\:/,$returnhash{$version.':keys'})) {
 2777:           $returnhash{$item}=$returnhash{$version.':'.$item};
 2778:        }
 2779:     }
 2780:     return %returnhash;
 2781: }
 2782: 
 2783: # ---------------------------------------------------------- Course Description
 2784: 
 2785: sub coursedescription {
 2786:     my ($courseid,$args)=@_;
 2787:     $courseid=~s/^\///;
 2788:     $courseid=~s/\_/\//g;
 2789:     my ($cdomain,$cnum)=split(/\//,$courseid);
 2790:     my $chome=&homeserver($cnum,$cdomain);
 2791:     my $normalid=$cdomain.'_'.$cnum;
 2792:     # need to always cache even if we get errors otherwise we keep 
 2793:     # trying and trying and trying to get the course description.
 2794:     my %envhash=();
 2795:     my %returnhash=();
 2796:     
 2797:     my $expiretime=600;
 2798:     if ($env{'request.course.id'} eq $normalid) {
 2799: 	$expiretime=120;
 2800:     }
 2801: 
 2802:     my $prefix='course.'.$cdomain.'_'.$cnum.'.';
 2803:     if (!$args->{'freshen_cache'}
 2804: 	&& ((time-$env{$prefix.'last_cache'}) < $expiretime) ) {
 2805: 	foreach my $key (keys(%env)) {
 2806: 	    next if ($key !~ /^\Q$prefix\E(.*)/);
 2807: 	    my ($setting) = $1;
 2808: 	    $returnhash{$setting} = $env{$key};
 2809: 	}
 2810: 	return %returnhash;
 2811:     }
 2812: 
 2813:     # get the data agin
 2814:     if (!$args->{'one_time'}) {
 2815: 	$envhash{'course.'.$normalid.'.last_cache'}=time;
 2816:     }
 2817: 
 2818:     if ($chome ne 'no_host') {
 2819:        %returnhash=&dump('environment',$cdomain,$cnum);
 2820:        if (!exists($returnhash{'con_lost'})) {
 2821:            $returnhash{'home'}= $chome;
 2822: 	   $returnhash{'domain'} = $cdomain;
 2823: 	   $returnhash{'num'} = $cnum;
 2824:            if (!defined($returnhash{'type'})) {
 2825:                $returnhash{'type'} = 'Course';
 2826:            }
 2827:            while (my ($name,$value) = each %returnhash) {
 2828:                $envhash{'course.'.$normalid.'.'.$name}=$value;
 2829:            }
 2830:            $returnhash{'url'}=&clutter($returnhash{'url'});
 2831:            $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'.
 2832: 	       $env{'user.name'}.'_'.$cdomain.'_'.$cnum;
 2833:            $envhash{'course.'.$normalid.'.home'}=$chome;
 2834:            $envhash{'course.'.$normalid.'.domain'}=$cdomain;
 2835:            $envhash{'course.'.$normalid.'.num'}=$cnum;
 2836:        }
 2837:     }
 2838:     if (!$args->{'one_time'}) {
 2839: 	&appenv(%envhash);
 2840:     }
 2841:     return %returnhash;
 2842: }
 2843: 
 2844: # -------------------------------------------------See if a user is privileged
 2845: 
 2846: sub privileged {
 2847:     my ($username,$domain)=@_;
 2848:     my $rolesdump=&reply("dump:$domain:$username:roles",
 2849: 			&homeserver($username,$domain));
 2850:     if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return 0; }
 2851:     my $now=time;
 2852:     if ($rolesdump ne '') {
 2853:         foreach my $entry (split(/&/,$rolesdump)) {
 2854: 	    if ($entry!~/^rolesdef_/) {
 2855: 		my ($area,$role)=split(/=/,$entry);
 2856: 		$area=~s/\_\w\w$//;
 2857: 		my ($trole,$tend,$tstart)=split(/_/,$role);
 2858: 		if (($trole eq 'dc') || ($trole eq 'su')) {
 2859: 		    my $active=1;
 2860: 		    if ($tend) {
 2861: 			if ($tend<$now) { $active=0; }
 2862: 		    }
 2863: 		    if ($tstart) {
 2864: 			if ($tstart>$now) { $active=0; }
 2865: 		    }
 2866: 		    if ($active) { return 1; }
 2867: 		}
 2868: 	    }
 2869: 	}
 2870:     }
 2871:     return 0;
 2872: }
 2873: 
 2874: # -------------------------------------------------------- Get user privileges
 2875: 
 2876: sub rolesinit {
 2877:     my ($domain,$username,$authhost)=@_;
 2878:     my $rolesdump=reply("dump:$domain:$username:roles",$authhost);
 2879:     if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; }
 2880:     my %allroles=();
 2881:     my %allgroups=();   
 2882:     my $now=time;
 2883:     my %userroles = ('user.login.time' => $now);
 2884:     my $group_privs;
 2885: 
 2886:     if ($rolesdump ne '') {
 2887:         foreach my $entry (split(/&/,$rolesdump)) {
 2888: 	  if ($entry!~/^rolesdef_/) {
 2889:             my ($area,$role)=split(/=/,$entry);
 2890: 	    $area=~s/\_\w\w$//;
 2891:             my ($trole,$tend,$tstart,$group_privs);
 2892: 	    if ($role=~/^cr/) { 
 2893: 		if ($role=~m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|) {
 2894: 		    ($trole,my $trest)=($role=~m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|);
 2895: 		    ($tend,$tstart)=split('_',$trest);
 2896: 		} else {
 2897: 		    $trole=$role;
 2898: 		}
 2899:             } elsif ($role =~ m|^gr/|) {
 2900:                 ($trole,$tend,$tstart) = split(/_/,$role);
 2901:                 ($trole,$group_privs) = split(/\//,$trole);
 2902:                 $group_privs = &unescape($group_privs);
 2903: 	    } else {
 2904: 		($trole,$tend,$tstart)=split(/_/,$role);
 2905: 	    }
 2906: 	    my %new_role = &set_arearole($trole,$area,$tstart,$tend,$domain,
 2907: 					 $username);
 2908: 	    @userroles{keys(%new_role)} = @new_role{keys(%new_role)};
 2909:             if (($tend!=0) && ($tend<$now)) { $trole=''; }
 2910:             if (($tstart!=0) && ($tstart>$now)) { $trole=''; }
 2911:             if (($area ne '') && ($trole ne '')) {
 2912: 		my $spec=$trole.'.'.$area;
 2913: 		my ($tdummy,$tdomain,$trest)=split(/\//,$area);
 2914: 		if ($trole =~ /^cr\//) {
 2915:                     &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);
 2916:                 } elsif ($trole eq 'gr') {
 2917:                     &group_roleprivs(\%allgroups,$area,$group_privs,$tend,$tstart);
 2918: 		} else {
 2919:                     &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
 2920: 		}
 2921:             }
 2922:           }
 2923:         }
 2924:         my ($author,$adv) = &set_userprivs(\%userroles,\%allroles,\%allgroups);
 2925:         $userroles{'user.adv'}    = $adv;
 2926: 	$userroles{'user.author'} = $author;
 2927:         $env{'user.adv'}=$adv;
 2928:     }
 2929:     return \%userroles;  
 2930: }
 2931: 
 2932: sub set_arearole {
 2933:     my ($trole,$area,$tstart,$tend,$domain,$username) = @_;
 2934: # log the associated role with the area
 2935:     &userrolelog($trole,$username,$domain,$area,$tstart,$tend);
 2936:     return ('user.role.'.$trole.'.'.$area => $tstart.'.'.$tend);
 2937: }
 2938: 
 2939: sub custom_roleprivs {
 2940:     my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_;
 2941:     my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
 2942:     my $homsvr=homeserver($rauthor,$rdomain);
 2943:     if ($hostname{$homsvr} ne '') {
 2944:         my ($rdummy,$roledef)=
 2945:             &get('roles',["rolesdef_$rrole"],$rdomain,$rauthor);
 2946:         if (($rdummy ne 'con_lost') && ($roledef ne '')) {
 2947:             my ($syspriv,$dompriv,$coursepriv)=split(/\_/,$roledef);
 2948:             if (defined($syspriv)) {
 2949:                 $$allroles{'cm./'}.=':'.$syspriv;
 2950:                 $$allroles{$spec.'./'}.=':'.$syspriv;
 2951:             }
 2952:             if ($tdomain ne '') {
 2953:                 if (defined($dompriv)) {
 2954:                     $$allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv;
 2955:                     $$allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv;
 2956:                 }
 2957:                 if (($trest ne '') && (defined($coursepriv))) {
 2958:                     $$allroles{'cm.'.$area}.=':'.$coursepriv;
 2959:                     $$allroles{$spec.'.'.$area}.=':'.$coursepriv;
 2960:                 }
 2961:             }
 2962:         }
 2963:     }
 2964: }
 2965: 
 2966: sub group_roleprivs {
 2967:     my ($allgroups,$area,$group_privs,$tend,$tstart) = @_;
 2968:     my $access = 1;
 2969:     my $now = time;
 2970:     if (($tend!=0) && ($tend<$now)) { $access = 0; }
 2971:     if (($tstart!=0) && ($tstart>$now)) { $access=0; }
 2972:     if ($access) {
 2973:         my ($course,$group) = ($area =~ m|(/$match_domain/$match_courseid)/([^/]+)$|);
 2974:         $$allgroups{$course}{$group} .=':'.$group_privs;
 2975:     }
 2976: }
 2977: 
 2978: sub standard_roleprivs {
 2979:     my ($allroles,$trole,$tdomain,$spec,$trest,$area) = @_;
 2980:     if (defined($pr{$trole.':s'})) {
 2981:         $$allroles{'cm./'}.=':'.$pr{$trole.':s'};
 2982:         $$allroles{$spec.'./'}.=':'.$pr{$trole.':s'};
 2983:     }
 2984:     if ($tdomain ne '') {
 2985:         if (defined($pr{$trole.':d'})) {
 2986:             $$allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
 2987:             $$allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
 2988:         }
 2989:         if (($trest ne '') && (defined($pr{$trole.':c'}))) {
 2990:             $$allroles{'cm.'.$area}.=':'.$pr{$trole.':c'};
 2991:             $$allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'};
 2992:         }
 2993:     }
 2994: }
 2995: 
 2996: sub set_userprivs {
 2997:     my ($userroles,$allroles,$allgroups) = @_; 
 2998:     my $author=0;
 2999:     my $adv=0;
 3000:     my %grouproles = ();
 3001:     if (keys(%{$allgroups}) > 0) {
 3002:         foreach my $role (keys %{$allroles}) {
 3003:             my ($trole,$area,$sec,$extendedarea);
 3004:             if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)-) {
 3005:                 $trole = $1;
 3006:                 $area = $2;
 3007:                 $sec = $3;
 3008:                 $extendedarea = $area.$sec;
 3009:                 if (exists($$allgroups{$area})) {
 3010:                     foreach my $group (keys(%{$$allgroups{$area}})) {
 3011:                         my $spec = $trole.'.'.$extendedarea;
 3012:                         $grouproles{$spec.'.'.$area.'/'.$group} = 
 3013:                                                 $$allgroups{$area}{$group};
 3014:                     }
 3015:                 }
 3016:             }
 3017:         }
 3018:     }
 3019:     foreach my $group (keys(%grouproles)) {
 3020:         $$allroles{$group} = $grouproles{$group};
 3021:     }
 3022:     foreach my $role (keys(%{$allroles})) {
 3023:         my %thesepriv;
 3024:         if (($role=~/^au/) || ($role=~/^ca/)) { $author=1; }
 3025:         foreach my $item (split(/:/,$$allroles{$role})) {
 3026:             if ($item ne '') {
 3027:                 my ($privilege,$restrictions)=split(/&/,$item);
 3028:                 if ($restrictions eq '') {
 3029:                     $thesepriv{$privilege}='F';
 3030:                 } elsif ($thesepriv{$privilege} ne 'F') {
 3031:                     $thesepriv{$privilege}.=$restrictions;
 3032:                 }
 3033:                 if ($thesepriv{'adv'} eq 'F') { $adv=1; }
 3034:             }
 3035:         }
 3036:         my $thesestr='';
 3037:         foreach my $priv (keys(%thesepriv)) {
 3038: 	    $thesestr.=':'.$priv.'&'.$thesepriv{$priv};
 3039: 	}
 3040:         $userroles->{'user.priv.'.$role} = $thesestr;
 3041:     }
 3042:     return ($author,$adv);
 3043: }
 3044: 
 3045: # --------------------------------------------------------------- get interface
 3046: 
 3047: sub get {
 3048:    my ($namespace,$storearr,$udomain,$uname)=@_;
 3049:    my $items='';
 3050:    foreach my $item (@$storearr) {
 3051:        $items.=&escape($item).'&';
 3052:    }
 3053:    $items=~s/\&$//;
 3054:    if (!$udomain) { $udomain=$env{'user.domain'}; }
 3055:    if (!$uname) { $uname=$env{'user.name'}; }
 3056:    my $uhome=&homeserver($uname,$udomain);
 3057: 
 3058:    my $rep=&reply("get:$udomain:$uname:$namespace:$items",$uhome);
 3059:    my @pairs=split(/\&/,$rep);
 3060:    if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) {
 3061:      return @pairs;
 3062:    }
 3063:    my %returnhash=();
 3064:    my $i=0;
 3065:    foreach my $item (@$storearr) {
 3066:       $returnhash{$item}=&thaw_unescape($pairs[$i]);
 3067:       $i++;
 3068:    }
 3069:    return %returnhash;
 3070: }
 3071: 
 3072: # --------------------------------------------------------------- del interface
 3073: 
 3074: sub del {
 3075:    my ($namespace,$storearr,$udomain,$uname)=@_;
 3076:    my $items='';
 3077:    foreach my $item (@$storearr) {
 3078:        $items.=&escape($item).'&';
 3079:    }
 3080:    $items=~s/\&$//;
 3081:    if (!$udomain) { $udomain=$env{'user.domain'}; }
 3082:    if (!$uname) { $uname=$env{'user.name'}; }
 3083:    my $uhome=&homeserver($uname,$udomain);
 3084: 
 3085:    return &reply("del:$udomain:$uname:$namespace:$items",$uhome);
 3086: }
 3087: 
 3088: # -------------------------------------------------------------- dump interface
 3089: 
 3090: sub dump {
 3091:     my ($namespace,$udomain,$uname,$regexp,$range)=@_;
 3092:     if (!$udomain) { $udomain=$env{'user.domain'}; }
 3093:     if (!$uname) { $uname=$env{'user.name'}; }
 3094:     my $uhome=&homeserver($uname,$udomain);
 3095:     if ($regexp) {
 3096: 	$regexp=&escape($regexp);
 3097:     } else {
 3098: 	$regexp='.';
 3099:     }
 3100:     my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
 3101:     my @pairs=split(/\&/,$rep);
 3102:     my %returnhash=();
 3103:     foreach my $item (@pairs) {
 3104: 	my ($key,$value)=split(/=/,$item,2);
 3105: 	$key = &unescape($key);
 3106: 	next if ($key =~ /^error: 2 /);
 3107: 	$returnhash{$key}=&thaw_unescape($value);
 3108:     }
 3109:     return %returnhash;
 3110: }
 3111: 
 3112: # --------------------------------------------------------- dumpstore interface
 3113: 
 3114: sub dumpstore {
 3115:    my ($namespace,$udomain,$uname,$regexp,$range)=@_;
 3116:    if (!$udomain) { $udomain=$env{'user.domain'}; }
 3117:    if (!$uname) { $uname=$env{'user.name'}; }
 3118:    my $uhome=&homeserver($uname,$udomain);
 3119:    if ($regexp) {
 3120:        $regexp=&escape($regexp);
 3121:    } else {
 3122:        $regexp='.';
 3123:    }
 3124:    my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
 3125:    my @pairs=split(/\&/,$rep);
 3126:    my %returnhash=();
 3127:    foreach my $item (@pairs) {
 3128:        my ($key,$value)=split(/=/,$item,2);
 3129:        next if ($key =~ /^error: 2 /);
 3130:        $returnhash{$key}=&thaw_unescape($value);
 3131:    }
 3132:    return %returnhash;
 3133: }
 3134: 
 3135: # -------------------------------------------------------------- keys interface
 3136: 
 3137: sub getkeys {
 3138:    my ($namespace,$udomain,$uname)=@_;
 3139:    if (!$udomain) { $udomain=$env{'user.domain'}; }
 3140:    if (!$uname) { $uname=$env{'user.name'}; }
 3141:    my $uhome=&homeserver($uname,$udomain);
 3142:    my $rep=reply("keys:$udomain:$uname:$namespace",$uhome);
 3143:    my @keyarray=();
 3144:    foreach my $key (split(/\&/,$rep)) {
 3145:       next if ($key =~ /^error: 2 /);
 3146:       push(@keyarray,&unescape($key));
 3147:    }
 3148:    return @keyarray;
 3149: }
 3150: 
 3151: # --------------------------------------------------------------- currentdump
 3152: sub currentdump {
 3153:    my ($courseid,$sdom,$sname)=@_;
 3154:    $courseid = $env{'request.course.id'} if (! defined($courseid));
 3155:    $sdom     = $env{'user.domain'}       if (! defined($sdom));
 3156:    $sname    = $env{'user.name'}         if (! defined($sname));
 3157:    my $uhome = &homeserver($sname,$sdom);
 3158:    my $rep=reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome);
 3159:    return if ($rep =~ /^(error:|no_such_host)/);
 3160:    #
 3161:    my %returnhash=();
 3162:    #
 3163:    if ($rep eq "unknown_cmd") { 
 3164:        # an old lond will not know currentdump
 3165:        # Do a dump and make it look like a currentdump
 3166:        my @tmp = &dumpstore($courseid,$sdom,$sname,'.');
 3167:        return if ($tmp[0] =~ /^(error:|no_such_host)/);
 3168:        my %hash = @tmp;
 3169:        @tmp=();
 3170:        %returnhash = %{&convert_dump_to_currentdump(\%hash)};
 3171:    } else {
 3172:        my @pairs=split(/\&/,$rep);
 3173:        foreach my $pair (@pairs) {
 3174:            my ($key,$value)=split(/=/,$pair,2);
 3175:            my ($symb,$param) = split(/:/,$key);
 3176:            $returnhash{&unescape($symb)}->{&unescape($param)} = 
 3177:                                                         &thaw_unescape($value);
 3178:        }
 3179:    }
 3180:    return %returnhash;
 3181: }
 3182: 
 3183: sub convert_dump_to_currentdump{
 3184:     my %hash = %{shift()};
 3185:     my %returnhash;
 3186:     # Code ripped from lond, essentially.  The only difference
 3187:     # here is the unescaping done by lonnet::dump().  Conceivably
 3188:     # we might run in to problems with parameter names =~ /^v\./
 3189:     while (my ($key,$value) = each(%hash)) {
 3190:         my ($v,$symb,$param) = split(/:/,$key);
 3191: 	$symb  = &unescape($symb);
 3192: 	$param = &unescape($param);
 3193:         next if ($v eq 'version' || $symb eq 'keys');
 3194:         next if (exists($returnhash{$symb}) &&
 3195:                  exists($returnhash{$symb}->{$param}) &&
 3196:                  $returnhash{$symb}->{'v.'.$param} > $v);
 3197:         $returnhash{$symb}->{$param}=$value;
 3198:         $returnhash{$symb}->{'v.'.$param}=$v;
 3199:     }
 3200:     #
 3201:     # Remove all of the keys in the hashes which keep track of
 3202:     # the version of the parameter.
 3203:     while (my ($symb,$param_hash) = each(%returnhash)) {
 3204:         # use a foreach because we are going to delete from the hash.
 3205:         foreach my $key (keys(%$param_hash)) {
 3206:             delete($param_hash->{$key}) if ($key =~ /^v\./);
 3207:         }
 3208:     }
 3209:     return \%returnhash;
 3210: }
 3211: 
 3212: # ------------------------------------------------------ critical inc interface
 3213: 
 3214: sub cinc {
 3215:     return &inc(@_,'critical');
 3216: }
 3217: 
 3218: # --------------------------------------------------------------- inc interface
 3219: 
 3220: sub inc {
 3221:     my ($namespace,$store,$udomain,$uname,$critical) = @_;
 3222:     if (!$udomain) { $udomain=$env{'user.domain'}; }
 3223:     if (!$uname) { $uname=$env{'user.name'}; }
 3224:     my $uhome=&homeserver($uname,$udomain);
 3225:     my $items='';
 3226:     if (! ref($store)) {
 3227:         # got a single value, so use that instead
 3228:         $items = &escape($store).'=&';
 3229:     } elsif (ref($store) eq 'SCALAR') {
 3230:         $items = &escape($$store).'=&';        
 3231:     } elsif (ref($store) eq 'ARRAY') {
 3232:         $items = join('=&',map {&escape($_);} @{$store});
 3233:     } elsif (ref($store) eq 'HASH') {
 3234:         while (my($key,$value) = each(%{$store})) {
 3235:             $items.= &escape($key).'='.&escape($value).'&';
 3236:         }
 3237:     }
 3238:     $items=~s/\&$//;
 3239:     if ($critical) {
 3240: 	return &critical("inc:$udomain:$uname:$namespace:$items",$uhome);
 3241:     } else {
 3242: 	return &reply("inc:$udomain:$uname:$namespace:$items",$uhome);
 3243:     }
 3244: }
 3245: 
 3246: # --------------------------------------------------------------- put interface
 3247: 
 3248: sub put {
 3249:    my ($namespace,$storehash,$udomain,$uname)=@_;
 3250:    if (!$udomain) { $udomain=$env{'user.domain'}; }
 3251:    if (!$uname) { $uname=$env{'user.name'}; }
 3252:    my $uhome=&homeserver($uname,$udomain);
 3253:    my $items='';
 3254:    foreach my $item (keys(%$storehash)) {
 3255:        $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
 3256:    }
 3257:    $items=~s/\&$//;
 3258:    return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
 3259: }
 3260: 
 3261: # ------------------------------------------------------------ newput interface
 3262: 
 3263: sub newput {
 3264:    my ($namespace,$storehash,$udomain,$uname)=@_;
 3265:    if (!$udomain) { $udomain=$env{'user.domain'}; }
 3266:    if (!$uname) { $uname=$env{'user.name'}; }
 3267:    my $uhome=&homeserver($uname,$udomain);
 3268:    my $items='';
 3269:    foreach my $key (keys(%$storehash)) {
 3270:        $items.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
 3271:    }
 3272:    $items=~s/\&$//;
 3273:    return &reply("newput:$udomain:$uname:$namespace:$items",$uhome);
 3274: }
 3275: 
 3276: # ---------------------------------------------------------  putstore interface
 3277: 
 3278: sub putstore {
 3279:    my ($namespace,$symb,$version,$storehash,$udomain,$uname)=@_;
 3280:    if (!$udomain) { $udomain=$env{'user.domain'}; }
 3281:    if (!$uname) { $uname=$env{'user.name'}; }
 3282:    my $uhome=&homeserver($uname,$udomain);
 3283:    my $items='';
 3284:    foreach my $key (keys(%$storehash)) {
 3285:        $items.= &escape($key).'='.&freeze_escape($storehash->{$key}).'&';
 3286:    }
 3287:    $items=~s/\&$//;
 3288:    my $esc_symb=&escape($symb);
 3289:    my $esc_v=&escape($version);
 3290:    my $reply =
 3291:        &reply("putstore:$udomain:$uname:$namespace:$esc_symb:$esc_v:$items",
 3292: 	      $uhome);
 3293:    if ($reply eq 'unknown_cmd') {
 3294:        # gfall back to way things use to be done
 3295:        return &old_putstore($namespace,$symb,$version,$storehash,$udomain,
 3296: 			    $uname);
 3297:    }
 3298:    return $reply;
 3299: }
 3300: 
 3301: sub old_putstore {
 3302:     my ($namespace,$symb,$version,$storehash,$udomain,$uname)=@_;
 3303:     if (!$udomain) { $udomain=$env{'user.domain'}; }
 3304:     if (!$uname) { $uname=$env{'user.name'}; }
 3305:     my $uhome=&homeserver($uname,$udomain);
 3306:     my %newstorehash;
 3307:     foreach my $item (keys(%$storehash)) {
 3308: 	my $key = $version.':'.&escape($symb).':'.$item;
 3309: 	$newstorehash{$key} = $storehash->{$item};
 3310:     }
 3311:     my $items='';
 3312:     my %allitems = ();
 3313:     foreach my $item (keys(%newstorehash)) {
 3314: 	if ($item =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) {
 3315: 	    my $key = $1.':keys:'.$2;
 3316: 	    $allitems{$key} .= $3.':';
 3317: 	}
 3318: 	$items.=$item.'='.&freeze_escape($newstorehash{$item}).'&';
 3319:     }
 3320:     foreach my $item (keys(%allitems)) {
 3321: 	$allitems{$item} =~ s/\:$//;
 3322: 	$items.= $item.'='.$allitems{$item}.'&';
 3323:     }
 3324:     $items=~s/\&$//;
 3325:     return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
 3326: }
 3327: 
 3328: # ------------------------------------------------------ critical put interface
 3329: 
 3330: sub cput {
 3331:    my ($namespace,$storehash,$udomain,$uname)=@_;
 3332:    if (!$udomain) { $udomain=$env{'user.domain'}; }
 3333:    if (!$uname) { $uname=$env{'user.name'}; }
 3334:    my $uhome=&homeserver($uname,$udomain);
 3335:    my $items='';
 3336:    foreach my $item (keys(%$storehash)) {
 3337:        $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
 3338:    }
 3339:    $items=~s/\&$//;
 3340:    return &critical("put:$udomain:$uname:$namespace:$items",$uhome);
 3341: }
 3342: 
 3343: # -------------------------------------------------------------- eget interface
 3344: 
 3345: sub eget {
 3346:    my ($namespace,$storearr,$udomain,$uname)=@_;
 3347:    my $items='';
 3348:    foreach my $item (@$storearr) {
 3349:        $items.=&escape($item).'&';
 3350:    }
 3351:    $items=~s/\&$//;
 3352:    if (!$udomain) { $udomain=$env{'user.domain'}; }
 3353:    if (!$uname) { $uname=$env{'user.name'}; }
 3354:    my $uhome=&homeserver($uname,$udomain);
 3355:    my $rep=&reply("eget:$udomain:$uname:$namespace:$items",$uhome);
 3356:    my @pairs=split(/\&/,$rep);
 3357:    my %returnhash=();
 3358:    my $i=0;
 3359:    foreach my $item (@$storearr) {
 3360:       $returnhash{$item}=&thaw_unescape($pairs[$i]);
 3361:       $i++;
 3362:    }
 3363:    return %returnhash;
 3364: }
 3365: 
 3366: # ------------------------------------------------------------ tmpput interface
 3367: sub tmpput {
 3368:     my ($storehash,$server,$context)=@_;
 3369:     my $items='';
 3370:     foreach my $item (keys(%$storehash)) {
 3371: 	$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
 3372:     }
 3373:     $items=~s/\&$//;
 3374:     if (defined($context)) {
 3375:         $items .= ':'.&escape($context);
 3376:     }
 3377:     return &reply("tmpput:$items",$server);
 3378: }
 3379: 
 3380: # ------------------------------------------------------------ tmpget interface
 3381: sub tmpget {
 3382:     my ($token,$server)=@_;
 3383:     if (!defined($server)) { $server = $perlvar{'lonHostID'}; }
 3384:     my $rep=&reply("tmpget:$token",$server);
 3385:     my %returnhash;
 3386:     foreach my $item (split(/\&/,$rep)) {
 3387: 	my ($key,$value)=split(/=/,$item);
 3388: 	$returnhash{&unescape($key)}=&thaw_unescape($value);
 3389:     }
 3390:     return %returnhash;
 3391: }
 3392: 
 3393: # ------------------------------------------------------------ tmpget interface
 3394: sub tmpdel {
 3395:     my ($token,$server)=@_;
 3396:     if (!defined($server)) { $server = $perlvar{'lonHostID'}; }
 3397:     return &reply("tmpdel:$token",$server);
 3398: }
 3399: 
 3400: # -------------------------------------------------- portfolio access checking
 3401: 
 3402: sub portfolio_access {
 3403:     my ($requrl) = @_;
 3404:     my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl);
 3405:     my $result = &get_portfolio_access($udom,$unum,$file_name,$group);
 3406:     if ($result) {
 3407:         my %setters;
 3408:         if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
 3409:             my ($startblock,$endblock) =
 3410:                 &Apache::loncommon::blockcheck(\%setters,'port',$unum,$udom);
 3411:             if ($startblock && $endblock) {
 3412:                 return 'B';
 3413:             }
 3414:         } else {
 3415:             my ($startblock,$endblock) =
 3416:                 &Apache::loncommon::blockcheck(\%setters,'port');
 3417:             if ($startblock && $endblock) {
 3418:                 return 'B';
 3419:             }
 3420:         }
 3421:     }
 3422:     if ($result eq 'ok') {
 3423:        return 'F';
 3424:     } elsif ($result =~ /^[^:]+:guest_/) {
 3425:        return 'A';
 3426:     }
 3427:     return '';
 3428: }
 3429: 
 3430: sub get_portfolio_access {
 3431:     my ($udom,$unum,$file_name,$group,$access_hash) = @_;
 3432: 
 3433:     if (!ref($access_hash)) {
 3434: 	my $current_perms = &get_portfile_permissions($udom,$unum);
 3435: 	my %access_controls = &get_access_controls($current_perms,$group,
 3436: 						   $file_name);
 3437: 	$access_hash = $access_controls{$file_name};
 3438:     }
 3439: 
 3440:     my ($public,$guest,@domains,@users,@courses,@groups);
 3441:     my $now = time;
 3442:     if (ref($access_hash) eq 'HASH') {
 3443:         foreach my $key (keys(%{$access_hash})) {
 3444:             my ($num,$scope,$end,$start) = ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/);
 3445:             if ($start > $now) {
 3446:                 next;
 3447:             }
 3448:             if ($end && $end<$now) {
 3449:                 next;
 3450:             }
 3451:             if ($scope eq 'public') {
 3452:                 $public = $key;
 3453:                 last;
 3454:             } elsif ($scope eq 'guest') {
 3455:                 $guest = $key;
 3456:             } elsif ($scope eq 'domains') {
 3457:                 push(@domains,$key);
 3458:             } elsif ($scope eq 'users') {
 3459:                 push(@users,$key);
 3460:             } elsif ($scope eq 'course') {
 3461:                 push(@courses,$key);
 3462:             } elsif ($scope eq 'group') {
 3463:                 push(@groups,$key);
 3464:             }
 3465:         }
 3466:         if ($public) {
 3467:             return 'ok';
 3468:         }
 3469:         if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
 3470:             if ($guest) {
 3471:                 return $guest;
 3472:             }
 3473:         } else {
 3474:             if (@domains > 0) {
 3475:                 foreach my $domkey (@domains) {
 3476:                     if (ref($access_hash->{$domkey}{'dom'}) eq 'ARRAY') {
 3477:                         if (grep(/^\Q$env{'user.domain'}\E$/,@{$access_hash->{$domkey}{'dom'}})) {
 3478:                             return 'ok';
 3479:                         }
 3480:                     }
 3481:                 }
 3482:             }
 3483:             if (@users > 0) {
 3484:                 foreach my $userkey (@users) {
 3485:                     if (exists($access_hash->{$userkey}{'users'}{$env{'user.name'}.':'.$env{'user.domain'}})) {
 3486:                         return 'ok';
 3487:                     }
 3488:                 }
 3489:             }
 3490:             my %roleshash;
 3491:             my @courses_and_groups = @courses;
 3492:             push(@courses_and_groups,@groups); 
 3493:             if (@courses_and_groups > 0) {
 3494:                 my (%allgroups,%allroles); 
 3495:                 my ($start,$end,$role,$sec,$group);
 3496:                 foreach my $envkey (%env) {
 3497:                     if ($envkey =~ m-^user\.role\.(gr|cc|in|ta|ep|st)\./($match_domain)/($match_courseid)/?([^/]*)$-) {
 3498:                         my $cid = $2.'_'.$3; 
 3499:                         if ($1 eq 'gr') {
 3500:                             $group = $4;
 3501:                             $allgroups{$cid}{$group} = $env{$envkey};
 3502:                         } else {
 3503:                             if ($4 eq '') {
 3504:                                 $sec = 'none';
 3505:                             } else {
 3506:                                 $sec = $4;
 3507:                             }
 3508:                             $allroles{$cid}{$1}{$sec} = $env{$envkey};
 3509:                         }
 3510:                     } elsif ($envkey =~ m-^user\.role\./cr/($match_domain/$match_username/\w*)./($match_domain)/($match_courseid)/?([^/]*)$-) {
 3511:                         my $cid = $2.'_'.$3;
 3512:                         if ($4 eq '') {
 3513:                             $sec = 'none';
 3514:                         } else {
 3515:                             $sec = $4;
 3516:                         }
 3517:                         $allroles{$cid}{$1}{$sec} = $env{$envkey};
 3518:                     }
 3519:                 }
 3520:                 if (keys(%allroles) == 0) {
 3521:                     return;
 3522:                 }
 3523:                 foreach my $key (@courses_and_groups) {
 3524:                     my %content = %{$$access_hash{$key}};
 3525:                     my $cnum = $content{'number'};
 3526:                     my $cdom = $content{'domain'};
 3527:                     my $cid = $cdom.'_'.$cnum;
 3528:                     if (!exists($allroles{$cid})) {
 3529:                         next;
 3530:                     }    
 3531:                     foreach my $role_id (keys(%{$content{'roles'}})) {
 3532:                         my @sections = @{$content{'roles'}{$role_id}{'section'}};
 3533:                         my @groups = @{$content{'roles'}{$role_id}{'group'}};
 3534:                         my @status = @{$content{'roles'}{$role_id}{'access'}};
 3535:                         my @roles = @{$content{'roles'}{$role_id}{'role'}};
 3536:                         foreach my $role (keys(%{$allroles{$cid}})) {
 3537:                             if ((grep/^all$/,@roles) || (grep/^\Q$role\E$/,@roles)) {
 3538:                                 foreach my $sec (keys(%{$allroles{$cid}{$role}})) {
 3539:                                     if (&course_group_datechecker($allroles{$cid}{$role}{$sec},$now,\@status) eq 'ok') {
 3540:                                         if (grep/^all$/,@sections) {
 3541:                                             return 'ok';
 3542:                                         } else {
 3543:                                             if (grep/^$sec$/,@sections) {
 3544:                                                 return 'ok';
 3545:                                             }
 3546:                                         }
 3547:                                     }
 3548:                                 }
 3549:                                 if (keys(%{$allgroups{$cid}}) == 0) {
 3550:                                     if (grep/^none$/,@groups) {
 3551:                                         return 'ok';
 3552:                                     }
 3553:                                 } else {
 3554:                                     if (grep/^all$/,@groups) {
 3555:                                         return 'ok';
 3556:                                     } 
 3557:                                     foreach my $group (keys(%{$allgroups{$cid}})) {
 3558:                                         if (grep/^$group$/,@groups) {
 3559:                                             return 'ok';
 3560:                                         }
 3561:                                     }
 3562:                                 } 
 3563:                             }
 3564:                         }
 3565:                     }
 3566:                 }
 3567:             }
 3568:             if ($guest) {
 3569:                 return $guest;
 3570:             }
 3571:         }
 3572:     }
 3573:     return;
 3574: }
 3575: 
 3576: sub course_group_datechecker {
 3577:     my ($dates,$now,$status) = @_;
 3578:     my ($start,$end) = split(/\./,$dates);
 3579:     if (!$start && !$end) {
 3580:         return 'ok';
 3581:     }
 3582:     if (grep/^active$/,@{$status}) {
 3583:         if (((!$start) || ($start && $start <= $now)) && ((!$end) || ($end && $end >= $now))) {
 3584:             return 'ok';
 3585:         }
 3586:     }
 3587:     if (grep/^previous$/,@{$status}) {
 3588:         if ($end > $now ) {
 3589:             return 'ok';
 3590:         }
 3591:     }
 3592:     if (grep/^future$/,@{$status}) {
 3593:         if ($start > $now) {
 3594:             return 'ok';
 3595:         }
 3596:     }
 3597:     return; 
 3598: }
 3599: 
 3600: sub parse_portfolio_url {
 3601:     my ($url) = @_;
 3602: 
 3603:     my ($type,$udom,$unum,$group,$file_name);
 3604:     
 3605:     if ($url =~  m-^/*(?:uploaded|editupload)/($match_domain)/($match_username)/portfolio(/.+)$-) {
 3606: 	$type = 1;
 3607:         $udom = $1;
 3608:         $unum = $2;
 3609:         $file_name = $3;
 3610:     } elsif ($url =~ m-^/*(?:uploaded|editupload)/($match_domain)/($match_courseid)/groups/([^/]+)/portfolio/(.+)$-) {
 3611: 	$type = 2;
 3612:         $udom = $1;
 3613:         $unum = $2;
 3614:         $group = $3;
 3615:         $file_name = $3.'/'.$4;
 3616:     }
 3617:     if (wantarray) {
 3618: 	return ($type,$udom,$unum,$file_name,$group);
 3619:     }
 3620:     return $type;
 3621: }
 3622: 
 3623: sub is_portfolio_url {
 3624:     my ($url) = @_;
 3625:     return scalar(&parse_portfolio_url($url));
 3626: }
 3627: 
 3628: sub is_portfolio_file {
 3629:     my ($file) = @_;
 3630:     if (($file =~ /^portfolio/) || ($file =~ /^groups\/\w+\/portfolio/)) {
 3631:         return 1;
 3632:     }
 3633:     return;
 3634: }
 3635: 
 3636: 
 3637: # ---------------------------------------------- Custom access rule evaluation
 3638: 
 3639: sub customaccess {
 3640:     my ($priv,$uri)=@_;
 3641:     my ($urole,$urealm)=split(/\./,$env{'request.role'},2);
 3642:     my (undef,$udom,$ucrs,$usec)=split(/\//,$urealm);
 3643:     $udom = &LONCAPA::clean_domain($udom);
 3644:     $ucrs = &LONCAPA::clean_username($ucrs);
 3645:     my $access=0;
 3646:     foreach my $right (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) {
 3647: 	my ($effect,$realm,$role)=split(/\:/,$right);
 3648:         if ($role) {
 3649: 	   if ($role ne $urole) { next; }
 3650:         }
 3651:         foreach my $scope (split(/\s*\,\s*/,$realm)) {
 3652:             my ($tdom,$tcrs,$tsec)=split(/\_/,$scope);
 3653:             if ($tdom) {
 3654: 		if ($tdom ne $udom) { next; }
 3655:             }
 3656:             if ($tcrs) {
 3657: 		if ($tcrs ne $ucrs) { next; }
 3658:             }
 3659:             if ($tsec) {
 3660: 		if ($tsec ne $usec) { next; }
 3661:             }
 3662:             $access=($effect eq 'allow');
 3663:             last;
 3664:         }
 3665: 	if ($realm eq '' && $role eq '') {
 3666:             $access=($effect eq 'allow');
 3667: 	}
 3668:     }
 3669:     return $access;
 3670: }
 3671: 
 3672: # ------------------------------------------------- Check for a user privilege
 3673: 
 3674: sub allowed {
 3675:     my ($priv,$uri,$symb,$role)=@_;
 3676:     my $ver_orguri=$uri;
 3677:     $uri=&deversion($uri);
 3678:     my $orguri=$uri;
 3679:     $uri=&declutter($uri);
 3680: 
 3681:     if ($priv eq 'evb') {
 3682: # Evade communication block restrictions for specified role in a course
 3683:         if ($env{'user.priv.'.$role} =~/evb\&([^\:]*)/) {
 3684:             return $1;
 3685:         } else {
 3686:             return;
 3687:         }
 3688:     }
 3689: 
 3690:     if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }
 3691: # Free bre access to adm and meta resources
 3692:     if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard)$})) 
 3693: 	 || (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) )) 
 3694: 	&& ($priv eq 'bre')) {
 3695: 	return 'F';
 3696:     }
 3697: 
 3698: # Free bre access to user's own portfolio contents
 3699:     my ($space,$domain,$name,@dir)=split('/',$uri);
 3700:     if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) && 
 3701: 	($env{'user.domain'} eq $domain) && ('portfolio' eq $dir[0])) {
 3702:         my %setters;
 3703:         my ($startblock,$endblock) = 
 3704:             &Apache::loncommon::blockcheck(\%setters,'port');
 3705:         if ($startblock && $endblock) {
 3706:             return 'B';
 3707:         } else {
 3708:             return 'F';
 3709:         }
 3710:     }
 3711: 
 3712: # bre access to group portfolio for rgf priv in group, or mdg or vcg in course.
 3713:     if (($space=~/^(uploaded|editupload)$/) && ($dir[0] eq 'groups') 
 3714:          && ($dir[2] eq 'portfolio') && ($priv eq 'bre')) {
 3715:         if (exists($env{'request.course.id'})) {
 3716:             my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
 3717:             my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
 3718:             if (($domain eq $cdom) && ($name eq $cnum)) {
 3719:                 my $courseprivid=$env{'request.course.id'};
 3720:                 $courseprivid=~s/\_/\//;
 3721:                 if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid
 3722:                     .'/'.$dir[1]} =~/rgf\&([^\:]*)/) {
 3723:                     return $1; 
 3724:                 } else {
 3725:                     if ($env{'request.course.sec'}) {
 3726:                         $courseprivid.='/'.$env{'request.course.sec'};
 3727:                     }
 3728:                     if ($env{'user.priv.'.$env{'request.role'}.'./'.
 3729:                         $courseprivid} =~/(mdg|vcg)\&([^\:]*)/) {
 3730:                         return $2;
 3731:                     }
 3732:                 }
 3733:             }
 3734:         }
 3735:     }
 3736: 
 3737: # Free bre to public access
 3738: 
 3739:     if ($priv eq 'bre') {
 3740:         my $copyright=&metadata($uri,'copyright');
 3741: 	if (($copyright eq 'public') && (!$env{'request.course.id'})) { 
 3742:            return 'F'; 
 3743:         }
 3744:         if ($copyright eq 'priv') {
 3745:             $uri=~/([^\/]+)\/([^\/]+)\//;
 3746: 	    unless (($env{'user.name'} eq $2) && ($env{'user.domain'} eq $1)) {
 3747: 		return '';
 3748:             }
 3749:         }
 3750:         if ($copyright eq 'domain') {
 3751:             $uri=~/([^\/]+)\/([^\/]+)\//;
 3752: 	    unless (($env{'user.domain'} eq $1) ||
 3753:                  ($env{'course.'.$env{'request.course.id'}.'.domain'} eq $1)) {
 3754: 		return '';
 3755:             }
 3756:         }
 3757:         if ($env{'request.role'}=~ /li\.\//) {
 3758:             # Library role, so allow browsing of resources in this domain.
 3759:             return 'F';
 3760:         }
 3761:         if ($copyright eq 'custom') {
 3762: 	    unless (&customaccess($priv,$uri)) { return ''; }
 3763:         }
 3764:     }
 3765:     # Domain coordinator is trying to create a course
 3766:     if (($priv eq 'ccc') && ($env{'request.role'} =~ /^dc\./)) {
 3767:         # uri is the requested domain in this case.
 3768:         # comparison to 'request.role.domain' shows if the user has selected
 3769:         # a role of dc for the domain in question.
 3770:         return 'F' if ($uri eq $env{'request.role.domain'});
 3771:     }
 3772: 
 3773:     my $thisallowed='';
 3774:     my $statecond=0;
 3775:     my $courseprivid='';
 3776: 
 3777: # Course
 3778: 
 3779:     if ($env{'user.priv.'.$env{'request.role'}.'./'}=~/\Q$priv\E\&([^\:]*)/) {
 3780:        $thisallowed.=$1;
 3781:     }
 3782: 
 3783: # Domain
 3784: 
 3785:     if ($env{'user.priv.'.$env{'request.role'}.'./'.(split(/\//,$uri))[0].'/'}
 3786:        =~/\Q$priv\E\&([^\:]*)/) {
 3787:        $thisallowed.=$1;
 3788:     }
 3789: 
 3790: # Course: uri itself is a course
 3791:     my $courseuri=$uri;
 3792:     $courseuri=~s/\_(\d)/\/$1/;
 3793:     $courseuri=~s/^([^\/])/\/$1/;
 3794: 
 3795:     if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseuri}
 3796:        =~/\Q$priv\E\&([^\:]*)/) {
 3797:        $thisallowed.=$1;
 3798:     }
 3799: 
 3800: # URI is an uploaded document for this course, default permissions don't matter
 3801: # not allowing 'edit' access (editupload) to uploaded course docs
 3802:     if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) {
 3803: 	$thisallowed='';
 3804:         my ($match)=&is_on_map($uri);
 3805:         if ($match) {
 3806:             if ($env{'user.priv.'.$env{'request.role'}.'./'}
 3807:                   =~/\Q$priv\E\&([^\:]*)/) {
 3808:                 $thisallowed.=$1;
 3809:             }
 3810:         } else {
 3811:             my $refuri = $env{'httpref.'.$orguri} || $env{'httpref.'.$ver_orguri};
 3812:             if ($refuri) {
 3813:                 if ($refuri =~ m|^/adm/|) {
 3814:                     $thisallowed='F';
 3815:                 } else {
 3816:                     $refuri=&declutter($refuri);
 3817:                     my ($match) = &is_on_map($refuri);
 3818:                     if ($match) {
 3819:                         $thisallowed='F';
 3820:                     }
 3821:                 }
 3822:             }
 3823:         }
 3824:     }
 3825: 
 3826:     if ($priv eq 'bre'
 3827: 	&& $thisallowed ne 'F' 
 3828: 	&& $thisallowed ne '2'
 3829: 	&& &is_portfolio_url($uri)) {
 3830: 	$thisallowed = &portfolio_access($uri);
 3831:     }
 3832:     
 3833: # Full access at system, domain or course-wide level? Exit.
 3834: 
 3835:     if ($thisallowed=~/F/) {
 3836: 	return 'F';
 3837:     }
 3838: 
 3839: # If this is generating or modifying users, exit with special codes
 3840: 
 3841:     if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:caa:'=~/\:\Q$priv\E\:/) {
 3842: 	if (($priv eq 'cca') || ($priv eq 'caa')) {
 3843: 	    my ($audom,$auname)=split('/',$uri);
 3844: # no author name given, so this just checks on the general right to make a co-author in this domain
 3845: 	    unless ($auname) { return $thisallowed; }
 3846: # an author name is given, so we are about to actually make a co-author for a certain account
 3847: 	    if (($auname ne $env{'user.name'} && $env{'request.role'} !~ /^dc\./) ||
 3848: 		(($audom ne $env{'user.domain'} && $env{'request.role'} !~ /^dc\./) &&
 3849: 		 ($audom ne $env{'request.role.domain'}))) { return ''; }
 3850: 	}
 3851: 	return $thisallowed;
 3852:     }
 3853: #
 3854: # Gathered so far: system, domain and course wide privileges
 3855: #
 3856: # Course: See if uri or referer is an individual resource that is part of 
 3857: # the course
 3858: 
 3859:     if ($env{'request.course.id'}) {
 3860: 
 3861:        $courseprivid=$env{'request.course.id'};
 3862:        if ($env{'request.course.sec'}) {
 3863:           $courseprivid.='/'.$env{'request.course.sec'};
 3864:        }
 3865:        $courseprivid=~s/\_/\//;
 3866:        my $checkreferer=1;
 3867:        my ($match,$cond)=&is_on_map($uri);
 3868:        if ($match) {
 3869:            $statecond=$cond;
 3870:            if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid}
 3871:                =~/\Q$priv\E\&([^\:]*)/) {
 3872:                $thisallowed.=$1;
 3873:                $checkreferer=0;
 3874:            }
 3875:        }
 3876:        
 3877:        if ($checkreferer) {
 3878: 	  my $refuri=$env{'httpref.'.$orguri};
 3879:             unless ($refuri) {
 3880:                 foreach my $key (keys(%env)) {
 3881: 		    if ($key=~/^httpref\..*\*/) {
 3882: 			my $pattern=$key;
 3883:                         $pattern=~s/^httpref\.\/res\///;
 3884:                         $pattern=~s/\*/\[\^\/\]\+/g;
 3885:                         $pattern=~s/\//\\\//g;
 3886:                         if ($orguri=~/$pattern/) {
 3887: 			    $refuri=$env{$key};
 3888:                         }
 3889:                     }
 3890:                 }
 3891:             }
 3892: 
 3893:          if ($refuri) { 
 3894: 	  $refuri=&declutter($refuri);
 3895:           my ($match,$cond)=&is_on_map($refuri);
 3896:             if ($match) {
 3897:               my $refstatecond=$cond;
 3898:               if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid}
 3899:                   =~/\Q$priv\E\&([^\:]*)/) {
 3900:                   $thisallowed.=$1;
 3901:                   $uri=$refuri;
 3902:                   $statecond=$refstatecond;
 3903:               }
 3904:           }
 3905:         }
 3906:        }
 3907:    }
 3908: 
 3909: #
 3910: # Gathered now: all privileges that could apply, and condition number
 3911: # 
 3912: #
 3913: # Full or no access?
 3914: #
 3915: 
 3916:     if ($thisallowed=~/F/) {
 3917: 	return 'F';
 3918:     }
 3919: 
 3920:     unless ($thisallowed) {
 3921:         return '';
 3922:     }
 3923: 
 3924: # Restrictions exist, deal with them
 3925: #
 3926: #   C:according to course preferences
 3927: #   R:according to resource settings
 3928: #   L:unless locked
 3929: #   X:according to user session state
 3930: #
 3931: 
 3932: # Possibly locked functionality, check all courses
 3933: # Locks might take effect only after 10 minutes cache expiration for other
 3934: # courses, and 2 minutes for current course
 3935: 
 3936:     my $envkey;
 3937:     if ($thisallowed=~/L/) {
 3938:         foreach $envkey (keys %env) {
 3939:            if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) {
 3940:                my $courseid=$2;
 3941:                my $roleid=$1.'.'.$2;
 3942:                $courseid=~s/^\///;
 3943:                my $expiretime=600;
 3944:                if ($env{'request.role'} eq $roleid) {
 3945: 		  $expiretime=120;
 3946:                }
 3947: 	       my ($cdom,$cnum,$csec)=split(/\//,$courseid);
 3948:                my $prefix='course.'.$cdom.'_'.$cnum.'.';
 3949:                if ((time-$env{$prefix.'last_cache'})>$expiretime) {
 3950: 		   &coursedescription($courseid,{'freshen_cache' => 1});
 3951:                }
 3952:                if (($env{$prefix.'res.'.$uri.'.lock.sections'}=~/\,\Q$csec\E\,/)
 3953:                 || ($env{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) {
 3954: 		   if ($env{$prefix.'res.'.$uri.'.lock.expire'}>time) {
 3955:                        &log($env{'user.domain'},$env{'user.name'},
 3956:                             $env{'user.home'},
 3957:                             'Locked by res: '.$priv.' for '.$uri.' due to '.
 3958:                             $cdom.'/'.$cnum.'/'.$csec.' expire '.
 3959:                             $env{$prefix.'priv.'.$priv.'.lock.expire'});
 3960: 		       return '';
 3961:                    }
 3962:                }
 3963:                if (($env{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,\Q$csec\E\,/)
 3964:                 || ($env{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) {
 3965: 		   if ($env{'priv.'.$priv.'.lock.expire'}>time) {
 3966:                        &log($env{'user.domain'},$env{'user.name'},
 3967:                             $env{'user.home'},
 3968:                             'Locked by priv: '.$priv.' for '.$uri.' due to '.
 3969:                             $cdom.'/'.$cnum.'/'.$csec.' expire '.
 3970:                             $env{$prefix.'priv.'.$priv.'.lock.expire'});
 3971: 		       return '';
 3972:                    }
 3973:                }
 3974: 	   }
 3975:        }
 3976:     }
 3977:    
 3978: #
 3979: # Rest of the restrictions depend on selected course
 3980: #
 3981: 
 3982:     unless ($env{'request.course.id'}) {
 3983: 	if ($thisallowed eq 'A') {
 3984: 	    return 'A';
 3985:         } elsif ($thisallowed eq 'B') {
 3986:             return 'B';
 3987: 	} else {
 3988: 	    return '1';
 3989: 	}
 3990:     }
 3991: 
 3992: #
 3993: # Now user is definitely in a course
 3994: #
 3995: 
 3996: 
 3997: # Course preferences
 3998: 
 3999:    if ($thisallowed=~/C/) {
 4000:        my $rolecode=(split(/\./,$env{'request.role'}))[0];
 4001:        my $unamedom=$env{'user.name'}.':'.$env{'user.domain'};
 4002:        if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'}
 4003: 	   =~/\Q$rolecode\E/) {
 4004: 	   if ($priv ne 'pch') { 
 4005: 	       &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
 4006: 			'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
 4007: 			$env{'request.course.id'});
 4008: 	   }
 4009:            return '';
 4010:        }
 4011: 
 4012:        if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'}
 4013: 	   =~/\Q$unamedom\E/) {
 4014: 	   if ($priv ne 'pch') { 
 4015: 	       &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.
 4016: 			'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.
 4017: 			$env{'request.course.id'});
 4018: 	   }
 4019:            return '';
 4020:        }
 4021:    }
 4022: 
 4023: # Resource preferences
 4024: 
 4025:    if ($thisallowed=~/R/) {
 4026:        my $rolecode=(split(/\./,$env{'request.role'}))[0];
 4027:        if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) {
 4028: 	   if ($priv ne 'pch') { 
 4029: 	       &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
 4030: 			'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
 4031: 	   }
 4032: 	   return '';
 4033:        }
 4034:    }
 4035: 
 4036: # Restricted by state or randomout?
 4037: 
 4038:    if ($thisallowed=~/X/) {
 4039:       if ($env{'acc.randomout'}) {
 4040: 	 if (!$symb) { $symb=&symbread($uri,1); }
 4041:          if (($symb) && ($env{'acc.randomout'}=~/\&\Q$symb\E\&/)) { 
 4042:             return ''; 
 4043:          }
 4044:       }
 4045:       if (&condval($statecond)) {
 4046: 	 return '2';
 4047:       } else {
 4048:          return '';
 4049:       }
 4050:    }
 4051: 
 4052:     if ($thisallowed eq 'A') {
 4053: 	return 'A';
 4054:     } elsif ($thisallowed eq 'B') {
 4055:         return 'B';
 4056:     }
 4057:    return 'F';
 4058: }
 4059: 
 4060: sub split_uri_for_cond {
 4061:     my $uri=&deversion(&declutter(shift));
 4062:     my @uriparts=split(/\//,$uri);
 4063:     my $filename=pop(@uriparts);
 4064:     my $pathname=join('/',@uriparts);
 4065:     return ($pathname,$filename);
 4066: }
 4067: # --------------------------------------------------- Is a resource on the map?
 4068: 
 4069: sub is_on_map {
 4070:     my ($pathname,$filename) = &split_uri_for_cond(shift);
 4071:     #Trying to find the conditional for the file
 4072:     my $match=($env{'acc.res.'.$env{'request.course.id'}.'.'.$pathname}=~
 4073: 	       /\&\Q$filename\E\:([\d\|]+)\&/);
 4074:     if ($match) {
 4075: 	return (1,$1);
 4076:     } else {
 4077: 	return (0,0);
 4078:     }
 4079: }
 4080: 
 4081: # --------------------------------------------------------- Get symb from alias
 4082: 
 4083: sub get_symb_from_alias {
 4084:     my $symb=shift;
 4085:     my ($map,$resid,$url)=&decode_symb($symb);
 4086: # Already is a symb
 4087:     if ($url) { return $symb; }
 4088: # Must be an alias
 4089:     my $aliassymb='';
 4090:     my %bighash;
 4091:     if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
 4092:                             &GDBM_READER(),0640)) {
 4093:         my $rid=$bighash{'mapalias_'.$symb};
 4094: 	if ($rid) {
 4095: 	    my ($mapid,$resid)=split(/\./,$rid);
 4096: 	    $aliassymb=&encode_symb($bighash{'map_id_'.$mapid},
 4097: 				    $resid,$bighash{'src_'.$rid});
 4098: 	}
 4099:         untie %bighash;
 4100:     }
 4101:     return $aliassymb;
 4102: }
 4103: 
 4104: # ----------------------------------------------------------------- Define Role
 4105: 
 4106: sub definerole {
 4107:   if (allowed('mcr','/')) {
 4108:     my ($rolename,$sysrole,$domrole,$courole)=@_;
 4109:     foreach my $role (split(':',$sysrole)) {
 4110: 	my ($crole,$cqual)=split(/\&/,$role);
 4111:         if ($pr{'cr:s'}!~/\Q$crole\E/) { return "refused:s:$crole"; }
 4112:         if ($pr{'cr:s'}=~/\Q$crole\E\&/) {
 4113: 	    if ($pr{'cr:s'}!~/\Q$crole\E\&\w*\Q$cqual\E/) { 
 4114:                return "refused:s:$crole&$cqual"; 
 4115:             }
 4116:         }
 4117:     }
 4118:     foreach my $role (split(':',$domrole)) {
 4119: 	my ($crole,$cqual)=split(/\&/,$role);
 4120:         if ($pr{'cr:d'}!~/\Q$crole\E/) { return "refused:d:$crole"; }
 4121:         if ($pr{'cr:d'}=~/\Q$crole\E\&/) {
 4122: 	    if ($pr{'cr:d'}!~/\Q$crole\W\&\w*\Q$cqual\E/) { 
 4123:                return "refused:d:$crole&$cqual"; 
 4124:             }
 4125:         }
 4126:     }
 4127:     foreach my $role (split(':',$courole)) {
 4128: 	my ($crole,$cqual)=split(/\&/,$role);
 4129:         if ($pr{'cr:c'}!~/\Q$crole\E/) { return "refused:c:$crole"; }
 4130:         if ($pr{'cr:c'}=~/\Q$crole\E\&/) {
 4131: 	    if ($pr{'cr:c'}!~/\Q$crole\E\&\w*\Q$cqual\E/) { 
 4132:                return "refused:c:$crole&$cqual"; 
 4133:             }
 4134:         }
 4135:     }
 4136:     my $command="encrypt:rolesput:$env{'user.domain'}:$env{'user.name'}:".
 4137:                 "$env{'user.domain'}:$env{'user.name'}:".
 4138: 	        "rolesdef_$rolename=".
 4139:                 escape($sysrole.'_'.$domrole.'_'.$courole);
 4140:     return reply($command,$env{'user.home'});
 4141:   } else {
 4142:     return 'refused';
 4143:   }
 4144: }
 4145: 
 4146: # ---------------- Make a metadata query against the network of library servers
 4147: 
 4148: sub metadata_query {
 4149:     my ($query,$custom,$customshow,$server_array)=@_;
 4150:     my %rhash;
 4151:     my @server_list = (defined($server_array) ? @$server_array
 4152:                                               : keys(%libserv) );
 4153:     for my $server (@server_list) {
 4154: 	unless ($custom or $customshow) {
 4155: 	    my $reply=&reply("querysend:".&escape($query),$server);
 4156: 	    $rhash{$server}=$reply;
 4157: 	}
 4158: 	else {
 4159: 	    my $reply=&reply("querysend:".&escape($query).':'.
 4160: 			     &escape($custom).':'.&escape($customshow),
 4161: 			     $server);
 4162: 	    $rhash{$server}=$reply;
 4163: 	}
 4164:     }
 4165:     return \%rhash;
 4166: }
 4167: 
 4168: # ----------------------------------------- Send log queries and wait for reply
 4169: 
 4170: sub log_query {
 4171:     my ($uname,$udom,$query,%filters)=@_;
 4172:     my $uhome=&homeserver($uname,$udom);
 4173:     if ($uhome eq 'no_host') { return 'error: no_host'; }
 4174:     my $uhost=$hostname{$uhome};
 4175:     my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys(%filters)));
 4176:     my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command,
 4177:                        $uhome);
 4178:     unless ($queryid=~/^\Q$uhost\E\_/) { return 'error: '.$queryid; }
 4179:     return get_query_reply($queryid);
 4180: }
 4181: 
 4182: # -------------------------- Update MySQL table for portfolio file
 4183: 
 4184: sub update_portfolio_table {
 4185:     my ($uname,$udom,$file_name,$query,$group,$action) = @_;
 4186:     my $homeserver = &homeserver($uname,$udom);
 4187:     my $queryid=
 4188:         &reply("querysend:".$query.':'.&escape($uname.':'.$udom.':'.$group).
 4189:                ':'.&escape($file_name).':'.$action,$homeserver);
 4190:     my $reply = &get_query_reply($queryid);
 4191:     return $reply;
 4192: }
 4193: 
 4194: # ------- Request retrieval of institutional classlists for course(s)
 4195: 
 4196: sub fetch_enrollment_query {
 4197:     my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_;
 4198:     my $homeserver;
 4199:     my $maxtries = 1;
 4200:     if ($context eq 'automated') {
 4201:         $homeserver = $perlvar{'lonHostID'};
 4202:         $maxtries = 10; # will wait for up to 2000s for retrieval of classlist data before timeout
 4203:     } else {
 4204:         $homeserver = &homeserver($cnum,$dom);
 4205:     }
 4206:     my $host=$hostname{$homeserver};
 4207:     my $cmd = '';
 4208:     foreach my $affiliate (keys %{$affiliatesref}) {
 4209:         $cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';
 4210:     }
 4211:     $cmd =~ s/%%$//;
 4212:     $cmd = &escape($cmd);
 4213:     my $query = 'fetchenrollment';
 4214:     my $queryid=&reply("querysend:".$query.':'.$dom.':'.$env{'user.name'}.':'.$cmd,$homeserver);
 4215:     unless ($queryid=~/^\Q$host\E\_/) { 
 4216:         &logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum); 
 4217:         return 'error: '.$queryid;
 4218:     }
 4219:     my $reply = &get_query_reply($queryid);
 4220:     my $tries = 1;
 4221:     while (($reply=~/^timeout/) && ($tries < $maxtries)) {
 4222:         $reply = &get_query_reply($queryid);
 4223:         $tries ++;
 4224:     }
 4225:     if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
 4226:         &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);
 4227:     } else {
 4228:         my @responses = split/:/,$reply;
 4229:         if ($homeserver eq $perlvar{'lonHostID'}) {
 4230:             foreach my $line (@responses) {
 4231:                 my ($key,$value) = split(/=/,$line,2);
 4232:                 $$replyref{$key} = $value;
 4233:             }
 4234:         } else {
 4235:             my $pathname = $perlvar{'lonDaemons'}.'/tmp';
 4236:             foreach my $line (@responses) {
 4237:                 my ($key,$value) = split(/=/,$line);
 4238:                 $$replyref{$key} = $value;
 4239:                 if ($value > 0) {
 4240:                     foreach my $item (@{$$affiliatesref{$key}}) {
 4241:                         my $filename = $dom.'_'.$key.'_'.$item.'_classlist.xml';
 4242:                         my $destname = $pathname.'/'.$filename;
 4243:                         my $xml_classlist = &reply("autoretrieve:".$filename,$homeserver);
 4244:                         if ($xml_classlist =~ /^error/) {
 4245:                             &logthis('fetch_enrollment_query - autoretrieve error: '.$xml_classlist.' for '.$filename.' from server: '.$homeserver.' '.$context.' '.$cnum);
 4246:                         } else {
 4247:                             if ( open(FILE,">$destname") ) {
 4248:                                 print FILE &unescape($xml_classlist);
 4249:                                 close(FILE);
 4250:                             } else {
 4251:                                 &logthis('fetch_enrollment_query - error opening classlist file '.$destname.' '.$context.' '.$cnum);
 4252:                             }
 4253:                         }
 4254:                     }
 4255:                 }
 4256:             }
 4257:         }
 4258:         return 'ok';
 4259:     }
 4260:     return 'error';
 4261: }
 4262: 
 4263: sub get_query_reply {
 4264:     my $queryid=shift;
 4265:     my $replyfile=$perlvar{'lonDaemons'}.'/tmp/'.$queryid;
 4266:     my $reply='';
 4267:     for (1..100) {
 4268: 	sleep 2;
 4269:         if (-e $replyfile.'.end') {
 4270: 	    if (open(my $fh,$replyfile)) {
 4271:                $reply.=<$fh>;
 4272:                close($fh);
 4273: 	   } else { return 'error: reply_file_error'; }
 4274:            return &unescape($reply);
 4275: 	}
 4276:     }
 4277:     return 'timeout:'.$queryid;
 4278: }
 4279: 
 4280: sub courselog_query {
 4281: #
 4282: # possible filters:
 4283: # url: url or symb
 4284: # username
 4285: # domain
 4286: # action: view, submit, grade
 4287: # start: timestamp
 4288: # end: timestamp
 4289: #
 4290:     my (%filters)=@_;
 4291:     unless ($env{'request.course.id'}) { return 'no_course'; }
 4292:     if ($filters{'url'}) {
 4293: 	$filters{'url'}=&symbclean(&declutter($filters{'url'}));
 4294:         $filters{'url'}=~s/\.(\w+)$/(\\.\\d+)*\\.$1/;
 4295:         $filters{'url'}=~s/\.(\w+)\_\_\_/(\\.\\d+)*\\.$1/;
 4296:     }
 4297:     my $cname=$env{'course.'.$env{'request.course.id'}.'.num'};
 4298:     my $cdom=$env{'course.'.$env{'request.course.id'}.'.domain'};
 4299:     return &log_query($cname,$cdom,'courselog',%filters);
 4300: }
 4301: 
 4302: sub userlog_query {
 4303:     my ($uname,$udom,%filters)=@_;
 4304:     return &log_query($uname,$udom,'userlog',%filters);
 4305: }
 4306: 
 4307: #--------- Call auto-enrollment subs in localenroll.pm for homeserver for course 
 4308: 
 4309: sub auto_run {
 4310:     my ($cnum,$cdom) = @_;
 4311:     my $homeserver = &homeserver($cnum,$cdom);
 4312:     my $response = &reply('autorun:'.$cdom,$homeserver);
 4313:     return $response;
 4314: }
 4315: 
 4316: sub auto_get_sections {
 4317:     my ($cnum,$cdom,$inst_coursecode) = @_;
 4318:     my $homeserver = &homeserver($cnum,$cdom);
 4319:     my @secs = ();
 4320:     my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver));
 4321:     unless ($response eq 'refused') {
 4322:         @secs = split/:/,$response;
 4323:     }
 4324:     return @secs;
 4325: }
 4326: 
 4327: sub auto_new_course {
 4328:     my ($cnum,$cdom,$inst_course_id,$owner) = @_;
 4329:     my $homeserver = &homeserver($cnum,$cdom);
 4330:     my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.$owner.':'.$cdom,$homeserver));
 4331:     return $response;
 4332: }
 4333: 
 4334: sub auto_validate_courseID {
 4335:     my ($cnum,$cdom,$inst_course_id) = @_;
 4336:     my $homeserver = &homeserver($cnum,$cdom);
 4337:     my $response=&unescape(&reply('autovalidatecourse:'.$inst_course_id.':'.$cdom,$homeserver));
 4338:     return $response;
 4339: }
 4340: 
 4341: sub auto_create_password {
 4342:     my ($cnum,$cdom,$authparam) = @_;
 4343:     my $homeserver = &homeserver($cnum,$cdom); 
 4344:     my $create_passwd = 0;
 4345:     my $authchk = '';
 4346:     my $response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver));
 4347:     if ($response eq 'refused') {
 4348:         $authchk = 'refused';
 4349:     } else {
 4350:         ($authparam,$create_passwd,$authchk) = split/:/,$response;
 4351:     }
 4352:     return ($authparam,$create_passwd,$authchk);
 4353: }
 4354: 
 4355: sub auto_photo_permission {
 4356:     my ($cnum,$cdom,$students) = @_;
 4357:     my $homeserver = &homeserver($cnum,$cdom);
 4358:     my ($outcome,$perm_reqd,$conditions) = 
 4359: 	split(/:/,&unescape(&reply('autophotopermission:'.$cdom,$homeserver)),3);
 4360:     if ($outcome =~ /^(con_lost|unknown_cmd|no_such_host)$/) {
 4361: 	return (undef,undef);
 4362:     }
 4363:     return ($outcome,$perm_reqd,$conditions);
 4364: }
 4365: 
 4366: sub auto_checkphotos {
 4367:     my ($uname,$udom,$pid) = @_;
 4368:     my $homeserver = &homeserver($uname,$udom);
 4369:     my ($result,$resulttype);
 4370:     my $outcome = &unescape(&reply('autophotocheck:'.&escape($udom).':'.
 4371: 				   &escape($uname).':'.&escape($pid),
 4372: 				   $homeserver));
 4373:     if ($outcome =~ /^(con_lost|unknown_cmd|no_such_host)$/) {
 4374: 	return (undef,undef);
 4375:     }
 4376:     if ($outcome) {
 4377:         ($result,$resulttype) = split(/:/,$outcome);
 4378:     } 
 4379:     return ($result,$resulttype);
 4380: }
 4381: 
 4382: sub auto_photochoice {
 4383:     my ($cnum,$cdom) = @_;
 4384:     my $homeserver = &homeserver($cnum,$cdom);
 4385:     my ($update,$comment) = split(/:/,&unescape(&reply('autophotochoice:'.
 4386: 						       &escape($cdom),
 4387: 						       $homeserver)));
 4388:     if ($update =~ /^(con_lost|unknown_cmd|no_such_host)$/) {
 4389: 	return (undef,undef);
 4390:     }
 4391:     return ($update,$comment);
 4392: }
 4393: 
 4394: sub auto_photoupdate {
 4395:     my ($affiliatesref,$dom,$cnum,$photo) = @_;
 4396:     my $homeserver = &homeserver($cnum,$dom);
 4397:     my $host=$hostname{$homeserver};
 4398:     my $cmd = '';
 4399:     my $maxtries = 1;
 4400:     foreach my $affiliate (keys(%{$affiliatesref})) {
 4401:         $cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';
 4402:     }
 4403:     $cmd =~ s/%%$//;
 4404:     $cmd = &escape($cmd);
 4405:     my $query = 'institutionalphotos';
 4406:     my $queryid=&reply("querysend:".$query.':'.$dom.':'.$cnum.':'.$cmd,$homeserver);
 4407:     unless ($queryid=~/^\Q$host\E\_/) {
 4408:         &logthis('institutionalphotos: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' and course: '.$cnum);
 4409:         return 'error: '.$queryid;
 4410:     }
 4411:     my $reply = &get_query_reply($queryid);
 4412:     my $tries = 1;
 4413:     while (($reply=~/^timeout/) && ($tries < $maxtries)) {
 4414:         $reply = &get_query_reply($queryid);
 4415:         $tries ++;
 4416:     }
 4417:     if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
 4418:         &logthis('institutionalphotos error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' course: '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);
 4419:     } else {
 4420:         my @responses = split(/:/,$reply);
 4421:         my $outcome = shift(@responses); 
 4422:         foreach my $item (@responses) {
 4423:             my ($key,$value) = split(/=/,$item);
 4424:             $$photo{$key} = $value;
 4425:         }
 4426:         return $outcome;
 4427:     }
 4428:     return 'error';
 4429: }
 4430: 
 4431: sub auto_instcode_format {
 4432:     my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,
 4433: 	$cat_order) = @_;
 4434:     my $courses = '';
 4435:     my @homeservers;
 4436:     if ($caller eq 'global') {
 4437:         foreach my $tryserver (keys(%libserv)) {
 4438:             if ($hostdom{$tryserver} eq $codedom) {
 4439:                 if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
 4440:                     push(@homeservers,$tryserver);
 4441:                 }
 4442:             }
 4443:         }
 4444:     } else {
 4445:         push(@homeservers,&homeserver($caller,$codedom));
 4446:     }
 4447:     foreach my $code (keys(%{$instcodes})) {
 4448:         $courses .= &escape($code).'='.&escape($$instcodes{$code}).'&';
 4449:     }
 4450:     chop($courses);
 4451:     my $ok_response = 0;
 4452:     my $response;
 4453:     while (@homeservers > 0 && $ok_response == 0) {
 4454:         my $server = shift(@homeservers); 
 4455:         $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$server);
 4456:         if ($response !~ /(con_lost|error|no_such_host|refused)/) {
 4457:             my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = 
 4458: 		split/:/,$response;
 4459:             %{$codes} = (%{$codes},&str2hash($codes_str));
 4460:             push(@{$codetitles},&str2array($codetitles_str));
 4461:             %{$cat_titles} = (%{$cat_titles},&str2hash($cat_titles_str));
 4462:             %{$cat_order} = (%{$cat_order},&str2hash($cat_order_str));
 4463:             $ok_response = 1;
 4464:         }
 4465:     }
 4466:     if ($ok_response) {
 4467:         return 'ok';
 4468:     } else {
 4469:         return $response;
 4470:     }
 4471: }
 4472: 
 4473: sub auto_instcode_defaults {
 4474:     my ($domain,$returnhash,$code_order) = @_;
 4475:     my @homeservers;
 4476:     foreach my $tryserver (keys(%libserv)) {
 4477:         if ($hostdom{$tryserver} eq $domain) {
 4478:             if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
 4479:                 push(@homeservers,$tryserver);
 4480:             }
 4481:         }
 4482:     }
 4483:     my $ok_response = 0;
 4484:     my $response;
 4485:     while (@homeservers > 0 && $ok_response == 0) {
 4486:         my $server = shift(@homeservers);
 4487:         $response=&reply('autoinstcodedefaults:'.$domain,$server);
 4488:         if ($response !~ /(con_lost|error|no_such_host|refused)/) {
 4489:             foreach my $pair (split(/\&/,$response)) {
 4490:                 my ($name,$value)=split(/\=/,$pair);
 4491:                 if ($name eq 'code_order') {
 4492:                     @{$code_order} = split(/\&/,&unescape($value));
 4493:                 } else {
 4494:                     $returnhash->{&unescape($name)}=&unescape($value);
 4495:                 }
 4496:             }
 4497:             $ok_response = 1;
 4498:         }
 4499:     }
 4500:     if ($ok_response) {
 4501:         return 'ok';
 4502:     } else {
 4503:         return $response;
 4504:     }
 4505: } 
 4506: 
 4507: sub auto_validate_class_sec {
 4508:     my ($cdom,$cnum,$owner,$inst_class) = @_;
 4509:     my $homeserver = &homeserver($cnum,$cdom);
 4510:     my $response=&reply('autovalidateclass_sec:'.$inst_class.':'.
 4511:                         &escape($owner).':'.$cdom,$homeserver);
 4512:     return $response;
 4513: }
 4514: 
 4515: # ------------------------------------------------------- Course Group routines
 4516: 
 4517: sub get_coursegroups {
 4518:     my ($cdom,$cnum,$group,$namespace) = @_;
 4519:     return(&dump($namespace,$cdom,$cnum,$group));
 4520: }
 4521: 
 4522: sub modify_coursegroup {
 4523:     my ($cdom,$cnum,$groupsettings) = @_;
 4524:     return(&put('coursegroups',$groupsettings,$cdom,$cnum));
 4525: }
 4526: 
 4527: sub toggle_coursegroup_status {
 4528:     my ($cdom,$cnum,$group,$action) = @_;
 4529:     my ($from_namespace,$to_namespace);
 4530:     if ($action eq 'delete') {
 4531:         $from_namespace = 'coursegroups';
 4532:         $to_namespace = 'deleted_groups';
 4533:     } else {
 4534:         $from_namespace = 'deleted_groups';
 4535:         $to_namespace = 'coursegroups';
 4536:     }
 4537:     my %curr_group = &get_coursegroups($cdom,$cnum,$group,$from_namespace);
 4538:     if (my $tmp = &error(%curr_group)) {
 4539:         &Apache::lonnet::logthis('Error retrieving group: '.$tmp.' in '.$cnum.':'.$cdom);
 4540:         return ('read error',$tmp);
 4541:     } else {
 4542:         my %savedsettings = %curr_group; 
 4543:         my $result = &put($to_namespace,\%savedsettings,$cdom,$cnum);
 4544:         my $deloutcome;
 4545:         if ($result eq 'ok') {
 4546:             $deloutcome = &del($from_namespace,[$group],$cdom,$cnum);
 4547:         } else {
 4548:             return ('write error',$result);
 4549:         }
 4550:         if ($deloutcome eq 'ok') {
 4551:             return 'ok';
 4552:         } else {
 4553:             return ('delete error',$deloutcome);
 4554:         }
 4555:     }
 4556: }
 4557: 
 4558: sub modify_group_roles {
 4559:     my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs) = @_;
 4560:     my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id;
 4561:     my $role = 'gr/'.&escape($userprivs);
 4562:     my ($uname,$udom) = split(/:/,$user);
 4563:     my $result = &assignrole($udom,$uname,$url,$role,$end,$start);
 4564:     if ($result eq 'ok') {
 4565:         &devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);
 4566:     }
 4567:     return $result;
 4568: }
 4569: 
 4570: sub modify_coursegroup_membership {
 4571:     my ($cdom,$cnum,$membership) = @_;
 4572:     my $result = &put('groupmembership',$membership,$cdom,$cnum);
 4573:     return $result;
 4574: }
 4575: 
 4576: sub get_active_groups {
 4577:     my ($udom,$uname,$cdom,$cnum) = @_;
 4578:     my $now = time;
 4579:     my %groups = ();
 4580:     foreach my $key (keys(%env)) {
 4581:         if ($key =~ m-user\.role\.gr\./($match_domain)/($match_courseid)/(\w+)$-) {
 4582:             my ($start,$end) = split(/\./,$env{$key});
 4583:             if (($end!=0) && ($end<$now)) { next; }
 4584:             if (($start!=0) && ($start>$now)) { next; }
 4585:             if ($1 eq $cdom && $2 eq $cnum) {
 4586:                 $groups{$3} = $env{$key} ;
 4587:             }
 4588:         }
 4589:     }
 4590:     return %groups;
 4591: }
 4592: 
 4593: sub get_group_membership {
 4594:     my ($cdom,$cnum,$group) = @_;
 4595:     return(&dump('groupmembership',$cdom,$cnum,$group));
 4596: }
 4597: 
 4598: sub get_users_groups {
 4599:     my ($udom,$uname,$courseid) = @_;
 4600:     my @usersgroups;
 4601:     my $cachetime=1800;
 4602: 
 4603:     my $hashid="$udom:$uname:$courseid";
 4604:     my ($grouplist,$cached)=&is_cached_new('getgroups',$hashid);
 4605:     if (defined($cached)) {
 4606:         @usersgroups = split(/:/,$grouplist);
 4607:     } else {  
 4608:         $grouplist = '';
 4609:         my $courseurl = &courseid_to_courseurl($courseid);
 4610:         my %roleshash = &dump('roles',$udom,$uname,$courseurl);
 4611:         my $access_end = $env{'course.'.$courseid.
 4612:                               '.default_enrollment_end_date'};
 4613:         my $now = time;
 4614:         foreach my $key (keys(%roleshash)) {
 4615:             if ($key =~ /^\Q$courseurl\E\/(\w+)\_gr$/) {
 4616:                 my $group = $1;
 4617:                 if ($roleshash{$key} =~ /_(\d+)_(\d+)$/) {
 4618:                     my $start = $2;
 4619:                     my $end = $1;
 4620:                     if ($start == -1) { next; } # deleted from group
 4621:                     if (($start!=0) && ($start>$now)) { next; }
 4622:                     if (($end!=0) && ($end<$now)) {
 4623:                         if ($access_end && $access_end < $now) {
 4624:                             if ($access_end - $end < 86400) {
 4625:                                 push(@usersgroups,$group);
 4626:                             }
 4627:                         }
 4628:                         next;
 4629:                     }
 4630:                     push(@usersgroups,$group);
 4631:                 }
 4632:             }
 4633:         }
 4634:         @usersgroups = &sort_course_groups($courseid,@usersgroups);
 4635:         $grouplist = join(':',@usersgroups);
 4636:         &do_cache_new('getgroups',$hashid,$grouplist,$cachetime);
 4637:     }
 4638:     return @usersgroups;
 4639: }
 4640: 
 4641: sub devalidate_getgroups_cache {
 4642:     my ($udom,$uname,$cdom,$cnum)=@_;
 4643:     my $courseid = $cdom.'_'.$cnum;
 4644: 
 4645:     my $hashid="$udom:$uname:$courseid";
 4646:     &devalidate_cache_new('getgroups',$hashid);
 4647: }
 4648: 
 4649: # ------------------------------------------------------------------ Plain Text
 4650: 
 4651: sub plaintext {
 4652:     my ($short,$type,$cid) = @_;
 4653:     if ($short =~ /^cr/) {
 4654: 	return (split('/',$short))[-1];
 4655:     }
 4656:     if (!defined($cid)) {
 4657:         $cid = $env{'request.course.id'};
 4658:     }
 4659:     if (defined($cid) && defined($env{'course.'.$cid.'.'.$short.'.plaintext'})) {
 4660:         return &Apache::lonlocal::mt($env{'course.'.$cid.'.'.$short.
 4661:                                           '.plaintext'});
 4662:     }
 4663:     my %rolenames = (
 4664:                       Course => 'std',
 4665:                       Group => 'alt1',
 4666:                     );
 4667:     if (defined($type) && 
 4668:          defined($rolenames{$type}) && 
 4669:          defined($prp{$short}{$rolenames{$type}})) {
 4670:         return &Apache::lonlocal::mt($prp{$short}{$rolenames{$type}});
 4671:     } else {
 4672:         return &Apache::lonlocal::mt($prp{$short}{'std'});
 4673:     }
 4674: }
 4675: 
 4676: # ----------------------------------------------------------------- Assign Role
 4677: 
 4678: sub assignrole {
 4679:     my ($udom,$uname,$url,$role,$end,$start,$deleteflag)=@_;
 4680:     my $mrole;
 4681:     if ($role =~ /^cr\//) {
 4682:         my $cwosec=$url;
 4683:         $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
 4684: 	unless (&allowed('ccr',$cwosec)) {
 4685:            &logthis('Refused custom assignrole: '.
 4686:              $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
 4687: 		    $env{'user.name'}.' at '.$env{'user.domain'});
 4688:            return 'refused'; 
 4689:         }
 4690:         $mrole='cr';
 4691:     } elsif ($role =~ /^gr\//) {
 4692:         my $cwogrp=$url;
 4693:         $cwogrp=~s{^/($match_domain)/($match_courseid)/.*}{$1/$2};
 4694:         unless (&allowed('mdg',$cwogrp)) {
 4695:             &logthis('Refused group assignrole: '.
 4696:               $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
 4697:                     $env{'user.name'}.' at '.$env{'user.domain'});
 4698:             return 'refused';
 4699:         }
 4700:         $mrole='gr';
 4701:     } else {
 4702:         my $cwosec=$url;
 4703:         $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
 4704:         unless ((&allowed('c'.$role,$cwosec)) || &allowed('c'.$role,$udom)) { 
 4705:            &logthis('Refused assignrole: '.
 4706:              $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
 4707: 		    $env{'user.name'}.' at '.$env{'user.domain'});
 4708:            return 'refused'; 
 4709:         }
 4710:         $mrole=$role;
 4711:     }
 4712:     my $command="encrypt:rolesput:$env{'user.domain'}:$env{'user.name'}:".
 4713:                 "$udom:$uname:$url".'_'."$mrole=$role";
 4714:     if ($end) { $command.='_'.$end; }
 4715:     if ($start) {
 4716: 	if ($end) { 
 4717:            $command.='_'.$start; 
 4718:         } else {
 4719:            $command.='_0_'.$start;
 4720:         }
 4721:     }
 4722:     my $origstart = $start;
 4723:     my $origend = $end;
 4724: # actually delete
 4725:     if ($deleteflag) {
 4726: 	if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) {
 4727: # modify command to delete the role
 4728:            $command="encrypt:rolesdel:$env{'user.domain'}:$env{'user.name'}:".
 4729:                 "$udom:$uname:$url".'_'."$mrole";
 4730: 	   &logthis("$env{'user.name'} at $env{'user.domain'} deletes $mrole in $url for $uname at $udom"); 
 4731: # set start and finish to negative values for userrolelog
 4732:            $start=-1;
 4733:            $end=-1;
 4734:         }
 4735:     }
 4736: # send command
 4737:     my $answer=&reply($command,&homeserver($uname,$udom));
 4738: # log new user role if status is ok
 4739:     if ($answer eq 'ok') {
 4740: 	&userrolelog($role,$uname,$udom,$url,$start,$end);
 4741: # for course roles, perform group memberships changes triggered by role change.
 4742:         unless ($role =~ /^gr/) {
 4743:             &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend,
 4744:                                              $origstart);
 4745:         }
 4746:     }
 4747:     return $answer;
 4748: }
 4749: 
 4750: # -------------------------------------------------- Modify user authentication
 4751: # Overrides without validation
 4752: 
 4753: sub modifyuserauth {
 4754:     my ($udom,$uname,$umode,$upass)=@_;
 4755:     my $uhome=&homeserver($uname,$udom);
 4756:     unless (&allowed('mau',$udom)) { return 'refused'; }
 4757:     &logthis('Call to modify user authentication '.$udom.', '.$uname.', '.
 4758:              $umode.' by '.$env{'user.name'}.' at '.$env{'user.domain'}.
 4759:              ' in domain '.$env{'request.role.domain'});  
 4760:     my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'.
 4761: 		     &escape($upass),$uhome);
 4762:     &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},
 4763:         'Authentication changed for '.$udom.', '.$uname.', '.$umode.
 4764:          '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply);
 4765:     &log($udom,,$uname,$uhome,
 4766:         'Authentication changed by '.$env{'user.domain'}.', '.
 4767:                                      $env{'user.name'}.', '.$umode.
 4768:          '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply);
 4769:     unless ($reply eq 'ok') {
 4770:         &logthis('Authentication mode error: '.$reply);
 4771: 	return 'error: '.$reply;
 4772:     }   
 4773:     return 'ok';
 4774: }
 4775: 
 4776: # --------------------------------------------------------------- Modify a user
 4777: 
 4778: sub modifyuser {
 4779:     my ($udom,    $uname, $uid,
 4780:         $umode,   $upass, $first,
 4781:         $middle,  $last,  $gene,
 4782:         $forceid, $desiredhome, $email)=@_;
 4783:     $udom= &LONCAPA::clean_domain($udom);
 4784:     $uname=&LONCAPA::clean_username($uname);
 4785:     &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
 4786:              $umode.', '.$first.', '.$middle.', '.
 4787: 	     $last.', '.$gene.'(forceid: '.$forceid.')'.
 4788:              (defined($desiredhome) ? ' desiredhome = '.$desiredhome :
 4789:                                      ' desiredhome not specified'). 
 4790:              ' by '.$env{'user.name'}.' at '.$env{'user.domain'}.
 4791:              ' in domain '.$env{'request.role.domain'});
 4792:     my $uhome=&homeserver($uname,$udom,'true');
 4793: # ----------------------------------------------------------------- Create User
 4794:     if (($uhome eq 'no_host') && 
 4795: 	(($umode && $upass) || ($umode eq 'localauth'))) {
 4796:         my $unhome='';
 4797:         if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) { 
 4798:             $unhome = $desiredhome;
 4799: 	} elsif($env{'course.'.$env{'request.course.id'}.'.domain'} eq $udom) {
 4800: 	    $unhome=$env{'course.'.$env{'request.course.id'}.'.home'};
 4801:         } else { # load balancing routine for determining $unhome
 4802:             my $tryserver;
 4803:             my $loadm=10000000;
 4804:             foreach $tryserver (keys %libserv) {
 4805: 	       if ($hostdom{$tryserver} eq $udom) {
 4806:                   my $answer=reply('load',$tryserver);
 4807:                   if (($answer=~/\d+/) && ($answer<$loadm)) {
 4808: 		      $loadm=$answer;
 4809:                       $unhome=$tryserver;
 4810:                   }
 4811: 	       }
 4812: 	    }
 4813:         }
 4814:         if (($unhome eq '') || ($unhome eq 'no_host')) {
 4815: 	    return 'error: unable to find a home server for '.$uname.
 4816:                    ' in domain '.$udom;
 4817:         }
 4818:         my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':'.$umode.':'.
 4819:                          &escape($upass),$unhome);
 4820: 	unless ($reply eq 'ok') {
 4821:             return 'error: '.$reply;
 4822:         }   
 4823:         $uhome=&homeserver($uname,$udom,'true');
 4824:         if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) {
 4825: 	    return 'error: unable verify users home machine.';
 4826:         }
 4827:     }   # End of creation of new user
 4828: # ---------------------------------------------------------------------- Add ID
 4829:     if ($uid) {
 4830:        $uid=~tr/A-Z/a-z/;
 4831:        my %uidhash=&idrget($udom,$uname);
 4832:        if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/) 
 4833:          && (!$forceid)) {
 4834: 	  unless ($uid eq $uidhash{$uname}) {
 4835: 	      return 'error: user id "'.$uid.'" does not match '.
 4836:                   'current user id "'.$uidhash{$uname}.'".';
 4837:           }
 4838:        } else {
 4839: 	  &idput($udom,($uname => $uid));
 4840:        }
 4841:     }
 4842: # -------------------------------------------------------------- Add names, etc
 4843:     my @tmp=&get('environment',
 4844: 		   ['firstname','middlename','lastname','generation'],
 4845: 		   $udom,$uname);
 4846:     my %names;
 4847:     if ($tmp[0] =~ m/^error:.*/) { 
 4848:         %names=(); 
 4849:     } else {
 4850:         %names = @tmp;
 4851:     }
 4852: #
 4853: # Make sure to not trash student environment if instructor does not bother
 4854: # to supply name and email information
 4855: #
 4856:     if ($first)  { $names{'firstname'}  = $first; }
 4857:     if (defined($middle)) { $names{'middlename'} = $middle; }
 4858:     if ($last)   { $names{'lastname'}   = $last; }
 4859:     if (defined($gene))   { $names{'generation'} = $gene; }
 4860:     if ($email) {
 4861:        $email=~s/[^\w\@\.\-\,]//gs;
 4862:        if ($email=~/\@/) { $names{'notification'} = $email;
 4863: 			   $names{'critnotification'} = $email;
 4864: 			   $names{'permanentemail'} = $email; }
 4865:     }
 4866:     my $reply = &put('environment', \%names, $udom,$uname);
 4867:     if ($reply ne 'ok') { return 'error: '.$reply; }
 4868:     &devalidate_cache_new('namescache',$uname.':'.$udom);
 4869:     &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
 4870:              $umode.', '.$first.', '.$middle.', '.
 4871: 	     $last.', '.$gene.' by '.
 4872:              $env{'user.name'}.' at '.$env{'user.domain'});
 4873:     return 'ok';
 4874: }
 4875: 
 4876: # -------------------------------------------------------------- Modify student
 4877: 
 4878: sub modifystudent {
 4879:     my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
 4880:         $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid)=@_;
 4881:     if (!$cid) {
 4882: 	unless ($cid=$env{'request.course.id'}) {
 4883: 	    return 'not_in_class';
 4884: 	}
 4885:     }
 4886: # --------------------------------------------------------------- Make the user
 4887:     my $reply=&modifyuser
 4888: 	($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid,
 4889:          $desiredhome,$email);
 4890:     unless ($reply eq 'ok') { return $reply; }
 4891:     # This will cause &modify_student_enrollment to get the uid from the
 4892:     # students environment
 4893:     $uid = undef if (!$forceid);
 4894:     $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,
 4895: 					$gene,$usec,$end,$start,$type,$locktype,$cid);
 4896:     return $reply;
 4897: }
 4898: 
 4899: sub modify_student_enrollment {
 4900:     my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid) = @_;
 4901:     my ($cdom,$cnum,$chome);
 4902:     if (!$cid) {
 4903: 	unless ($cid=$env{'request.course.id'}) {
 4904: 	    return 'not_in_class';
 4905: 	}
 4906: 	$cdom=$env{'course.'.$cid.'.domain'};
 4907: 	$cnum=$env{'course.'.$cid.'.num'};
 4908:     } else {
 4909: 	($cdom,$cnum)=split(/_/,$cid);
 4910:     }
 4911:     $chome=$env{'course.'.$cid.'.home'};
 4912:     if (!$chome) {
 4913: 	$chome=&homeserver($cnum,$cdom);
 4914:     }
 4915:     if (!$chome) { return 'unknown_course'; }
 4916:     # Make sure the user exists
 4917:     my $uhome=&homeserver($uname,$udom);
 4918:     if (($uhome eq '') || ($uhome eq 'no_host')) { 
 4919: 	return 'error: no such user';
 4920:     }
 4921:     # Get student data if we were not given enough information
 4922:     if (!defined($first)  || $first  eq '' || 
 4923:         !defined($last)   || $last   eq '' || 
 4924:         !defined($uid)    || $uid    eq '' || 
 4925:         !defined($middle) || $middle eq '' || 
 4926:         !defined($gene)   || $gene   eq '') {
 4927:         # They did not supply us with enough data to enroll the student, so
 4928:         # we need to pick up more information.
 4929:         my %tmp = &get('environment',
 4930:                        ['firstname','middlename','lastname', 'generation','id']
 4931:                        ,$udom,$uname);
 4932: 
 4933:         #foreach my $key (keys(%tmp)) {
 4934:         #    &logthis("key $key = ".$tmp{$key});
 4935:         #}
 4936:         $first  = $tmp{'firstname'}  if (!defined($first)  || $first  eq '');
 4937:         $middle = $tmp{'middlename'} if (!defined($middle) || $middle eq '');
 4938:         $last   = $tmp{'lastname'}   if (!defined($last)   || $last eq '');
 4939:         $gene   = $tmp{'generation'} if (!defined($gene)   || $gene eq '');
 4940:         $uid    = $tmp{'id'}         if (!defined($uid)    || $uid  eq '');
 4941:     }
 4942:     my $fullname = &format_name($first,$middle,$last,$gene,'lastname');
 4943:     my $reply=cput('classlist',
 4944: 		   {"$uname:$udom" => 
 4945: 			join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) },
 4946: 		   $cdom,$cnum);
 4947:     unless (($reply eq 'ok') || ($reply eq 'delayed')) {
 4948: 	return 'error: '.$reply;
 4949:     } else {
 4950: 	&devalidate_getsection_cache($udom,$uname,$cid);
 4951:     }
 4952:     # Add student role to user
 4953:     my $uurl='/'.$cid;
 4954:     $uurl=~s/\_/\//g;
 4955:     if ($usec) {
 4956: 	$uurl.='/'.$usec;
 4957:     }
 4958:     return &assignrole($udom,$uname,$uurl,'st',$end,$start);
 4959: }
 4960: 
 4961: sub format_name {
 4962:     my ($firstname,$middlename,$lastname,$generation,$first)=@_;
 4963:     my $name;
 4964:     if ($first ne 'lastname') {
 4965: 	$name=$firstname.' '.$middlename.' '.$lastname.' '.$generation;
 4966:     } else {
 4967: 	if ($lastname=~/\S/) {
 4968: 	    $name.= $lastname.' '.$generation.', '.$firstname.' '.$middlename;
 4969: 	    $name=~s/\s+,/,/;
 4970: 	} else {
 4971: 	    $name.= $firstname.' '.$middlename.' '.$generation;
 4972: 	}
 4973:     }
 4974:     $name=~s/^\s+//;
 4975:     $name=~s/\s+$//;
 4976:     $name=~s/\s+/ /g;
 4977:     return $name;
 4978: }
 4979: 
 4980: # ------------------------------------------------- Write to course preferences
 4981: 
 4982: sub writecoursepref {
 4983:     my ($courseid,%prefs)=@_;
 4984:     $courseid=~s/^\///;
 4985:     $courseid=~s/\_/\//g;
 4986:     my ($cdomain,$cnum)=split(/\//,$courseid);
 4987:     my $chome=homeserver($cnum,$cdomain);
 4988:     if (($chome eq '') || ($chome eq 'no_host')) { 
 4989: 	return 'error: no such course';
 4990:     }
 4991:     my $cstring='';
 4992:     foreach my $pref (keys(%prefs)) {
 4993: 	$cstring.=&escape($pref).'='.&escape($prefs{$pref}).'&';
 4994:     }
 4995:     $cstring=~s/\&$//;
 4996:     return reply('put:'.$cdomain.':'.$cnum.':environment:'.$cstring,$chome);
 4997: }
 4998: 
 4999: # ---------------------------------------------------------- Make/modify course
 5000: 
 5001: sub createcourse {
 5002:     my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,
 5003:         $course_owner,$crstype)=@_;
 5004:     $url=&declutter($url);
 5005:     my $cid='';
 5006:     unless (&allowed('ccc',$udom)) {
 5007:         return 'refused';
 5008:     }
 5009: # ------------------------------------------------------------------- Create ID
 5010:    my $uname=int(1+rand(9)).
 5011:        ('a'..'z','A'..'Z','0'..'9')[int(rand(62))].
 5012:        substr($$.time,0,5).unpack("H8",pack("I32",time)).
 5013:        unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
 5014: # ----------------------------------------------- Make sure that does not exist
 5015:    my $uhome=&homeserver($uname,$udom,'true');
 5016:    unless (($uhome eq '') || ($uhome eq 'no_host')) {
 5017:        $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).
 5018:         unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
 5019:        $uhome=&homeserver($uname,$udom,'true');       
 5020:        unless (($uhome eq '') || ($uhome eq 'no_host')) {
 5021:            return 'error: unable to generate unique course-ID';
 5022:        } 
 5023:    }
 5024: # ------------------------------------------------ Check supplied server name
 5025:     $course_server = $env{'user.homeserver'} if (! defined($course_server));
 5026:     if (! exists($libserv{$course_server})) {
 5027:         return 'error:bad server name '.$course_server;
 5028:     }
 5029: # ------------------------------------------------------------- Make the course
 5030:     my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',
 5031:                       $course_server);
 5032:     unless ($reply eq 'ok') { return 'error: '.$reply; }
 5033:     $uhome=&homeserver($uname,$udom,'true');
 5034:     if (($uhome eq '') || ($uhome eq 'no_host')) { 
 5035: 	return 'error: no such course';
 5036:     }
 5037: # ----------------------------------------------------------------- Course made
 5038: # log existence
 5039:     &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description).
 5040:                  ':'.&escape($inst_code).':'.&escape($course_owner).':'.
 5041:                   &escape($crstype),$uhome);
 5042:     &flushcourselogs();
 5043: # set toplevel url
 5044:     my $topurl=$url;
 5045:     unless ($nonstandard) {
 5046: # ------------------------------------------ For standard courses, make top url
 5047:         my $mapurl=&clutter($url);
 5048:         if ($mapurl eq '/res/') { $mapurl=''; }
 5049:         $env{'form.initmap'}=(<<ENDINITMAP);
 5050: <map>
 5051: <resource id="1" type="start"></resource>
 5052: <resource id="2" src="$mapurl"></resource>
 5053: <resource id="3" type="finish"></resource>
 5054: <link index="1" from="1" to="2"></link>
 5055: <link index="2" from="2" to="3"></link>
 5056: </map>
 5057: ENDINITMAP
 5058:         $topurl=&declutter(
 5059:         &finishuserfileupload($uname,$udom,'initmap','default.sequence')
 5060:                           );
 5061:     }
 5062: # ----------------------------------------------------------- Write preferences
 5063:     &writecoursepref($udom.'_'.$uname,
 5064:                      ('description' => $description,
 5065:                       'url'         => $topurl));
 5066:     return '/'.$udom.'/'.$uname;
 5067: }
 5068: 
 5069: sub is_course {
 5070:     my ($cdom,$cnum) = @_;
 5071:     my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,
 5072: 				undef,'.');
 5073:     if (exists($courses{$cdom.'_'.$cnum})) {
 5074:         return 1;
 5075:     }
 5076:     return 0;
 5077: }
 5078: 
 5079: # ---------------------------------------------------------- Assign Custom Role
 5080: 
 5081: sub assigncustomrole {
 5082:     my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag)=@_;
 5083:     return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename,
 5084:                        $end,$start,$deleteflag);
 5085: }
 5086: 
 5087: # ----------------------------------------------------------------- Revoke Role
 5088: 
 5089: sub revokerole {
 5090:     my ($udom,$uname,$url,$role,$deleteflag)=@_;
 5091:     my $now=time;
 5092:     return &assignrole($udom,$uname,$url,$role,$now,$deleteflag);
 5093: }
 5094: 
 5095: # ---------------------------------------------------------- Revoke Custom Role
 5096: 
 5097: sub revokecustomrole {
 5098:     my ($udom,$uname,$url,$rdom,$rnam,$rolename,$deleteflag)=@_;
 5099:     my $now=time;
 5100:     return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now,
 5101:            $deleteflag);
 5102: }
 5103: 
 5104: # ------------------------------------------------------------ Disk usage
 5105: sub diskusage {
 5106:     my ($udom,$uname,$directoryRoot)=@_;
 5107:     $directoryRoot =~ s/\/$//;
 5108:     my $listing=&reply('du:'.$directoryRoot,homeserver($uname,$udom));
 5109:     return $listing;
 5110: }
 5111: 
 5112: sub is_locked {
 5113:     my ($file_name, $domain, $user) = @_;
 5114:     my @check;
 5115:     my $is_locked;
 5116:     push @check, $file_name;
 5117:     my %locked = &get('file_permissions',\@check,
 5118: 		      $env{'user.domain'},$env{'user.name'});
 5119:     my ($tmp)=keys(%locked);
 5120:     if ($tmp=~/^error:/) { undef(%locked); }
 5121:     
 5122:     if (ref($locked{$file_name}) eq 'ARRAY') {
 5123:         $is_locked = 'false';
 5124:         foreach my $entry (@{$locked{$file_name}}) {
 5125:            if (ref($entry) eq 'ARRAY') { 
 5126:                $is_locked = 'true';
 5127:                last;
 5128:            }
 5129:        }
 5130:     } else {
 5131:         $is_locked = 'false';
 5132:     }
 5133: }
 5134: 
 5135: sub declutter_portfile {
 5136:     my ($file) = @_;
 5137:     &logthis("got $file");
 5138:     $file =~ s-^(/portfolio/|portfolio/)-/-;
 5139:     &logthis("ret $file");
 5140:     return $file;
 5141: }
 5142: 
 5143: # ------------------------------------------------------------- Mark as Read Only
 5144: 
 5145: sub mark_as_readonly {
 5146:     my ($domain,$user,$files,$what) = @_;
 5147:     my %current_permissions = &dump('file_permissions',$domain,$user);
 5148:     my ($tmp)=keys(%current_permissions);
 5149:     if ($tmp=~/^error:/) { undef(%current_permissions); }
 5150:     foreach my $file (@{$files}) {
 5151: 	$file = &declutter_portfile($file);
 5152:         push(@{$current_permissions{$file}},$what);
 5153:     }
 5154:     &put('file_permissions',\%current_permissions,$domain,$user);
 5155:     return;
 5156: }
 5157: 
 5158: # ------------------------------------------------------------Save Selected Files
 5159: 
 5160: sub save_selected_files {
 5161:     my ($user, $path, @files) = @_;
 5162:     my $filename = $user."savedfiles";
 5163:     my @other_files = &files_not_in_path($user, $path);
 5164:     open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
 5165:     foreach my $file (@files) {
 5166:         print (OUT $env{'form.currentpath'}.$file."\n");
 5167:     }
 5168:     foreach my $file (@other_files) {
 5169:         print (OUT $file."\n");
 5170:     }
 5171:     close (OUT);
 5172:     return 'ok';
 5173: }
 5174: 
 5175: sub clear_selected_files {
 5176:     my ($user) = @_;
 5177:     my $filename = $user."savedfiles";
 5178:     open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
 5179:     print (OUT undef);
 5180:     close (OUT);
 5181:     return ("ok");    
 5182: }
 5183: 
 5184: sub files_in_path {
 5185:     my ($user, $path) = @_;
 5186:     my $filename = $user."savedfiles";
 5187:     my %return_files;
 5188:     open (IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
 5189:     while (my $line_in = <IN>) {
 5190:         chomp ($line_in);
 5191:         my @paths_and_file = split (m!/!, $line_in);
 5192:         my $file_part = pop (@paths_and_file);
 5193:         my $path_part = join ('/', @paths_and_file);
 5194:         $path_part.='/';
 5195:         my $path_and_file = $path_part.$file_part;
 5196:         if ($path_part eq $path) {
 5197:             $return_files{$file_part}= 'selected';
 5198:         }
 5199:     }
 5200:     close (IN);
 5201:     return (\%return_files);
 5202: }
 5203: 
 5204: # called in portfolio select mode, to show files selected NOT in current directory
 5205: sub files_not_in_path {
 5206:     my ($user, $path) = @_;
 5207:     my $filename = $user."savedfiles";
 5208:     my @return_files;
 5209:     my $path_part;
 5210:     open(IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
 5211:     while (my $line = <IN>) {
 5212:         #ok, I know it's clunky, but I want it to work
 5213:         my @paths_and_file = split(m|/|, $line);
 5214:         my $file_part = pop(@paths_and_file);
 5215:         chomp($file_part);
 5216:         my $path_part = join('/', @paths_and_file);
 5217:         $path_part .= '/';
 5218:         my $path_and_file = $path_part.$file_part;
 5219:         if ($path_part ne $path) {
 5220:             push(@return_files, ($path_and_file));
 5221:         }
 5222:     }
 5223:     close(OUT);
 5224:     return (@return_files);
 5225: }
 5226: 
 5227: #----------------------------------------------Get portfolio file permissions
 5228: 
 5229: sub get_portfile_permissions {
 5230:     my ($domain,$user) = @_;
 5231:     my %current_permissions = &dump('file_permissions',$domain,$user);
 5232:     my ($tmp)=keys(%current_permissions);
 5233:     if ($tmp=~/^error:/) { undef(%current_permissions); }
 5234:     return \%current_permissions;
 5235: }
 5236: 
 5237: #---------------------------------------------Get portfolio file access controls
 5238: 
 5239: sub get_access_controls {
 5240:     my ($current_permissions,$group,$file) = @_;
 5241:     my %access;
 5242:     my $real_file = $file;
 5243:     $file =~ s/\.meta$//;
 5244:     if (defined($file)) {
 5245:         if (ref($$current_permissions{$file."\0".'accesscontrol'}) eq 'HASH') {
 5246:             foreach my $control (keys(%{$$current_permissions{$file."\0".'accesscontrol'}})) {
 5247:                 $access{$real_file}{$control} = $$current_permissions{$file."\0".$control};
 5248:             }
 5249:         }
 5250:     } else {
 5251:         foreach my $key (keys(%{$current_permissions})) {
 5252:             if ($key =~ /\0accesscontrol$/) {
 5253:                 if (defined($group)) {
 5254:                     if ($key !~ m-^\Q$group\E/-) {
 5255:                         next;
 5256:                     }
 5257:                 }
 5258:                 my ($fullpath) = split(/\0/,$key);
 5259:                 if (ref($$current_permissions{$key}) eq 'HASH') {
 5260:                     foreach my $control (keys(%{$$current_permissions{$key}})) {
 5261:                         $access{$fullpath}{$control}=$$current_permissions{$fullpath."\0".$control};
 5262:                     }
 5263:                 }
 5264:             }
 5265:         }
 5266:     }
 5267:     return %access;
 5268: }
 5269: 
 5270: sub modify_access_controls {
 5271:     my ($file_name,$changes,$domain,$user)=@_;
 5272:     my ($outcome,$deloutcome);
 5273:     my %store_permissions;
 5274:     my %new_values;
 5275:     my %new_control;
 5276:     my %translation;
 5277:     my @deletions = ();
 5278:     my $now = time;
 5279:     if (exists($$changes{'activate'})) {
 5280:         if (ref($$changes{'activate'}) eq 'HASH') {
 5281:             my @newitems = sort(keys(%{$$changes{'activate'}}));
 5282:             my $numnew = scalar(@newitems);
 5283:             for (my $i=0; $i<$numnew; $i++) {
 5284:                 my $newkey = $newitems[$i];
 5285:                 my $newid = &Apache::loncommon::get_cgi_id();
 5286:                 if ($newkey =~ /^\d+:/) { 
 5287:                     $newkey =~ s/^(\d+)/$newid/;
 5288:                     $translation{$1} = $newid;
 5289:                 } elsif ($newkey =~ /^\d+_\d+_\d+:/) {
 5290:                     $newkey =~ s/^(\d+_\d+_\d+)/$newid/;
 5291:                     $translation{$1} = $newid;
 5292:                 }
 5293:                 $new_values{$file_name."\0".$newkey} = 
 5294:                                           $$changes{'activate'}{$newitems[$i]};
 5295:                 $new_control{$newkey} = $now;
 5296:             }
 5297:         }
 5298:     }
 5299:     my %todelete;
 5300:     my %changed_items;
 5301:     foreach my $action ('delete','update') {
 5302:         if (exists($$changes{$action})) {
 5303:             if (ref($$changes{$action}) eq 'HASH') {
 5304:                 foreach my $key (keys(%{$$changes{$action}})) {
 5305:                     my ($itemnum) = ($key =~ /^([^:]+):/);
 5306:                     if ($action eq 'delete') { 
 5307:                         $todelete{$itemnum} = 1;
 5308:                     } else {
 5309:                         $changed_items{$itemnum} = $key;
 5310:                     }
 5311:                 }
 5312:             }
 5313:         }
 5314:     }
 5315:     # get lock on access controls for file.
 5316:     my $lockhash = {
 5317:                   $file_name."\0".'locked_access_records' => $env{'user.name'}.
 5318:                                                        ':'.$env{'user.domain'},
 5319:                    }; 
 5320:     my $tries = 0;
 5321:     my $gotlock = &newput('file_permissions',$lockhash,$domain,$user);
 5322:    
 5323:     while (($gotlock ne 'ok') && $tries <3) {
 5324:         $tries ++;
 5325:         sleep 1;
 5326:         $gotlock = &newput('file_permissions',$lockhash,$domain,$user);
 5327:     }
 5328:     if ($gotlock eq 'ok') {
 5329:         my %curr_permissions = &dump('file_permissions',$domain,$user,$file_name);
 5330:         my ($tmp)=keys(%curr_permissions);
 5331:         if ($tmp=~/^error:/) { undef(%curr_permissions); }
 5332:         if (exists($curr_permissions{$file_name."\0".'accesscontrol'})) {
 5333:             my $curr_controls = $curr_permissions{$file_name."\0".'accesscontrol'};
 5334:             if (ref($curr_controls) eq 'HASH') {
 5335:                 foreach my $control_item (keys(%{$curr_controls})) {
 5336:                     my ($itemnum) = ($control_item =~ /^([^:]+):/);
 5337:                     if (defined($todelete{$itemnum})) {
 5338:                         push(@deletions,$file_name."\0".$control_item);
 5339:                     } else {
 5340:                         if (defined($changed_items{$itemnum})) {
 5341:                             $new_control{$changed_items{$itemnum}} = $now;
 5342:                             push(@deletions,$file_name."\0".$control_item);
 5343:                             $new_values{$file_name."\0".$changed_items{$itemnum}} = $$changes{'update'}{$changed_items{$itemnum}};
 5344:                         } else {
 5345:                             $new_control{$control_item} = $$curr_controls{$control_item};
 5346:                         }
 5347:                     }
 5348:                 }
 5349:             }
 5350:         }
 5351:         $deloutcome = &del('file_permissions',\@deletions,$domain,$user);
 5352:         $new_values{$file_name."\0".'accesscontrol'} = \%new_control;
 5353:         $outcome = &put('file_permissions',\%new_values,$domain,$user);
 5354:         #  remove lock
 5355:         my @del_lock = ($file_name."\0".'locked_access_records');
 5356:         my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user);
 5357:         my ($file,$group);
 5358:         if (&is_course($domain,$user)) {
 5359:             ($group,$file) = split(/\//,$file_name,2);
 5360:         } else {
 5361:             $file = $file_name;
 5362:         }
 5363:         my $sqlresult =
 5364:             &update_portfolio_table($user,$domain,$file,'portfolio_access',
 5365:                                     $group);
 5366:     } else {
 5367:         $outcome = "error: could not obtain lockfile\n";  
 5368:     }
 5369:     return ($outcome,$deloutcome,\%new_values,\%translation);
 5370: }
 5371: 
 5372: sub make_public_indefinitely {
 5373:     my ($requrl) = @_;
 5374:     my $now = time;
 5375:     my $action = 'activate';
 5376:     my $aclnum = 0;
 5377:     if (&is_portfolio_url($requrl)) {
 5378:         my (undef,$udom,$unum,$file_name,$group) =
 5379:             &parse_portfolio_url($requrl);
 5380:         my $current_perms = &get_portfile_permissions($udom,$unum);
 5381:         my %access_controls = &get_access_controls($current_perms,
 5382:                                                    $group,$file_name);
 5383:         foreach my $key (keys(%{$access_controls{$file_name}})) {
 5384:             my ($num,$scope,$end,$start) = 
 5385:                 ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/);
 5386:             if ($scope eq 'public') {
 5387:                 if ($start <= $now && $end == 0) {
 5388:                     $action = 'none';
 5389:                 } else {
 5390:                     $action = 'update';
 5391:                     $aclnum = $num;
 5392:                 }
 5393:                 last;
 5394:             }
 5395:         }
 5396:         if ($action eq 'none') {
 5397:              return 'ok';
 5398:         } else {
 5399:             my %changes;
 5400:             my $newend = 0;
 5401:             my $newstart = $now;
 5402:             my $newkey = $aclnum.':public_'.$newend.'_'.$newstart;
 5403:             $changes{$action}{$newkey} = {
 5404:                 type => 'public',
 5405:                 time => {
 5406:                     start => $newstart,
 5407:                     end   => $newend,
 5408:                 },
 5409:             };
 5410:             my ($outcome,$deloutcome,$new_values,$translation) =
 5411:                 &modify_access_controls($file_name,\%changes,$udom,$unum);
 5412:             return $outcome;
 5413:         }
 5414:     } else {
 5415:         return 'invalid';
 5416:     }
 5417: }
 5418: 
 5419: #------------------------------------------------------Get Marked as Read Only
 5420: 
 5421: sub get_marked_as_readonly {
 5422:     my ($domain,$user,$what,$group) = @_;
 5423:     my $current_permissions = &get_portfile_permissions($domain,$user);
 5424:     my @readonly_files;
 5425:     my $cmp1=$what;
 5426:     if (ref($what)) { $cmp1=join('',@{$what}) };
 5427:     while (my ($file_name,$value) = each(%{$current_permissions})) {
 5428:         if (defined($group)) {
 5429:             if ($file_name !~ m-^\Q$group\E/-) {
 5430:                 next;
 5431:             }
 5432:         }
 5433:         if (ref($value) eq "ARRAY"){
 5434:             foreach my $stored_what (@{$value}) {
 5435:                 my $cmp2=$stored_what;
 5436:                 if (ref($stored_what) eq 'ARRAY') {
 5437:                     $cmp2=join('',@{$stored_what});
 5438:                 }
 5439:                 if ($cmp1 eq $cmp2) {
 5440:                     push(@readonly_files, $file_name);
 5441:                     last;
 5442:                 } elsif (!defined($what)) {
 5443:                     push(@readonly_files, $file_name);
 5444:                     last;
 5445:                 }
 5446:             }
 5447:         }
 5448:     }
 5449:     return @readonly_files;
 5450: }
 5451: #-----------------------------------------------------------Get Marked as Read Only Hash
 5452: 
 5453: sub get_marked_as_readonly_hash {
 5454:     my ($current_permissions,$group,$what) = @_;
 5455:     my %readonly_files;
 5456:     while (my ($file_name,$value) = each(%{$current_permissions})) {
 5457:         if (defined($group)) {
 5458:             if ($file_name !~ m-^\Q$group\E/-) {
 5459:                 next;
 5460:             }
 5461:         }
 5462:         if (ref($value) eq "ARRAY"){
 5463:             foreach my $stored_what (@{$value}) {
 5464:                 if (ref($stored_what) eq 'ARRAY') {
 5465:                     foreach my $lock_descriptor(@{$stored_what}) {
 5466:                         if ($lock_descriptor eq 'graded') {
 5467:                             $readonly_files{$file_name} = 'graded';
 5468:                         } elsif ($lock_descriptor eq 'handback') {
 5469:                             $readonly_files{$file_name} = 'handback';
 5470:                         } else {
 5471:                             if (!exists($readonly_files{$file_name})) {
 5472:                                 $readonly_files{$file_name} = 'locked';
 5473:                             }
 5474:                         }
 5475:                     }
 5476:                 } 
 5477:             }
 5478:         } 
 5479:     }
 5480:     return %readonly_files;
 5481: }
 5482: # ------------------------------------------------------------ Unmark as Read Only
 5483: 
 5484: sub unmark_as_readonly {
 5485:     # unmarks $file_name (if $file_name is defined), or all files locked by $what 
 5486:     # for portfolio submissions, $what contains [$symb,$crsid] 
 5487:     my ($domain,$user,$what,$file_name,$group) = @_;
 5488:     $file_name = &declutter_portfile($file_name);
 5489:     my $symb_crs = $what;
 5490:     if (ref($what)) { $symb_crs=join('',@$what); }
 5491:     my %current_permissions = &dump('file_permissions',$domain,$user,$group);
 5492:     my ($tmp)=keys(%current_permissions);
 5493:     if ($tmp=~/^error:/) { undef(%current_permissions); }
 5494:     my @readonly_files = &get_marked_as_readonly($domain,$user,$what,$group);
 5495:     foreach my $file (@readonly_files) {
 5496: 	my $clean_file = &declutter_portfile($file);
 5497: 	if (defined($file_name) && ($file_name ne $clean_file)) { next; }
 5498: 	my $current_locks = $current_permissions{$file};
 5499:         my @new_locks;
 5500:         my @del_keys;
 5501:         if (ref($current_locks) eq "ARRAY"){
 5502:             foreach my $locker (@{$current_locks}) {
 5503:                 my $compare=$locker;
 5504:                 if (ref($locker) eq 'ARRAY') {
 5505:                     $compare=join('',@{$locker});
 5506:                     if ($compare ne $symb_crs) {
 5507:                         push(@new_locks, $locker);
 5508:                     }
 5509:                 }
 5510:             }
 5511:             if (scalar(@new_locks) > 0) {
 5512:                 $current_permissions{$file} = \@new_locks;
 5513:             } else {
 5514:                 push(@del_keys, $file);
 5515:                 &del('file_permissions',\@del_keys, $domain, $user);
 5516:                 delete($current_permissions{$file});
 5517:             }
 5518:         }
 5519:     }
 5520:     &put('file_permissions',\%current_permissions,$domain,$user);
 5521:     return;
 5522: }
 5523: 
 5524: # ------------------------------------------------------------ Directory lister
 5525: 
 5526: sub dirlist {
 5527:     my ($uri,$userdomain,$username,$alternateDirectoryRoot)=@_;
 5528: 
 5529:     $uri=~s/^\///;
 5530:     $uri=~s/\/$//;
 5531:     my ($udom, $uname);
 5532:     (undef,$udom,$uname)=split(/\//,$uri);
 5533:     if(defined($userdomain)) {
 5534:         $udom = $userdomain;
 5535:     }
 5536:     if(defined($username)) {
 5537:         $uname = $username;
 5538:     }
 5539: 
 5540:     my $dirRoot = $perlvar{'lonDocRoot'};
 5541:     if(defined($alternateDirectoryRoot)) {
 5542:         $dirRoot = $alternateDirectoryRoot;
 5543:         $dirRoot =~ s/\/$//;
 5544:     }
 5545: 
 5546:     if($udom) {
 5547:         if($uname) {
 5548:             my $listing = &reply('ls2:'.$dirRoot.'/'.$uri,
 5549: 				 &homeserver($uname,$udom));
 5550:             my @listing_results;
 5551:             if ($listing eq 'unknown_cmd') {
 5552:                 $listing = &reply('ls:'.$dirRoot.'/'.$uri,
 5553: 				  &homeserver($uname,$udom));
 5554:                 @listing_results = split(/:/,$listing);
 5555:             } else {
 5556:                 @listing_results = map { &unescape($_); } split(/:/,$listing);
 5557:             }
 5558:             return @listing_results;
 5559:         } elsif(!defined($alternateDirectoryRoot)) {
 5560:             my %allusers;
 5561:             foreach my $tryserver (keys(%libserv)) {
 5562:                 if($hostdom{$tryserver} eq $udom) {
 5563:                     my $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'.
 5564: 					 $udom, $tryserver);
 5565:                     my @listing_results;
 5566:                     if ($listing eq 'unknown_cmd') {
 5567:                         $listing = &reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.
 5568: 					  $udom, $tryserver);
 5569:                         @listing_results = split(/:/,$listing);
 5570:                     } else {
 5571:                         @listing_results =
 5572:                             map { &unescape($_); } split(/:/,$listing);
 5573:                     }
 5574:                     if ($listing_results[0] ne 'no_such_dir' && 
 5575:                         $listing_results[0] ne 'empty'       &&
 5576:                         $listing_results[0] ne 'con_lost') {
 5577:                         foreach my $line (@listing_results) {
 5578:                             my ($entry) = split(/&/,$line,2);
 5579:                             $allusers{$entry} = 1;
 5580:                         }
 5581:                     }
 5582:                 }
 5583:             }
 5584:             my $alluserstr='';
 5585:             foreach my $user (sort(keys(%allusers))) {
 5586:                 $alluserstr.=$user.'&user:';
 5587:             }
 5588:             $alluserstr=~s/:$//;
 5589:             return split(/:/,$alluserstr);
 5590:         } else {
 5591:             return ('missing user name');
 5592:         }
 5593:     } elsif(!defined($alternateDirectoryRoot)) {
 5594:         my $tryserver;
 5595:         my %alldom=();
 5596:         foreach $tryserver (keys(%libserv)) {
 5597:             $alldom{$hostdom{$tryserver}}=1;
 5598:         }
 5599:         my $alldomstr='';
 5600:         foreach my $domain (sort(keys(%alldom))) {
 5601:             $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain:';
 5602:         }
 5603:         $alldomstr=~s/:$//;
 5604:         return split(/:/,$alldomstr);       
 5605:     } else {
 5606:         return ('missing domain');
 5607:     }
 5608: }
 5609: 
 5610: # --------------------------------------------- GetFileTimestamp
 5611: # This function utilizes dirlist and returns the date stamp for
 5612: # when it was last modified.  It will also return an error of -1
 5613: # if an error occurs
 5614: 
 5615: ##
 5616: ## FIXME: This subroutine assumes its caller knows something about the
 5617: ## directory structure of the home server for the student ($root).
 5618: ## Not a good assumption to make.  Since this is for looking up files
 5619: ## in user directories, the full path should be constructed by lond, not
 5620: ## whatever machine we request data from.
 5621: ##
 5622: sub GetFileTimestamp {
 5623:     my ($studentDomain,$studentName,$filename,$root)=@_;
 5624:     $studentDomain = &LONCAPA::clean_domain($studentDomain);
 5625:     $studentName   = &LONCAPA::clean_username($studentName);
 5626:     my $subdir=$studentName.'__';
 5627:     $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
 5628:     my $proname="$studentDomain/$subdir/$studentName";
 5629:     $proname .= '/'.$filename;
 5630:     my ($fileStat) = &Apache::lonnet::dirlist($proname, $studentDomain, 
 5631:                                               $studentName, $root);
 5632:     my @stats = split('&', $fileStat);
 5633:     if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {
 5634:         # @stats contains first the filename, then the stat output
 5635:         return $stats[10]; # so this is 10 instead of 9.
 5636:     } else {
 5637:         return -1;
 5638:     }
 5639: }
 5640: 
 5641: sub stat_file {
 5642:     my ($uri) = @_;
 5643:     $uri = &clutter_with_no_wrapper($uri);
 5644: 
 5645:     my ($udom,$uname,$file,$dir);
 5646:     if ($uri =~ m-^/(uploaded|editupload)/-) {
 5647: 	($udom,$uname,$file) =
 5648: 	    ($uri =~ m-/(?:uploaded|editupload)/?($match_domain)/?($match_name)/?(.*)-);
 5649: 	$file = 'userfiles/'.$file;
 5650: 	$dir = &propath($udom,$uname);
 5651:     }
 5652:     if ($uri =~ m-^/res/-) {
 5653: 	($udom,$uname) = 
 5654: 	    ($uri =~ m-/(?:res)/?($match_domain)/?($match_username)/-);
 5655: 	$file = $uri;
 5656:     }
 5657: 
 5658:     if (!$udom || !$uname || !$file) {
 5659: 	# unable to handle the uri
 5660: 	return ();
 5661:     }
 5662: 
 5663:     my ($result) = &dirlist($file,$udom,$uname,$dir);
 5664:     my @stats = split('&', $result);
 5665:     
 5666:     if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {
 5667: 	shift(@stats); #filename is first
 5668: 	return @stats;
 5669:     }
 5670:     return ();
 5671: }
 5672: 
 5673: # -------------------------------------------------------- Value of a Condition
 5674: 
 5675: # gets the value of a specific preevaluated condition
 5676: #    stored in the string  $env{user.state.<cid>}
 5677: # or looks up a condition reference in the bighash and if if hasn't
 5678: # already been evaluated recurses into docondval to get the value of
 5679: # the condition, then memoizing it to 
 5680: #   $env{user.state.<cid>.<condition>}
 5681: sub directcondval {
 5682:     my $number=shift;
 5683:     if (!defined($env{'user.state.'.$env{'request.course.id'}})) {
 5684: 	&Apache::lonuserstate::evalstate();
 5685:     }
 5686:     if (exists($env{'user.state.'.$env{'request.course.id'}.".$number"})) {
 5687: 	return $env{'user.state.'.$env{'request.course.id'}.".$number"};
 5688:     } elsif ($number =~ /^_/) {
 5689: 	my $sub_condition;
 5690: 	if (tie(my %bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
 5691: 		&GDBM_READER(),0640)) {
 5692: 	    $sub_condition=$bighash{'conditions'.$number};
 5693: 	    untie(%bighash);
 5694: 	}
 5695: 	my $value = &docondval($sub_condition);
 5696: 	&appenv('user.state.'.$env{'request.course.id'}.".$number" => $value);
 5697: 	return $value;
 5698:     }
 5699:     if ($env{'user.state.'.$env{'request.course.id'}}) {
 5700:        return substr($env{'user.state.'.$env{'request.course.id'}},$number,1);
 5701:     } else {
 5702:        return 2;
 5703:     }
 5704: }
 5705: 
 5706: # get the collection of conditions for this resource
 5707: sub condval {
 5708:     my $condidx=shift;
 5709:     my $allpathcond='';
 5710:     foreach my $cond (split(/\|/,$condidx)) {
 5711: 	if (defined($env{'acc.cond.'.$env{'request.course.id'}.'.'.$cond})) {
 5712: 	    $allpathcond.=
 5713: 		'('.$env{'acc.cond.'.$env{'request.course.id'}.'.'.$cond}.')|';
 5714: 	}
 5715:     }
 5716:     $allpathcond=~s/\|$//;
 5717:     return &docondval($allpathcond);
 5718: }
 5719: 
 5720: #evaluates an expression of conditions
 5721: sub docondval {
 5722:     my ($allpathcond) = @_;
 5723:     my $result=0;
 5724:     if ($env{'request.course.id'}
 5725: 	&& defined($allpathcond)) {
 5726: 	my $operand='|';
 5727: 	my @stack;
 5728: 	foreach my $chunk ($allpathcond=~/(\d+|_\d+\.\d+|\(|\)|\&|\|)/g) {
 5729: 	    if ($chunk eq '(') {
 5730: 		push @stack,($operand,$result);
 5731: 	    } elsif ($chunk eq ')') {
 5732: 		my $before=pop @stack;
 5733: 		if (pop @stack eq '&') {
 5734: 		    $result=$result>$before?$before:$result;
 5735: 		} else {
 5736: 		    $result=$result>$before?$result:$before;
 5737: 		}
 5738: 	    } elsif (($chunk eq '&') || ($chunk eq '|')) {
 5739: 		$operand=$chunk;
 5740: 	    } else {
 5741: 		my $new=directcondval($chunk);
 5742: 		if ($operand eq '&') {
 5743: 		    $result=$result>$new?$new:$result;
 5744: 		} else {
 5745: 		    $result=$result>$new?$result:$new;
 5746: 		}
 5747: 	    }
 5748: 	}
 5749:     }
 5750:     return $result;
 5751: }
 5752: 
 5753: # ---------------------------------------------------- Devalidate courseresdata
 5754: 
 5755: sub devalidatecourseresdata {
 5756:     my ($coursenum,$coursedomain)=@_;
 5757:     my $hashid=$coursenum.':'.$coursedomain;
 5758:     &devalidate_cache_new('courseres',$hashid);
 5759: }
 5760: 
 5761: 
 5762: # --------------------------------------------------- Course Resourcedata Query
 5763: 
 5764: sub get_courseresdata {
 5765:     my ($coursenum,$coursedomain)=@_;
 5766:     my $coursehom=&homeserver($coursenum,$coursedomain);
 5767:     my $hashid=$coursenum.':'.$coursedomain;
 5768:     my ($result,$cached)=&is_cached_new('courseres',$hashid);
 5769:     my %dumpreply;
 5770:     unless (defined($cached)) {
 5771: 	%dumpreply=&dump('resourcedata',$coursedomain,$coursenum);
 5772: 	$result=\%dumpreply;
 5773: 	my ($tmp) = keys(%dumpreply);
 5774: 	if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
 5775: 	    &do_cache_new('courseres',$hashid,$result,600);
 5776: 	} elsif ($tmp =~ /^(con_lost|no_such_host)/) {
 5777: 	    return $tmp;
 5778: 	} elsif ($tmp =~ /^(error)/) {
 5779: 	    $result=undef;
 5780: 	    &do_cache_new('courseres',$hashid,$result,600);
 5781: 	}
 5782:     }
 5783:     return $result;
 5784: }
 5785: 
 5786: sub devalidateuserresdata {
 5787:     my ($uname,$udom)=@_;
 5788:     my $hashid="$udom:$uname";
 5789:     &devalidate_cache_new('userres',$hashid);
 5790: }
 5791: 
 5792: sub get_userresdata {
 5793:     my ($uname,$udom)=@_;
 5794:     #most student don\'t have any data set, check if there is some data
 5795:     if (&EXT_cache_status($udom,$uname)) { return undef; }
 5796: 
 5797:     my $hashid="$udom:$uname";
 5798:     my ($result,$cached)=&is_cached_new('userres',$hashid);
 5799:     if (!defined($cached)) {
 5800: 	my %resourcedata=&dump('resourcedata',$udom,$uname);
 5801: 	$result=\%resourcedata;
 5802: 	&do_cache_new('userres',$hashid,$result,600);
 5803:     }
 5804:     my ($tmp)=keys(%$result);
 5805:     if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) {
 5806: 	return $result;
 5807:     }
 5808:     #error 2 occurs when the .db doesn't exist
 5809:     if ($tmp!~/error: 2 /) {
 5810: 	&logthis("<font color=\"blue\">WARNING:".
 5811: 		 " Trying to get resource data for ".
 5812: 		 $uname." at ".$udom.": ".
 5813: 		 $tmp."</font>");
 5814:     } elsif ($tmp=~/error: 2 /) {
 5815: 	#&EXT_cache_set($udom,$uname);
 5816: 	&do_cache_new('userres',$hashid,undef,600);
 5817: 	undef($tmp); # not really an error so don't send it back
 5818:     }
 5819:     return $tmp;
 5820: }
 5821: 
 5822: sub resdata {
 5823:     my ($name,$domain,$type,@which)=@_;
 5824:     my $result;
 5825:     if ($type eq 'course') {
 5826: 	$result=&get_courseresdata($name,$domain);
 5827:     } elsif ($type eq 'user') {
 5828: 	$result=&get_userresdata($name,$domain);
 5829:     }
 5830:     if (!ref($result)) { return $result; }    
 5831:     foreach my $item (@which) {
 5832: 	if (defined($result->{$item})) {
 5833: 	    return $result->{$item};
 5834: 	}
 5835:     }
 5836:     return undef;
 5837: }
 5838: 
 5839: #
 5840: # EXT resource caching routines
 5841: #
 5842: 
 5843: sub clear_EXT_cache_status {
 5844:     &delenv('cache.EXT.');
 5845: }
 5846: 
 5847: sub EXT_cache_status {
 5848:     my ($target_domain,$target_user) = @_;
 5849:     my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain;
 5850:     if (exists($env{$cachename}) && ($env{$cachename}+600) > time) {
 5851:         # We know already the user has no data
 5852:         return 1;
 5853:     } else {
 5854:         return 0;
 5855:     }
 5856: }
 5857: 
 5858: sub EXT_cache_set {
 5859:     my ($target_domain,$target_user) = @_;
 5860:     my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain;
 5861:     #&appenv($cachename => time);
 5862: }
 5863: 
 5864: # --------------------------------------------------------- Value of a Variable
 5865: sub EXT {
 5866: 
 5867:     my ($varname,$symbparm,$udom,$uname,$usection,$recurse)=@_;
 5868:     unless ($varname) { return ''; }
 5869:     #get real user name/domain, courseid and symb
 5870:     my $courseid;
 5871:     my $publicuser;
 5872:     if ($symbparm) {
 5873: 	$symbparm=&get_symb_from_alias($symbparm);
 5874:     }
 5875:     if (!($uname && $udom)) {
 5876:       (my $cursymb,$courseid,$udom,$uname,$publicuser)= &whichuser($symbparm);
 5877:       if (!$symbparm) {	$symbparm=$cursymb; }
 5878:     } else {
 5879: 	$courseid=$env{'request.course.id'};
 5880:     }
 5881:     my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);
 5882:     my $rest;
 5883:     if (defined($therest[0])) {
 5884:        $rest=join('.',@therest);
 5885:     } else {
 5886:        $rest='';
 5887:     }
 5888: 
 5889:     my $qualifierrest=$qualifier;
 5890:     if ($rest) { $qualifierrest.='.'.$rest; }
 5891:     my $spacequalifierrest=$space;
 5892:     if ($qualifierrest) { $spacequalifierrest.='.'.$qualifierrest; }
 5893:     if ($realm eq 'user') {
 5894: # --------------------------------------------------------------- user.resource
 5895: 	if ($space eq 'resource') {
 5896: 	    if ( (defined($Apache::lonhomework::parsing_a_problem)
 5897: 		  || defined($Apache::lonhomework::parsing_a_task))
 5898: 		 &&
 5899: 		 ($symbparm eq &symbread()) ) {	
 5900: 		# if we are in the middle of processing the resource the
 5901: 		# get the value we are planning on committing
 5902:                 if (defined($Apache::lonhomework::results{$qualifierrest})) {
 5903:                     return $Apache::lonhomework::results{$qualifierrest};
 5904:                 } else {
 5905:                     return $Apache::lonhomework::history{$qualifierrest};
 5906:                 }
 5907: 	    } else {
 5908: 		my %restored;
 5909: 		if ($publicuser || $env{'request.state'} eq 'construct') {
 5910: 		    %restored=&tmprestore($symbparm,$courseid,$udom,$uname);
 5911: 		} else {
 5912: 		    %restored=&restore($symbparm,$courseid,$udom,$uname);
 5913: 		}
 5914: 		return $restored{$qualifierrest};
 5915: 	    }
 5916: # ----------------------------------------------------------------- user.access
 5917:         } elsif ($space eq 'access') {
 5918: 	    # FIXME - not supporting calls for a specific user
 5919:             return &allowed($qualifier,$rest);
 5920: # ------------------------------------------ user.preferences, user.environment
 5921:         } elsif (($space eq 'preferences') || ($space eq 'environment')) {
 5922: 	    if (($uname eq $env{'user.name'}) &&
 5923: 		($udom eq $env{'user.domain'})) {
 5924: 		return $env{join('.',('environment',$qualifierrest))};
 5925: 	    } else {
 5926: 		my %returnhash;
 5927: 		if (!$publicuser) {
 5928: 		    %returnhash=&userenvironment($udom,$uname,
 5929: 						 $qualifierrest);
 5930: 		}
 5931: 		return $returnhash{$qualifierrest};
 5932: 	    }
 5933: # ----------------------------------------------------------------- user.course
 5934:         } elsif ($space eq 'course') {
 5935: 	    # FIXME - not supporting calls for a specific user
 5936:             return $env{join('.',('request.course',$qualifier))};
 5937: # ------------------------------------------------------------------- user.role
 5938:         } elsif ($space eq 'role') {
 5939: 	    # FIXME - not supporting calls for a specific user
 5940:             my ($role,$where)=split(/\./,$env{'request.role'});
 5941:             if ($qualifier eq 'value') {
 5942: 		return $role;
 5943:             } elsif ($qualifier eq 'extent') {
 5944:                 return $where;
 5945:             }
 5946: # ----------------------------------------------------------------- user.domain
 5947:         } elsif ($space eq 'domain') {
 5948:             return $udom;
 5949: # ------------------------------------------------------------------- user.name
 5950:         } elsif ($space eq 'name') {
 5951:             return $uname;
 5952: # ---------------------------------------------------- Any other user namespace
 5953:         } else {
 5954: 	    my %reply;
 5955: 	    if (!$publicuser) {
 5956: 		%reply=&get($space,[$qualifierrest],$udom,$uname);
 5957: 	    }
 5958: 	    return $reply{$qualifierrest};
 5959:         }
 5960:     } elsif ($realm eq 'query') {
 5961: # ---------------------------------------------- pull stuff out of query string
 5962:         &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'},
 5963: 						[$spacequalifierrest]);
 5964: 	return $env{'form.'.$spacequalifierrest}; 
 5965:    } elsif ($realm eq 'request') {
 5966: # ------------------------------------------------------------- request.browser
 5967:         if ($space eq 'browser') {
 5968: 	    if ($qualifier eq 'textremote') {
 5969: 		if (&Apache::lonlocal::mt('textual_remote_display') eq 'on') {
 5970: 		    return 1;
 5971: 		} else {
 5972: 		    return 0;
 5973: 		}
 5974: 	    } else {
 5975: 		return $env{'browser.'.$qualifier};
 5976: 	    }
 5977: # ------------------------------------------------------------ request.filename
 5978:         } else {
 5979:             return $env{'request.'.$spacequalifierrest};
 5980:         }
 5981:     } elsif ($realm eq 'course') {
 5982: # ---------------------------------------------------------- course.description
 5983:         return $env{'course.'.$courseid.'.'.$spacequalifierrest};
 5984:     } elsif ($realm eq 'resource') {
 5985: 
 5986: 	if (defined($courseid) && $courseid eq $env{'request.course.id'}) {
 5987: 	    if (!$symbparm) { $symbparm=&symbread(); }
 5988: 	}
 5989: 
 5990: 	if ($space eq 'title') {
 5991: 	    if (!$symbparm) { $symbparm = $env{'request.filename'}; }
 5992: 	    return &gettitle($symbparm);
 5993: 	}
 5994: 	
 5995: 	if ($space eq 'map') {
 5996: 	    my ($map) = &decode_symb($symbparm);
 5997: 	    return &symbread($map);
 5998: 	}
 5999: 
 6000: 	my ($section, $group, @groups);
 6001: 	my ($courselevelm,$courselevel);
 6002: 	if ($symbparm && defined($courseid) && 
 6003: 	    $courseid eq $env{'request.course.id'}) {
 6004: 
 6005: 	    #print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;
 6006: 
 6007: # ----------------------------------------------------- Cascading lookup scheme
 6008: 	    my $symbp=$symbparm;
 6009: 	    my $mapp=&deversion((&decode_symb($symbp))[0]);
 6010: 
 6011: 	    my $symbparm=$symbp.'.'.$spacequalifierrest;
 6012: 	    my $mapparm=$mapp.'___(all).'.$spacequalifierrest;
 6013: 
 6014: 	    if (($env{'user.name'} eq $uname) &&
 6015: 		($env{'user.domain'} eq $udom)) {
 6016: 		$section=$env{'request.course.sec'};
 6017:                 @groups = split(/:/,$env{'request.course.groups'});  
 6018:                 @groups=&sort_course_groups($courseid,@groups); 
 6019: 	    } else {
 6020: 		if (! defined($usection)) {
 6021: 		    $section=&getsection($udom,$uname,$courseid);
 6022: 		} else {
 6023: 		    $section = $usection;
 6024: 		}
 6025:                 @groups = &get_users_groups($udom,$uname,$courseid);
 6026: 	    }
 6027: 
 6028: 	    my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
 6029: 	    my $seclevelr=$courseid.'.['.$section.'].'.$symbparm;
 6030: 	    my $seclevelm=$courseid.'.['.$section.'].'.$mapparm;
 6031: 
 6032: 	    $courselevel=$courseid.'.'.$spacequalifierrest;
 6033: 	    my $courselevelr=$courseid.'.'.$symbparm;
 6034: 	    $courselevelm=$courseid.'.'.$mapparm;
 6035: 
 6036: # ----------------------------------------------------------- first, check user
 6037: 
 6038: 	    my $userreply=&resdata($uname,$udom,'user',
 6039: 				       ($courselevelr,$courselevelm,
 6040: 					$courselevel));
 6041: 	    if (defined($userreply)) { return $userreply; }
 6042: 
 6043: # ------------------------------------------------ second, check some of course
 6044:             my $coursereply;
 6045:             if (@groups > 0) {
 6046:                 $coursereply = &check_group_parms($courseid,\@groups,$symbparm,
 6047:                                        $mapparm,$spacequalifierrest);
 6048:                 if (defined($coursereply)) { return $coursereply; }
 6049:             }
 6050: 
 6051: 	    $coursereply=&resdata($env{'course.'.$courseid.'.num'},
 6052: 				     $env{'course.'.$courseid.'.domain'},
 6053: 				     'course',
 6054: 				     ($seclevelr,$seclevelm,$seclevel,
 6055: 				      $courselevelr));
 6056: 	    if (defined($coursereply)) { return $coursereply; }
 6057: 
 6058: # ------------------------------------------------------ third, check map parms
 6059: 	    my %parmhash=();
 6060: 	    my $thisparm='';
 6061: 	    if (tie(%parmhash,'GDBM_File',
 6062: 		    $env{'request.course.fn'}.'_parms.db',
 6063: 		    &GDBM_READER(),0640)) {
 6064: 		$thisparm=$parmhash{$symbparm};
 6065: 		untie(%parmhash);
 6066: 	    }
 6067: 	    if ($thisparm) { return $thisparm; }
 6068: 	}
 6069: # ------------------------------------------ fourth, look in resource metadata
 6070: 
 6071: 	$spacequalifierrest=~s/\./\_/;
 6072: 	my $filename;
 6073: 	if (!$symbparm) { $symbparm=&symbread(); }
 6074: 	if ($symbparm) {
 6075: 	    $filename=(&decode_symb($symbparm))[2];
 6076: 	} else {
 6077: 	    $filename=$env{'request.filename'};
 6078: 	}
 6079: 	my $metadata=&metadata($filename,$spacequalifierrest);
 6080: 	if (defined($metadata)) { return $metadata; }
 6081: 	$metadata=&metadata($filename,'parameter_'.$spacequalifierrest);
 6082: 	if (defined($metadata)) { return $metadata; }
 6083: 
 6084: # ---------------------------------------------- fourth, look in rest pf course
 6085: 	if ($symbparm && defined($courseid) && 
 6086: 	    $courseid eq $env{'request.course.id'}) {
 6087: 	    my $coursereply=&resdata($env{'course.'.$courseid.'.num'},
 6088: 				     $env{'course.'.$courseid.'.domain'},
 6089: 				     'course',
 6090: 				     ($courselevelm,$courselevel));
 6091: 	    if (defined($coursereply)) { return $coursereply; }
 6092: 	}
 6093: # ------------------------------------------------------------------ Cascade up
 6094: 	unless ($space eq '0') {
 6095: 	    my @parts=split(/_/,$space);
 6096: 	    my $id=pop(@parts);
 6097: 	    my $part=join('_',@parts);
 6098: 	    if ($part eq '') { $part='0'; }
 6099: 	    my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,
 6100: 				 $symbparm,$udom,$uname,$section,1);
 6101: 	    if (defined($partgeneral)) { return $partgeneral; }
 6102: 	}
 6103: 	if ($recurse) { return undef; }
 6104: 	my $pack_def=&packages_tab_default($filename,$varname);
 6105: 	if (defined($pack_def)) { return $pack_def; }
 6106: 
 6107: # ---------------------------------------------------- Any other user namespace
 6108:     } elsif ($realm eq 'environment') {
 6109: # ----------------------------------------------------------------- environment
 6110: 	if (($uname eq $env{'user.name'})&&($udom eq $env{'user.domain'})) {
 6111: 	    return $env{'environment.'.$spacequalifierrest};
 6112: 	} else {
 6113: 	    if ($uname eq 'anonymous' && $udom eq '') {
 6114: 		return '';
 6115: 	    }
 6116: 	    my %returnhash=&userenvironment($udom,$uname,
 6117: 					    $spacequalifierrest);
 6118: 	    return $returnhash{$spacequalifierrest};
 6119: 	}
 6120:     } elsif ($realm eq 'system') {
 6121: # ----------------------------------------------------------------- system.time
 6122: 	if ($space eq 'time') {
 6123: 	    return time;
 6124:         }
 6125:     } elsif ($realm eq 'server') {
 6126: # ----------------------------------------------------------------- system.time
 6127: 	if ($space eq 'name') {
 6128: 	    return $ENV{'SERVER_NAME'};
 6129:         }
 6130:     }
 6131:     return '';
 6132: }
 6133: 
 6134: sub check_group_parms {
 6135:     my ($courseid,$groups,$symbparm,$mapparm,$what) = @_;
 6136:     my @groupitems = ();
 6137:     my $resultitem;
 6138:     my @levels = ($symbparm,$mapparm,$what);
 6139:     foreach my $group (@{$groups}) {
 6140:         foreach my $level (@levels) {
 6141:              my $item = $courseid.'.['.$group.'].'.$level;
 6142:              push(@groupitems,$item);
 6143:         }
 6144:     }
 6145:     my $coursereply = &resdata($env{'course.'.$courseid.'.num'},
 6146:                             $env{'course.'.$courseid.'.domain'},
 6147:                                      'course',@groupitems);
 6148:     return $coursereply;
 6149: }
 6150: 
 6151: sub sort_course_groups { # Sort groups based on defined rankings. Default is sort().
 6152:     my ($courseid,@groups) = @_;
 6153:     @groups = sort(@groups);
 6154:     return @groups;
 6155: }
 6156: 
 6157: sub packages_tab_default {
 6158:     my ($uri,$varname)=@_;
 6159:     my (undef,$part,$name)=split(/\./,$varname);
 6160: 
 6161:     my (@extension,@specifics,$do_default);
 6162:     foreach my $package (split(/,/,&metadata($uri,'packages'))) {
 6163: 	my ($pack_type,$pack_part)=split(/_/,$package,2);
 6164: 	if ($pack_type eq 'default') {
 6165: 	    $do_default=1;
 6166: 	} elsif ($pack_type eq 'extension') {
 6167: 	    push(@extension,[$package,$pack_type,$pack_part]);
 6168: 	} else {
 6169: 	    push(@specifics,[$package,$pack_type,$pack_part]);
 6170: 	}
 6171:     }
 6172:     # first look for a package that matches the requested part id
 6173:     foreach my $package (@specifics) {
 6174: 	my (undef,$pack_type,$pack_part)=@{$package};
 6175: 	next if ($pack_part ne $part);
 6176: 	if (defined($packagetab{"$pack_type&$name&default"})) {
 6177: 	    return $packagetab{"$pack_type&$name&default"};
 6178: 	}
 6179:     }
 6180:     # look for any possible matching non extension_ package
 6181:     foreach my $package (@specifics) {
 6182: 	my (undef,$pack_type,$pack_part)=@{$package};
 6183: 	if (defined($packagetab{"$pack_type&$name&default"})) {
 6184: 	    return $packagetab{"$pack_type&$name&default"};
 6185: 	}
 6186: 	if ($pack_type eq 'part') { $pack_part='0'; }
 6187: 	if (defined($packagetab{$pack_type."_".$pack_part."&$name&default"})) {
 6188: 	    return $packagetab{$pack_type."_".$pack_part."&$name&default"};
 6189: 	}
 6190:     }
 6191:     # look for any posible extension_ match
 6192:     foreach my $package (@extension) {
 6193: 	my ($package,$pack_type)=@{$package};
 6194: 	if (defined($packagetab{"$pack_type&$name&default"})) {
 6195: 	    return $packagetab{"$pack_type&$name&default"};
 6196: 	}
 6197: 	if (defined($packagetab{$package."&$name&default"})) {
 6198: 	    return $packagetab{$package."&$name&default"};
 6199: 	}
 6200:     }
 6201:     # look for a global default setting
 6202:     if ($do_default && defined($packagetab{"default&$name&default"})) {
 6203: 	return $packagetab{"default&$name&default"};
 6204:     }
 6205:     return undef;
 6206: }
 6207: 
 6208: sub add_prefix_and_part {
 6209:     my ($prefix,$part)=@_;
 6210:     my $keyroot;
 6211:     if (defined($prefix) && $prefix !~ /^__/) {
 6212: 	# prefix that has a part already
 6213: 	$keyroot=$prefix;
 6214:     } elsif (defined($prefix)) {
 6215: 	# prefix that is missing a part
 6216: 	if (defined($part)) { $keyroot='_'.$part.substr($prefix,1); }
 6217:     } else {
 6218: 	# no prefix at all
 6219: 	if (defined($part)) { $keyroot='_'.$part; }
 6220:     }
 6221:     return $keyroot;
 6222: }
 6223: 
 6224: # ---------------------------------------------------------------- Get metadata
 6225: 
 6226: my %metaentry;
 6227: sub metadata {
 6228:     my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
 6229:     $uri=&declutter($uri);
 6230:     # if it is a non metadata possible uri return quickly
 6231:     if (($uri eq '') || 
 6232: 	(($uri =~ m|^/*adm/|) && 
 6233: 	     ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) ||
 6234:         ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) ||
 6235: 	($uri =~ m|home/$match_username/public_html/|)) {
 6236: 	return undef;
 6237:     }
 6238:     my $filename=$uri;
 6239:     $uri=~s/\.meta$//;
 6240: #
 6241: # Is the metadata already cached?
 6242: # Look at timestamp of caching
 6243: # Everything is cached by the main uri, libraries are never directly cached
 6244: #
 6245:     if (!defined($liburi)) {
 6246: 	my ($result,$cached)=&is_cached_new('meta',$uri);
 6247: 	if (defined($cached)) { return $result->{':'.$what}; }
 6248:     }
 6249:     {
 6250: #
 6251: # Is this a recursive call for a library?
 6252: #
 6253: #	if (! exists($metacache{$uri})) {
 6254: #	    $metacache{$uri}={};
 6255: #	}
 6256:         if ($liburi) {
 6257: 	    $liburi=&declutter($liburi);
 6258:             $filename=$liburi;
 6259:         } else {
 6260: 	    &devalidate_cache_new('meta',$uri);
 6261: 	    undef(%metaentry);
 6262: 	}
 6263:         my %metathesekeys=();
 6264:         unless ($filename=~/\.meta$/) { $filename.='.meta'; }
 6265: 	my $metastring;
 6266: 	if ($uri !~ m -^(editupload)/-) {
 6267: 	    my $file=&filelocation('',&clutter($filename));
 6268: 	    #push(@{$metaentry{$uri.'.file'}},$file);
 6269: 	    $metastring=&getfile($file);
 6270: 	}
 6271:         my $parser=HTML::LCParser->new(\$metastring);
 6272:         my $token;
 6273:         undef %metathesekeys;
 6274:         while ($token=$parser->get_token) {
 6275: 	    if ($token->[0] eq 'S') {
 6276: 		if (defined($token->[2]->{'package'})) {
 6277: #
 6278: # This is a package - get package info
 6279: #
 6280: 		    my $package=$token->[2]->{'package'};
 6281: 		    my $keyroot=&add_prefix_and_part($prefix,$token->[2]->{'part'});
 6282: 		    if (defined($token->[2]->{'id'})) { 
 6283: 			$keyroot.='_'.$token->[2]->{'id'}; 
 6284: 		    }
 6285: 		    if ($metaentry{':packages'}) {
 6286: 			$metaentry{':packages'}.=','.$package.$keyroot;
 6287: 		    } else {
 6288: 			$metaentry{':packages'}=$package.$keyroot;
 6289: 		    }
 6290: 		    foreach my $pack_entry (keys(%packagetab)) {
 6291: 			my $part=$keyroot;
 6292: 			$part=~s/^\_//;
 6293: 			if ($pack_entry=~/^\Q$package\E\&/ || 
 6294: 			    $pack_entry=~/^\Q$package\E_0\&/) {
 6295: 			    my ($pack,$name,$subp)=split(/\&/,$pack_entry);
 6296: 			    # ignore package.tab specified default values
 6297:                             # here &package_tab_default() will fetch those
 6298: 			    if ($subp eq 'default') { next; }
 6299: 			    my $value=$packagetab{$pack_entry};
 6300: 			    my $unikey;
 6301: 			    if ($pack =~ /_0$/) {
 6302: 				$unikey='parameter_0_'.$name;
 6303: 				$part=0;
 6304: 			    } else {
 6305: 				$unikey='parameter'.$keyroot.'_'.$name;
 6306: 			    }
 6307: 			    if ($subp eq 'display') {
 6308: 				$value.=' [Part: '.$part.']';
 6309: 			    }
 6310: 			    $metaentry{':'.$unikey.'.part'}=$part;
 6311: 			    $metathesekeys{$unikey}=1;
 6312: 			    unless (defined($metaentry{':'.$unikey.'.'.$subp})) {
 6313: 				$metaentry{':'.$unikey.'.'.$subp}=$value;
 6314: 			    }
 6315: 			    if (defined($metaentry{':'.$unikey.'.default'})) {
 6316: 				$metaentry{':'.$unikey}=
 6317: 				    $metaentry{':'.$unikey.'.default'};
 6318: 			    }
 6319: 			}
 6320: 		    }
 6321: 		} else {
 6322: #
 6323: # This is not a package - some other kind of start tag
 6324: #
 6325: 		    my $entry=$token->[1];
 6326: 		    my $unikey;
 6327: 		    if ($entry eq 'import') {
 6328: 			$unikey='';
 6329: 		    } else {
 6330: 			$unikey=$entry;
 6331: 		    }
 6332: 		    $unikey.=&add_prefix_and_part($prefix,$token->[2]->{'part'});
 6333: 
 6334: 		    if (defined($token->[2]->{'id'})) { 
 6335: 			$unikey.='_'.$token->[2]->{'id'}; 
 6336: 		    }
 6337: 
 6338: 		    if ($entry eq 'import') {
 6339: #
 6340: # Importing a library here
 6341: #
 6342: 			if ($depthcount<20) {
 6343: 			    my $location=$parser->get_text('/import');
 6344: 			    my $dir=$filename;
 6345: 			    $dir=~s|[^/]*$||;
 6346: 			    $location=&filelocation($dir,$location);
 6347: 			    my $metadata = 
 6348: 				&metadata($uri,'keys', $location,$unikey,
 6349: 					  $depthcount+1);
 6350: 			    foreach my $meta (split(',',$metadata)) {
 6351: 				$metaentry{':'.$meta}=$metaentry{':'.$meta};
 6352: 				$metathesekeys{$meta}=1;
 6353: 			    }
 6354: 			}
 6355: 		    } else { 
 6356: 			
 6357: 			if (defined($token->[2]->{'name'})) { 
 6358: 			    $unikey.='_'.$token->[2]->{'name'}; 
 6359: 			}
 6360: 			$metathesekeys{$unikey}=1;
 6361: 			foreach my $param (@{$token->[3]}) {
 6362: 			    $metaentry{':'.$unikey.'.'.$param} =
 6363: 				$token->[2]->{$param};
 6364: 			}
 6365: 			my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));
 6366: 			my $default=$metaentry{':'.$unikey.'.default'};
 6367: 			if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) {
 6368: 		 # only ws inside the tag, and not in default, so use default
 6369: 		 # as value
 6370: 			    $metaentry{':'.$unikey}=$default;
 6371: 			} else {
 6372: 		  # either something interesting inside the tag or default
 6373:                   # uninteresting
 6374: 			    $metaentry{':'.$unikey}=$internaltext;
 6375: 			}
 6376: # end of not-a-package not-a-library import
 6377: 		    }
 6378: # end of not-a-package start tag
 6379: 		}
 6380: # the next is the end of "start tag"
 6381: 	    }
 6382: 	}
 6383: 	my ($extension) = ($uri =~ /\.(\w+)$/);
 6384: 	foreach my $key (keys(%packagetab)) {
 6385: 	    #no specific packages #how's our extension
 6386: 	    if ($key!~/^extension_\Q$extension\E&/) { next; }
 6387: 	    &metadata_create_package_def($uri,$key,'extension_'.$extension,
 6388: 					 \%metathesekeys);
 6389: 	}
 6390: 	if (!exists($metaentry{':packages'})) {
 6391: 	    foreach my $key (keys(%packagetab)) {
 6392: 		#no specific packages well let's get default then
 6393: 		if ($key!~/^default&/) { next; }
 6394: 		&metadata_create_package_def($uri,$key,'default',
 6395: 					     \%metathesekeys);
 6396: 	    }
 6397: 	}
 6398: # are there custom rights to evaluate
 6399: 	if ($metaentry{':copyright'} eq 'custom') {
 6400: 
 6401:     #
 6402:     # Importing a rights file here
 6403:     #
 6404: 	    unless ($depthcount) {
 6405: 		my $location=$metaentry{':customdistributionfile'};
 6406: 		my $dir=$filename;
 6407: 		$dir=~s|[^/]*$||;
 6408: 		$location=&filelocation($dir,$location);
 6409: 		my $rights_metadata =
 6410: 		    &metadata($uri,'keys',$location,'_rights',
 6411: 			      $depthcount+1);
 6412: 		foreach my $rights (split(',',$rights_metadata)) {
 6413: 		    #$metaentry{':'.$rights}=$metacache{$uri}->{':'.$rights};
 6414: 		    $metathesekeys{$rights}=1;
 6415: 		}
 6416: 	    }
 6417: 	}
 6418: 	# uniqifiy package listing
 6419: 	my %seen;
 6420: 	my @uniq_packages =
 6421: 	    grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'}));
 6422: 	$metaentry{':packages'} = join(',',@uniq_packages);
 6423: 
 6424: 	$metaentry{':keys'} = join(',',keys(%metathesekeys));
 6425: 	&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
 6426: 	$metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);
 6427: 	&do_cache_new('meta',$uri,\%metaentry,60*60);
 6428: # this is the end of "was not already recently cached
 6429:     }
 6430:     return $metaentry{':'.$what};
 6431: }
 6432: 
 6433: sub metadata_create_package_def {
 6434:     my ($uri,$key,$package,$metathesekeys)=@_;
 6435:     my ($pack,$name,$subp)=split(/\&/,$key);
 6436:     if ($subp eq 'default') { next; }
 6437:     
 6438:     if (defined($metaentry{':packages'})) {
 6439: 	$metaentry{':packages'}.=','.$package;
 6440:     } else {
 6441: 	$metaentry{':packages'}=$package;
 6442:     }
 6443:     my $value=$packagetab{$key};
 6444:     my $unikey;
 6445:     $unikey='parameter_0_'.$name;
 6446:     $metaentry{':'.$unikey.'.part'}=0;
 6447:     $$metathesekeys{$unikey}=1;
 6448:     unless (defined($metaentry{':'.$unikey.'.'.$subp})) {
 6449: 	$metaentry{':'.$unikey.'.'.$subp}=$value;
 6450:     }
 6451:     if (defined($metaentry{':'.$unikey.'.default'})) {
 6452: 	$metaentry{':'.$unikey}=
 6453: 	    $metaentry{':'.$unikey.'.default'};
 6454:     }
 6455: }
 6456: 
 6457: sub metadata_generate_part0 {
 6458:     my ($metadata,$metacache,$uri) = @_;
 6459:     my %allnames;
 6460:     foreach my $metakey (keys(%$metadata)) {
 6461: 	if ($metakey=~/^parameter\_(.*)/) {
 6462: 	  my $part=$$metacache{':'.$metakey.'.part'};
 6463: 	  my $name=$$metacache{':'.$metakey.'.name'};
 6464: 	  if (! exists($$metadata{'parameter_0_'.$name.'.name'})) {
 6465: 	    $allnames{$name}=$part;
 6466: 	  }
 6467: 	}
 6468:     }
 6469:     foreach my $name (keys(%allnames)) {
 6470:       $$metadata{"parameter_0_$name"}=1;
 6471:       my $key=":parameter_0_$name";
 6472:       $$metacache{"$key.part"}='0';
 6473:       $$metacache{"$key.name"}=$name;
 6474:       $$metacache{"$key.type"}=$$metacache{':parameter_'.
 6475: 					   $allnames{$name}.'_'.$name.
 6476: 					   '.type'};
 6477:       my $olddis=$$metacache{':parameter_'.$allnames{$name}.'_'.$name.
 6478: 			     '.display'};
 6479:       my $expr='[Part: '.$allnames{$name}.']';
 6480:       $olddis=~s/\Q$expr\E/\[Part: 0\]/;
 6481:       $$metacache{"$key.display"}=$olddis;
 6482:     }
 6483: }
 6484: 
 6485: # ------------------------------------------------------ Devalidate title cache
 6486: 
 6487: sub devalidate_title_cache {
 6488:     my ($url)=@_;
 6489:     if (!$env{'request.course.id'}) { return; }
 6490:     my $symb=&symbread($url);
 6491:     if (!$symb) { return; }
 6492:     my $key=$env{'request.course.id'}."\0".$symb;
 6493:     &devalidate_cache_new('title',$key);
 6494: }
 6495: 
 6496: # ------------------------------------------------- Get the title of a resource
 6497: 
 6498: sub gettitle {
 6499:     my $urlsymb=shift;
 6500:     my $symb=&symbread($urlsymb);
 6501:     if ($symb) {
 6502: 	my $key=$env{'request.course.id'}."\0".$symb;
 6503: 	my ($result,$cached)=&is_cached_new('title',$key);
 6504: 	if (defined($cached)) { 
 6505: 	    return $result;
 6506: 	}
 6507: 	my ($map,$resid,$url)=&decode_symb($symb);
 6508: 	my $title='';
 6509: 	my %bighash;
 6510: 	if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
 6511: 		&GDBM_READER(),0640)) {
 6512: 	    my $mapid=$bighash{'map_pc_'.&clutter($map)};
 6513: 	    $title=$bighash{'title_'.$mapid.'.'.$resid};
 6514: 	    untie %bighash;
 6515: 	}
 6516: 	$title=~s/\&colon\;/\:/gs;
 6517: 	if ($title) {
 6518: 	    return &do_cache_new('title',$key,$title,600);
 6519: 	}
 6520: 	$urlsymb=$url;
 6521:     }
 6522:     my $title=&metadata($urlsymb,'title');
 6523:     if (!$title) { $title=(split('/',$urlsymb))[-1]; }    
 6524:     return $title;
 6525: }
 6526: 
 6527: sub get_slot {
 6528:     my ($which,$cnum,$cdom)=@_;
 6529:     if (!$cnum || !$cdom) {
 6530: 	(undef,my $courseid)=&whichuser();
 6531: 	$cdom=$env{'course.'.$courseid.'.domain'};
 6532: 	$cnum=$env{'course.'.$courseid.'.num'};
 6533:     }
 6534:     my $key=join("\0",'slots',$cdom,$cnum,$which);
 6535:     my %slotinfo;
 6536:     if (exists($remembered{$key})) {
 6537: 	$slotinfo{$which} = $remembered{$key};
 6538:     } else {
 6539: 	%slotinfo=&get('slots',[$which],$cdom,$cnum);
 6540: 	&Apache::lonhomework::showhash(%slotinfo);
 6541: 	my ($tmp)=keys(%slotinfo);
 6542: 	if ($tmp=~/^error:/) { return (); }
 6543: 	$remembered{$key} = $slotinfo{$which};
 6544:     }
 6545:     if (ref($slotinfo{$which}) eq 'HASH') {
 6546: 	return %{$slotinfo{$which}};
 6547:     }
 6548:     return $slotinfo{$which};
 6549: }
 6550: # ------------------------------------------------- Update symbolic store links
 6551: 
 6552: sub symblist {
 6553:     my ($mapname,%newhash)=@_;
 6554:     $mapname=&deversion(&declutter($mapname));
 6555:     my %hash;
 6556:     if (($env{'request.course.fn'}) && (%newhash)) {
 6557:         if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
 6558:                       &GDBM_WRCREAT(),0640)) {
 6559: 	    foreach my $url (keys %newhash) {
 6560: 		next if ($url eq 'last_known'
 6561: 			 && $env{'form.no_update_last_known'});
 6562: 		$hash{declutter($url)}=&encode_symb($mapname,
 6563: 						    $newhash{$url}->[1],
 6564: 						    $newhash{$url}->[0]);
 6565:             }
 6566:             if (untie(%hash)) {
 6567: 		return 'ok';
 6568:             }
 6569:         }
 6570:     }
 6571:     return 'error';
 6572: }
 6573: 
 6574: # --------------------------------------------------------------- Verify a symb
 6575: 
 6576: sub symbverify {
 6577:     my ($symb,$thisurl)=@_;
 6578:     my $thisfn=$thisurl;
 6579:     $thisfn=&declutter($thisfn);
 6580: # direct jump to resource in page or to a sequence - will construct own symbs
 6581:     if ($thisfn=~/\.(page|sequence)$/) { return 1; }
 6582: # check URL part
 6583:     my ($map,$resid,$url)=&decode_symb($symb);
 6584: 
 6585:     unless ($url eq $thisfn) { return 0; }
 6586: 
 6587:     $symb=&symbclean($symb);
 6588:     $thisurl=&deversion($thisurl);
 6589:     $thisfn=&deversion($thisfn);
 6590: 
 6591:     my %bighash;
 6592:     my $okay=0;
 6593: 
 6594:     if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
 6595:                             &GDBM_READER(),0640)) {
 6596:         my $ids=$bighash{'ids_'.&clutter($thisurl)};
 6597:         unless ($ids) { 
 6598:            $ids=$bighash{'ids_/'.$thisurl};
 6599:         }
 6600:         if ($ids) {
 6601: # ------------------------------------------------------------------- Has ID(s)
 6602: 	    foreach my $id (split(/\,/,$ids)) {
 6603: 	       my ($mapid,$resid)=split(/\./,$id);
 6604:                if (
 6605:   &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)
 6606:    eq $symb) { 
 6607: 		   if (($env{'request.role.adv'}) ||
 6608: 		       $bighash{'encrypted_'.$id} eq $env{'request.enc'}) {
 6609: 		       $okay=1; 
 6610: 		   }
 6611: 	       }
 6612: 	   }
 6613:         }
 6614: 	untie(%bighash);
 6615:     }
 6616:     return $okay;
 6617: }
 6618: 
 6619: # --------------------------------------------------------------- Clean-up symb
 6620: 
 6621: sub symbclean {
 6622:     my $symb=shift;
 6623:     if ($symb=~m|^/enc/|) { $symb=&Apache::lonenc::unencrypted($symb); }
 6624: # remove version from map
 6625:     $symb=~s/\.(\d+)\.(\w+)\_\_\_/\.$2\_\_\_/;
 6626: 
 6627: # remove version from URL
 6628:     $symb=~s/\.(\d+)\.(\w+)$/\.$2/;
 6629: 
 6630: # remove wrapper
 6631: 
 6632:     $symb=~s/(\_\_\_\d+\_\_\_)adm\/wrapper\/(res\/)*/$1/;
 6633:     $symb=~s/(\_\_\_\d+\_\_\_)adm\/coursedocs\/showdoc\/(res\/)*/$1/;
 6634:     return $symb;
 6635: }
 6636: 
 6637: # ---------------------------------------------- Split symb to find map and url
 6638: 
 6639: sub encode_symb {
 6640:     my ($map,$resid,$url)=@_;
 6641:     return &symbclean(&declutter($map).'___'.$resid.'___'.&declutter($url));
 6642: }
 6643: 
 6644: sub decode_symb {
 6645:     my $symb=shift;
 6646:     if ($symb=~m|^/enc/|) { $symb=&Apache::lonenc::unencrypted($symb); }
 6647:     my ($map,$resid,$url)=split(/___/,$symb);
 6648:     return (&fixversion($map),$resid,&fixversion($url));
 6649: }
 6650: 
 6651: sub fixversion {
 6652:     my $fn=shift;
 6653:     if ($fn=~/^(adm|uploaded|editupload|public)/) { return $fn; }
 6654:     my %bighash;
 6655:     my $uri=&clutter($fn);
 6656:     my $key=$env{'request.course.id'}.'_'.$uri;
 6657: # is this cached?
 6658:     my ($result,$cached)=&is_cached_new('courseresversion',$key);
 6659:     if (defined($cached)) { return $result; }
 6660: # unfortunately not cached, or expired
 6661:     if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
 6662: 	    &GDBM_READER(),0640)) {
 6663:  	if ($bighash{'version_'.$uri}) {
 6664:  	    my $version=$bighash{'version_'.$uri};
 6665:  	    unless (($version eq 'mostrecent') || 
 6666: 		    ($version==&getversion($uri))) {
 6667:  		$uri=~s/\.(\w+)$/\.$version\.$1/;
 6668:  	    }
 6669:  	}
 6670:  	untie %bighash;
 6671:     }
 6672:     return &do_cache_new('courseresversion',$key,&declutter($uri),600);
 6673: }
 6674: 
 6675: sub deversion {
 6676:     my $url=shift;
 6677:     $url=~s/\.\d+\.(\w+)$/\.$1/;
 6678:     return $url;
 6679: }
 6680: 
 6681: # ------------------------------------------------------ Return symb list entry
 6682: 
 6683: sub symbread {
 6684:     my ($thisfn,$donotrecurse)=@_;
 6685:     my $cache_str='request.symbread.cached.'.$thisfn;
 6686:     if (defined($env{$cache_str})) { return $env{$cache_str}; }
 6687: # no filename provided? try from environment
 6688:     unless ($thisfn) {
 6689:         if ($env{'request.symb'}) {
 6690: 	    return $env{$cache_str}=&symbclean($env{'request.symb'});
 6691: 	}
 6692: 	$thisfn=$env{'request.filename'};
 6693:     }
 6694:     if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }
 6695: # is that filename actually a symb? Verify, clean, and return
 6696:     if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) {
 6697: 	if (&symbverify($thisfn,$1)) {
 6698: 	    return $env{$cache_str}=&symbclean($thisfn);
 6699: 	}
 6700:     }
 6701:     $thisfn=declutter($thisfn);
 6702:     my %hash;
 6703:     my %bighash;
 6704:     my $syval='';
 6705:     if (($env{'request.course.fn'}) && ($thisfn)) {
 6706:         my $targetfn = $thisfn;
 6707:         if ( ($thisfn =~ m/^(uploaded|editupload)\//) && ($thisfn !~ m/\.(page|sequence)$/) ) {
 6708:             $targetfn = 'adm/wrapper/'.$thisfn;
 6709:         }
 6710: 	if ($targetfn =~ m|^adm/wrapper/(ext/.*)|) {
 6711: 	    $targetfn=$1;
 6712: 	}
 6713:         if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
 6714:                       &GDBM_READER(),0640)) {
 6715: 	    $syval=$hash{$targetfn};
 6716:             untie(%hash);
 6717:         }
 6718: # ---------------------------------------------------------- There was an entry
 6719:         if ($syval) {
 6720: 	    #unless ($syval=~/\_\d+$/) {
 6721: 		#unless ($env{'form.request.prefix'}=~/\.(\d+)\_$/) {
 6722: 		    #&appenv('request.ambiguous' => $thisfn);
 6723: 		    #return $env{$cache_str}='';
 6724: 		#}    
 6725: 		#$syval.=$1;
 6726: 	    #}
 6727:         } else {
 6728: # ------------------------------------------------------- Was not in symb table
 6729:            if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
 6730:                             &GDBM_READER(),0640)) {
 6731: # ---------------------------------------------- Get ID(s) for current resource
 6732:               my $ids=$bighash{'ids_'.&clutter($thisfn)};
 6733:               unless ($ids) { 
 6734:                  $ids=$bighash{'ids_/'.$thisfn};
 6735:               }
 6736:               unless ($ids) {
 6737: # alias?
 6738: 		  $ids=$bighash{'mapalias_'.$thisfn};
 6739:               }
 6740:               if ($ids) {
 6741: # ------------------------------------------------------------------- Has ID(s)
 6742:                  my @possibilities=split(/\,/,$ids);
 6743:                  if ($#possibilities==0) {
 6744: # ----------------------------------------------- There is only one possibility
 6745: 		     my ($mapid,$resid)=split(/\./,$ids);
 6746: 		     $syval=&encode_symb($bighash{'map_id_'.$mapid},
 6747: 						    $resid,$thisfn);
 6748:                  } elsif (!$donotrecurse) {
 6749: # ------------------------------------------ There is more than one possibility
 6750:                      my $realpossible=0;
 6751:                      foreach my $id (@possibilities) {
 6752: 			 my $file=$bighash{'src_'.$id};
 6753:                          if (&allowed('bre',$file)) {
 6754:          		    my ($mapid,$resid)=split(/\./,$id);
 6755:                             if ($bighash{'map_type_'.$mapid} ne 'page') {
 6756: 				$realpossible++;
 6757:                                 $syval=&encode_symb($bighash{'map_id_'.$mapid},
 6758: 						    $resid,$thisfn);
 6759:                             }
 6760: 			 }
 6761:                      }
 6762: 		     if ($realpossible!=1) { $syval=''; }
 6763:                  } else {
 6764:                      $syval='';
 6765:                  }
 6766: 	      }
 6767:               untie(%bighash)
 6768:            }
 6769:         }
 6770:         if ($syval) {
 6771: 	    return $env{$cache_str}=$syval;
 6772:         }
 6773:     }
 6774:     &appenv('request.ambiguous' => $thisfn);
 6775:     return $env{$cache_str}='';
 6776: }
 6777: 
 6778: # ---------------------------------------------------------- Return random seed
 6779: 
 6780: sub numval {
 6781:     my $txt=shift;
 6782:     $txt=~tr/A-J/0-9/;
 6783:     $txt=~tr/a-j/0-9/;
 6784:     $txt=~tr/K-T/0-9/;
 6785:     $txt=~tr/k-t/0-9/;
 6786:     $txt=~tr/U-Z/0-5/;
 6787:     $txt=~tr/u-z/0-5/;
 6788:     $txt=~s/\D//g;
 6789:     if ($_64bit) { if ($txt > 2**32) { return -1; } }
 6790:     return int($txt);
 6791: }
 6792: 
 6793: sub numval2 {
 6794:     my $txt=shift;
 6795:     $txt=~tr/A-J/0-9/;
 6796:     $txt=~tr/a-j/0-9/;
 6797:     $txt=~tr/K-T/0-9/;
 6798:     $txt=~tr/k-t/0-9/;
 6799:     $txt=~tr/U-Z/0-5/;
 6800:     $txt=~tr/u-z/0-5/;
 6801:     $txt=~s/\D//g;
 6802:     my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt);
 6803:     my $total;
 6804:     foreach my $val (@txts) { $total+=$val; }
 6805:     if ($_64bit) { if ($total > 2**32) { return -1; } }
 6806:     return int($total);
 6807: }
 6808: 
 6809: sub numval3 {
 6810:     use integer;
 6811:     my $txt=shift;
 6812:     $txt=~tr/A-J/0-9/;
 6813:     $txt=~tr/a-j/0-9/;
 6814:     $txt=~tr/K-T/0-9/;
 6815:     $txt=~tr/k-t/0-9/;
 6816:     $txt=~tr/U-Z/0-5/;
 6817:     $txt=~tr/u-z/0-5/;
 6818:     $txt=~s/\D//g;
 6819:     my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt);
 6820:     my $total;
 6821:     foreach my $val (@txts) { $total+=$val; }
 6822:     if ($_64bit) { $total=(($total<<32)>>32); }
 6823:     return $total;
 6824: }
 6825: 
 6826: sub digest {
 6827:     my ($data)=@_;
 6828:     my $digest=&Digest::MD5::md5($data);
 6829:     my ($a,$b,$c,$d)=unpack("iiii",$digest);
 6830:     my ($e,$f);
 6831:     {
 6832:         use integer;
 6833:         $e=($a+$b);
 6834:         $f=($c+$d);
 6835:         if ($_64bit) {
 6836:             $e=(($e<<32)>>32);
 6837:             $f=(($f<<32)>>32);
 6838:         }
 6839:     }
 6840:     if (wantarray) {
 6841: 	return ($e,$f);
 6842:     } else {
 6843: 	my $g;
 6844: 	{
 6845: 	    use integer;
 6846: 	    $g=($e+$f);
 6847: 	    if ($_64bit) {
 6848: 		$g=(($g<<32)>>32);
 6849: 	    }
 6850: 	}
 6851: 	return $g;
 6852:     }
 6853: }
 6854: 
 6855: sub latest_rnd_algorithm_id {
 6856:     return '64bit5';
 6857: }
 6858: 
 6859: sub get_rand_alg {
 6860:     my ($courseid)=@_;
 6861:     if (!$courseid) { $courseid=(&whichuser())[1]; }
 6862:     if ($courseid) {
 6863: 	return $env{"course.$courseid.rndseed"};
 6864:     }
 6865:     return &latest_rnd_algorithm_id();
 6866: }
 6867: 
 6868: sub validCODE {
 6869:     my ($CODE)=@_;
 6870:     if (defined($CODE) && $CODE ne '' && $CODE =~ /^\w+$/) { return 1; }
 6871:     return 0;
 6872: }
 6873: 
 6874: sub getCODE {
 6875:     if (&validCODE($env{'form.CODE'})) { return $env{'form.CODE'}; }
 6876:     if ( (defined($Apache::lonhomework::parsing_a_problem) ||
 6877: 	  defined($Apache::lonhomework::parsing_a_task) ) &&
 6878: 	 &validCODE($Apache::lonhomework::history{'resource.CODE'})) {
 6879: 	return $Apache::lonhomework::history{'resource.CODE'};
 6880:     }
 6881:     return undef;
 6882: }
 6883: 
 6884: sub rndseed {
 6885:     my ($symb,$courseid,$domain,$username)=@_;
 6886: 
 6887:     my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser();
 6888:     if (!$symb) {
 6889: 	unless ($symb=$wsymb) { return time; }
 6890:     }
 6891:     if (!$courseid) { $courseid=$wcourseid; }
 6892:     if (!$domain) { $domain=$wdomain; }
 6893:     if (!$username) { $username=$wusername }
 6894:     my $which=&get_rand_alg();
 6895: 
 6896:     if (defined(&getCODE())) {
 6897: 	if ($which eq '64bit5') {
 6898: 	    return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username);
 6899: 	} elsif ($which eq '64bit4') {
 6900: 	    return &rndseed_CODE_64bit4($symb,$courseid,$domain,$username);
 6901: 	} else {
 6902: 	    return &rndseed_CODE_64bit($symb,$courseid,$domain,$username);
 6903: 	}
 6904:     } elsif ($which eq '64bit5') {
 6905: 	return &rndseed_64bit5($symb,$courseid,$domain,$username);
 6906:     } elsif ($which eq '64bit4') {
 6907: 	return &rndseed_64bit4($symb,$courseid,$domain,$username);
 6908:     } elsif ($which eq '64bit3') {
 6909: 	return &rndseed_64bit3($symb,$courseid,$domain,$username);
 6910:     } elsif ($which eq '64bit2') {
 6911: 	return &rndseed_64bit2($symb,$courseid,$domain,$username);
 6912:     } elsif ($which eq '64bit') {
 6913: 	return &rndseed_64bit($symb,$courseid,$domain,$username);
 6914:     }
 6915:     return &rndseed_32bit($symb,$courseid,$domain,$username);
 6916: }
 6917: 
 6918: sub rndseed_32bit {
 6919:     my ($symb,$courseid,$domain,$username)=@_;
 6920:     {
 6921: 	use integer;
 6922: 	my $symbchck=unpack("%32C*",$symb) << 27;
 6923: 	my $symbseed=numval($symb) << 22;
 6924: 	my $namechck=unpack("%32C*",$username) << 17;
 6925: 	my $nameseed=numval($username) << 12;
 6926: 	my $domainseed=unpack("%32C*",$domain) << 7;
 6927: 	my $courseseed=unpack("%32C*",$courseid);
 6928: 	my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;
 6929: 	#&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
 6930: 	#&logthis("rndseed :$num:$symb");
 6931: 	if ($_64bit) { $num=(($num<<32)>>32); }
 6932: 	return $num;
 6933:     }
 6934: }
 6935: 
 6936: sub rndseed_64bit {
 6937:     my ($symb,$courseid,$domain,$username)=@_;
 6938:     {
 6939: 	use integer;
 6940: 	my $symbchck=unpack("%32S*",$symb) << 21;
 6941: 	my $symbseed=numval($symb) << 10;
 6942: 	my $namechck=unpack("%32S*",$username);
 6943: 	
 6944: 	my $nameseed=numval($username) << 21;
 6945: 	my $domainseed=unpack("%32S*",$domain) << 10;
 6946: 	my $courseseed=unpack("%32S*",$courseid);
 6947: 	
 6948: 	my $num1=$symbchck+$symbseed+$namechck;
 6949: 	my $num2=$nameseed+$domainseed+$courseseed;
 6950: 	#&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
 6951: 	#&logthis("rndseed :$num:$symb");
 6952: 	if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
 6953: 	return "$num1,$num2";
 6954:     }
 6955: }
 6956: 
 6957: sub rndseed_64bit2 {
 6958:     my ($symb,$courseid,$domain,$username)=@_;
 6959:     {
 6960: 	use integer;
 6961: 	# strings need to be an even # of cahracters long, it it is odd the
 6962:         # last characters gets thrown away
 6963: 	my $symbchck=unpack("%32S*",$symb.' ') << 21;
 6964: 	my $symbseed=numval($symb) << 10;
 6965: 	my $namechck=unpack("%32S*",$username.' ');
 6966: 	
 6967: 	my $nameseed=numval($username) << 21;
 6968: 	my $domainseed=unpack("%32S*",$domain.' ') << 10;
 6969: 	my $courseseed=unpack("%32S*",$courseid.' ');
 6970: 	
 6971: 	my $num1=$symbchck+$symbseed+$namechck;
 6972: 	my $num2=$nameseed+$domainseed+$courseseed;
 6973: 	#&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
 6974: 	#&logthis("rndseed :$num:$symb");
 6975: 	if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
 6976: 	return "$num1,$num2";
 6977:     }
 6978: }
 6979: 
 6980: sub rndseed_64bit3 {
 6981:     my ($symb,$courseid,$domain,$username)=@_;
 6982:     {
 6983: 	use integer;
 6984: 	# strings need to be an even # of cahracters long, it it is odd the
 6985:         # last characters gets thrown away
 6986: 	my $symbchck=unpack("%32S*",$symb.' ') << 21;
 6987: 	my $symbseed=numval2($symb) << 10;
 6988: 	my $namechck=unpack("%32S*",$username.' ');
 6989: 	
 6990: 	my $nameseed=numval2($username) << 21;
 6991: 	my $domainseed=unpack("%32S*",$domain.' ') << 10;
 6992: 	my $courseseed=unpack("%32S*",$courseid.' ');
 6993: 	
 6994: 	my $num1=$symbchck+$symbseed+$namechck;
 6995: 	my $num2=$nameseed+$domainseed+$courseseed;
 6996: 	#&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
 6997: 	#&logthis("rndseed :$num1:$num2:$_64bit");
 6998: 	if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
 6999: 	
 7000: 	return "$num1:$num2";
 7001:     }
 7002: }
 7003: 
 7004: sub rndseed_64bit4 {
 7005:     my ($symb,$courseid,$domain,$username)=@_;
 7006:     {
 7007: 	use integer;
 7008: 	# strings need to be an even # of cahracters long, it it is odd the
 7009:         # last characters gets thrown away
 7010: 	my $symbchck=unpack("%32S*",$symb.' ') << 21;
 7011: 	my $symbseed=numval3($symb) << 10;
 7012: 	my $namechck=unpack("%32S*",$username.' ');
 7013: 	
 7014: 	my $nameseed=numval3($username) << 21;
 7015: 	my $domainseed=unpack("%32S*",$domain.' ') << 10;
 7016: 	my $courseseed=unpack("%32S*",$courseid.' ');
 7017: 	
 7018: 	my $num1=$symbchck+$symbseed+$namechck;
 7019: 	my $num2=$nameseed+$domainseed+$courseseed;
 7020: 	#&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
 7021: 	#&logthis("rndseed :$num1:$num2:$_64bit");
 7022: 	if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
 7023: 	
 7024: 	return "$num1:$num2";
 7025:     }
 7026: }
 7027: 
 7028: sub rndseed_64bit5 {
 7029:     my ($symb,$courseid,$domain,$username)=@_;
 7030:     my ($num1,$num2)=&digest("$symb,$courseid,$domain,$username");
 7031:     return "$num1:$num2";
 7032: }
 7033: 
 7034: sub rndseed_CODE_64bit {
 7035:     my ($symb,$courseid,$domain,$username)=@_;
 7036:     {
 7037: 	use integer;
 7038: 	my $symbchck=unpack("%32S*",$symb.' ') << 16;
 7039: 	my $symbseed=numval2($symb);
 7040: 	my $CODEchck=unpack("%32S*",&getCODE().' ') << 16;
 7041: 	my $CODEseed=numval(&getCODE());
 7042: 	my $courseseed=unpack("%32S*",$courseid.' ');
 7043: 	my $num1=$symbseed+$CODEchck;
 7044: 	my $num2=$CODEseed+$courseseed+$symbchck;
 7045: 	#&logthis("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck");
 7046: 	#&logthis("rndseed :$num1:$num2:$symb");
 7047: 	if ($_64bit) { $num1=(($num1<<32)>>32); }
 7048: 	if ($_64bit) { $num2=(($num2<<32)>>32); }
 7049: 	return "$num1:$num2";
 7050:     }
 7051: }
 7052: 
 7053: sub rndseed_CODE_64bit4 {
 7054:     my ($symb,$courseid,$domain,$username)=@_;
 7055:     {
 7056: 	use integer;
 7057: 	my $symbchck=unpack("%32S*",$symb.' ') << 16;
 7058: 	my $symbseed=numval3($symb);
 7059: 	my $CODEchck=unpack("%32S*",&getCODE().' ') << 16;
 7060: 	my $CODEseed=numval3(&getCODE());
 7061: 	my $courseseed=unpack("%32S*",$courseid.' ');
 7062: 	my $num1=$symbseed+$CODEchck;
 7063: 	my $num2=$CODEseed+$courseseed+$symbchck;
 7064: 	#&logthis("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck");
 7065: 	#&logthis("rndseed :$num1:$num2:$symb");
 7066: 	if ($_64bit) { $num1=(($num1<<32)>>32); }
 7067: 	if ($_64bit) { $num2=(($num2<<32)>>32); }
 7068: 	return "$num1:$num2";
 7069:     }
 7070: }
 7071: 
 7072: sub rndseed_CODE_64bit5 {
 7073:     my ($symb,$courseid,$domain,$username)=@_;
 7074:     my $code = &getCODE();
 7075:     my ($num1,$num2)=&digest("$symb,$courseid,$code");
 7076:     return "$num1:$num2";
 7077: }
 7078: 
 7079: sub setup_random_from_rndseed {
 7080:     my ($rndseed)=@_;
 7081:     if ($rndseed =~/([,:])/) {
 7082: 	my ($num1,$num2)=split(/[,:]/,$rndseed);
 7083: 	&Math::Random::random_set_seed(abs($num1),abs($num2));
 7084:     } else {
 7085: 	&Math::Random::random_set_seed_from_phrase($rndseed);
 7086:     }
 7087: }
 7088: 
 7089: sub latest_receipt_algorithm_id {
 7090:     return 'receipt2';
 7091: }
 7092: 
 7093: sub recunique {
 7094:     my $fucourseid=shift;
 7095:     my $unique;
 7096:     if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') {
 7097: 	$unique=$env{"course.$fucourseid.internal.encseed"};
 7098:     } else {
 7099: 	$unique=$perlvar{'lonReceipt'};
 7100:     }
 7101:     return unpack("%32C*",$unique);
 7102: }
 7103: 
 7104: sub recprefix {
 7105:     my $fucourseid=shift;
 7106:     my $prefix;
 7107:     if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') {
 7108: 	$prefix=$env{"course.$fucourseid.internal.encpref"};
 7109:     } else {
 7110: 	$prefix=$perlvar{'lonHostID'};
 7111:     }
 7112:     return unpack("%32C*",$prefix);
 7113: }
 7114: 
 7115: sub ireceipt {
 7116:     my ($funame,$fudom,$fucourseid,$fusymb,$part)=@_;
 7117:     my $cuname=unpack("%32C*",$funame);
 7118:     my $cudom=unpack("%32C*",$fudom);
 7119:     my $cucourseid=unpack("%32C*",$fucourseid);
 7120:     my $cusymb=unpack("%32C*",$fusymb);
 7121:     my $cunique=&recunique($fucourseid);
 7122:     my $cpart=unpack("%32S*",$part);
 7123:     my $return =&recprefix($fucourseid).'-';
 7124:     if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' ||
 7125: 	$env{'request.state'} eq 'construct') {
 7126: 	#&logthis("doing receipt2  using parts $cpart, uname $cuname and udom $cudom gets  ".($cpart%$cuname)." and ".($cpart%$cudom));
 7127: 			       
 7128: 	$return.= ($cunique%$cuname+
 7129: 		   $cunique%$cudom+
 7130: 		   $cusymb%$cuname+
 7131: 		   $cusymb%$cudom+
 7132: 		   $cucourseid%$cuname+
 7133: 		   $cucourseid%$cudom+
 7134: 		   $cpart%$cuname+
 7135: 		   $cpart%$cudom);
 7136:     } else {
 7137: 	$return.= ($cunique%$cuname+
 7138: 		   $cunique%$cudom+
 7139: 		   $cusymb%$cuname+
 7140: 		   $cusymb%$cudom+
 7141: 		   $cucourseid%$cuname+
 7142: 		   $cucourseid%$cudom);
 7143:     }
 7144:     return $return;
 7145: }
 7146: 
 7147: sub receipt {
 7148:     my ($part)=@_;
 7149:     my ($symb,$courseid,$domain,$name) = &whichuser();
 7150:     return &ireceipt($name,$domain,$courseid,$symb,$part);
 7151: }
 7152: 
 7153: sub whichuser {
 7154:     my ($passedsymb)=@_;
 7155:     my ($symb,$courseid,$domain,$name,$publicuser);
 7156:     if (defined($env{'form.grade_symb'})) {
 7157: 	my ($tmp_courseid)=&get_env_multiple('form.grade_courseid');
 7158: 	my $allowed=&allowed('vgr',$tmp_courseid);
 7159: 	if (!$allowed &&
 7160: 	    exists($env{'request.course.sec'}) &&
 7161: 	    $env{'request.course.sec'} !~ /^\s*$/) {
 7162: 	    $allowed=&allowed('vgr',$tmp_courseid.
 7163: 			      '/'.$env{'request.course.sec'});
 7164: 	}
 7165: 	if ($allowed) {
 7166: 	    ($symb)=&get_env_multiple('form.grade_symb');
 7167: 	    $courseid=$tmp_courseid;
 7168: 	    ($domain)=&get_env_multiple('form.grade_domain');
 7169: 	    ($name)=&get_env_multiple('form.grade_username');
 7170: 	    return ($symb,$courseid,$domain,$name,$publicuser);
 7171: 	}
 7172:     }
 7173:     if (!$passedsymb) {
 7174: 	$symb=&symbread();
 7175:     } else {
 7176: 	$symb=$passedsymb;
 7177:     }
 7178:     $courseid=$env{'request.course.id'};
 7179:     $domain=$env{'user.domain'};
 7180:     $name=$env{'user.name'};
 7181:     if ($name eq 'public' && $domain eq 'public') {
 7182: 	if (!defined($env{'form.username'})) {
 7183: 	    $env{'form.username'}.=time.rand(10000000);
 7184: 	}
 7185: 	$name.=$env{'form.username'};
 7186:     }
 7187:     return ($symb,$courseid,$domain,$name,$publicuser);
 7188: 
 7189: }
 7190: 
 7191: # ------------------------------------------------------------ Serves up a file
 7192: # returns either the contents of the file or 
 7193: # -1 if the file doesn't exist
 7194: #
 7195: # if the target is a file that was uploaded via DOCS, 
 7196: # a check will be made to see if a current copy exists on the local server,
 7197: # if it does this will be served, otherwise a copy will be retrieved from
 7198: # the home server for the course and stored in /home/httpd/html/userfiles on
 7199: # the local server.   
 7200: 
 7201: sub getfile {
 7202:     my ($file) = @_;
 7203:     if ($file =~ m -^/*(uploaded|editupload)/-) { $file=&filelocation("",$file); }
 7204:     &repcopy($file);
 7205:     return &readfile($file);
 7206: }
 7207: 
 7208: sub repcopy_userfile {
 7209:     my ($file)=@_;
 7210:     if ($file =~ m -^/*(uploaded|editupload)/-) { $file=&filelocation("",$file); }
 7211:     if ($file =~ m|^/home/httpd/html/lonUsers/|) { return 'ok'; }
 7212:     my ($cdom,$cnum,$filename) = 
 7213: 	($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_name)/+(.*)|);
 7214:     my $uri="/uploaded/$cdom/$cnum/$filename";
 7215:     if (-e "$file") {
 7216: # we already have a local copy, check it out
 7217: 	my @fileinfo = stat($file);
 7218: 	my $rtncode;
 7219: 	my $info;
 7220: 	my $lwpresp = &getuploaded('HEAD',$uri,$cdom,$cnum,\$info,\$rtncode);
 7221: 	if ($lwpresp ne 'ok') {
 7222: # there is no such file anymore, even though we had a local copy
 7223: 	    if ($rtncode eq '404') {
 7224: 		unlink($file);
 7225: 	    }
 7226: 	    return -1;
 7227: 	}
 7228: 	if ($info < $fileinfo[9]) {
 7229: # nice, the file we have is up-to-date, just say okay
 7230: 	    return 'ok';
 7231: 	} else {
 7232: # the file is outdated, get rid of it
 7233: 	    unlink($file);
 7234: 	}
 7235:     }
 7236: # one way or the other, at this point, we don't have the file
 7237: # construct the correct path for the file
 7238:     my @parts = ($cdom,$cnum); 
 7239:     if ($filename =~ m|^(.+)/[^/]+$|) {
 7240: 	push @parts, split(/\//,$1);
 7241:     }
 7242:     my $path = $perlvar{'lonDocRoot'}.'/userfiles';
 7243:     foreach my $part (@parts) {
 7244: 	$path .= '/'.$part;
 7245: 	if (!-e $path) {
 7246: 	    mkdir($path,0770);
 7247: 	}
 7248:     }
 7249: # now the path exists for sure
 7250: # get a user agent
 7251:     my $ua=new LWP::UserAgent;
 7252:     my $transferfile=$file.'.in.transfer';
 7253: # FIXME: this should flock
 7254:     if (-e $transferfile) { return 'ok'; }
 7255:     my $request;
 7256:     $uri=~s/^\///;
 7257:     $request=new HTTP::Request('GET','http://'.$hostname{&homeserver($cnum,$cdom)}.'/raw/'.$uri);
 7258:     my $response=$ua->request($request,$transferfile);
 7259: # did it work?
 7260:     if ($response->is_error()) {
 7261: 	unlink($transferfile);
 7262: 	&logthis("Userfile repcopy failed for $uri");
 7263: 	return -1;
 7264:     }
 7265: # worked, rename the transfer file
 7266:     rename($transferfile,$file);
 7267:     return 'ok';
 7268: }
 7269: 
 7270: sub tokenwrapper {
 7271:     my $uri=shift;
 7272:     $uri=~s|^http\://([^/]+)||;
 7273:     $uri=~s|^/||;
 7274:     $env{'user.environment'}=~/\/([^\/]+)\.id/;
 7275:     my $token=$1;
 7276:     my (undef,$udom,$uname,$file)=split('/',$uri,4);
 7277:     if ($udom && $uname && $file) {
 7278: 	$file=~s|(\?\.*)*$||;
 7279:         &appenv("userfile.$udom/$uname/$file" => $env{'request.course.id'});
 7280:         return 'http://'.$hostname{ &homeserver($uname,$udom)}.'/'.$uri.
 7281:                (($uri=~/\?/)?'&':'?').'token='.$token.
 7282:                                '&tokenissued='.$perlvar{'lonHostID'};
 7283:     } else {
 7284:         return '/adm/notfound.html';
 7285:     }
 7286: }
 7287: 
 7288: # call with reqtype HEAD: get last modification time
 7289: # call with reqtype GET: get the file contents
 7290: # Do not call this with reqtype GET for large files! It loads everything into memory
 7291: #
 7292: sub getuploaded {
 7293:     my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
 7294:     $uri=~s/^\///;
 7295:     $uri = 'http://'.$hostname{ &homeserver($cnum,$cdom)}.'/raw/'.$uri;
 7296:     my $ua=new LWP::UserAgent;
 7297:     my $request=new HTTP::Request($reqtype,$uri);
 7298:     my $response=$ua->request($request);
 7299:     $$rtncode = $response->code;
 7300:     if (! $response->is_success()) {
 7301: 	return 'failed';
 7302:     }      
 7303:     if ($reqtype eq 'HEAD') {
 7304: 	$$info = &HTTP::Date::str2time( $response->header('Last-modified') );
 7305:     } elsif ($reqtype eq 'GET') {
 7306: 	$$info = $response->content;
 7307:     }
 7308:     return 'ok';
 7309: }
 7310: 
 7311: sub readfile {
 7312:     my $file = shift;
 7313:     if ( (! -e $file ) || ($file eq '') ) { return -1; };
 7314:     my $fh;
 7315:     open($fh,"<$file");
 7316:     my $a='';
 7317:     while (my $line = <$fh>) { $a .= $line; }
 7318:     return $a;
 7319: }
 7320: 
 7321: sub filelocation {
 7322:     my ($dir,$file) = @_;
 7323:     my $location;
 7324:     $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces
 7325: 
 7326:     if ($file =~ m-^/adm/-) {
 7327: 	$file=~s-^/adm/wrapper/-/-;
 7328: 	$file=~s-^/adm/coursedocs/showdoc/-/-;
 7329:     }
 7330:     if ($file=~m:^/~:) { # is a contruction space reference
 7331:         $location = $file;
 7332:         $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;
 7333:     } elsif ($file=~m{^/home/$match_username/public_html/}) {
 7334: 	# is a correct contruction space reference
 7335:         $location = $file;
 7336:     } elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file
 7337:         my ($udom,$uname,$filename)=
 7338:   	    ($file=~m -^/+(?:uploaded|editupload)/+($match_domain)/+($match_name)/+(.*)$-);
 7339:         my $home=&homeserver($uname,$udom);
 7340:         my $is_me=0;
 7341:         my @ids=&current_machine_ids();
 7342:         foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }
 7343:         if ($is_me) {
 7344:   	    $location=&propath($udom,$uname).
 7345:   	      '/userfiles/'.$filename;
 7346:         } else {
 7347:   	  $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.
 7348:   	      $udom.'/'.$uname.'/'.$filename;
 7349:         }
 7350:     } else {
 7351:         $file=~s/^\Q$perlvar{'lonDocRoot'}\E//;
 7352:         $file=~s:^/res/:/:;
 7353:         if ( !( $file =~ m:^/:) ) {
 7354:             $location = $dir. '/'.$file;
 7355:         } else {
 7356:             $location = '/home/httpd/html/res'.$file;
 7357:         }
 7358:     }
 7359:     $location=~s://+:/:g; # remove duplicate /
 7360:     while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..
 7361:     while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./
 7362:     return $location;
 7363: }
 7364: 
 7365: sub hreflocation {
 7366:     my ($dir,$file)=@_;
 7367:     unless (($file=~m-^http://-i) || ($file=~m-^/-)) {
 7368: 	$file=filelocation($dir,$file);
 7369:     } elsif ($file=~m-^/adm/-) {
 7370: 	$file=~s-^/adm/wrapper/-/-;
 7371: 	$file=~s-^/adm/coursedocs/showdoc/-/-;
 7372:     }
 7373:     if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) {
 7374: 	$file=~s-^\Q$perlvar{'lonDocRoot'}\E--;
 7375:     } elsif ($file=~m-/home/($match_username)/public_html/-) {
 7376: 	$file=~s-^/home/($match_username)/public_html/-/~$1/-;
 7377:     } elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) {
 7378: 	$file=~s-^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/
 7379: 	    -/uploaded/$1/$2/-x;
 7380:     }
 7381:     return $file;
 7382: }
 7383: 
 7384: sub current_machine_domains {
 7385:     my $hostname=$hostname{$perlvar{'lonHostID'}};
 7386:     my @domains;
 7387:     while( my($id, $name) = each(%hostname)) {
 7388: #	&logthis("-$id-$name-$hostname-");
 7389: 	if ($hostname eq $name) {
 7390: 	    push(@domains,$hostdom{$id});
 7391: 	}
 7392:     }
 7393:     return @domains;
 7394: }
 7395: 
 7396: sub current_machine_ids {
 7397:     my $hostname=$hostname{$perlvar{'lonHostID'}};
 7398:     my @ids;
 7399:     while( my($id, $name) = each(%hostname)) {
 7400: #	&logthis("-$id-$name-$hostname-");
 7401: 	if ($hostname eq $name) {
 7402: 	    push(@ids,$id);
 7403: 	}
 7404:     }
 7405:     return @ids;
 7406: }
 7407: 
 7408: sub additional_machine_domains {
 7409:     my @domains;
 7410:     open(my $fh,"<$perlvar{'lonTabDir'}/expected_domains.tab");
 7411:     while( my $line = <$fh>) {
 7412:         $line =~ s/\s//g;
 7413:         push(@domains,$line);
 7414:     }
 7415:     return @domains;
 7416: }
 7417: 
 7418: sub default_login_domain {
 7419:     my $domain = $perlvar{'lonDefDomain'};
 7420:     my $testdomain=(split(/\./,$ENV{'HTTP_HOST'}))[0];
 7421:     foreach my $posdom (&current_machine_domains(),
 7422:                         &additional_machine_domains()) {
 7423:         if (lc($posdom) eq lc($testdomain)) {
 7424:             $domain=$posdom;
 7425:             last;
 7426:         }
 7427:     }
 7428:     return $domain;
 7429: }
 7430: 
 7431: # ------------------------------------------------------------- Declutters URLs
 7432: 
 7433: sub declutter {
 7434:     my $thisfn=shift;
 7435:     if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }
 7436:     $thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//;
 7437:     $thisfn=~s/^\///;
 7438:     $thisfn=~s|^adm/wrapper/||;
 7439:     $thisfn=~s|^adm/coursedocs/showdoc/||;
 7440:     $thisfn=~s/^res\///;
 7441:     $thisfn=~s/\?.+$//;
 7442:     return $thisfn;
 7443: }
 7444: 
 7445: # ------------------------------------------------------------- Clutter up URLs
 7446: 
 7447: sub clutter {
 7448:     my $thisfn='/'.&declutter(shift);
 7449:     unless ($thisfn=~/^\/(uploaded|editupload|adm|userfiles|ext|raw|priv|public)\//) { 
 7450:        $thisfn='/res'.$thisfn; 
 7451:     }
 7452:     if ($thisfn !~m|/adm|) {
 7453: 	if ($thisfn =~ m|/ext/|) {
 7454: 	    $thisfn='/adm/wrapper'.$thisfn;
 7455: 	} else {
 7456: 	    my ($ext) = ($thisfn =~ /\.(\w+)$/);
 7457: 	    my $embstyle=&Apache::loncommon::fileembstyle($ext);
 7458: 	    if ($embstyle eq 'ssi'
 7459: 		|| ($embstyle eq 'hdn')
 7460: 		|| ($embstyle eq 'rat')
 7461: 		|| ($embstyle eq 'prv')
 7462: 		|| ($embstyle eq 'ign')) {
 7463: 		#do nothing with these
 7464: 	    } elsif (($embstyle eq 'img') 
 7465: 		|| ($embstyle eq 'emb')
 7466: 		|| ($embstyle eq 'wrp')) {
 7467: 		$thisfn='/adm/wrapper'.$thisfn;
 7468: 	    } elsif ($embstyle eq 'unk'
 7469: 		     && $thisfn!~/\.(sequence|page)$/) {
 7470: 		$thisfn='/adm/coursedocs/showdoc'.$thisfn;
 7471: 	    } else {
 7472: #		&logthis("Got a blank emb style");
 7473: 	    }
 7474: 	}
 7475:     }
 7476:     return $thisfn;
 7477: }
 7478: 
 7479: sub clutter_with_no_wrapper {
 7480:     my $uri = &clutter(shift);
 7481:     if ($uri =~ m-^/adm/-) {
 7482: 	$uri =~ s-^/adm/wrapper/-/-;
 7483: 	$uri =~ s-^/adm/coursedocs/showdoc/-/-;
 7484:     }
 7485:     return $uri;
 7486: }
 7487: 
 7488: sub freeze_escape {
 7489:     my ($value)=@_;
 7490:     if (ref($value)) {
 7491: 	$value=&nfreeze($value);
 7492: 	return '__FROZEN__'.&escape($value);
 7493:     }
 7494:     return &escape($value);
 7495: }
 7496: 
 7497: 
 7498: sub thaw_unescape {
 7499:     my ($value)=@_;
 7500:     if ($value =~ /^__FROZEN__/) {
 7501: 	substr($value,0,10,undef);
 7502: 	$value=&unescape($value);
 7503: 	return &thaw($value);
 7504:     }
 7505:     return &unescape($value);
 7506: }
 7507: 
 7508: sub correct_line_ends {
 7509:     my ($result)=@_;
 7510:     $$result =~s/\r\n/\n/mg;
 7511:     $$result =~s/\r/\n/mg;
 7512: }
 7513: # ================================================================ Main Program
 7514: 
 7515: sub goodbye {
 7516:    &logthis("Starting Shut down");
 7517: #not converted to using infrastruture and probably shouldn't be
 7518:    &logthis(sprintf("%-20s is %s",'%badServerCache',length(&freeze(\%badServerCache))));
 7519: #converted
 7520: #   &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));
 7521:    &logthis(sprintf("%-20s is %s",'%homecache',length(&freeze(\%homecache))));
 7522: #   &logthis(sprintf("%-20s is %s",'%titlecache',length(&freeze(\%titlecache))));
 7523: #   &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&freeze(\%courseresdatacache))));
 7524: #1.1 only
 7525: #   &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&freeze(\%userresdatacache))));
 7526: #   &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&freeze(\%getsectioncache))));
 7527: #   &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&freeze(\%courseresversioncache))));
 7528: #   &logthis(sprintf("%-20s is %s",'%resversioncache',length(&freeze(\%resversioncache))));
 7529:    &logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered))));
 7530:    &logthis(sprintf("%-20s is %s",'kicks',$kicks));
 7531:    &logthis(sprintf("%-20s is %s",'hits',$hits));
 7532:    &flushcourselogs();
 7533:    &logthis("Shutting down");
 7534: }
 7535: 
 7536: BEGIN {
 7537: # ----------------------------------- Read loncapa.conf and loncapa_apache.conf
 7538:     unless ($readit) {
 7539: {
 7540:     my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf');
 7541:     %perlvar = (%perlvar,%{$configvars});
 7542: }
 7543: 
 7544: # ------------------------------------------------------------ Read domain file
 7545: {
 7546:     %domaindescription = ();
 7547:     %domain_auth_def = ();
 7548:     %domain_auth_arg_def = ();
 7549:     my $fh;
 7550:     if (open($fh,"<".$Apache::lonnet::perlvar{'lonTabDir'}.'/domain.tab')) {
 7551: 	while (my $line = <$fh>) {
 7552:            next if ($line =~ /^(\#|\s*$)/);
 7553: #           next if /^\#/;
 7554:            chomp $line;
 7555:            my ($domain, $domain_description, $def_auth, $def_auth_arg,
 7556: 	       $def_lang, $city, $longi, $lati, $primary) = split(/:/,$line,9);
 7557: 	   $domain_auth_def{$domain}=$def_auth;
 7558:            $domain_auth_arg_def{$domain}=$def_auth_arg;
 7559: 	   $domaindescription{$domain}=$domain_description;
 7560: 	   $domain_lang_def{$domain}=$def_lang;
 7561: 	   $domain_city{$domain}=$city;
 7562: 	   $domain_longi{$domain}=$longi;
 7563: 	   $domain_lati{$domain}=$lati;
 7564:            $domain_primary{$domain}=$primary;
 7565: 
 7566:  #         &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}");
 7567: #          &logthis("Domain.tab: $domain ".$domaindescription{$domain} );
 7568: 	}
 7569:     }
 7570:     close ($fh);
 7571: }
 7572: 
 7573: 
 7574: # ------------------------------------------------------------- Read hosts file
 7575: {
 7576:     open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
 7577: 
 7578:     while (my $configline=<$config>) {
 7579:        next if ($configline =~ /^(\#|\s*$)/);
 7580:        chomp($configline);
 7581:        my ($id,$domain,$role,$name)=split(/:/,$configline);
 7582:        $name=~s/\s//g;
 7583:        if ($id && $domain && $role && $name) {
 7584: 	 $hostname{$id}=$name;
 7585: 	 $hostdom{$id}=$domain;
 7586: 	 if ($role eq 'library') { $libserv{$id}=$name; }
 7587:        }
 7588:     }
 7589:     close($config);
 7590:     # FIXME: dev server don't want this, production servers _do_ want this
 7591:     #&get_iphost();
 7592: }
 7593: 
 7594: sub get_iphost {
 7595:     if (%iphost) { return %iphost; }
 7596:     my %name_to_ip;
 7597:     foreach my $id (keys(%hostname)) {
 7598: 	my $name=$hostname{$id};
 7599: 	my $ip;
 7600: 	if (!exists($name_to_ip{$name})) {
 7601: 	    $ip = gethostbyname($name);
 7602: 	    if (!$ip || length($ip) ne 4) {
 7603: 		&logthis("Skipping host $id name $name no IP found");
 7604: 		next;
 7605: 	    }
 7606: 	    $ip=inet_ntoa($ip);
 7607: 	    $name_to_ip{$name} = $ip;
 7608: 	} else {
 7609: 	    $ip = $name_to_ip{$name};
 7610: 	}
 7611: 	push(@{$iphost{$ip}},$id);
 7612:     }
 7613:     return %iphost;
 7614: }
 7615: 
 7616: # ------------------------------------------------------ Read spare server file
 7617: {
 7618:     open(my $config,"<$perlvar{'lonTabDir'}/spare.tab");
 7619: 
 7620:     while (my $configline=<$config>) {
 7621:        chomp($configline);
 7622:        if ($configline) {
 7623: 	   my ($host,$type) = split(':',$configline,2);
 7624: 	   if (!defined($type) || $type eq '') { $type = 'default' };
 7625: 	   push(@{ $spareid{$type} }, $host);
 7626:        }
 7627:     }
 7628:     close($config);
 7629: }
 7630: # ------------------------------------------------------------ Read permissions
 7631: {
 7632:     open(my $config,"<$perlvar{'lonTabDir'}/roles.tab");
 7633: 
 7634:     while (my $configline=<$config>) {
 7635: 	chomp($configline);
 7636: 	if ($configline) {
 7637: 	    my ($role,$perm)=split(/ /,$configline);
 7638: 	    if ($perm ne '') { $pr{$role}=$perm; }
 7639: 	}
 7640:     }
 7641:     close($config);
 7642: }
 7643: 
 7644: # -------------------------------------------- Read plain texts for permissions
 7645: {
 7646:     open(my $config,"<$perlvar{'lonTabDir'}/rolesplain.tab");
 7647: 
 7648:     while (my $configline=<$config>) {
 7649: 	chomp($configline);
 7650: 	if ($configline) {
 7651: 	    my ($short,@plain)=split(/:/,$configline);
 7652:             %{$prp{$short}} = ();
 7653: 	    if (@plain > 0) {
 7654:                 $prp{$short}{'std'} = $plain[0];
 7655:                 for (my $i=1; $i<@plain; $i++) {
 7656:                     $prp{$short}{'alt'.$i} = $plain[$i];  
 7657:                 }
 7658:             }
 7659: 	}
 7660:     }
 7661:     close($config);
 7662: }
 7663: 
 7664: # ---------------------------------------------------------- Read package table
 7665: {
 7666:     open(my $config,"<$perlvar{'lonTabDir'}/packages.tab");
 7667: 
 7668:     while (my $configline=<$config>) {
 7669: 	if ($configline !~ /\S/ || $configline=~/^#/) { next; }
 7670: 	chomp($configline);
 7671: 	my ($short,$plain)=split(/:/,$configline);
 7672: 	my ($pack,$name)=split(/\&/,$short);
 7673: 	if ($plain ne '') {
 7674: 	    $packagetab{$pack.'&'.$name.'&name'}=$name; 
 7675: 	    $packagetab{$short}=$plain; 
 7676: 	}
 7677:     }
 7678:     close($config);
 7679: }
 7680: 
 7681: # ------------- set up temporary directory
 7682: {
 7683:     $tmpdir = $perlvar{'lonDaemons'}.'/tmp/';
 7684: 
 7685: }
 7686: 
 7687: $memcache=new Cache::Memcached({'servers'           => ['127.0.0.1:11211'],
 7688: 				'compress_threshold'=> 20_000,
 7689:  			        });
 7690: 
 7691: $processmarker='_'.time.'_'.$perlvar{'lonHostID'};
 7692: $dumpcount=0;
 7693: 
 7694: &logtouch();
 7695: &logthis('<font color="yellow">INFO: Read configuration</font>');
 7696: $readit=1;
 7697:     {
 7698: 	use integer;
 7699: 	my $test=(2**32)+1;
 7700: 	if ($test != 0) { $_64bit=1; } else { $_64bit=0; }
 7701: 	&logthis(" Detected 64bit platform ($_64bit)");
 7702:     }
 7703: }
 7704: }
 7705: 
 7706: 1;
 7707: __END__
 7708: 
 7709: =pod
 7710: 
 7711: =head1 NAME
 7712: 
 7713: Apache::lonnet - Subroutines to ask questions about things in the network.
 7714: 
 7715: =head1 SYNOPSIS
 7716: 
 7717: Invoked by other LON-CAPA modules, when they need to talk to or about objects in the network.
 7718: 
 7719:  &Apache::lonnet::SUBROUTINENAME(ARGUMENTS);
 7720: 
 7721: Common parameters:
 7722: 
 7723: =over 4
 7724: 
 7725: =item *
 7726: 
 7727: $uname : an internal username (if $cname expecting a course Id specifically)
 7728: 
 7729: =item *
 7730: 
 7731: $udom : a domain (if $cdom expecting a course's domain specifically)
 7732: 
 7733: =item *
 7734: 
 7735: $symb : a resource instance identifier
 7736: 
 7737: =item *
 7738: 
 7739: $namespace : the name of a .db file that contains the data needed or
 7740: being set.
 7741: 
 7742: =back
 7743: 
 7744: =head1 OVERVIEW
 7745: 
 7746: lonnet provides subroutines which interact with the
 7747: lonc/lond (TCP) network layer of LON-CAPA. They can be used to ask
 7748: about classes, users, and resources.
 7749: 
 7750: For many of these objects you can also use this to store data about
 7751: them or modify them in various ways.
 7752: 
 7753: =head2 Symbs
 7754: 
 7755: To identify a specific instance of a resource, LON-CAPA uses symbols
 7756: or "symbs"X<symb>. These identifiers are built from the URL of the
 7757: map, the resource number of the resource in the map, and the URL of
 7758: the resource itself. The latter is somewhat redundant, but might help
 7759: if maps change.
 7760: 
 7761: An example is
 7762: 
 7763:  msu/korte/parts/part1.sequence___19___msu/korte/tests/part12.problem
 7764: 
 7765: The respective map entry is
 7766: 
 7767:  <resource id="19" src="/res/msu/korte/tests/part12.problem"
 7768:   title="Problem 2">
 7769:  </resource>
 7770: 
 7771: Symbs are used by the random number generator, as well as to store and
 7772: restore data specific to a certain instance of for example a problem.
 7773: 
 7774: =head2 Storing And Retrieving Data
 7775: 
 7776: X<store()>X<cstore()>X<restore()>Three of the most important functions
 7777: in C<lonnet.pm> are C<&Apache::lonnet::cstore()>,
 7778: C<&Apache::lonnet:restore()>, and C<&Apache::lonnet::store()>, which
 7779: is is the non-critical message twin of cstore. These functions are for
 7780: handlers to store a perl hash to a user's permanent data space in an
 7781: easy manner, and to retrieve it again on another call. It is expected
 7782: that a handler would use this once at the beginning to retrieve data,
 7783: and then again once at the end to send only the new data back.
 7784: 
 7785: The data is stored in the user's data directory on the user's
 7786: homeserver under the ID of the course.
 7787: 
 7788: The hash that is returned by restore will have all of the previous
 7789: value for all of the elements of the hash.
 7790: 
 7791: Example:
 7792: 
 7793:  #creating a hash
 7794:  my %hash;
 7795:  $hash{'foo'}='bar';
 7796: 
 7797:  #storing it
 7798:  &Apache::lonnet::cstore(\%hash);
 7799: 
 7800:  #changing a value
 7801:  $hash{'foo'}='notbar';
 7802: 
 7803:  #adding a new value
 7804:  $hash{'bar'}='foo';
 7805:  &Apache::lonnet::cstore(\%hash);
 7806: 
 7807:  #retrieving the hash
 7808:  my %history=&Apache::lonnet::restore();
 7809: 
 7810:  #print the hash
 7811:  foreach my $key (sort(keys(%history))) {
 7812:    print("\%history{$key} = $history{$key}");
 7813:  }
 7814: 
 7815: Will print out:
 7816: 
 7817:  %history{1:foo} = bar
 7818:  %history{1:keys} = foo:timestamp
 7819:  %history{1:timestamp} = 990455579
 7820:  %history{2:bar} = foo
 7821:  %history{2:foo} = notbar
 7822:  %history{2:keys} = foo:bar:timestamp
 7823:  %history{2:timestamp} = 990455580
 7824:  %history{bar} = foo
 7825:  %history{foo} = notbar
 7826:  %history{timestamp} = 990455580
 7827:  %history{version} = 2
 7828: 
 7829: Note that the special hash entries C<keys>, C<version> and
 7830: C<timestamp> were added to the hash. C<version> will be equal to the
 7831: total number of versions of the data that have been stored. The
 7832: C<timestamp> attribute will be the UNIX time the hash was
 7833: stored. C<keys> is available in every historical section to list which
 7834: keys were added or changed at a specific historical revision of a
 7835: hash.
 7836: 
 7837: B<Warning>: do not store the hash that restore returns directly. This
 7838: will cause a mess since it will restore the historical keys as if the
 7839: were new keys. I.E. 1:foo will become 1:1:foo etc.
 7840: 
 7841: Calling convention:
 7842: 
 7843:  my %record=&Apache::lonnet::restore($symb,$courseid,$domain,$uname,$home);
 7844:  &Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname,$home);
 7845: 
 7846: For more detailed information, see lonnet specific documentation.
 7847: 
 7848: =head1 RETURN MESSAGES
 7849: 
 7850: =over 4
 7851: 
 7852: =item * B<con_lost>: unable to contact remote host
 7853: 
 7854: =item * B<con_delayed>: unable to contact remote host, message will be delivered
 7855: when the connection is brought back up
 7856: 
 7857: =item * B<con_failed>: unable to contact remote host and unable to save message
 7858: for later delivery
 7859: 
 7860: =item * B<error:>: an error a occured, a description of the error follows the :
 7861: 
 7862: =item * B<no_such_host>: unable to fund a host associated with the user/domain
 7863: that was requested
 7864: 
 7865: =back
 7866: 
 7867: =head1 PUBLIC SUBROUTINES
 7868: 
 7869: =head2 Session Environment Functions
 7870: 
 7871: =over 4
 7872: 
 7873: =item * 
 7874: X<appenv()>
 7875: B<appenv(%hash)>: the value of %hash is written to
 7876: the user envirnoment file, and will be restored for each access this
 7877: user makes during this session, also modifies the %env for the current
 7878: process
 7879: 
 7880: =item *
 7881: X<delenv()>
 7882: B<delenv($regexp)>: removes all items from the session
 7883: environment file that matches the regular expression in $regexp. The
 7884: values are also delted from the current processes %env.
 7885: 
 7886: =item * get_env_multiple($name) 
 7887: 
 7888: gets $name from the %env hash, it seemlessly handles the cases where multiple
 7889: values may be defined and end up as an array ref.
 7890: 
 7891: returns an array of values
 7892: 
 7893: =back
 7894: 
 7895: =head2 User Information
 7896: 
 7897: =over 4
 7898: 
 7899: =item *
 7900: X<queryauthenticate()>
 7901: B<queryauthenticate($uname,$udom)>: try to determine user's current 
 7902: authentication scheme
 7903: 
 7904: =item *
 7905: X<authenticate()>
 7906: B<authenticate($uname,$upass,$udom)>: try to
 7907: authenticate user from domain's lib servers (first use the current
 7908: one). C<$upass> should be the users password.
 7909: 
 7910: =item *
 7911: X<homeserver()>
 7912: B<homeserver($uname,$udom)>: find the server which has
 7913: the user's directory and files (there must be only one), this caches
 7914: the answer, and also caches if there is a borken connection.
 7915: 
 7916: =item *
 7917: X<idget()>
 7918: B<idget($udom,@ids)>: find the usernames behind a list of IDs
 7919: (IDs are a unique resource in a domain, there must be only 1 ID per
 7920: username, and only 1 username per ID in a specific domain) (returns
 7921: hash: id=>name,id=>name)
 7922: 
 7923: =item *
 7924: X<idrget()>
 7925: B<idrget($udom,@unames)>: find the IDs behind a list of
 7926: usernames (returns hash: name=>id,name=>id)
 7927: 
 7928: =item *
 7929: X<idput()>
 7930: B<idput($udom,%ids)>: store away a list of names and associated IDs
 7931: 
 7932: =item *
 7933: X<rolesinit()>
 7934: B<rolesinit($udom,$username,$authhost)>: get user privileges
 7935: 
 7936: =item *
 7937: X<getsection()>
 7938: B<getsection($udom,$uname,$cname)>: finds the section of student in the
 7939: course $cname, return section name/number or '' for "not in course"
 7940: and '-1' for "no section"
 7941: 
 7942: =item *
 7943: X<userenvironment()>
 7944: B<userenvironment($udom,$uname,@what)>: gets the values of the keys
 7945: passed in @what from the requested user's environment, returns a hash
 7946: 
 7947: =back
 7948: 
 7949: =head2 User Roles
 7950: 
 7951: =over 4
 7952: 
 7953: =item *
 7954: 
 7955: allowed($priv,$uri,$symb,$role) : check for a user privilege; returns codes for allowed actions
 7956:  F: full access
 7957:  U,I,K: authentication modes (cxx only)
 7958:  '': forbidden
 7959:  1: user needs to choose course
 7960:  2: browse allowed
 7961:  A: passphrase authentication needed
 7962: 
 7963: =item *
 7964: 
 7965: definerole($rolename,$sysrole,$domrole,$courole) : define role; define a custom
 7966: role rolename set privileges in format of lonTabs/roles.tab for system, domain,
 7967: and course level
 7968: 
 7969: =item *
 7970: 
 7971: plaintext($short) : return value in %prp hash (rolesplain.tab); plain text
 7972: explanation of a user role term
 7973: 
 7974: =item *
 7975: 
 7976: get_my_roles($uname,$udom,$types,$roles,$roledoms) : All arguments are optional.  Returns a hash of a user's roles, with keys set to colon-sparated $uname,$udom,and $role, and value set to colon-separated start and end times for the role. If no username and domain are specified, will default to current user/domain. Types, roles, and roledoms are references to arrays, of role statuses (active, future or previous), roles (e.g., cc,in, st etc.) and domains of the roles which can be used to restrict the list if roles reported. If no array ref is provided for types, will default to return only active roles.  
 7977: =back
 7978: 
 7979: =head2 User Modification
 7980: 
 7981: =over 4
 7982: 
 7983: =item *
 7984: 
 7985: assignrole($udom,$uname,$url,$role,$end,$start) : assign role; give a role to a
 7986: user for the level given by URL.  Optional start and end dates (leave empty
 7987: string or zero for "no date")
 7988: 
 7989: =item *
 7990: 
 7991: changepass($uname,$udom,$currentpass,$newpass,$server) : attempts to
 7992: change a users, password, possible return values are: ok,
 7993: pwchange_failure, non_authorized, auth_mode_error, unknown_user,
 7994: refused
 7995: 
 7996: =item *
 7997: 
 7998: modifyuserauth($udom,$uname,$umode,$upass) : modify user authentication
 7999: 
 8000: =item *
 8001: 
 8002: modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene) : 
 8003: modify user
 8004: 
 8005: =item *
 8006: 
 8007: modifystudent
 8008: 
 8009: modify a students enrollment and identification information.
 8010: The course id is resolved based on the current users environment.  
 8011: This means the envoking user must be a course coordinator or otherwise
 8012: associated with a course.
 8013: 
 8014: This call is essentially a wrapper for lonnet::modifyuser and
 8015: lonnet::modify_student_enrollment
 8016: 
 8017: Inputs: 
 8018: 
 8019: =over 4
 8020: 
 8021: =item B<$udom> Students loncapa domain
 8022: 
 8023: =item B<$uname> Students loncapa login name
 8024: 
 8025: =item B<$uid> Students id/student number
 8026: 
 8027: =item B<$umode> Students authentication mode
 8028: 
 8029: =item B<$upass> Students password
 8030: 
 8031: =item B<$first> Students first name
 8032: 
 8033: =item B<$middle> Students middle name
 8034: 
 8035: =item B<$last> Students last name
 8036: 
 8037: =item B<$gene> Students generation
 8038: 
 8039: =item B<$usec> Students section in course
 8040: 
 8041: =item B<$end> Unix time of the roles expiration
 8042: 
 8043: =item B<$start> Unix time of the roles start date
 8044: 
 8045: =item B<$forceid> If defined, allow $uid to be changed
 8046: 
 8047: =item B<$desiredhome> server to use as home server for student
 8048: 
 8049: =back
 8050: 
 8051: =item *
 8052: 
 8053: modify_student_enrollment
 8054: 
 8055: Change a students enrollment status in a class.  The environment variable
 8056: 'role.request.course' must be defined for this function to proceed.
 8057: 
 8058: Inputs:
 8059: 
 8060: =over 4
 8061: 
 8062: =item $udom, students domain
 8063: 
 8064: =item $uname, students name
 8065: 
 8066: =item $uid, students user id
 8067: 
 8068: =item $first, students first name
 8069: 
 8070: =item $middle
 8071: 
 8072: =item $last
 8073: 
 8074: =item $gene
 8075: 
 8076: =item $usec
 8077: 
 8078: =item $end
 8079: 
 8080: =item $start
 8081: 
 8082: =back
 8083: 
 8084: 
 8085: =item *
 8086: 
 8087: assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start) : assign
 8088: custom role; give a custom role to a user for the level given by URL.  Specify
 8089: name and domain of role author, and role name
 8090: 
 8091: =item *
 8092: 
 8093: revokerole($udom,$uname,$url,$role) : revoke a role for url
 8094: 
 8095: =item *
 8096: 
 8097: revokecustomrole($udom,$uname,$url,$role) : revoke a custom role
 8098: 
 8099: =back
 8100: 
 8101: =head2 Course Infomation
 8102: 
 8103: =over 4
 8104: 
 8105: =item *
 8106: 
 8107: coursedescription($courseid) : returns a hash of information about the
 8108: specified course id, including all environment settings for the
 8109: course, the description of the course will be in the hash under the
 8110: key 'description'
 8111: 
 8112: =item *
 8113: 
 8114: resdata($name,$domain,$type,@which) : request for current parameter
 8115: setting for a specific $type, where $type is either 'course' or 'user',
 8116: @what should be a list of parameters to ask about. This routine caches
 8117: answers for 5 minutes.
 8118: 
 8119: =back
 8120: 
 8121: =head2 Course Modification
 8122: 
 8123: =over 4
 8124: 
 8125: =item *
 8126: 
 8127: writecoursepref($courseid,%prefs) : write preferences (environment
 8128: database) for a course
 8129: 
 8130: =item *
 8131: 
 8132: createcourse($udom,$description,$url) : make/modify course
 8133: 
 8134: =back
 8135: 
 8136: =head2 Resource Subroutines
 8137: 
 8138: =over 4
 8139: 
 8140: =item *
 8141: 
 8142: subscribe($fname) : subscribe to a resource, returns URL if possible (probably should use repcopy instead)
 8143: 
 8144: =item *
 8145: 
 8146: repcopy($filename) : subscribes to the requested file, and attempts to
 8147: replicate from the owning library server, Might return
 8148: 'unavailable', 'not_found', 'forbidden', 'ok', or
 8149: 'bad_request', also attempts to grab the metadata for the
 8150: resource. Expects the local filesystem pathname
 8151: (/home/httpd/html/res/....)
 8152: 
 8153: =back
 8154: 
 8155: =head2 Resource Information
 8156: 
 8157: =over 4
 8158: 
 8159: =item *
 8160: 
 8161: EXT($varname,$symb,$udom,$uname) : evaluates and returns the value of
 8162: a vairety of different possible values, $varname should be a request
 8163: string, and the other parameters can be used to specify who and what
 8164: one is asking about.
 8165: 
 8166: Possible values for $varname are environment.lastname (or other item
 8167: from the envirnment hash), user.name (or someother aspect about the
 8168: user), resource.0.maxtries (or some other part and parameter of a
 8169: resource)
 8170: 
 8171: =item *
 8172: 
 8173: directcondval($number) : get current value of a condition; reads from a state
 8174: string
 8175: 
 8176: =item *
 8177: 
 8178: condval($condidx) : value of condition index based on state
 8179: 
 8180: =item *
 8181: 
 8182: metadata($uri,$what,$liburi,$prefix,$depthcount) : request a
 8183: resource's metadata, $what should be either a specific key, or either
 8184: 'keys' (to get a list of possible keys) or 'packages' to get a list of
 8185: packages that this resource currently uses, the last 3 arguments are only used internally for recursive metadata.
 8186: 
 8187: this function automatically caches all requests
 8188: 
 8189: =item *
 8190: 
 8191: metadata_query($query,$custom,$customshow) : make a metadata query against the
 8192: network of library servers; returns file handle of where SQL and regex results
 8193: will be stored for query
 8194: 
 8195: =item *
 8196: 
 8197: symbread($filename) : return symbolic list entry (filename argument optional);
 8198: returns the data handle
 8199: 
 8200: =item *
 8201: 
 8202: symbverify($symb,$thisfn) : verifies that $symb actually exists and is
 8203: a possible symb for the URL in $thisfn, and if is an encryypted
 8204: resource that the user accessed using /enc/ returns a 1 on success, 0
 8205: on failure, user must be in a course, as it assumes the existance of
 8206: the course initial hash, and uses $env('request.course.id'}
 8207: 
 8208: 
 8209: =item *
 8210: 
 8211: symbclean($symb) : removes versions numbers from a symb, returns the
 8212: cleaned symb
 8213: 
 8214: =item *
 8215: 
 8216: is_on_map($uri) : checks if the $uri is somewhere on the current
 8217: course map, user must be in a course for it to work.
 8218: 
 8219: =item *
 8220: 
 8221: numval($salt) : return random seed value (addend for rndseed)
 8222: 
 8223: =item *
 8224: 
 8225: rndseed($symb,$courseid,$udom,$uname) : create a random sum; returns
 8226: a random seed, all arguments are optional, if they aren't sent it uses the
 8227: environment to derive them. Note: if symb isn't sent and it can't get one
 8228: from &symbread it will use the current time as its return value
 8229: 
 8230: =item *
 8231: 
 8232: ireceipt($funame,$fudom,$fucourseid,$fusymb) : return unique,
 8233: unfakeable, receipt
 8234: 
 8235: =item *
 8236: 
 8237: receipt() : API to ireceipt working off of env values; given out to users
 8238: 
 8239: =item *
 8240: 
 8241: countacc($url) : count the number of accesses to a given URL
 8242: 
 8243: =item *
 8244: 
 8245: 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
 8246: 
 8247: =item *
 8248: 
 8249: 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)
 8250: 
 8251: =item *
 8252: 
 8253: expirespread($uname,$udom,$stype,$usymb) : set expire date for spreadsheet
 8254: 
 8255: =item *
 8256: 
 8257: devalidate($symb) : devalidate temporary spreadsheet calculations,
 8258: forcing spreadsheet to reevaluate the resource scores next time.
 8259: 
 8260: =back
 8261: 
 8262: =head2 Storing/Retreiving Data
 8263: 
 8264: =over 4
 8265: 
 8266: =item *
 8267: 
 8268: store($storehash,$symb,$namespace,$udom,$uname) : stores hash permanently
 8269: for this url; hashref needs to be given and should be a \%hashname; the
 8270: remaining args aren't required and if they aren't passed or are '' they will
 8271: be derived from the env
 8272: 
 8273: =item *
 8274: 
 8275: cstore($storehash,$symb,$namespace,$udom,$uname) : same as store but
 8276: uses critical subroutine
 8277: 
 8278: =item *
 8279: 
 8280: restore($symb,$namespace,$udom,$uname) : returns hash for this symb;
 8281: all args are optional
 8282: 
 8283: =item *
 8284: 
 8285: dumpstore($namespace,$udom,$uname,$regexp,$range) : 
 8286: dumps the complete (or key matching regexp) namespace into a hash
 8287: ($udom, $uname, $regexp, $range are optional) for a namespace that is
 8288: normally &store()ed into
 8289: 
 8290: $range should be either an integer '100' (give me the first 100
 8291:                                            matching records)
 8292:               or be  two integers sperated by a - with no spaces
 8293:                  '30-50' (give me the 30th through the 50th matching
 8294:                           records)
 8295: 
 8296: 
 8297: =item *
 8298: 
 8299: putstore($namespace,$symb,$version,$storehash,$udomain,$uname) :
 8300: replaces a &store() version of data with a replacement set of data
 8301: for a particular resource in a namespace passed in the $storehash hash 
 8302: reference
 8303: 
 8304: =item *
 8305: 
 8306: tmpstore($storehash,$symb,$namespace,$udom,$uname) : storage that
 8307: works very similar to store/cstore, but all data is stored in a
 8308: temporary location and can be reset using tmpreset, $storehash should
 8309: be a hash reference, returns nothing on success
 8310: 
 8311: =item *
 8312: 
 8313: tmprestore($symb,$namespace,$udom,$uname) : storage that works very
 8314: similar to restore, but all data is stored in a temporary location and
 8315: can be reset using tmpreset. Returns a hash of values on success,
 8316: error string otherwise.
 8317: 
 8318: =item *
 8319: 
 8320: tmpreset($symb,$namespace,$udom,$uname) : temporary storage reset,
 8321: deltes all keys for $symb form the temporary storage hash.
 8322: 
 8323: =item *
 8324: 
 8325: get($namespace,$storearr,$udom,$uname) : returns hash with keys from array
 8326: reference filled in from namesp ($udom and $uname are optional)
 8327: 
 8328: =item *
 8329: 
 8330: del($namespace,$storearr,$udom,$uname) : deletes keys out of array from
 8331: namesp ($udom and $uname are optional)
 8332: 
 8333: =item *
 8334: 
 8335: dump($namespace,$udom,$uname,$regexp,$range) : 
 8336: dumps the complete (or key matching regexp) namespace into a hash
 8337: ($udom, $uname, $regexp, $range are optional)
 8338: 
 8339: $range should be either an integer '100' (give me the first 100
 8340:                                            matching records)
 8341:               or be  two integers sperated by a - with no spaces
 8342:                  '30-50' (give me the 30th through the 50th matching
 8343:                           records)
 8344: =item *
 8345: 
 8346: inc($namespace,$store,$udom,$uname) : increments $store in $namespace.
 8347: $store can be a scalar, an array reference, or if the amount to be 
 8348: incremented is > 1, a hash reference.
 8349: 
 8350: ($udom and $uname are optional)
 8351: 
 8352: =item *
 8353: 
 8354: put($namespace,$storehash,$udom,$uname) : stores hash in namesp
 8355: ($udom and $uname are optional)
 8356: 
 8357: =item *
 8358: 
 8359: cput($namespace,$storehash,$udom,$uname) : critical put
 8360: ($udom and $uname are optional)
 8361: 
 8362: =item *
 8363: 
 8364: newput($namespace,$storehash,$udom,$uname) :
 8365: 
 8366: Attempts to store the items in the $storehash, but only if they don't
 8367: currently exist, if this succeeds you can be certain that you have 
 8368: successfully created a new key value pair in the $namespace db.
 8369: 
 8370: 
 8371: Args:
 8372:  $namespace: name of database to store values to
 8373:  $storehash: hashref to store to the db
 8374:  $udom: (optional) domain of user containing the db
 8375:  $uname: (optional) name of user caontaining the db
 8376: 
 8377: Returns:
 8378:  'ok' -> succeeded in storing all keys of $storehash
 8379:  'key_exists: <key>' -> failed to anything out of $storehash, as at
 8380:                         least <key> already existed in the db (other
 8381:                         requested keys may also already exist)
 8382:  'error: <msg>' -> unable to tie the DB or other erorr occured
 8383:  'con_lost' -> unable to contact request server
 8384:  'refused' -> action was not allowed by remote machine
 8385: 
 8386: 
 8387: =item *
 8388: 
 8389: eget($namespace,$storearr,$udom,$uname) : returns hash with keys from array
 8390: reference filled in from namesp (encrypts the return communication)
 8391: ($udom and $uname are optional)
 8392: 
 8393: =item *
 8394: 
 8395: log($udom,$name,$home,$message) : write to permanent log for user; use
 8396: critical subroutine
 8397: 
 8398: =item *
 8399: 
 8400: get_dom($namespace,$storearr,$udomain) : returns hash with keys from array
 8401: reference filled in from namespace found in domain level on primary domain server ($udomain is optional)
 8402: 
 8403: =item *
 8404: 
 8405: put_dom($namespace,$storehash,$udomain) :  stores hash in namespace at domain level on primary domain server ($udomain is optional)
 8406: 
 8407: =back
 8408: 
 8409: =head2 Network Status Functions
 8410: 
 8411: =over 4
 8412: 
 8413: =item *
 8414: 
 8415: dirlist($uri) : return directory list based on URI
 8416: 
 8417: =item *
 8418: 
 8419: spareserver() : find server with least workload from spare.tab
 8420: 
 8421: =back
 8422: 
 8423: =head2 Apache Request
 8424: 
 8425: =over 4
 8426: 
 8427: =item *
 8428: 
 8429: ssi($url,%hash) : server side include, does a complete request cycle on url to
 8430: localhost, posts hash
 8431: 
 8432: =back
 8433: 
 8434: =head2 Data to String to Data
 8435: 
 8436: =over 4
 8437: 
 8438: =item *
 8439: 
 8440: hash2str(%hash) : convert a hash into a string complete with escaping and '='
 8441: and '&' separators, supports elements that are arrayrefs and hashrefs
 8442: 
 8443: =item *
 8444: 
 8445: hashref2str($hashref) : convert a hashref into a string complete with
 8446: escaping and '=' and '&' separators, supports elements that are
 8447: arrayrefs and hashrefs
 8448: 
 8449: =item *
 8450: 
 8451: arrayref2str($arrayref) : convert an arrayref into a string complete
 8452: with escaping and '&' separators, supports elements that are arrayrefs
 8453: and hashrefs
 8454: 
 8455: =item *
 8456: 
 8457: str2hash($string) : convert string to hash using unescaping and
 8458: splitting on '=' and '&', supports elements that are arrayrefs and
 8459: hashrefs
 8460: 
 8461: =item *
 8462: 
 8463: str2array($string) : convert string to hash using unescaping and
 8464: splitting on '&', supports elements that are arrayrefs and hashrefs
 8465: 
 8466: =back
 8467: 
 8468: =head2 Logging Routines
 8469: 
 8470: =over 4
 8471: 
 8472: These routines allow one to make log messages in the lonnet.log and
 8473: lonnet.perm logfiles.
 8474: 
 8475: =item *
 8476: 
 8477: logtouch() : make sure the logfile, lonnet.log, exists
 8478: 
 8479: =item *
 8480: 
 8481: logthis() : append message to the normal lonnet.log file, it gets
 8482: preiodically rolled over and deleted.
 8483: 
 8484: =item *
 8485: 
 8486: logperm() : append a permanent message to lonnet.perm.log, this log
 8487: file never gets deleted by any automated portion of the system, only
 8488: messages of critical importance should go in here.
 8489: 
 8490: =back
 8491: 
 8492: =head2 General File Helper Routines
 8493: 
 8494: =over 4
 8495: 
 8496: =item *
 8497: 
 8498: getfile($file,$caller) : two cases - requests for files in /res or in /uploaded.
 8499: (a) files in /uploaded
 8500:   (i) If a local copy of the file exists - 
 8501:       compares modification date of local copy with last-modified date for 
 8502:       definitive version stored on home server for course. If local copy is 
 8503:       stale, requests a new version from the home server and stores it. 
 8504:       If the original has been removed from the home server, then local copy 
 8505:       is unlinked.
 8506:   (ii) If local copy does not exist -
 8507:       requests the file from the home server and stores it. 
 8508:   
 8509:   If $caller is 'uploadrep':  
 8510:     This indicates a call from lonuploadrep.pm (PerlHeaderParserHandler phase)
 8511:     for request for files originally uploaded via DOCS. 
 8512:      - returns 'ok' if fresh local copy now available, -1 otherwise.
 8513:   
 8514:   Otherwise:
 8515:      This indicates a call from the content generation phase of the request.
 8516:      -  returns the entire contents of the file or -1.
 8517:      
 8518: (b) files in /res
 8519:    - returns the entire contents of a file or -1; 
 8520:    it properly subscribes to and replicates the file if neccessary.
 8521: 
 8522: 
 8523: =item *
 8524: 
 8525: stat_file($url) : $url is expected to be a /res/ or /uploaded/ style file
 8526:                   reference
 8527: 
 8528: returns either a stat() list of data about the file or an empty list
 8529: if the file doesn't exist or couldn't find out about it (connection
 8530: problems or user unknown)
 8531: 
 8532: =item *
 8533: 
 8534: filelocation($dir,$file) : returns file system location of a file
 8535: based on URI; meant to be "fairly clean" absolute reference, $dir is a
 8536: directory that relative $file lookups are to looked in ($dir of /a/dir
 8537: and a file of ../bob will become /a/bob)
 8538: 
 8539: =item *
 8540: 
 8541: hreflocation($dir,$file) : returns file system location or a URL; same as
 8542: filelocation except for hrefs
 8543: 
 8544: =item *
 8545: 
 8546: declutter() : declutters URLs (remove docroot, beginning slashes, 'res' etc)
 8547: 
 8548: =back
 8549: 
 8550: =head2 Usererfile file routines (/uploaded*)
 8551: 
 8552: =over 4
 8553: 
 8554: =item *
 8555: 
 8556: userfileupload(): main rotine for putting a file in a user or course's
 8557:                   filespace, arguments are,
 8558: 
 8559:  formname - required - this is the name of the element in $env where the
 8560:            filename, and the contents of the file to create/modifed exist
 8561:            the filename is in $env{'form.'.$formname.'.filename'} and the
 8562:            contents of the file is located in $env{'form.'.$formname}
 8563:  coursedoc - if true, store the file in the course of the active role
 8564:              of the current user
 8565:  subdir - required - subdirectory to put the file in under ../userfiles/
 8566:          if undefined, it will be placed in "unknown"
 8567: 
 8568:  (This routine calls clean_filename() to remove any dangerous
 8569:  characters from the filename, and then calls finuserfileupload() to
 8570:  complete the transaction)
 8571: 
 8572:  returns either the url of the uploaded file (/uploaded/....) if successful
 8573:  and /adm/notfound.html if unsuccessful
 8574: 
 8575: =item *
 8576: 
 8577: clean_filename(): routine for cleaing a filename up for storage in
 8578:                  userfile space, argument is:
 8579: 
 8580:  filename - proposed filename
 8581: 
 8582: returns: the new clean filename
 8583: 
 8584: =item *
 8585: 
 8586: finishuserfileupload(): routine that creaes and sends the file to
 8587: userspace, probably shouldn't be called directly
 8588: 
 8589:   docuname: username or courseid of destination for the file
 8590:   docudom: domain of user/course of destination for the file
 8591:   formname: same as for userfileupload()
 8592:   fname: filename (inculding subdirectories) for the file
 8593: 
 8594:  returns either the url of the uploaded file (/uploaded/....) if successful
 8595:  and /adm/notfound.html if unsuccessful
 8596: 
 8597: =item *
 8598: 
 8599: renameuserfile(): renames an existing userfile to a new name
 8600: 
 8601:   Args:
 8602:    docuname: username or courseid of destination for the file
 8603:    docudom: domain of user/course of destination for the file
 8604:    old: current file name (including any subdirs under userfiles)
 8605:    new: desired file name (including any subdirs under userfiles)
 8606: 
 8607: =item *
 8608: 
 8609: mkdiruserfile(): creates a directory is a userfiles dir
 8610: 
 8611:   Args:
 8612:    docuname: username or courseid of destination for the file
 8613:    docudom: domain of user/course of destination for the file
 8614:    dir: dir to create (including any subdirs under userfiles)
 8615: 
 8616: =item *
 8617: 
 8618: removeuserfile(): removes a file that exists in userfiles
 8619: 
 8620:   Args:
 8621:    docuname: username or courseid of destination for the file
 8622:    docudom: domain of user/course of destination for the file
 8623:    fname: filname to delete (including any subdirs under userfiles)
 8624: 
 8625: =item *
 8626: 
 8627: removeuploadedurl(): convience function for removeuserfile()
 8628: 
 8629:   Args:
 8630:    url:  a full /uploaded/... url to delete
 8631: 
 8632: =item * 
 8633: 
 8634: get_portfile_permissions():
 8635:   Args:
 8636:     domain: domain of user or course contain the portfolio files
 8637:     user: name of user or num of course contain the portfolio files
 8638:   Returns:
 8639:     hashref of a dump of the proper file_permissions.db
 8640:    
 8641: 
 8642: =item * 
 8643: 
 8644: get_access_controls():
 8645: 
 8646: Args:
 8647:   current_permissions: the hash ref returned from get_portfile_permissions()
 8648:   group: (optional) the group you want the files associated with
 8649:   file: (optional) the file you want access info on
 8650: 
 8651: Returns:
 8652:     a hash (keys are file names) of hashes containing
 8653:         keys are: path to file/file_name\0uniqueID:scope_end_start (see below)
 8654:         values are XML containing access control settings (see below) 
 8655: 
 8656: Internal notes:
 8657: 
 8658:  access controls are stored in file_permissions.db as key=value pairs.
 8659:     key -> path to file/file_name\0uniqueID:scope_end_start
 8660:         where scope -> public,guest,course,group,domains or users.
 8661:               end -> UNIX time for end of access (0 -> no end date)
 8662:               start -> UNIX time for start of access
 8663: 
 8664:     value -> XML description of access control
 8665:            <scope type=""> (type =1 of: public,guest,course,group,domains,users">
 8666:             <start></start>
 8667:             <end></end>
 8668: 
 8669:             <password></password>  for scope type = guest
 8670: 
 8671:             <domain></domain>     for scope type = course or group
 8672:             <number></number>
 8673:             <roles id="">
 8674:              <role></role>
 8675:              <access></access>
 8676:              <section></section>
 8677:              <group></group>
 8678:             </roles>
 8679: 
 8680:             <dom></dom>         for scope type = domains
 8681: 
 8682:             <users>             for scope type = users
 8683:              <user>
 8684:               <uname></uname>
 8685:               <udom></udom>
 8686:              </user>
 8687:             </users>
 8688:            </scope> 
 8689:               
 8690:  Access data is also aggregated for each file in an additional key=value pair:
 8691:  key -> path to file/file_name\0accesscontrol 
 8692:  value -> reference to hash
 8693:           hash contains key = value pairs
 8694:           where key = uniqueID:scope_end_start
 8695:                 value = UNIX time record was last updated
 8696: 
 8697:           Used to improve speed of look-ups of access controls for each file.  
 8698:  
 8699:  Locks on files (resulting from submission of portfolio file to a homework problem stored in array of arrays.
 8700: 
 8701: modify_access_controls():
 8702: 
 8703: Modifies access controls for a portfolio file
 8704: Args
 8705: 1. file name
 8706: 2. reference to hash of required changes,
 8707: 3. domain
 8708: 4. username
 8709:   where domain,username are the domain of the portfolio owner 
 8710:   (either a user or a course) 
 8711: 
 8712: Returns:
 8713: 1. result of additions or updates ('ok' or 'error', with error message). 
 8714: 2. result of deletions ('ok' or 'error', with error message).
 8715: 3. reference to hash of any new or updated access controls.
 8716: 4. reference to hash used to map incoming IDs to uniqueIDs assigned to control.
 8717:    key = integer (inbound ID)
 8718:    value = uniqueID  
 8719: 
 8720: =back
 8721: 
 8722: =head2 HTTP Helper Routines
 8723: 
 8724: =over 4
 8725: 
 8726: =item *
 8727: 
 8728: escape() : unpack non-word characters into CGI-compatible hex codes
 8729: 
 8730: =item *
 8731: 
 8732: unescape() : pack CGI-compatible hex codes into actual non-word ASCII character
 8733: 
 8734: =back
 8735: 
 8736: =head1 PRIVATE SUBROUTINES
 8737: 
 8738: =head2 Underlying communication routines (Shouldn't call)
 8739: 
 8740: =over 4
 8741: 
 8742: =item *
 8743: 
 8744: subreply() : tries to pass a message to lonc, returns con_lost if incapable
 8745: 
 8746: =item *
 8747: 
 8748: reply() : uses subreply to send a message to remote machine, logs all failures
 8749: 
 8750: =item *
 8751: 
 8752: critical() : passes a critical message to another server; if cannot
 8753: get through then place message in connection buffer directory and
 8754: returns con_delayed, if incapable of saving message, returns
 8755: con_failed
 8756: 
 8757: =item *
 8758: 
 8759: reconlonc() : tries to reconnect lonc client processes.
 8760: 
 8761: =back
 8762: 
 8763: =head2 Resource Access Logging
 8764: 
 8765: =over 4
 8766: 
 8767: =item *
 8768: 
 8769: flushcourselogs() : flush (save) buffer logs and access logs
 8770: 
 8771: =item *
 8772: 
 8773: courselog($what) : save message for course in hash
 8774: 
 8775: =item *
 8776: 
 8777: courseacclog($what) : save message for course using &courselog().  Perform
 8778: special processing for specific resource types (problems, exams, quizzes, etc).
 8779: 
 8780: =item *
 8781: 
 8782: goodbye() : flush course logs and log shutting down; it is called in srm.conf
 8783: as a PerlChildExitHandler
 8784: 
 8785: =back
 8786: 
 8787: =head2 Other
 8788: 
 8789: =over 4
 8790: 
 8791: =item *
 8792: 
 8793: symblist($mapname,%newhash) : update symbolic storage links
 8794: 
 8795: =back
 8796: 
 8797: =cut