Annotation of loncom/lonnet/perl/lonnet.pm, revision 1.459

1.1       albertel    1: # The LearningOnline Network
                      2: # TCP networking package
1.12      www         3: #
1.459   ! albertel    4: # $Id: lonnet.pm,v 1.458 2003/12/09 16:22:06 matthew Exp $
1.178     www         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: #
1.169     harris41   28: ###
                     29: 
1.1       albertel   30: package Apache::lonnet;
                     31: 
                     32: use strict;
1.8       www        33: use LWP::UserAgent();
1.15      www        34: use HTTP::Headers;
1.11      www        35: use vars 
1.300     albertel   36: qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom 
1.440     www        37:    %libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache
1.349     www        38:    %courselogs %accesshash %userrolehash $processmarker $dumpcount 
1.352     www        39:    %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache 
1.420     albertel   40:    %userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def 
1.403     www        41:    %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir);
                     42: 
1.1       albertel   43: use IO::Socket;
1.31      www        44: use GDBM_File;
1.8       www        45: use Apache::Constants qw(:common :http);
1.208     albertel   46: use HTML::LCParser;
1.88      www        47: use Fcntl qw(:flock);
1.294     matthew    48: use Apache::loncoursedata;
1.414     www        49: use Apache::lonlocal;
1.428     albertel   50: use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw);
1.425     albertel   51: use Time::HiRes();
1.195     www        52: my $readit;
1.1       albertel   53: 
1.449     matthew    54: =pod
                     55: 
                     56: =head1 Package Variables
                     57: 
                     58: These are largely undocumented, so if you decipher one please note it here.
                     59: 
                     60: =over 4
                     61: 
                     62: =item $processmarker
                     63: 
                     64: Contains the time this process was started and this servers host id.
                     65: 
                     66: =item $dumpcount
                     67: 
                     68: Counts the number of times a message log flush has been attempted (regardless
                     69: of success) by this process.  Used as part of the filename when messages are
                     70: delayed.
                     71: 
                     72: =back
                     73: 
                     74: =cut
                     75: 
                     76: 
1.1       albertel   77: # --------------------------------------------------------------------- Logging
                     78: 
1.163     harris41   79: sub logtouch {
                     80:     my $execdir=$perlvar{'lonDaemons'};
1.448     albertel   81:     unless (-e "$execdir/logs/lonnet.log") {	
                     82: 	open(my $fh,">>$execdir/logs/lonnet.log");
1.163     harris41   83: 	close $fh;
                     84:     }
                     85:     my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3];
                     86:     chown($wwwuid,$wwwgid,$execdir.'/logs/lonnet.log');
                     87: }
                     88: 
1.1       albertel   89: sub logthis {
                     90:     my $message=shift;
                     91:     my $execdir=$perlvar{'lonDaemons'};
                     92:     my $now=time;
                     93:     my $local=localtime($now);
1.448     albertel   94:     if (open(my $fh,">>$execdir/logs/lonnet.log")) {
                     95: 	print $fh "$local ($$): $message\n";
                     96: 	close($fh);
                     97:     }
1.1       albertel   98:     return 1;
                     99: }
                    100: 
                    101: sub logperm {
                    102:     my $message=shift;
                    103:     my $execdir=$perlvar{'lonDaemons'};
                    104:     my $now=time;
                    105:     my $local=localtime($now);
1.448     albertel  106:     if (open(my $fh,">>$execdir/logs/lonnet.perm.log")) {
                    107: 	print $fh "$now:$message:$local\n";
                    108: 	close($fh);
                    109:     }
1.1       albertel  110:     return 1;
                    111: }
                    112: 
                    113: # -------------------------------------------------- Non-critical communication
                    114: sub subreply {
                    115:     my ($cmd,$server)=@_;
                    116:     my $peerfile="$perlvar{'lonSockDir'}/$server";
                    117:     my $client=IO::Socket::UNIX->new(Peer    =>"$peerfile",
                    118:                                      Type    => SOCK_STREAM,
                    119:                                      Timeout => 10)
                    120:        or return "con_lost";
                    121:     print $client "$cmd\n";
                    122:     my $answer=<$client>;
1.9       www       123:     if (!$answer) { $answer="con_lost"; }
1.1       albertel  124:     chomp($answer);
                    125:     return $answer;
                    126: }
                    127: 
                    128: sub reply {
                    129:     my ($cmd,$server)=@_;
1.205     www       130:     unless (defined($hostname{$server})) { return 'no_such_host'; }
1.1       albertel  131:     my $answer=subreply($cmd,$server);
1.203     www       132:     if ($answer eq 'con_lost') {
1.311     matthew   133:         #sleep 5; 
                    134:         #$answer=subreply($cmd,$server);
                    135:         #if ($answer eq 'con_lost') {
1.233     albertel  136: 	#   &logthis("Second attempt con_lost on $server");
                    137:         #   my $peerfile="$perlvar{'lonSockDir'}/$server";
                    138:         #   my $client=IO::Socket::UNIX->new(Peer    =>"$peerfile",
                    139:         #                                    Type    => SOCK_STREAM,
                    140:         #                                    Timeout => 10)
                    141:         #              or return "con_lost";
                    142:         #   &logthis("Killing socket");
                    143:         #   print $client "close_connection_exit\n";
                    144:            #sleep 5;
                    145:         #   $answer=subreply($cmd,$server);       
                    146:        #}   
1.203     www       147:     }
1.65      www       148:     if (($answer=~/^refused/) || ($answer=~/^rejected/)) {
1.12      www       149:        &logthis("<font color=blue>WARNING:".
                    150:                 " $cmd to $server returned $answer</font>");
                    151:     }
1.1       albertel  152:     return $answer;
                    153: }
                    154: 
                    155: # ----------------------------------------------------------- Send USR1 to lonc
                    156: 
                    157: sub reconlonc {
                    158:     my $peerfile=shift;
                    159:     &logthis("Trying to reconnect for $peerfile");
                    160:     my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
1.448     albertel  161:     if (open(my $fh,"<$loncfile")) {
1.1       albertel  162: 	my $loncpid=<$fh>;
                    163:         chomp($loncpid);
                    164:         if (kill 0 => $loncpid) {
                    165: 	    &logthis("lonc at pid $loncpid responding, sending USR1");
                    166:             kill USR1 => $loncpid;
                    167:             sleep 1;
                    168:             if (-e "$peerfile") { return; }
                    169:             &logthis("$peerfile still not there, give it another try");
                    170:             sleep 5;
                    171:             if (-e "$peerfile") { return; }
1.12      www       172:             &logthis(
                    173:   "<font color=blue>WARNING: $peerfile still not there, giving up</font>");
1.1       albertel  174:         } else {
1.12      www       175: 	    &logthis(
                    176:                "<font color=blue>WARNING:".
                    177:                " lonc at pid $loncpid not responding, giving up</font>");
1.1       albertel  178:         }
                    179:     } else {
1.12      www       180:      &logthis('<font color=blue>WARNING: lonc not running, giving up</font>');
1.1       albertel  181:     }
                    182: }
                    183: 
                    184: # ------------------------------------------------------ Critical communication
1.12      www       185: 
1.1       albertel  186: sub critical {
                    187:     my ($cmd,$server)=@_;
1.89      www       188:     unless ($hostname{$server}) {
                    189:         &logthis("<font color=blue>WARNING:".
                    190:                " Critical message to unknown server ($server)</font>");
                    191:         return 'no_such_host';
                    192:     }
1.1       albertel  193:     my $answer=reply($cmd,$server);
                    194:     if ($answer eq 'con_lost') {
                    195:         my $pingreply=reply('ping',$server);
                    196: 	&reconlonc("$perlvar{'lonSockDir'}/$server");
                    197:         my $pongreply=reply('pong',$server);
                    198:         &logthis("Ping/Pong for $server: $pingreply/$pongreply");
                    199:         $answer=reply($cmd,$server);
                    200:         if ($answer eq 'con_lost') {
                    201:             my $now=time;
                    202:             my $middlename=$cmd;
1.5       www       203:             $middlename=substr($middlename,0,16);
1.1       albertel  204:             $middlename=~s/\W//g;
                    205:             my $dfilename=
1.305     www       206:       "$perlvar{'lonSockDir'}/delayed/$now.$dumpcount.$$.$middlename.$server";
                    207:             $dumpcount++;
1.1       albertel  208:             {
1.448     albertel  209: 		my $dfh;
                    210: 		if (open($dfh,">$dfilename")) {
                    211: 		    print $dfh "$cmd\n"; 
                    212: 		    close($dfh);
                    213: 		}
1.1       albertel  214:             }
                    215:             sleep 2;
                    216:             my $wcmd='';
                    217:             {
1.448     albertel  218: 		my $dfh;
                    219: 		if (open($dfh,"<$dfilename")) {
                    220: 		    $wcmd=<$dfh>; 
                    221: 		    close($dfh);
                    222: 		}
1.1       albertel  223:             }
                    224:             chomp($wcmd);
1.7       www       225:             if ($wcmd eq $cmd) {
1.12      www       226: 		&logthis("<font color=blue>WARNING: ".
                    227:                          "Connection buffer $dfilename: $cmd</font>");
1.1       albertel  228:                 &logperm("D:$server:$cmd");
                    229: 	        return 'con_delayed';
                    230:             } else {
1.12      www       231:                 &logthis("<font color=red>CRITICAL:"
                    232:                         ." Critical connection failed: $server $cmd</font>");
1.1       albertel  233:                 &logperm("F:$server:$cmd");
                    234:                 return 'con_failed';
                    235:             }
                    236:         }
                    237:     }
                    238:     return $answer;
1.405     albertel  239: }
                    240: 
1.412     www       241: #
1.405     albertel  242: # -------------- Remove all key from the env that start witha lowercase letter
1.412     www       243: #                (Which is always a lon-capa value)
                    244: 
1.405     albertel  245: sub cleanenv {
1.412     www       246: #    unless (defined(&Apache::exists_config_define("MODPERL2"))) { return; }
                    247: #    unless (&Apache::exists_config_define("MODPERL2")) { return; }
1.405     albertel  248:     foreach my $key (keys(%ENV)) {
                    249: 	if ($key =~ /^[a-z]/) {
                    250: 	    delete($ENV{$key});
                    251: 	}
                    252:     }
1.374     www       253: }
                    254:  
                    255: # ------------------------------------------- Transfer profile into environment
                    256: 
                    257: sub transfer_profile_to_env {
                    258:     my ($lonidsdir,$handle)=@_;
                    259:     my @profile;
                    260:     {
1.448     albertel  261: 	open(my $idf,"$lonidsdir/$handle.id");
1.374     www       262: 	flock($idf,LOCK_SH);
                    263: 	@profile=<$idf>;
1.448     albertel  264: 	close($idf);
1.374     www       265:     }
                    266:     my $envi;
1.433     matthew   267:     my %Remove;
1.374     www       268:     for ($envi=0;$envi<=$#profile;$envi++) {
                    269: 	chomp($profile[$envi]);
                    270: 	my ($envname,$envvalue)=split(/=/,$profile[$envi]);
                    271: 	$ENV{$envname} = $envvalue;
1.433     matthew   272:         if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {
                    273:             if ($time < time-300) {
                    274:                 $Remove{$key}++;
                    275:             }
                    276:         }
                    277:     }
1.446     albertel  278:     $ENV{'user.environment'} = "$lonidsdir/$handle.id";
1.433     matthew   279:     foreach my $expired_key (keys(%Remove)) {
                    280:         &delenv($expired_key);
1.374     www       281:     }
1.1       albertel  282: }
                    283: 
1.5       www       284: # ---------------------------------------------------------- Append Environment
                    285: 
                    286: sub appenv {
1.6       www       287:     my %newenv=@_;
1.191     harris41  288:     foreach (keys %newenv) {
1.35      www       289: 	if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) {
                    290:             &logthis("<font color=blue>WARNING: ".
1.151     www       291:                 "Attempt to modify environment ".$_." to ".$newenv{$_}
                    292:                 .'</font>');
1.35      www       293: 	    delete($newenv{$_});
                    294:         } else {
                    295:             $ENV{$_}=$newenv{$_};
                    296:         }
1.191     harris41  297:     }
1.95      www       298: 
                    299:     my $lockfh;
1.448     albertel  300:     unless (open($lockfh,"$ENV{'user.environment'}")) {
                    301: 	return 'error: '.$!;
1.95      www       302:     }
                    303:     unless (flock($lockfh,LOCK_EX)) {
                    304:          &logthis("<font color=blue>WARNING: ".
                    305:                   'Could not obtain exclusive lock in appenv: '.$!);
1.448     albertel  306:          close($lockfh);
1.95      www       307:          return 'error: '.$!;
                    308:     }
                    309: 
1.6       www       310:     my @oldenv;
                    311:     {
1.448     albertel  312: 	my $fh;
                    313: 	unless (open($fh,"$ENV{'user.environment'}")) {
                    314: 	    return 'error: '.$!;
                    315: 	}
                    316: 	@oldenv=<$fh>;
                    317: 	close($fh);
1.6       www       318:     }
                    319:     for (my $i=0; $i<=$#oldenv; $i++) {
                    320:         chomp($oldenv[$i]);
1.9       www       321:         if ($oldenv[$i] ne '') {
1.448     albertel  322: 	    my ($name,$value)=split(/=/,$oldenv[$i]);
                    323: 	    unless (defined($newenv{$name})) {
                    324: 		$newenv{$name}=$value;
                    325: 	    }
1.9       www       326:         }
1.6       www       327:     }
                    328:     {
1.448     albertel  329: 	my $fh;
                    330: 	unless (open($fh,">$ENV{'user.environment'}")) {
                    331: 	    return 'error';
                    332: 	}
                    333: 	my $newname;
                    334: 	foreach $newname (keys %newenv) {
                    335: 	    print $fh "$newname=$newenv{$newname}\n";
                    336: 	}
                    337: 	close($fh);
1.56      www       338:     }
1.448     albertel  339: 	
                    340:     close($lockfh);
1.56      www       341:     return 'ok';
                    342: }
                    343: # ----------------------------------------------------- Delete from Environment
                    344: 
                    345: sub delenv {
                    346:     my $delthis=shift;
                    347:     my %newenv=();
                    348:     if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {
                    349:         &logthis("<font color=blue>WARNING: ".
                    350:                 "Attempt to delete from environment ".$delthis);
                    351:         return 'error';
                    352:     }
                    353:     my @oldenv;
                    354:     {
1.448     albertel  355: 	my $fh;
                    356: 	unless (open($fh,"$ENV{'user.environment'}")) {
                    357: 	    return 'error';
                    358: 	}
                    359: 	unless (flock($fh,LOCK_SH)) {
                    360: 	    &logthis("<font color=blue>WARNING: ".
                    361: 		     'Could not obtain shared lock in delenv: '.$!);
                    362: 	    close($fh);
                    363: 	    return 'error: '.$!;
                    364: 	}
                    365: 	@oldenv=<$fh>;
                    366: 	close($fh);
1.56      www       367:     }
                    368:     {
1.448     albertel  369: 	my $fh;
                    370: 	unless (open($fh,">$ENV{'user.environment'}")) {
                    371: 	    return 'error';
                    372: 	}
                    373: 	unless (flock($fh,LOCK_EX)) {
                    374: 	    &logthis("<font color=blue>WARNING: ".
                    375: 		     'Could not obtain exclusive lock in delenv: '.$!);
                    376: 	    close($fh);
                    377: 	    return 'error: '.$!;
                    378: 	}
                    379: 	foreach (@oldenv) {
                    380: 	    unless ($_=~/^$delthis/) { print $fh $_; }
                    381: 	}
                    382: 	close($fh);
1.5       www       383:     }
                    384:     return 'ok';
1.369     albertel  385: }
                    386: 
                    387: # ------------------------------------------ Find out current server userload
                    388: # there is a copy in lond
                    389: sub userload {
                    390:     my $numusers=0;
                    391:     {
                    392: 	opendir(LONIDS,$perlvar{'lonIDsDir'});
                    393: 	my $filename;
                    394: 	my $curtime=time;
                    395: 	while ($filename=readdir(LONIDS)) {
                    396: 	    if ($filename eq '.' || $filename eq '..') {next;}
1.404     albertel  397: 	    my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];
1.437     albertel  398: 	    if ($curtime-$mtime < 1800) { $numusers++; }
1.369     albertel  399: 	}
                    400: 	closedir(LONIDS);
                    401:     }
                    402:     my $userloadpercent=0;
                    403:     my $maxuserload=$perlvar{'lonUserLoadLim'};
                    404:     if ($maxuserload) {
1.371     albertel  405: 	$userloadpercent=100*$numusers/$maxuserload;
1.369     albertel  406:     }
1.372     albertel  407:     $userloadpercent=sprintf("%.2f",$userloadpercent);
1.369     albertel  408:     return $userloadpercent;
1.283     www       409: }
                    410: 
                    411: # ------------------------------------------ Fight off request when overloaded
                    412: 
                    413: sub overloaderror {
                    414:     my ($r,$checkserver)=@_;
                    415:     unless ($checkserver) { $checkserver=$perlvar{'lonHostID'}; }
                    416:     my $loadavg;
                    417:     if ($checkserver eq $perlvar{'lonHostID'}) {
1.448     albertel  418:        open(my $loadfile,'/proc/loadavg');
1.283     www       419:        $loadavg=<$loadfile>;
                    420:        $loadavg =~ s/\s.*//g;
1.285     matthew   421:        $loadavg = 100*$loadavg/$perlvar{'lonLoadLim'};
1.448     albertel  422:        close($loadfile);
1.283     www       423:     } else {
                    424:        $loadavg=&reply('load',$checkserver);
                    425:     }
1.285     matthew   426:     my $overload=$loadavg-100;
1.283     www       427:     if ($overload>0) {
1.285     matthew   428: 	$r->err_headers_out->{'Retry-After'}=$overload;
1.283     www       429:         $r->log_error('Overload of '.$overload.' on '.$checkserver);
                    430:         return 413;
                    431:     }    
                    432:     return '';
1.5       www       433: }
1.1       albertel  434: 
                    435: # ------------------------------ Find server with least workload from spare.tab
1.11      www       436: 
1.1       albertel  437: sub spareserver {
1.370     albertel  438:     my ($loadpercent,$userloadpercent) = @_;
1.1       albertel  439:     my $tryserver;
                    440:     my $spareserver='';
1.370     albertel  441:     if ($userloadpercent !~ /\d/) { $userloadpercent=0; }
                    442:     my $lowestserver=$loadpercent > $userloadpercent?
                    443: 	             $loadpercent :  $userloadpercent;
1.1       albertel  444:     foreach $tryserver (keys %spareid) {
1.411     albertel  445: 	my $loadans=reply('load',$tryserver);
                    446: 	my $userloadans=reply('userload',$tryserver);
                    447: 	if ($loadans !~ /\d/ && $userloadans !~ /\d/) {
                    448: 	    next; #didn't get a number from the server
                    449: 	}
                    450: 	my $answer;
                    451: 	if ($loadans =~ /\d/) {
                    452: 	    if ($userloadans =~ /\d/) {
                    453: 		#both are numbers, pick the bigger one
                    454: 		$answer=$loadans > $userloadans?
                    455: 		    $loadans :  $userloadans;
                    456: 	    } else {
                    457: 		$answer = $loadans;
                    458: 	    }
                    459: 	} else {
                    460: 	    $answer = $userloadans;
                    461: 	}
                    462: 	if (($answer =~ /\d/) && ($answer<$lowestserver)) {
                    463: 	    $spareserver="http://$hostname{$tryserver}";
                    464: 	    $lowestserver=$answer;
                    465: 	}
1.370     albertel  466:     }
1.1       albertel  467:     return $spareserver;
1.202     matthew   468: }
                    469: 
                    470: # --------------------------------------------- Try to change a user's password
                    471: 
                    472: sub changepass {
                    473:     my ($uname,$udom,$currentpass,$newpass,$server)=@_;
                    474:     $currentpass = &escape($currentpass);
                    475:     $newpass     = &escape($newpass);
                    476:     my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass",
                    477: 		       $server);
                    478:     if (! $answer) {
                    479: 	&logthis("No reply on password change request to $server ".
                    480: 		 "by $uname in domain $udom.");
                    481:     } elsif ($answer =~ "^ok") {
                    482:         &logthis("$uname in $udom successfully changed their password ".
                    483: 		 "on $server.");
                    484:     } elsif ($answer =~ "^pwchange_failure") {
                    485: 	&logthis("$uname in $udom was unable to change their password ".
                    486: 		 "on $server.  The action was blocked by either lcpasswd ".
                    487: 		 "or pwchange");
                    488:     } elsif ($answer =~ "^non_authorized") {
                    489:         &logthis("$uname in $udom did not get their password correct when ".
                    490: 		 "attempting to change it on $server.");
                    491:     } elsif ($answer =~ "^auth_mode_error") {
                    492:         &logthis("$uname in $udom attempted to change their password despite ".
                    493: 		 "not being locally or internally authenticated on $server.");
                    494:     } elsif ($answer =~ "^unknown_user") {
                    495:         &logthis("$uname in $udom attempted to change their password ".
                    496: 		 "on $server but were unable to because $server is not ".
                    497: 		 "their home server.");
                    498:     } elsif ($answer =~ "^refused") {
                    499: 	&logthis("$server refused to change $uname in $udom password because ".
                    500: 		 "it was sent an unencrypted request to change the password.");
                    501:     }
                    502:     return $answer;
1.1       albertel  503: }
                    504: 
1.169     harris41  505: # ----------------------- Try to determine user's current authentication scheme
                    506: 
                    507: sub queryauthenticate {
                    508:     my ($uname,$udom)=@_;
1.456     albertel  509:     my $uhome=&homeserver($uname,$udom);
                    510:     if (!$uhome) {
                    511: 	&logthis("User $uname at $udom is unknown when looking for authentication mechanism");
                    512: 	return 'no_host';
                    513:     }
                    514:     my $answer=reply("encrypt:currentauth:$udom:$uname",$uhome);
                    515:     if ($answer =~ /^(unknown_user|refused|con_lost)/) {
                    516: 	&logthis("User $uname at $udom threw error $answer when checking authentication mechanism");
1.169     harris41  517:     }
1.456     albertel  518:     return $answer;
1.169     harris41  519: }
                    520: 
1.1       albertel  521: # --------- Try to authenticate user from domain's lib servers (first this one)
1.11      www       522: 
1.1       albertel  523: sub authenticate {
                    524:     my ($uname,$upass,$udom)=@_;
1.12      www       525:     $upass=escape($upass);
1.199     www       526:     $uname=~s/\W//g;
1.1       albertel  527:     if (($perlvar{'lonRole'} eq 'library') && 
                    528:         ($udom eq $perlvar{'lonDefDomain'})) {
1.3       www       529:     my $answer=reply("encrypt:auth:$udom:$uname:$upass",$perlvar{'lonHostID'});
1.2       www       530:         if ($answer =~ /authorized/) {
1.9       www       531:               if ($answer eq 'authorized') {
                    532:                  &logthis("User $uname at $udom authorized by local server"); 
                    533:                  return $perlvar{'lonHostID'}; 
                    534:               }
                    535:               if ($answer eq 'non_authorized') {
                    536:                  &logthis("User $uname at $udom rejected by local server"); 
                    537:                  return 'no_host'; 
                    538:               }
1.2       www       539: 	}
1.1       albertel  540:     }
                    541: 
                    542:     my $tryserver;
                    543:     foreach $tryserver (keys %libserv) {
                    544: 	if ($hostdom{$tryserver} eq $udom) {
1.10      www       545:            my $answer=reply("encrypt:auth:$udom:$uname:$upass",$tryserver);
1.1       albertel  546:            if ($answer =~ /authorized/) {
1.9       www       547:               if ($answer eq 'authorized') {
                    548:                  &logthis("User $uname at $udom authorized by $tryserver"); 
                    549:                  return $tryserver; 
                    550:               }
                    551:               if ($answer eq 'non_authorized') {
                    552:                  &logthis("User $uname at $udom rejected by $tryserver");
                    553:                  return 'no_host';
                    554:               } 
1.1       albertel  555: 	   }
                    556:        }
1.9       www       557:     }
                    558:     &logthis("User $uname at $udom could not be authenticated");    
1.1       albertel  559:     return 'no_host';
                    560: }
                    561: 
                    562: # ---------------------- Find the homebase for a user from domain's lib servers
1.11      www       563: 
1.1       albertel  564: sub homeserver {
1.230     stredwic  565:     my ($uname,$udom,$ignoreBadCache)=@_;
1.1       albertel  566:     my $index="$uname:$udom";
1.426     albertel  567: 
                    568:     my ($result,$cached)=&is_cached(\%homecache,$index,'home',86400);
                    569:     if (defined($cached)) { return $result; }
1.1       albertel  570:     my $tryserver;
                    571:     foreach $tryserver (keys %libserv) {
1.230     stredwic  572:         next if ($ignoreBadCache ne 'true' && 
1.231     stredwic  573: 		 exists($badServerCache{$tryserver}));
1.1       albertel  574: 	if ($hostdom{$tryserver} eq $udom) {
                    575:            my $answer=reply("home:$udom:$uname",$tryserver);
                    576:            if ($answer eq 'found') { 
1.426     albertel  577: 	       return &do_cache(\%homecache,$index,$tryserver,'home');
1.231     stredwic  578:            } elsif ($answer eq 'no_host') {
                    579: 	       $badServerCache{$tryserver}=1;
1.221     matthew   580:            }
1.1       albertel  581:        }
                    582:     }    
                    583:     return 'no_host';
1.70      www       584: }
                    585: 
                    586: # ------------------------------------- Find the usernames behind a list of IDs
                    587: 
                    588: sub idget {
                    589:     my ($udom,@ids)=@_;
                    590:     my %returnhash=();
                    591:     
                    592:     my $tryserver;
                    593:     foreach $tryserver (keys %libserv) {
                    594:        if ($hostdom{$tryserver} eq $udom) {
                    595: 	  my $idlist=join('&',@ids);
                    596:           $idlist=~tr/A-Z/a-z/; 
                    597: 	  my $reply=&reply("idget:$udom:".$idlist,$tryserver);
                    598:           my @answer=();
1.76      www       599:           if (($reply ne 'con_lost') && ($reply!~/^error\:/)) {
1.70      www       600: 	      @answer=split(/\&/,$reply);
                    601:           }                    ;
                    602:           my $i;
                    603:           for ($i=0;$i<=$#ids;$i++) {
                    604:               if ($answer[$i]) {
                    605: 		  $returnhash{$ids[$i]}=$answer[$i];
                    606:               } 
                    607:           }
                    608:        }
                    609:     }    
                    610:     return %returnhash;
                    611: }
                    612: 
                    613: # ------------------------------------- Find the IDs behind a list of usernames
                    614: 
                    615: sub idrget {
                    616:     my ($udom,@unames)=@_;
                    617:     my %returnhash=();
1.191     harris41  618:     foreach (@unames) {
1.70      www       619:         $returnhash{$_}=(&userenvironment($udom,$_,'id'))[1];
1.191     harris41  620:     }
1.70      www       621:     return %returnhash;
                    622: }
                    623: 
                    624: # ------------------------------- Store away a list of names and associated IDs
                    625: 
                    626: sub idput {
                    627:     my ($udom,%ids)=@_;
                    628:     my %servers=();
1.191     harris41  629:     foreach (keys %ids) {
1.70      www       630:         my $uhom=&homeserver($_,$udom);
                    631:         if ($uhom ne 'no_host') {
                    632:             my $id=&escape($ids{$_});
                    633:             $id=~tr/A-Z/a-z/;
                    634:             my $unam=&escape($_);
                    635: 	    if ($servers{$uhom}) {
                    636: 		$servers{$uhom}.='&'.$id.'='.$unam;
                    637:             } else {
                    638:                 $servers{$uhom}=$id.'='.$unam;
                    639:             }
                    640:             &critical('put:'.$udom.':'.$unam.':environment:id='.$id,$uhom);
                    641:         }
1.191     harris41  642:     }
                    643:     foreach (keys %servers) {
1.70      www       644:         &critical('idput:'.$udom.':'.$servers{$_},$_);
1.191     harris41  645:     }
1.344     www       646: }
                    647: 
                    648: # --------------------------------------------------- Assign a key to a student
                    649: 
                    650: sub assign_access_key {
1.364     www       651: #
                    652: # a valid key looks like uname:udom#comments
                    653: # comments are being appended
                    654: #
                    655:     my ($ckey,$cdom,$cnum,$udom,$uname,$logentry)=@_;
1.344     www       656:     $cdom=
                    657:    $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));
                    658:     $cnum=
                    659:    $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));
                    660:     $udom=$ENV{'user.name'} unless (defined($udom));
                    661:     $uname=$ENV{'user.domain'} unless (defined($uname));
1.345     www       662:     my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
1.364     www       663:     if (($existing{$ckey}=~/^\#(.*)$/) || # - new key
                    664:         ($existing{$ckey}=~/^$uname\:$udom\#(.*)$/)) { 
                    665:                                                   # assigned to this person
                    666:                                                   # - this should not happen,
1.345     www       667:                                                   # unless something went wrong
                    668:                                                   # the first time around
                    669: # ready to assign
1.364     www       670:         $logentry=$1.'; '.$logentry;
                    671:         if (&put('accesskey',{$ckey=>$uname.':'.$udom.'#'.$logentry},
                    672:                                                  $cdom,$cnum) eq 'ok') {
1.345     www       673: # key now belongs to user
1.346     www       674: 	    my $envkey='key.'.$cdom.'_'.$cnum;
1.345     www       675:             if (&put('environment',{$envkey => $ckey}) eq 'ok') {
                    676:                 &appenv('environment.'.$envkey => $ckey);
                    677:                 return 'ok';
                    678:             } else {
                    679:                 return 
                    680:   'error: Count not permanently assign key, will need to be re-entered later.';
                    681: 	    }
                    682:         } else {
                    683:             return 'error: Could not assign key, try again later.';
                    684:         }
1.364     www       685:     } elsif (!$existing{$ckey}) {
1.345     www       686: # the key does not exist
                    687: 	return 'error: The key does not exist';
                    688:     } else {
                    689: # the key is somebody else's
                    690: 	return 'error: The key is already in use';
                    691:     }
1.344     www       692: }
                    693: 
1.364     www       694: # ------------------------------------------ put an additional comment on a key
                    695: 
                    696: sub comment_access_key {
                    697: #
                    698: # a valid key looks like uname:udom#comments
                    699: # comments are being appended
                    700: #
                    701:     my ($ckey,$cdom,$cnum,$logentry)=@_;
                    702:     $cdom=
                    703:    $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));
                    704:     $cnum=
                    705:    $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));
                    706:     my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
                    707:     if ($existing{$ckey}) {
                    708:         $existing{$ckey}.='; '.$logentry;
                    709: # ready to assign
1.367     www       710:         if (&put('accesskeys',{$ckey=>$existing{$ckey}},
1.364     www       711:                                                  $cdom,$cnum) eq 'ok') {
                    712: 	    return 'ok';
                    713:         } else {
                    714: 	    return 'error: Count not store comment.';
                    715:         }
                    716:     } else {
                    717: # the key does not exist
                    718: 	return 'error: The key does not exist';
                    719:     }
                    720: }
                    721: 
1.344     www       722: # ------------------------------------------------------ Generate a set of keys
                    723: 
                    724: sub generate_access_keys {
1.364     www       725:     my ($number,$cdom,$cnum,$logentry)=@_;
1.344     www       726:     $cdom=
                    727:    $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));
                    728:     $cnum=
                    729:    $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));
1.361     www       730:     unless (&allowed('mky',$cdom)) { return 0; }
1.344     www       731:     unless (($cdom) && ($cnum)) { return 0; }
                    732:     if ($number>10000) { return 0; }
                    733:     sleep(2); # make sure don't get same seed twice
                    734:     srand(time()^($$+($$<<15))); # from "Programming Perl"
                    735:     my $total=0;
                    736:     for (my $i=1;$i<=$number;$i++) {
                    737:        my $newkey=sprintf("%lx",int(100000*rand)).'-'.
                    738:                   sprintf("%lx",int(100000*rand)).'-'.
                    739:                   sprintf("%lx",int(100000*rand));
                    740:        $newkey=~s/1/g/g; # folks mix up 1 and l
                    741:        $newkey=~s/0/h/g; # and also 0 and O
                    742:        my %existing=&get('accesskeys',[$newkey],$cdom,$cnum);
                    743:        if ($existing{$newkey}) {
                    744:            $i--;
                    745:        } else {
1.364     www       746: 	  if (&put('accesskeys',
                    747:               { $newkey => '# generated '.localtime().
                    748:                            ' by '.$ENV{'user.name'}.'@'.$ENV{'user.domain'}.
                    749:                            '; '.$logentry },
                    750: 		   $cdom,$cnum) eq 'ok') {
1.344     www       751:               $total++;
                    752: 	  }
                    753:        }
                    754:     }
                    755:     &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.home'},
                    756:          'Generated '.$total.' keys for '.$cnum.' at '.$cdom);
                    757:     return $total;
                    758: }
                    759: 
                    760: # ------------------------------------------------------- Validate an accesskey
                    761: 
                    762: sub validate_access_key {
                    763:     my ($ckey,$cdom,$cnum,$udom,$uname)=@_;
                    764:     $cdom=
                    765:    $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));
                    766:     $cnum=
                    767:    $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));
                    768:     $udom=$ENV{'user.name'} unless (defined($udom));
                    769:     $uname=$ENV{'user.domain'} unless (defined($uname));
1.345     www       770:     my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
1.364     www       771:     return ($existing{$ckey}=~/^$uname\:$udom\#/);
1.70      www       772: }
                    773: 
                    774: # ------------------------------------- Find the section of student in a course
1.298     matthew   775: 
                    776: sub getsection {
                    777:     my ($udom,$unam,$courseid)=@_;
                    778:     $courseid=~s/\_/\//g;
                    779:     $courseid=~s/^(\w)/\/$1/;
                    780:     my %Pending; 
                    781:     my %Expired;
                    782:     #
                    783:     # Each role can either have not started yet (pending), be active, 
                    784:     #    or have expired.
                    785:     #
                    786:     # If there is an active role, we are done.
                    787:     #
                    788:     # If there is more than one role which has not started yet, 
                    789:     #     choose the one which will start sooner
                    790:     # If there is one role which has not started yet, return it.
                    791:     #
                    792:     # If there is more than one expired role, choose the one which ended last.
                    793:     # If there is a role which has expired, return it.
                    794:     #
                    795:     foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',
                    796:                         &homeserver($unam,$udom)))) {
                    797:         my ($key,$value)=split(/\=/,$_);
                    798:         $key=&unescape($key);
                    799:         next if ($key !~/^$courseid(?:\/)*(\w+)*\_st$/);
                    800:         my $section=$1;
                    801:         if ($key eq $courseid.'_st') { $section=''; }
                    802:         my ($dummy,$end,$start)=split(/\_/,&unescape($value));
                    803:         my $now=time;
                    804:         if (defined($end) && ($now > $end)) {
                    805:             $Expired{$end}=$section;
                    806:             next;
                    807:         }
                    808:         if (defined($start) && ($now < $start)) {
                    809:             $Pending{$start}=$section;
                    810:             next;
                    811:         }
                    812:         return $section;
                    813:     }
                    814:     #
                    815:     # Presumedly there will be few matching roles from the above
                    816:     # loop and the sorting time will be negligible.
                    817:     if (scalar(keys(%Pending))) {
                    818:         my ($time) = sort {$a <=> $b} keys(%Pending);
                    819:         return $Pending{$time};
                    820:     } 
                    821:     if (scalar(keys(%Expired))) {
                    822:         my @sorted = sort {$a <=> $b} keys(%Expired);
                    823:         my $time = pop(@sorted);
                    824:         return $Expired{$time};
                    825:     }
                    826:     return '-1';
                    827: }
1.70      www       828: 
1.452     albertel  829: 
                    830: my $disk_caching_disabled=1;
                    831: 
1.416     albertel  832: sub devalidate_cache {
1.428     albertel  833:     my ($cache,$id,$name) = @_;
1.417     albertel  834:     delete $$cache{$id.'.time'};
                    835:     delete $$cache{$id};
1.452     albertel  836:     if ($disk_caching_disabled) { return; }
1.442     albertel  837:     my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";
1.428     albertel  838:     open(DB,"$filename.lock");
                    839:     flock(DB,LOCK_EX);
                    840:     my %hash;
                    841:     if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {
1.442     albertel  842: 	eval <<'EVALBLOCK';
                    843: 	    delete($hash{$id});
                    844: 	    delete($hash{$id.'.time'});
                    845: EVALBLOCK
                    846:         if ($@) {
                    847: 	    &logthis("<font color='red'>devalidate_cache blew up :$@:$name</font>");
                    848: 	    unlink($filename);
                    849: 	}
1.428     albertel  850:     } else {
1.442     albertel  851: 	if (-e $filename) {
                    852: 	    &logthis("Unable to tie hash (devalidate cache): $name");
                    853: 	    unlink($filename);
                    854: 	}
1.428     albertel  855:     }
                    856:     untie(%hash);
                    857:     flock(DB,LOCK_UN);
                    858:     close(DB);
1.416     albertel  859: }
                    860: 
                    861: sub is_cached {
1.425     albertel  862:     my ($cache,$id,$name,$time) = @_;
1.420     albertel  863:     if (!$time) { $time=300; }
1.416     albertel  864:     if (!exists($$cache{$id.'.time'})) {
1.428     albertel  865: 	&load_cache_item($cache,$name,$id);
1.425     albertel  866:     }
                    867:     if (!exists($$cache{$id.'.time'})) {
                    868: #	&logthis("Didn't find $id");
1.417     albertel  869: 	return (undef,undef);
1.416     albertel  870:     } else {
1.425     albertel  871: 	if (time-($$cache{$id.'.time'})>$time) {
1.435     www       872: #	    &logthis("Devalidating $id - ".time-($$cache{$id.'.time'}));
1.428     albertel  873: 	    &devalidate_cache($cache,$id,$name);
1.417     albertel  874: 	    return (undef,undef);
1.416     albertel  875: 	}
                    876:     }
1.417     albertel  877:     return ($$cache{$id},1);
1.416     albertel  878: }
                    879: 
                    880: sub do_cache {
1.425     albertel  881:     my ($cache,$id,$value,$name) = @_;
1.416     albertel  882:     $$cache{$id.'.time'}=time;
1.425     albertel  883:     $$cache{$id}=$value;
1.428     albertel  884: #    &logthis("Caching $id as :$value:");
                    885:     &save_cache_item($cache,$name,$id);
1.416     albertel  886:     # do_cache implictly return the set value
1.425     albertel  887:     $$cache{$id};
                    888: }
                    889: 
1.428     albertel  890: sub save_cache_item {
                    891:     my ($cache,$name,$id)=@_;
1.452     albertel  892:     if ($disk_caching_disabled) { return; }
1.428     albertel  893:     my $starttime=&Time::HiRes::time();
1.442     albertel  894: #    &logthis("Saving :$name:$id");
1.428     albertel  895:     my %hash;
1.442     albertel  896:     my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";
1.428     albertel  897:     open(DB,"$filename.lock");
                    898:     flock(DB,LOCK_EX);
                    899:     if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {
1.442     albertel  900: 	eval <<'EVALBLOCK';
                    901: 	    $hash{$id.'.time'}=$$cache{$id.'.time'};
                    902: 	    $hash{$id}=freeze({'item'=>$$cache{$id}});
                    903: EVALBLOCK
                    904:         if ($@) {
                    905: 	    &logthis("<font color='red'>save_cache blew up :$@:$name</font>");
                    906: 	    unlink($filename);
                    907: 	}
1.428     albertel  908:     } else {
1.442     albertel  909: 	if (-e $filename) {
1.445     www       910: 	    &logthis("Unable to tie hash (save cache item): $name ($!)");
1.442     albertel  911: 	    unlink($filename);
                    912: 	}
1.428     albertel  913:     }
                    914:     untie(%hash);
                    915:     flock(DB,LOCK_UN);
                    916:     close(DB);
                    917: #    &logthis("save_cache_item $name took ".(&Time::HiRes::time()-$starttime));
                    918: }
                    919: 
                    920: sub load_cache_item {
                    921:     my ($cache,$name,$id)=@_;
1.452     albertel  922:     if ($disk_caching_disabled) { return; }
1.428     albertel  923:     my $starttime=&Time::HiRes::time();
                    924: #    &logthis("Before Loading $name  for $id size is ".scalar(%$cache));
                    925:     my %hash;
1.442     albertel  926:     my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";
1.428     albertel  927:     open(DB,"$filename.lock");
                    928:     flock(DB,LOCK_SH);
                    929:     if (tie(%hash,'GDBM_File',$filename,&GDBM_READER(),0640)) {
1.442     albertel  930: 	eval <<'EVALBLOCK';
                    931: 	    if (!%$cache) {
                    932: 		my $count;
                    933: 		while (my ($key,$value)=each(%hash)) { 
                    934: 		    $count++;
                    935: 		    if ($key =~ /\.time$/) {
                    936: 			$$cache{$key}=$value;
                    937: 		    } else {
                    938: 			my $hashref=thaw($value);
                    939: 			$$cache{$key}=$hashref->{'item'};
                    940: 		    }
1.428     albertel  941: 		}
1.442     albertel  942: #	    &logthis("Initial load: $count");
                    943: 	    } else {
                    944: 		my $hashref=thaw($hash{$id});
                    945: 		$$cache{$id}=$hashref->{'item'};
                    946: 		$$cache{$id.'.time'}=$hash{$id.'.time'};
1.428     albertel  947: 	    }
1.442     albertel  948: EVALBLOCK
                    949:         if ($@) {
                    950: 	    &logthis("<font color='red'>load_cache blew up :$@:$name</font>");
                    951: 	    unlink($filename);
                    952: 	}        
                    953:     } else {
                    954: 	if (-e $filename) {
1.445     www       955: 	    &logthis("Unable to tie hash (load cache item): $name ($!)");
1.442     albertel  956: 	    unlink($filename);
1.428     albertel  957: 	}
                    958:     }
                    959:     untie(%hash);
                    960:     flock(DB,LOCK_UN);
                    961:     close(DB);
                    962: #    &logthis("After Loading $name size is ".scalar(%$cache));
                    963: #    &logthis("load_cache_item $name took ".(&Time::HiRes::time()-$starttime));
                    964: }
                    965: 
1.70      www       966: sub usection {
                    967:     my ($udom,$unam,$courseid)=@_;
1.416     albertel  968:     my $hashid="$udom:$unam:$courseid";
                    969:     
1.425     albertel  970:     my ($result,$cached)=&is_cached(\%usectioncache,$hashid,'usection');
1.417     albertel  971:     if (defined($cached)) { return $result; }
1.70      www       972:     $courseid=~s/\_/\//g;
                    973:     $courseid=~s/^(\w)/\/$1/;
1.191     harris41  974:     foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',
                    975:                         &homeserver($unam,$udom)))) {
1.70      www       976:         my ($key,$value)=split(/\=/,$_);
                    977:         $key=&unescape($key);
                    978:         if ($key=~/^$courseid(?:\/)*(\w+)*\_st$/) {
                    979:             my $section=$1;
                    980:             if ($key eq $courseid.'_st') { $section=''; }
                    981: 	    my ($dummy,$end,$start)=split(/\_/,&unescape($value));
                    982:             my $now=time;
                    983:             my $notactive=0;
                    984:             if ($start) {
                    985: 		if ($now<$start) { $notactive=1; }
                    986:             }
                    987:             if ($end) {
                    988:                 if ($now>$end) { $notactive=1; }
                    989:             } 
1.416     albertel  990:             unless ($notactive) {
1.425     albertel  991: 		return &do_cache(\%usectioncache,$hashid,$section,'usection');
1.416     albertel  992: 	    }
1.70      www       993:         }
1.191     harris41  994:     }
1.425     albertel  995:     return &do_cache(\%usectioncache,$hashid,'-1','usection');
1.70      www       996: }
                    997: 
                    998: # ------------------------------------- Read an entry from a user's environment
                    999: 
                   1000: sub userenvironment {
                   1001:     my ($udom,$unam,@what)=@_;
                   1002:     my %returnhash=();
                   1003:     my @answer=split(/\&/,
                   1004:                 &reply('get:'.$udom.':'.$unam.':environment:'.join('&',@what),
                   1005:                       &homeserver($unam,$udom)));
                   1006:     my $i;
                   1007:     for ($i=0;$i<=$#what;$i++) {
                   1008: 	$returnhash{$what[$i]}=&unescape($answer[$i]);
                   1009:     }
                   1010:     return %returnhash;
1.1       albertel 1011: }
                   1012: 
1.263     www      1013: # -------------------------------------------------------------------- New chat
                   1014: 
                   1015: sub chatsend {
                   1016:     my ($newentry,$anon)=@_;
                   1017:     my $cnum=$ENV{'course.'.$ENV{'request.course.id'}.'.num'};
                   1018:     my $cdom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'};
                   1019:     my $chome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'};
                   1020:     &reply('chatsend:'.$cdom.':'.$cnum.':'.
                   1021: 	   &escape($ENV{'user.domain'}.':'.$ENV{'user.name'}.':'.$anon.':'.
                   1022: 		   &escape($newentry)),$chome);
1.292     www      1023: }
                   1024: 
                   1025: # ------------------------------------------ Find current version of a resource
                   1026: 
                   1027: sub getversion {
                   1028:     my $fname=&clutter(shift);
                   1029:     unless ($fname=~/^\/res\//) { return -1; }
                   1030:     return &currentversion(&filelocation('',$fname));
                   1031: }
                   1032: 
                   1033: sub currentversion {
                   1034:     my $fname=shift;
1.440     www      1035:     my ($result,$cached)=&is_cached(\%resversioncache,$fname,'resversion',600);
                   1036:     if (defined($cached)) { return $result; }
1.292     www      1037:     my $author=$fname;
                   1038:     $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
                   1039:     my ($udom,$uname)=split(/\//,$author);
                   1040:     my $home=homeserver($uname,$udom);
                   1041:     if ($home eq 'no_host') { 
                   1042:         return -1; 
                   1043:     }
                   1044:     my $answer=reply("currentversion:$fname",$home);
                   1045:     if (($answer eq 'con_lost') || ($answer eq 'rejected')) {
                   1046: 	return -1;
                   1047:     }
1.440     www      1048:     return &do_cache(\%resversioncache,$fname,$answer,'resversion');
1.263     www      1049: }
                   1050: 
1.1       albertel 1051: # ----------------------------- Subscribe to a resource, return URL if possible
1.11      www      1052: 
1.1       albertel 1053: sub subscribe {
                   1054:     my $fname=shift;
1.312     www      1055:     if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return ''; }
1.1       albertel 1056:     my $author=$fname;
                   1057:     $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
                   1058:     my ($udom,$uname)=split(/\//,$author);
                   1059:     my $home=homeserver($uname,$udom);
1.335     albertel 1060:     if ($home eq 'no_host') {
                   1061:         return 'not_found';
1.1       albertel 1062:     }
                   1063:     my $answer=reply("sub:$fname",$home);
1.64      www      1064:     if (($answer eq 'con_lost') || ($answer eq 'rejected')) {
                   1065: 	$answer.=' by '.$home;
                   1066:     }
1.1       albertel 1067:     return $answer;
                   1068: }
                   1069:     
1.8       www      1070: # -------------------------------------------------------------- Replicate file
                   1071: 
                   1072: sub repcopy {
                   1073:     my $filename=shift;
1.23      www      1074:     $filename=~s/\/+/\//g;
1.214     www      1075:     if ($filename=~/^\/home\/httpd\/html\/adm\//) { return OK; }
1.8       www      1076:     my $transname="$filename.in.transfer";
1.17      www      1077:     if ((-e $filename) || (-e $transname)) { return OK; }
1.8       www      1078:     my $remoteurl=subscribe($filename);
1.64      www      1079:     if ($remoteurl =~ /^con_lost by/) {
                   1080: 	   &logthis("Subscribe returned $remoteurl: $filename");
1.8       www      1081:            return HTTP_SERVICE_UNAVAILABLE;
                   1082:     } elsif ($remoteurl eq 'not_found') {
1.441     albertel 1083: 	   #&logthis("Subscribe returned not_found: $filename");
1.8       www      1084: 	   return HTTP_NOT_FOUND;
1.64      www      1085:     } elsif ($remoteurl =~ /^rejected by/) {
                   1086: 	   &logthis("Subscribe returned $remoteurl: $filename");
1.8       www      1087:            return FORBIDDEN;
1.20      www      1088:     } elsif ($remoteurl eq 'directory') {
                   1089:            return OK;
1.8       www      1090:     } else {
1.290     www      1091:         my $author=$filename;
                   1092:         $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
                   1093:         my ($udom,$uname)=split(/\//,$author);
                   1094:         my $home=homeserver($uname,$udom);
                   1095:         unless ($home eq $perlvar{'lonHostID'}) {
1.8       www      1096:            my @parts=split(/\//,$filename);
                   1097:            my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";
                   1098:            if ($path ne "$perlvar{'lonDocRoot'}/res") {
                   1099:                &logthis("Malconfiguration for replication: $filename");
                   1100: 	       return HTTP_BAD_REQUEST;
                   1101:            }
                   1102:            my $count;
                   1103:            for ($count=5;$count<$#parts;$count++) {
                   1104:                $path.="/$parts[$count]";
                   1105:                if ((-e $path)!=1) {
                   1106: 		   mkdir($path,0777);
                   1107:                }
                   1108:            }
                   1109:            my $ua=new LWP::UserAgent;
                   1110:            my $request=new HTTP::Request('GET',"$remoteurl");
                   1111:            my $response=$ua->request($request,$transname);
                   1112:            if ($response->is_error()) {
                   1113: 	       unlink($transname);
                   1114:                my $message=$response->status_line;
1.12      www      1115:                &logthis("<font color=blue>WARNING:"
                   1116:                        ." LWP get: $message: $filename</font>");
1.8       www      1117:                return HTTP_SERVICE_UNAVAILABLE;
                   1118:            } else {
1.16      www      1119: 	       if ($remoteurl!~/\.meta$/) {
                   1120:                   my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');
                   1121:                   my $mresponse=$ua->request($mrequest,$filename.'.meta');
                   1122:                   if ($mresponse->is_error()) {
                   1123: 		      unlink($filename.'.meta');
                   1124:                       &logthis(
                   1125:                      "<font color=yellow>INFO: No metadata: $filename</font>");
                   1126:                   }
                   1127: 	       }
1.8       www      1128:                rename($transname,$filename);
                   1129:                return OK;
                   1130:            }
1.290     www      1131:        }
1.8       www      1132:     }
1.330     www      1133: }
                   1134: 
                   1135: # ------------------------------------------------ Get server side include body
                   1136: sub ssi_body {
1.381     albertel 1137:     my ($filelink,%form)=@_;
1.330     www      1138:     my $output=($filelink=~/^http\:/?&externalssi($filelink):
1.381     albertel 1139:                                      &ssi($filelink,%form));
1.451     albertel 1140:     $output=~s/^.*?\<body[^\>]*\>//si;
                   1141:     $output=~s/(.*)\<\/body\s*\>.*?$/$1/si;
1.331     www      1142:     $output=~
                   1143:             s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs;
1.330     www      1144:     return $output;
1.8       www      1145: }
                   1146: 
1.15      www      1147: # --------------------------------------------------------- Server Side Include
                   1148: 
                   1149: sub ssi {
                   1150: 
1.23      www      1151:     my ($fn,%form)=@_;
1.15      www      1152: 
                   1153:     my $ua=new LWP::UserAgent;
1.23      www      1154:     
                   1155:     my $request;
                   1156:     
                   1157:     if (%form) {
                   1158:       $request=new HTTP::Request('POST',"http://".$ENV{'HTTP_HOST'}.$fn);
1.201     albertel 1159:       $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form));
1.23      www      1160:     } else {
                   1161:       $request=new HTTP::Request('GET',"http://".$ENV{'HTTP_HOST'}.$fn);
                   1162:     }
                   1163: 
1.15      www      1164:     $request->header(Cookie => $ENV{'HTTP_COOKIE'});
                   1165:     my $response=$ua->request($request);
                   1166: 
1.324     www      1167:     return $response->content;
                   1168: }
                   1169: 
                   1170: sub externalssi {
                   1171:     my ($url)=@_;
                   1172:     my $ua=new LWP::UserAgent;
                   1173:     my $request=new HTTP::Request('GET',$url);
                   1174:     my $response=$ua->request($request);
1.15      www      1175:     return $response->content;
                   1176: }
1.254     www      1177: 
                   1178: # ------- Add a token to a remote URI's query string to vouch for access rights
                   1179: 
                   1180: sub tokenwrapper {
                   1181:     my $uri=shift;
1.259     www      1182:     $uri=~s/^http\:\/\/([^\/]+)//;
                   1183:     $uri=~s/^\///;
                   1184:     $ENV{'user.environment'}=~/\/([^\/]+)\.id/;
                   1185:     my $token=$1;
                   1186:     if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.*)*$/) {
                   1187: 	&appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'});
                   1188:         return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri.
1.304     www      1189:                (($uri=~/\?/)?'&':'?').'token='.$token.
                   1190:                                '&tokenissued='.$perlvar{'lonHostID'};
1.259     www      1191:     } else {
                   1192: 	return '/adm/notfound.html';
                   1193:     }
1.254     www      1194: }
                   1195:     
1.257     www      1196: # --------------- Take an uploaded file and put it into the userfiles directory
1.259     www      1197: # input: name of form element, coursedoc=1 means this is for the course
1.257     www      1198: # output: url of file in userspace
                   1199: 
                   1200: sub userfileupload {
1.259     www      1201:     my ($formname,$coursedoc)=@_;
1.257     www      1202:     my $fname=$ENV{'form.'.$formname.'.filename'};
1.315     www      1203: # Replace Windows backslashes by forward slashes
1.257     www      1204:     $fname=~s/\\/\//g;
1.315     www      1205: # Get rid of everything but the actual filename
1.257     www      1206:     $fname=~s/^.*\/([^\/]+)$/$1/;
1.315     www      1207: # Replace spaces by underscores
                   1208:     $fname=~s/\s+/\_/g;
                   1209: # Replace all other weird characters by nothing
1.317     www      1210:     $fname=~s/[^\w\.\-]//g;
1.315     www      1211: # See if there is anything left
1.257     www      1212:     unless ($fname) { return 'error: no uploaded file'; }
                   1213:     chop($ENV{'form.'.$formname});
1.258     www      1214: # Create the directory if not present
1.259     www      1215:     my $docuname='';
                   1216:     my $docudom='';
                   1217:     my $docuhome='';
                   1218:     if ($coursedoc) {
                   1219: 	$docuname=$ENV{'course.'.$ENV{'request.course.id'}.'.num'};
                   1220: 	$docudom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'};
                   1221: 	$docuhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'};
                   1222:     } else {
                   1223:         $docuname=$ENV{'user.name'};
                   1224:         $docudom=$ENV{'user.domain'};
                   1225:         $docuhome=$ENV{'user.home'};
                   1226:     }
1.271     www      1227:     return 
                   1228:         &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname);
                   1229: }
                   1230: 
                   1231: sub finishuserfileupload {
                   1232:     my ($docuname,$docudom,$docuhome,$formname,$fname)=@_;
1.259     www      1233:     my $path=$docudom.'/'.$docuname.'/';
1.258     www      1234:     my $filepath=$perlvar{'lonDocRoot'};
1.259     www      1235:     my @parts=split(/\//,$filepath.'/userfiles/'.$path);
1.258     www      1236:     my $count;
                   1237:     for ($count=4;$count<=$#parts;$count++) {
                   1238:         $filepath.="/$parts[$count]";
                   1239:         if ((-e $filepath)!=1) {
                   1240: 	    mkdir($filepath,0777);
                   1241:         }
                   1242:     }
                   1243: # Save the file
                   1244:     {
1.448     albertel 1245:        open(my $fh,'>'.$filepath.'/'.$fname);
1.258     www      1246:        print $fh $ENV{'form.'.$formname};
1.448     albertel 1247:        close($fh);
1.258     www      1248:     }
1.259     www      1249: # Notify homeserver to grep it
                   1250: #
1.295     www      1251:     
                   1252:     my $fetchresult= 
                   1253:  &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,$docuhome);
                   1254:     if ($fetchresult eq 'ok') {
1.259     www      1255: #
1.258     www      1256: # Return the URL to it
1.263     www      1257:         return '/uploaded/'.$path.$fname;
                   1258:     } else {
1.295     www      1259:         &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$fname.
                   1260:          ' to host '.$docuhome.': '.$fetchresult);
1.263     www      1261:         return '/adm/notfound.html';
                   1262:     }    
1.257     www      1263: }
1.15      www      1264: 
1.14      www      1265: # ------------------------------------------------------------------------- Log
                   1266: 
                   1267: sub log {
                   1268:     my ($dom,$nam,$hom,$what)=@_;
1.47      www      1269:     return critical("log:$dom:$nam:$what",$hom);
1.157     www      1270: }
                   1271: 
                   1272: # ------------------------------------------------------------------ Course Log
1.352     www      1273: #
                   1274: # This routine flushes several buffers of non-mission-critical nature
                   1275: #
1.157     www      1276: 
                   1277: sub flushcourselogs {
1.352     www      1278:     &logthis('Flushing log buffers');
                   1279: #
                   1280: # course logs
                   1281: # This is a log of all transactions in a course, which can be used
                   1282: # for data mining purposes
                   1283: #
                   1284: # It also collects the courseid database, which lists last transaction
                   1285: # times and course titles for all courseids
                   1286: #
                   1287:     my %courseidbuffer=();
1.191     harris41 1288:     foreach (keys %courselogs) {
1.157     www      1289:         my $crsid=$_;
1.352     www      1290:         if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$crsid}.':'.
1.188     www      1291: 		          &escape($courselogs{$crsid}),
                   1292: 		          $coursehombuf{$crsid}) eq 'ok') {
1.157     www      1293: 	    delete $courselogs{$crsid};
                   1294:         } else {
                   1295:             &logthis('Failed to flush log buffer for '.$crsid);
                   1296:             if (length($courselogs{$crsid})>40000) {
                   1297:                &logthis("<font color=blue>WARNING: Buffer for ".$crsid.
                   1298:                         " exceeded maximum size, deleting.</font>");
                   1299:                delete $courselogs{$crsid};
                   1300:             }
1.352     www      1301:         }
                   1302:         if ($courseidbuffer{$coursehombuf{$crsid}}) {
                   1303:            $courseidbuffer{$coursehombuf{$crsid}}.='&'.
                   1304: 			 &escape($crsid).'='.&escape($coursedescrbuf{$crsid});
                   1305:         } else {
                   1306:            $courseidbuffer{$coursehombuf{$crsid}}=
                   1307: 			 &escape($crsid).'='.&escape($coursedescrbuf{$crsid});
                   1308:         }    
1.191     harris41 1309:     }
1.352     www      1310: #
                   1311: # Write course id database (reverse lookup) to homeserver of courses 
                   1312: # Is used in pickcourse
                   1313: #
                   1314:     foreach (keys %courseidbuffer) {
1.353     www      1315:         &courseidput($hostdom{$_},$courseidbuffer{$_},$_);
1.352     www      1316:     }
                   1317: #
                   1318: # File accesses
                   1319: # Writes to the dynamic metadata of resources to get hit counts, etc.
                   1320: #
1.449     matthew  1321:     foreach my $entry (keys(%accesshash)) {
1.458     matthew  1322:         if ($entry =~ /___count$/) {
                   1323:             my ($dom,$name);
                   1324:             ($dom,$name,undef)=($entry=~m:___(\w+)/(\w+)/(.*)___count$:);
                   1325:             if (! defined($dom) || $dom eq '' || 
                   1326:                 ! defined($name) || $name eq '') {
                   1327:                 my $cid = $ENV{'request.course.id'};
                   1328:                 $dom  = $ENV{'request.'.$cid.'.domain'};
                   1329:                 $name = $ENV{'request.'.$cid.'.num'};
                   1330:             }
1.450     matthew  1331:             my $value = $accesshash{$entry};
                   1332:             my (undef,$url,undef) = ($entry =~ /^(.*)___(.*)___count$/);
                   1333:             my %temphash=($url => $value);
1.449     matthew  1334:             my $result = &inc('nohist_accesscount',\%temphash,$dom,$name);
                   1335:             if ($result eq 'ok') {
                   1336:                 delete $accesshash{$entry};
                   1337:             } elsif ($result eq 'unknown_cmd') {
                   1338:                 # Target server has old code running on it.
1.450     matthew  1339:                 my %temphash=($entry => $value);
1.449     matthew  1340:                 if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {
                   1341:                     delete $accesshash{$entry};
                   1342:                 }
                   1343:             }
                   1344:         } else {
1.458     matthew  1345:             my ($dom,$name) = ($entry=~m:___(\w+)/(\w+)/(.*)___(\w+)$:);
1.450     matthew  1346:             my %temphash=($entry => $accesshash{$entry});
1.449     matthew  1347:             if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {
                   1348:                 delete $accesshash{$entry};
                   1349:             }
1.185     www      1350:         }
1.191     harris41 1351:     }
1.352     www      1352: #
                   1353: # Roles
                   1354: # Reverse lookup of user roles for course faculty/staff and co-authorship
                   1355: #
1.349     www      1356:     foreach (keys %userrolehash) {
                   1357:         my $entry=$_;
1.351     www      1358:         my ($role,$uname,$udom,$runame,$rudom,$rsec)=
1.349     www      1359: 	    split(/\:/,$entry);
                   1360:         if (&Apache::lonnet::put('nohist_userroles',
1.351     www      1361:              { $role.':'.$uname.':'.$udom.':'.$rsec => $userrolehash{$entry} },
1.349     www      1362:                 $rudom,$runame) eq 'ok') {
                   1363: 	    delete $userrolehash{$entry};
                   1364:         }
                   1365:     }
1.186     www      1366:     $dumpcount++;
1.157     www      1367: }
                   1368: 
                   1369: sub courselog {
                   1370:     my $what=shift;
1.158     www      1371:     $what=time.':'.$what;
1.157     www      1372:     unless ($ENV{'request.course.id'}) { return ''; }
1.188     www      1373:     $coursedombuf{$ENV{'request.course.id'}}=
1.352     www      1374:        $ENV{'course.'.$ENV{'request.course.id'}.'.domain'};
                   1375:     $coursenumbuf{$ENV{'request.course.id'}}=
1.188     www      1376:        $ENV{'course.'.$ENV{'request.course.id'}.'.num'};
                   1377:     $coursehombuf{$ENV{'request.course.id'}}=
                   1378:        $ENV{'course.'.$ENV{'request.course.id'}.'.home'};
1.352     www      1379:     $coursedescrbuf{$ENV{'request.course.id'}}=
                   1380:        $ENV{'course.'.$ENV{'request.course.id'}.'.description'};
1.157     www      1381:     if (defined $courselogs{$ENV{'request.course.id'}}) {
                   1382: 	$courselogs{$ENV{'request.course.id'}}.='&'.$what;
                   1383:     } else {
                   1384: 	$courselogs{$ENV{'request.course.id'}}.=$what;
                   1385:     }
1.458     matthew  1386:     if (length($courselogs{$ENV{'request.course.id'}})>4048) {
1.157     www      1387: 	&flushcourselogs();
                   1388:     }
1.158     www      1389: }
                   1390: 
                   1391: sub courseacclog {
                   1392:     my $fnsymb=shift;
                   1393:     unless ($ENV{'request.course.id'}) { return ''; }
                   1394:     my $what=$fnsymb.':'.$ENV{'user.name'}.':'.$ENV{'user.domain'};
1.408     www      1395:     if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|page)$/) {
1.187     www      1396:         $what.=':POST';
1.191     harris41 1397: 	foreach (keys %ENV) {
1.158     www      1398:             if ($_=~/^form\.(.*)/) {
                   1399: 		$what.=':'.$1.'='.$ENV{$_};
                   1400:             }
1.191     harris41 1401:         }
1.158     www      1402:     }
                   1403:     &courselog($what);
1.149     www      1404: }
                   1405: 
1.185     www      1406: sub countacc {
                   1407:     my $url=&declutter(shift);
1.458     matthew  1408:     return if (! defined($url) || $url eq '');
1.185     www      1409:     unless ($ENV{'request.course.id'}) { return ''; }
                   1410:     $accesshash{$ENV{'request.course.id'}.'___'.$url.'___course'}=1;
1.281     www      1411:     my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count';
1.450     matthew  1412:     $accesshash{$key}++;
1.185     www      1413: }
1.349     www      1414: 
1.361     www      1415: sub linklog {
                   1416:     my ($from,$to)=@_;
                   1417:     $from=&declutter($from);
                   1418:     $to=&declutter($to);
                   1419:     $accesshash{$from.'___'.$to.'___comefrom'}=1;
                   1420:     $accesshash{$to.'___'.$from.'___goto'}=1;
                   1421: }
                   1422:   
1.349     www      1423: sub userrolelog {
                   1424:     my ($trole,$username,$domain,$area,$tstart,$tend)=@_;
                   1425:     if (($trole=~/^ca/) || ($trole=~/^in/) || 
                   1426:         ($trole=~/^cc/) || ($trole=~/^ep/) ||
                   1427:         ($trole=~/^cr/)) {
1.350     www      1428:        my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
                   1429:        $userrolehash
                   1430:          {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
1.349     www      1431:                     =$tend.':'.$tstart;
                   1432:    }
1.351     www      1433: }
                   1434: 
                   1435: sub get_course_adv_roles {
                   1436:     my $cid=shift;
                   1437:     $cid=$ENV{'request.course.id'} unless (defined($cid));
                   1438:     my %coursehash=&coursedescription($cid);
                   1439:     my %returnhash=();
                   1440:     my %dumphash=
                   1441:             &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});
                   1442:     my $now=time;
                   1443:     foreach (keys %dumphash) {
                   1444: 	my ($tend,$tstart)=split(/\:/,$dumphash{$_});
                   1445:         if (($tstart) && ($tstart<0)) { next; }
                   1446:         if (($tend) && ($tend<$now)) { next; }
                   1447:         if (($tstart) && ($now<$tstart)) { next; }
                   1448:         my ($role,$username,$domain,$section)=split(/\:/,$_);
                   1449:         my $key=&plaintext($role);
                   1450:         if ($section) { $key.=' (Sec/Grp '.$section.')'; }
                   1451:         if ($returnhash{$key}) {
                   1452: 	    $returnhash{$key}.=','.$username.':'.$domain;
                   1453:         } else {
                   1454:             $returnhash{$key}=$username.':'.$domain;
                   1455:         }
1.400     www      1456:      }
                   1457:     return %returnhash;
                   1458: }
                   1459: 
                   1460: sub get_my_roles {
                   1461:     my ($uname,$udom)=@_;
                   1462:     unless (defined($uname)) { $uname=$ENV{'user.name'}; }
                   1463:     unless (defined($udom)) { $udom=$ENV{'user.domain'}; }
                   1464:     my %dumphash=
                   1465:             &dump('nohist_userroles',$udom,$uname);
                   1466:     my %returnhash=();
                   1467:     my $now=time;
                   1468:     foreach (keys %dumphash) {
                   1469: 	my ($tend,$tstart)=split(/\:/,$dumphash{$_});
                   1470:         if (($tstart) && ($tstart<0)) { next; }
                   1471:         if (($tend) && ($tend<$now)) { next; }
                   1472:         if (($tstart) && ($now<$tstart)) { next; }
                   1473:         my ($role,$username,$domain,$section)=split(/\:/,$_);
                   1474: 	$returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;
1.373     www      1475:      }
                   1476:     return %returnhash;
1.399     www      1477: }
                   1478: 
                   1479: # ----------------------------------------------------- Frontpage Announcements
                   1480: #
                   1481: #
                   1482: 
                   1483: sub postannounce {
                   1484:     my ($server,$text)=@_;
                   1485:     unless (&allowed('psa',$hostdom{$server})) { return 'refused'; }
                   1486:     unless ($text=~/\w/) { $text=''; }
                   1487:     return &reply('setannounce:'.&escape($text),$server);
                   1488: }
                   1489: 
                   1490: sub getannounce {
1.448     albertel 1491: 
                   1492:     if (open(my $fh,$perlvar{'lonDocRoot'}.'/announcement.txt')) {
1.399     www      1493: 	my $announcement='';
                   1494: 	while (<$fh>) { $announcement .=$_; }
1.448     albertel 1495: 	close($fh);
1.399     www      1496: 	if ($announcement=~/\w/) { 
                   1497: 	    return 
                   1498:    '<table bgcolor="#FF5555" cellpadding="5" cellspacing="3">'.
                   1499:    '<tr><td bgcolor="#FFFFFF"><pre>'.$announcement.'</pre></td></tr></table>'; 
                   1500: 	} else {
                   1501: 	    return '';
                   1502: 	}
                   1503:     } else {
                   1504: 	return '';
                   1505:     }
1.351     www      1506: }
1.353     www      1507: 
                   1508: # ---------------------------------------------------------- Course ID routines
                   1509: # Deal with domain's nohist_courseid.db files
                   1510: #
                   1511: 
                   1512: sub courseidput {
                   1513:     my ($domain,$what,$coursehome)=@_;
                   1514:     return &reply('courseidput:'.$domain.':'.$what,$coursehome);
                   1515: }
                   1516: 
                   1517: sub courseiddump {
                   1518:     my ($domfilter,$descfilter,$sincefilter)=@_;
                   1519:     my %returnhash=();
1.355     www      1520:     unless ($domfilter) { $domfilter=''; }
1.353     www      1521:     foreach my $tryserver (keys %libserv) {
1.355     www      1522: 	if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) {
1.353     www      1523: 	    foreach (
                   1524:              split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'.
1.354     www      1525: 			       $sincefilter.':'.&escape($descfilter),
                   1526:                                $tryserver))) {
1.353     www      1527: 		my ($key,$value)=split(/\=/,$_);
                   1528:                 if (($key) && ($value)) {
                   1529: 		    $returnhash{&unescape($key)}=&unescape($value);
                   1530:                 }
                   1531:             }
                   1532: 
                   1533:         }
                   1534:     }
                   1535:     return %returnhash;
                   1536: }
                   1537: 
                   1538: #
1.149     www      1539: # ----------------------------------------------------------- Check out an item
                   1540: 
                   1541: sub checkout {
                   1542:     my ($symb,$tuname,$tudom,$tcrsid)=@_;
                   1543:     my $now=time;
                   1544:     my $lonhost=$perlvar{'lonHostID'};
                   1545:     my $infostr=&escape(
1.234     www      1546:                  'CHECKOUTTOKEN&'.
1.149     www      1547:                  $tuname.'&'.
                   1548:                  $tudom.'&'.
                   1549:                  $tcrsid.'&'.
                   1550:                  $symb.'&'.
                   1551: 		 $now.'&'.$ENV{'REMOTE_ADDR'});
                   1552:     my $token=&reply('tmpput:'.$infostr,$lonhost);
1.151     www      1553:     if ($token=~/^error\:/) { 
                   1554:         &logthis("<font color=blue>WARNING: ".
                   1555:                 "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.
                   1556:                  "</font>");
                   1557:         return ''; 
                   1558:     }
                   1559: 
1.149     www      1560:     $token=~s/^(\d+)\_.*\_(\d+)$/$1\*$2\*$lonhost/;
                   1561:     $token=~tr/a-z/A-Z/;
                   1562: 
1.153     www      1563:     my %infohash=('resource.0.outtoken' => $token,
                   1564:                   'resource.0.checkouttime' => $now,
                   1565:                   'resource.0.outremote' => $ENV{'REMOTE_ADDR'});
1.149     www      1566: 
                   1567:     unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
                   1568:        return '';
1.151     www      1569:     } else {
                   1570:         &logthis("<font color=blue>WARNING: ".
                   1571:                 "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.
                   1572:                  "</font>");
1.149     www      1573:     }    
                   1574: 
                   1575:     if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
                   1576:                          &escape('Checkout '.$infostr.' - '.
                   1577:                                                  $token)) ne 'ok') {
                   1578: 	return '';
1.151     www      1579:     } else {
                   1580:         &logthis("<font color=blue>WARNING: ".
                   1581:                 "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.
                   1582:                  "</font>");
1.149     www      1583:     }
1.151     www      1584:     return $token;
1.149     www      1585: }
                   1586: 
                   1587: # ------------------------------------------------------------ Check in an item
                   1588: 
                   1589: sub checkin {
                   1590:     my $token=shift;
1.150     www      1591:     my $now=time;
                   1592:     my ($ta,$tb,$lonhost)=split(/\*/,$token);
                   1593:     $lonhost=~tr/A-Z/a-z/;
                   1594:     my $dtoken=$ta.'_'.$hostip{$lonhost}.'_'.$tb;
                   1595:     $dtoken=~s/\W/\_/g;
1.234     www      1596:     my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
1.150     www      1597:                  split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));
                   1598: 
1.154     www      1599:     unless (($tuname) && ($tudom)) {
                   1600:         &logthis('Check in '.$token.' ('.$dtoken.') failed');
                   1601:         return '';
                   1602:     }
                   1603:     
                   1604:     unless (&allowed('mgr',$tcrsid)) {
                   1605:         &logthis('Check in '.$token.' ('.$dtoken.') unauthorized: '.
                   1606:                  $ENV{'user.name'}.' - '.$ENV{'user.domain'});
                   1607:         return '';
                   1608:     }
                   1609: 
1.153     www      1610:     my %infohash=('resource.0.intoken' => $token,
                   1611:                   'resource.0.checkintime' => $now,
                   1612:                   'resource.0.inremote' => $ENV{'REMOTE_ADDR'});
1.150     www      1613: 
                   1614:     unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
                   1615:        return '';
                   1616:     }    
                   1617: 
                   1618:     if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
                   1619:                          &escape('Checkin - '.$token)) ne 'ok') {
                   1620: 	return '';
                   1621:     }
                   1622: 
                   1623:     return ($symb,$tuname,$tudom,$tcrsid);    
1.110     www      1624: }
                   1625: 
                   1626: # --------------------------------------------- Set Expire Date for Spreadsheet
                   1627: 
                   1628: sub expirespread {
                   1629:     my ($uname,$udom,$stype,$usymb)=@_;
                   1630:     my $cid=$ENV{'request.course.id'}; 
                   1631:     if ($cid) {
                   1632:        my $now=time;
                   1633:        my $key=$uname.':'.$udom.':'.$stype.':'.$usymb;
                   1634:        return &reply('put:'.$ENV{'course.'.$cid.'.domain'}.':'.
                   1635:                             $ENV{'course.'.$cid.'.num'}.
                   1636: 	        	    ':nohist_expirationdates:'.
                   1637:                             &escape($key).'='.$now,
                   1638:                             $ENV{'course.'.$cid.'.home'})
                   1639:     }
                   1640:     return 'ok';
1.14      www      1641: }
                   1642: 
1.109     www      1643: # ----------------------------------------------------- Devalidate Spreadsheets
                   1644: 
                   1645: sub devalidate {
1.325     www      1646:     my ($symb,$uname,$udom)=@_;
1.109     www      1647:     my $cid=$ENV{'request.course.id'}; 
                   1648:     if ($cid) {
1.391     matthew  1649:         # delete the stored spreadsheets for
                   1650:         # - the student level sheet of this user in course's homespace
                   1651:         # - the assessment level sheet for this resource 
                   1652:         #   for this user in user's homespace
1.325     www      1653: 	my $key=$uname.':'.$udom.':';
1.109     www      1654:         my $status=
1.299     matthew  1655: 	    &del('nohist_calculatedsheets',
1.391     matthew  1656: 		 [$key.'studentcalc:'],
1.133     albertel 1657: 		 $ENV{'course.'.$cid.'.domain'},
                   1658: 		 $ENV{'course.'.$cid.'.num'})
                   1659: 		.' '.
                   1660: 	    &del('nohist_calculatedsheets_'.$cid,
1.391     matthew  1661: 		 [$key.'assesscalc:'.$symb],$udom,$uname);
1.109     www      1662:         unless ($status eq 'ok ok') {
                   1663:            &logthis('Could not devalidate spreadsheet '.
1.325     www      1664:                     $uname.' at '.$udom.' for '.
1.109     www      1665: 		    $symb.': '.$status);
1.133     albertel 1666:         }
1.109     www      1667:     }
                   1668: }
                   1669: 
1.265     albertel 1670: sub get_scalar {
                   1671:     my ($string,$end) = @_;
                   1672:     my $value;
                   1673:     if ($$string =~ s/^([^&]*?)($end)/$2/) {
                   1674: 	$value = $1;
                   1675:     } elsif ($$string =~ s/^([^&]*?)&//) {
                   1676: 	$value = $1;
                   1677:     }
                   1678:     return &unescape($value);
                   1679: }
                   1680: 
                   1681: sub array2str {
                   1682:   my (@array) = @_;
                   1683:   my $result=&arrayref2str(\@array);
                   1684:   $result=~s/^__ARRAY_REF__//;
                   1685:   $result=~s/__END_ARRAY_REF__$//;
                   1686:   return $result;
                   1687: }
                   1688: 
1.204     albertel 1689: sub arrayref2str {
                   1690:   my ($arrayref) = @_;
1.265     albertel 1691:   my $result='__ARRAY_REF__';
1.204     albertel 1692:   foreach my $elem (@$arrayref) {
1.265     albertel 1693:     if(ref($elem) eq 'ARRAY') {
                   1694:       $result.=&arrayref2str($elem).'&';
                   1695:     } elsif(ref($elem) eq 'HASH') {
                   1696:       $result.=&hashref2str($elem).'&';
                   1697:     } elsif(ref($elem)) {
                   1698:       #print("Got a ref of ".(ref($elem))." skipping.");
1.204     albertel 1699:     } else {
                   1700:       $result.=&escape($elem).'&';
                   1701:     }
                   1702:   }
                   1703:   $result=~s/\&$//;
1.265     albertel 1704:   $result .= '__END_ARRAY_REF__';
1.204     albertel 1705:   return $result;
                   1706: }
                   1707: 
1.168     albertel 1708: sub hash2str {
1.204     albertel 1709:   my (%hash) = @_;
                   1710:   my $result=&hashref2str(\%hash);
1.265     albertel 1711:   $result=~s/^__HASH_REF__//;
                   1712:   $result=~s/__END_HASH_REF__$//;
1.204     albertel 1713:   return $result;
                   1714: }
                   1715: 
                   1716: sub hashref2str {
                   1717:   my ($hashref)=@_;
1.265     albertel 1718:   my $result='__HASH_REF__';
1.204     albertel 1719:   foreach (keys(%$hashref)) {
                   1720:     if (ref($_) eq 'ARRAY') {
1.265     albertel 1721:       $result.=&arrayref2str($_).'=';
1.204     albertel 1722:     } elsif (ref($_) eq 'HASH') {
1.265     albertel 1723:       $result.=&hashref2str($_).'=';
1.204     albertel 1724:     } elsif (ref($_)) {
1.265     albertel 1725:       $result.='=';
                   1726:       #print("Got a ref of ".(ref($_))." skipping.");
1.204     albertel 1727:     } else {
1.265     albertel 1728: 	if ($_) {$result.=&escape($_).'=';} else { last; }
1.204     albertel 1729:     }
                   1730: 
1.265     albertel 1731:     if(ref($hashref->{$_}) eq 'ARRAY') {
                   1732:       $result.=&arrayref2str($hashref->{$_}).'&';
                   1733:     } elsif(ref($hashref->{$_}) eq 'HASH') {
                   1734:       $result.=&hashref2str($hashref->{$_}).'&';
                   1735:     } elsif(ref($hashref->{$_})) {
                   1736:        $result.='&';
                   1737:       #print("Got a ref of ".(ref($hashref->{$_}))." skipping.");
1.204     albertel 1738:     } else {
1.265     albertel 1739:       $result.=&escape($hashref->{$_}).'&';
1.204     albertel 1740:     }
                   1741:   }
1.168     albertel 1742:   $result=~s/\&$//;
1.265     albertel 1743:   $result .= '__END_HASH_REF__';
1.168     albertel 1744:   return $result;
                   1745: }
                   1746: 
                   1747: sub str2hash {
1.265     albertel 1748:     my ($string)=@_;
                   1749:     my ($hash)=&str2hashref('__HASH_REF__'.$string.'__END_HASH_REF__');
                   1750:     return %$hash;
                   1751: }
                   1752: 
                   1753: sub str2hashref {
1.168     albertel 1754:   my ($string) = @_;
1.265     albertel 1755: 
                   1756:   my %hash;
                   1757: 
                   1758:   if($string !~ /^__HASH_REF__/) {
                   1759:       if (! ($string eq '' || !defined($string))) {
                   1760: 	  $hash{'error'}='Not hash reference';
                   1761:       }
                   1762:       return (\%hash, $string);
                   1763:   }
                   1764: 
                   1765:   $string =~ s/^__HASH_REF__//;
                   1766: 
                   1767:   while($string !~ /^__END_HASH_REF__/) {
                   1768:       #key
                   1769:       my $key='';
                   1770:       if($string =~ /^__HASH_REF__/) {
                   1771:           ($key, $string)=&str2hashref($string);
                   1772:           if(defined($key->{'error'})) {
                   1773:               $hash{'error'}='Bad data';
                   1774:               return (\%hash, $string);
                   1775:           }
                   1776:       } elsif($string =~ /^__ARRAY_REF__/) {
                   1777:           ($key, $string)=&str2arrayref($string);
                   1778:           if($key->[0] eq 'Array reference error') {
                   1779:               $hash{'error'}='Bad data';
                   1780:               return (\%hash, $string);
                   1781:           }
                   1782:       } else {
                   1783:           $string =~ s/^(.*?)=//;
1.267     albertel 1784: 	  $key=&unescape($1);
1.265     albertel 1785:       }
                   1786:       $string =~ s/^=//;
                   1787: 
                   1788:       #value
                   1789:       my $value='';
                   1790:       if($string =~ /^__HASH_REF__/) {
                   1791:           ($value, $string)=&str2hashref($string);
                   1792:           if(defined($value->{'error'})) {
                   1793:               $hash{'error'}='Bad data';
                   1794:               return (\%hash, $string);
                   1795:           }
                   1796:       } elsif($string =~ /^__ARRAY_REF__/) {
                   1797:           ($value, $string)=&str2arrayref($string);
                   1798:           if($value->[0] eq 'Array reference error') {
                   1799:               $hash{'error'}='Bad data';
                   1800:               return (\%hash, $string);
                   1801:           }
                   1802:       } else {
                   1803: 	  $value=&get_scalar(\$string,'__END_HASH_REF__');
                   1804:       }
                   1805:       $string =~ s/^&//;
                   1806: 
                   1807:       $hash{$key}=$value;
1.204     albertel 1808:   }
1.265     albertel 1809: 
                   1810:   $string =~ s/^__END_HASH_REF__//;
                   1811: 
                   1812:   return (\%hash, $string);
1.204     albertel 1813: }
                   1814: 
                   1815: sub str2array {
1.265     albertel 1816:     my ($string)=@_;
                   1817:     my ($array)=&str2arrayref('__ARRAY_REF__'.$string.'__END_ARRAY_REF__');
                   1818:     return @$array;
                   1819: }
                   1820: 
                   1821: sub str2arrayref {
1.204     albertel 1822:   my ($string) = @_;
1.265     albertel 1823:   my @array;
                   1824: 
                   1825:   if($string !~ /^__ARRAY_REF__/) {
                   1826:       if (! ($string eq '' || !defined($string))) {
                   1827: 	  $array[0]='Array reference error';
                   1828:       }
                   1829:       return (\@array, $string);
                   1830:   }
                   1831: 
                   1832:   $string =~ s/^__ARRAY_REF__//;
                   1833: 
                   1834:   while($string !~ /^__END_ARRAY_REF__/) {
                   1835:       my $value='';
                   1836:       if($string =~ /^__HASH_REF__/) {
                   1837:           ($value, $string)=&str2hashref($string);
                   1838:           if(defined($value->{'error'})) {
                   1839:               $array[0] ='Array reference error';
                   1840:               return (\@array, $string);
                   1841:           }
                   1842:       } elsif($string =~ /^__ARRAY_REF__/) {
                   1843:           ($value, $string)=&str2arrayref($string);
                   1844:           if($value->[0] eq 'Array reference error') {
                   1845:               $array[0] ='Array reference error';
                   1846:               return (\@array, $string);
                   1847:           }
                   1848:       } else {
                   1849: 	  $value=&get_scalar(\$string,'__END_ARRAY_REF__');
                   1850:       }
                   1851:       $string =~ s/^&//;
                   1852: 
                   1853:       push(@array, $value);
1.191     harris41 1854:   }
1.265     albertel 1855: 
                   1856:   $string =~ s/^__END_ARRAY_REF__//;
                   1857: 
                   1858:   return (\@array, $string);
1.168     albertel 1859: }
                   1860: 
1.167     albertel 1861: # -------------------------------------------------------------------Temp Store
                   1862: 
1.168     albertel 1863: sub tmpreset {
                   1864:   my ($symb,$namespace,$domain,$stuname) = @_;
                   1865:   if (!$symb) {
                   1866:     $symb=&symbread();
1.380     albertel 1867:     if (!$symb) { $symb= $ENV{'request.url'}; }
1.168     albertel 1868:   }
                   1869:   $symb=escape($symb);
                   1870: 
                   1871:   if (!$namespace) { $namespace=$ENV{'request.state'}; }
                   1872:   $namespace=~s/\//\_/g;
                   1873:   $namespace=~s/\W//g;
                   1874: 
                   1875:   #FIXME needs to do something for /pub resources
                   1876:   if (!$domain) { $domain=$ENV{'user.domain'}; }
                   1877:   if (!$stuname) { $stuname=$ENV{'user.name'}; }
                   1878:   my $path=$perlvar{'lonDaemons'}.'/tmp';
                   1879:   my %hash;
                   1880:   if (tie(%hash,'GDBM_File',
                   1881: 	  $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
1.256     albertel 1882: 	  &GDBM_WRCREAT(),0640)) {
1.168     albertel 1883:     foreach my $key (keys %hash) {
1.180     albertel 1884:       if ($key=~ /:$symb/) {
1.168     albertel 1885: 	delete($hash{$key});
                   1886:       }
                   1887:     }
                   1888:   }
                   1889: }
                   1890: 
1.167     albertel 1891: sub tmpstore {
1.168     albertel 1892:   my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
                   1893: 
                   1894:   if (!$symb) {
                   1895:     $symb=&symbread();
                   1896:     if (!$symb) { $symb= $ENV{'request.url'}; }
                   1897:   }
                   1898:   $symb=escape($symb);
                   1899: 
                   1900:   if (!$namespace) {
                   1901:     # I don't think we would ever want to store this for a course.
                   1902:     # it seems this will only be used if we don't have a course.
                   1903:     #$namespace=$ENV{'request.course.id'};
                   1904:     #if (!$namespace) {
                   1905:       $namespace=$ENV{'request.state'};
                   1906:     #}
                   1907:   }
                   1908:   $namespace=~s/\//\_/g;
                   1909:   $namespace=~s/\W//g;
                   1910: #FIXME needs to do something for /pub resources
                   1911:   if (!$domain) { $domain=$ENV{'user.domain'}; }
                   1912:   if (!$stuname) { $stuname=$ENV{'user.name'}; }
                   1913:   my $now=time;
                   1914:   my %hash;
                   1915:   my $path=$perlvar{'lonDaemons'}.'/tmp';
                   1916:   if (tie(%hash,'GDBM_File',
                   1917: 	  $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
1.256     albertel 1918: 	  &GDBM_WRCREAT(),0640)) {
1.168     albertel 1919:     $hash{"version:$symb"}++;
                   1920:     my $version=$hash{"version:$symb"};
                   1921:     my $allkeys=''; 
                   1922:     foreach my $key (keys(%$storehash)) {
                   1923:       $allkeys.=$key.':';
                   1924:       $hash{"$version:$symb:$key"}=$$storehash{$key};
                   1925:     }
                   1926:     $hash{"$version:$symb:timestamp"}=$now;
                   1927:     $allkeys.='timestamp';
                   1928:     $hash{"$version:keys:$symb"}=$allkeys;
                   1929:     if (untie(%hash)) {
                   1930:       return 'ok';
                   1931:     } else {
                   1932:       return "error:$!";
                   1933:     }
                   1934:   } else {
                   1935:     return "error:$!";
                   1936:   }
                   1937: }
1.167     albertel 1938: 
1.168     albertel 1939: # -----------------------------------------------------------------Temp Restore
1.167     albertel 1940: 
1.168     albertel 1941: sub tmprestore {
                   1942:   my ($symb,$namespace,$domain,$stuname) = @_;
1.167     albertel 1943: 
1.168     albertel 1944:   if (!$symb) {
                   1945:     $symb=&symbread();
                   1946:     if (!$symb) { $symb= $ENV{'request.url'}; }
                   1947:   }
                   1948:   $symb=escape($symb);
                   1949: 
                   1950:   if (!$namespace) { $namespace=$ENV{'request.state'}; }
                   1951:   #FIXME needs to do something for /pub resources
                   1952:   if (!$domain) { $domain=$ENV{'user.domain'}; }
                   1953:   if (!$stuname) { $stuname=$ENV{'user.name'}; }
                   1954: 
                   1955:   my %returnhash;
                   1956:   $namespace=~s/\//\_/g;
                   1957:   $namespace=~s/\W//g;
                   1958:   my %hash;
                   1959:   my $path=$perlvar{'lonDaemons'}.'/tmp';
                   1960:   if (tie(%hash,'GDBM_File',
                   1961: 	  $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
1.256     albertel 1962: 	  &GDBM_READER(),0640)) {
1.168     albertel 1963:     my $version=$hash{"version:$symb"};
                   1964:     $returnhash{'version'}=$version;
                   1965:     my $scope;
                   1966:     for ($scope=1;$scope<=$version;$scope++) {
                   1967:       my $vkeys=$hash{"$scope:keys:$symb"};
                   1968:       my @keys=split(/:/,$vkeys);
                   1969:       my $key;
                   1970:       $returnhash{"$scope:keys"}=$vkeys;
                   1971:       foreach $key (@keys) {
                   1972: 	$returnhash{"$scope:$key"}=$hash{"$scope:$symb:$key"};
                   1973: 	$returnhash{"$key"}=$hash{"$scope:$symb:$key"};
1.167     albertel 1974:       }
                   1975:     }
1.168     albertel 1976:     if (!(untie(%hash))) {
                   1977:       return "error:$!";
                   1978:     }
                   1979:   } else {
                   1980:     return "error:$!";
                   1981:   }
                   1982:   return %returnhash;
1.167     albertel 1983: }
                   1984: 
1.9       www      1985: # ----------------------------------------------------------------------- Store
                   1986: 
                   1987: sub store {
1.124     www      1988:     my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
                   1989:     my $home='';
                   1990: 
1.168     albertel 1991:     if ($stuname) { $home=&homeserver($stuname,$domain); }
1.124     www      1992: 
1.213     www      1993:     $symb=&symbclean($symb);
1.122     albertel 1994:     if (!$symb) { unless ($symb=&symbread()) { return ''; } }
1.109     www      1995: 
1.325     www      1996:     if (!$domain) { $domain=$ENV{'user.domain'}; }
                   1997:     if (!$stuname) { $stuname=$ENV{'user.name'}; }
                   1998: 
                   1999:     &devalidate($symb,$stuname,$domain);
1.109     www      2000: 
                   2001:     $symb=escape($symb);
1.187     www      2002:     if (!$namespace) { 
                   2003:        unless ($namespace=$ENV{'request.course.id'}) { 
                   2004:           return ''; 
                   2005:        } 
                   2006:     }
1.122     albertel 2007:     if (!$home) { $home=$ENV{'user.home'}; }
1.447     www      2008: 
                   2009:     $$storehash{'ip'}=$ENV{'REMOTE_ADDR'};
                   2010:     $$storehash{'host'}=$perlvar{'lonHostID'};
                   2011: 
1.12      www      2012:     my $namevalue='';
1.191     harris41 2013:     foreach (keys %$storehash) {
1.122     albertel 2014:         $namevalue.=escape($_).'='.escape($$storehash{$_}).'&';
1.191     harris41 2015:     }
1.12      www      2016:     $namevalue=~s/\&$//;
1.187     www      2017:     &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue);
1.124     www      2018:     return reply("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");
1.9       www      2019: }
                   2020: 
1.47      www      2021: # -------------------------------------------------------------- Critical Store
                   2022: 
                   2023: sub cstore {
1.124     www      2024:     my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
                   2025:     my $home='';
                   2026: 
1.168     albertel 2027:     if ($stuname) { $home=&homeserver($stuname,$domain); }
1.124     www      2028: 
1.213     www      2029:     $symb=&symbclean($symb);
1.122     albertel 2030:     if (!$symb) { unless ($symb=&symbread()) { return ''; } }
1.109     www      2031: 
1.325     www      2032:     if (!$domain) { $domain=$ENV{'user.domain'}; }
                   2033:     if (!$stuname) { $stuname=$ENV{'user.name'}; }
                   2034: 
                   2035:     &devalidate($symb,$stuname,$domain);
1.109     www      2036: 
                   2037:     $symb=escape($symb);
1.187     www      2038:     if (!$namespace) { 
                   2039:        unless ($namespace=$ENV{'request.course.id'}) { 
                   2040:           return ''; 
                   2041:        } 
                   2042:     }
1.122     albertel 2043:     if (!$home) { $home=$ENV{'user.home'}; }
1.447     www      2044: 
                   2045:     $$storehash{'ip'}=$ENV{'REMOTE_ADDR'};
                   2046:     $$storehash{'host'}=$perlvar{'lonHostID'};
1.122     albertel 2047: 
1.47      www      2048:     my $namevalue='';
1.191     harris41 2049:     foreach (keys %$storehash) {
1.122     albertel 2050:         $namevalue.=escape($_).'='.escape($$storehash{$_}).'&';
1.191     harris41 2051:     }
1.47      www      2052:     $namevalue=~s/\&$//;
1.187     www      2053:     &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue);
1.188     www      2054:     return critical
                   2055:                 ("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");
1.47      www      2056: }
                   2057: 
1.9       www      2058: # --------------------------------------------------------------------- Restore
                   2059: 
                   2060: sub restore {
1.124     www      2061:     my ($symb,$namespace,$domain,$stuname) = @_;
                   2062:     my $home='';
                   2063: 
1.168     albertel 2064:     if ($stuname) { $home=&homeserver($stuname,$domain); }
1.124     www      2065: 
1.122     albertel 2066:     if (!$symb) {
                   2067:       unless ($symb=escape(&symbread())) { return ''; }
                   2068:     } else {
1.213     www      2069:       $symb=&escape(&symbclean($symb));
1.122     albertel 2070:     }
1.188     www      2071:     if (!$namespace) { 
                   2072:        unless ($namespace=$ENV{'request.course.id'}) { 
                   2073:           return ''; 
                   2074:        } 
                   2075:     }
1.122     albertel 2076:     if (!$domain) { $domain=$ENV{'user.domain'}; }
                   2077:     if (!$stuname) { $stuname=$ENV{'user.name'}; }
                   2078:     if (!$home) { $home=$ENV{'user.home'}; }
                   2079:     my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home");
                   2080: 
1.12      www      2081:     my %returnhash=();
1.191     harris41 2082:     foreach (split(/\&/,$answer)) {
1.12      www      2083: 	my ($name,$value)=split(/\=/,$_);
                   2084:         $returnhash{&unescape($name)}=&unescape($value);
1.191     harris41 2085:     }
1.75      www      2086:     my $version;
                   2087:     for ($version=1;$version<=$returnhash{'version'};$version++) {
1.191     harris41 2088:        foreach (split(/\:/,$returnhash{$version.':keys'})) {
1.75      www      2089:           $returnhash{$_}=$returnhash{$version.':'.$_};
1.191     harris41 2090:        }
1.75      www      2091:     }
1.13      www      2092:     return %returnhash;
1.34      www      2093: }
                   2094: 
                   2095: # ---------------------------------------------------------- Course Description
                   2096: 
                   2097: sub coursedescription {
                   2098:     my $courseid=shift;
                   2099:     $courseid=~s/^\///;
1.49      www      2100:     $courseid=~s/\_/\//g;
1.34      www      2101:     my ($cdomain,$cnum)=split(/\//,$courseid);
1.129     albertel 2102:     my $chome=&homeserver($cnum,$cdomain);
1.302     albertel 2103:     my $normalid=$cdomain.'_'.$cnum;
                   2104:     # need to always cache even if we get errors otherwise we keep 
                   2105:     # trying and trying and trying to get the course description.
                   2106:     my %envhash=();
                   2107:     my %returnhash=();
                   2108:     $envhash{'course.'.$normalid.'.last_cache'}=time;
1.34      www      2109:     if ($chome ne 'no_host') {
1.302     albertel 2110:        %returnhash=&dump('environment',$cdomain,$cnum);
1.129     albertel 2111:        if (!exists($returnhash{'con_lost'})) {
                   2112:            $returnhash{'home'}= $chome;
                   2113: 	   $returnhash{'domain'} = $cdomain;
                   2114: 	   $returnhash{'num'} = $cnum;
1.130     albertel 2115:            while (my ($name,$value) = each %returnhash) {
1.53      www      2116:                $envhash{'course.'.$normalid.'.'.$name}=$value;
1.129     albertel 2117:            }
1.270     www      2118:            $returnhash{'url'}=&clutter($returnhash{'url'});
1.34      www      2119:            $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'.
1.38      www      2120: 	       $ENV{'user.name'}.'_'.$cdomain.'_'.$cnum;
1.60      www      2121:            $envhash{'course.'.$normalid.'.home'}=$chome;
                   2122:            $envhash{'course.'.$normalid.'.domain'}=$cdomain;
                   2123:            $envhash{'course.'.$normalid.'.num'}=$cnum;
1.34      www      2124:        }
                   2125:     }
1.302     albertel 2126:     &appenv(%envhash);
                   2127:     return %returnhash;
1.9       www      2128: }
1.1       albertel 2129: 
1.103     harris41 2130: # -------------------------------------------------------- Get user privileges
1.11      www      2131: 
                   2132: sub rolesinit {
                   2133:     my ($domain,$username,$authhost)=@_;
                   2134:     my $rolesdump=reply("dump:$domain:$username:roles",$authhost);
1.12      www      2135:     if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; }
1.11      www      2136:     my %allroles=();
                   2137:     my %thesepriv=();
                   2138:     my $now=time;
1.21      www      2139:     my $userroles="user.login.time=$now\n";
1.11      www      2140:     my $thesestr;
                   2141: 
                   2142:     if ($rolesdump ne '') {
1.191     harris41 2143:         foreach (split(/&/,$rolesdump)) {
1.21      www      2144: 	  if ($_!~/^rolesdef\&/) {
1.11      www      2145:             my ($area,$role)=split(/=/,$_);
1.21      www      2146:             $area=~s/\_\w\w$//;
1.11      www      2147:             my ($trole,$tend,$tstart)=split(/_/,$role);
1.21      www      2148:             $userroles.='user.role.'.$trole.'.'.$area.'='.
                   2149:                         $tstart.'.'.$tend."\n";
1.349     www      2150: # log the associated role with the area
                   2151:             &userrolelog($trole,$username,$domain,$area,$tstart,$tend);
1.11      www      2152:             if ($tend!=0) {
                   2153: 	        if ($tend<$now) {
                   2154: 	            $trole='';
                   2155:                 } 
                   2156:             }
                   2157:             if ($tstart!=0) {
                   2158:                 if ($tstart>$now) {
                   2159:                    $trole='';        
                   2160:                 }
                   2161:             }
                   2162:             if (($area ne '') && ($trole ne '')) {
1.347     albertel 2163: 		my $spec=$trole.'.'.$area;
                   2164: 		my ($tdummy,$tdomain,$trest)=split(/\//,$area);
                   2165: 		if ($trole =~ /^cr\//) {
                   2166: 		    my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
1.392     www      2167:  		    my $homsvr=homeserver($rauthor,$rdomain);
1.347     albertel 2168: 		    if ($hostname{$homsvr} ne '') {
1.392     www      2169: 			my ($rdummy,$roledef)=
                   2170: 			   &get('roles',["rolesdef_$rrole"],$rdomain,$rauthor);
                   2171: 				
                   2172: 			if (($rdummy ne 'con_lost') && ($roledef ne '')) {
1.347     albertel 2173: 			    my ($syspriv,$dompriv,$coursepriv)=
1.392     www      2174: 				split(/\_/,$roledef);
1.347     albertel 2175: 			    if (defined($syspriv)) {
                   2176: 				$allroles{'cm./'}.=':'.$syspriv;
                   2177: 				$allroles{$spec.'./'}.=':'.$syspriv;
                   2178: 			    }
                   2179: 			    if ($tdomain ne '') {
                   2180: 				if (defined($dompriv)) {
                   2181: 				    $allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv;
                   2182: 				    $allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv;
                   2183: 				}
                   2184: 				if ($trest ne '') {
                   2185: 				    if (defined($coursepriv)) {
                   2186: 					$allroles{'cm.'.$area}.=':'.$coursepriv;
                   2187: 					$allroles{$spec.'.'.$area}.=':'.$coursepriv;
                   2188: 				    }
                   2189: 				}
                   2190: 			    }
                   2191: 			}
                   2192: 		    }
                   2193: 		} else {
                   2194: 		    if (defined($pr{$trole.':s'})) {
                   2195: 			$allroles{'cm./'}.=':'.$pr{$trole.':s'};
                   2196: 			$allroles{$spec.'./'}.=':'.$pr{$trole.':s'};
                   2197: 		    }
                   2198: 		    if ($tdomain ne '') {
                   2199: 			if (defined($pr{$trole.':d'})) {
                   2200: 			    $allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
                   2201: 			    $allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
                   2202: 			}
                   2203: 			if ($trest ne '') {
                   2204: 			    if (defined($pr{$trole.':c'})) {
                   2205: 				$allroles{'cm.'.$area}.=':'.$pr{$trole.':c'};
                   2206: 				$allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'};
                   2207: 			    }
                   2208: 			}
                   2209: 		    }
                   2210: 		}
1.12      www      2211:             }
                   2212:           } 
1.191     harris41 2213:         }
1.125     www      2214:         my $adv=0;
1.128     www      2215:         my $author=0;
1.191     harris41 2216:         foreach (keys %allroles) {
1.11      www      2217:             %thesepriv=();
1.146     www      2218:             if (($_!~/^st/) && ($_!~/^ta/) && ($_!~/^cm/)) { $adv=1; }
1.128     www      2219:             if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; }
1.191     harris41 2220:             foreach (split(/:/,$allroles{$_})) {
1.11      www      2221:                 if ($_ ne '') {
1.103     harris41 2222: 		    my ($privilege,$restrictions)=split(/&/,$_);
1.11      www      2223:                     if ($restrictions eq '') {
1.103     harris41 2224: 			$thesepriv{$privilege}='F';
1.11      www      2225:                     } else {
1.103     harris41 2226:                         if ($thesepriv{$privilege} ne 'F') {
                   2227: 			    $thesepriv{$privilege}.=$restrictions;
1.11      www      2228:                         }
                   2229:                     }
                   2230:                 }
1.191     harris41 2231:             }
1.11      www      2232:             $thesestr='';
1.191     harris41 2233:             foreach (keys %thesepriv) { $thesestr.=':'.$_.'&'.$thesepriv{$_}; }
1.11      www      2234:             $userroles.='user.priv.'.$_.'='.$thesestr."\n";
1.191     harris41 2235:         }
1.128     www      2236:         $userroles.='user.adv='.$adv."\n".
                   2237: 	            'user.author='.$author."\n";
1.126     www      2238:         $ENV{'user.adv'}=$adv;
1.11      www      2239:     }
                   2240:     return $userroles;  
                   2241: }
                   2242: 
1.12      www      2243: # --------------------------------------------------------------- get interface
                   2244: 
                   2245: sub get {
1.131     albertel 2246:    my ($namespace,$storearr,$udomain,$uname)=@_;
1.12      www      2247:    my $items='';
1.191     harris41 2248:    foreach (@$storearr) {
1.12      www      2249:        $items.=escape($_).'&';
1.191     harris41 2250:    }
1.12      www      2251:    $items=~s/\&$//;
1.131     albertel 2252:    if (!$udomain) { $udomain=$ENV{'user.domain'}; }
                   2253:    if (!$uname) { $uname=$ENV{'user.name'}; }
                   2254:    my $uhome=&homeserver($uname,$udomain);
                   2255: 
1.133     albertel 2256:    my $rep=&reply("get:$udomain:$uname:$namespace:$items",$uhome);
1.15      www      2257:    my @pairs=split(/\&/,$rep);
1.273     albertel 2258:    if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) {
                   2259:      return @pairs;
                   2260:    }
1.15      www      2261:    my %returnhash=();
1.42      www      2262:    my $i=0;
1.191     harris41 2263:    foreach (@$storearr) {
1.42      www      2264:       $returnhash{$_}=unescape($pairs[$i]);
                   2265:       $i++;
1.191     harris41 2266:    }
1.15      www      2267:    return %returnhash;
1.27      www      2268: }
                   2269: 
                   2270: # --------------------------------------------------------------- del interface
                   2271: 
                   2272: sub del {
1.133     albertel 2273:    my ($namespace,$storearr,$udomain,$uname)=@_;
1.27      www      2274:    my $items='';
1.191     harris41 2275:    foreach (@$storearr) {
1.27      www      2276:        $items.=escape($_).'&';
1.191     harris41 2277:    }
1.27      www      2278:    $items=~s/\&$//;
1.133     albertel 2279:    if (!$udomain) { $udomain=$ENV{'user.domain'}; }
                   2280:    if (!$uname) { $uname=$ENV{'user.name'}; }
                   2281:    my $uhome=&homeserver($uname,$udomain);
                   2282: 
                   2283:    return &reply("del:$udomain:$uname:$namespace:$items",$uhome);
1.15      www      2284: }
                   2285: 
                   2286: # -------------------------------------------------------------- dump interface
                   2287: 
                   2288: sub dump {
1.193     www      2289:    my ($namespace,$udomain,$uname,$regexp)=@_;
1.129     albertel 2290:    if (!$udomain) { $udomain=$ENV{'user.domain'}; }
                   2291:    if (!$uname) { $uname=$ENV{'user.name'}; }
                   2292:    my $uhome=&homeserver($uname,$udomain);
1.193     www      2293:    if ($regexp) {
                   2294:        $regexp=&escape($regexp);
                   2295:    } else {
                   2296:        $regexp='.';
                   2297:    }
                   2298:    my $rep=reply("dump:$udomain:$uname:$namespace:$regexp",$uhome);
1.12      www      2299:    my @pairs=split(/\&/,$rep);
                   2300:    my %returnhash=();
1.191     harris41 2301:    foreach (@pairs) {
1.12      www      2302:       my ($key,$value)=split(/=/,$_);
1.29      www      2303:       $returnhash{unescape($key)}=unescape($value);
1.318     matthew  2304:    }
                   2305:    return %returnhash;
1.407     www      2306: }
                   2307: 
                   2308: # -------------------------------------------------------------- keys interface
                   2309: 
                   2310: sub getkeys {
                   2311:    my ($namespace,$udomain,$uname)=@_;
                   2312:    if (!$udomain) { $udomain=$ENV{'user.domain'}; }
                   2313:    if (!$uname) { $uname=$ENV{'user.name'}; }
                   2314:    my $uhome=&homeserver($uname,$udomain);
                   2315:    my $rep=reply("keys:$udomain:$uname:$namespace",$uhome);
                   2316:    my @keyarray=();
                   2317:    foreach (split(/\&/,$rep)) {
                   2318:       push (@keyarray,&unescape($_));
                   2319:    }
                   2320:    return @keyarray;
1.318     matthew  2321: }
                   2322: 
1.319     matthew  2323: # --------------------------------------------------------------- currentdump
                   2324: sub currentdump {
1.328     matthew  2325:    my ($courseid,$sdom,$sname)=@_;
1.326     matthew  2326:    $courseid = $ENV{'request.course.id'} if (! defined($courseid));
                   2327:    $sdom     = $ENV{'user.domain'}       if (! defined($sdom));
                   2328:    $sname    = $ENV{'user.name'}         if (! defined($sname));
                   2329:    my $uhome = &homeserver($sname,$sdom);
                   2330:    my $rep=reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome);
1.318     matthew  2331:    return if ($rep =~ /^(error:|no_such_host)/);
1.319     matthew  2332:    #
1.318     matthew  2333:    my %returnhash=();
1.319     matthew  2334:    #
                   2335:    if ($rep eq "unknown_cmd") { 
                   2336:        # an old lond will not know currentdump
                   2337:        # Do a dump and make it look like a currentdump
1.326     matthew  2338:        my @tmp = &dump($courseid,$sdom,$sname,'.');
1.319     matthew  2339:        return if ($tmp[0] =~ /^(error:|no_such_host)/);
                   2340:        my %hash = @tmp;
                   2341:        @tmp=();
1.424     matthew  2342:        %returnhash = %{&convert_dump_to_currentdump(\%hash)};
1.319     matthew  2343:    } else {
                   2344:        my @pairs=split(/\&/,$rep);
                   2345:        foreach (@pairs) {
                   2346:            my ($key,$value)=split(/=/,$_);
                   2347:            my ($symb,$param) = split(/:/,$key);
                   2348:            $returnhash{&unescape($symb)}->{&unescape($param)} = 
                   2349:                                                           &unescape($value);
                   2350:        }
1.191     harris41 2351:    }
1.12      www      2352:    return %returnhash;
1.424     matthew  2353: }
                   2354: 
                   2355: sub convert_dump_to_currentdump{
                   2356:     my %hash = %{shift()};
                   2357:     my %returnhash;
                   2358:     # Code ripped from lond, essentially.  The only difference
                   2359:     # here is the unescaping done by lonnet::dump().  Conceivably
                   2360:     # we might run in to problems with parameter names =~ /^v\./
                   2361:     while (my ($key,$value) = each(%hash)) {
                   2362:         my ($v,$symb,$param) = split(/:/,$key);
                   2363:         next if ($v eq 'version' || $symb eq 'keys');
                   2364:         next if (exists($returnhash{$symb}) &&
                   2365:                  exists($returnhash{$symb}->{$param}) &&
                   2366:                  $returnhash{$symb}->{'v.'.$param} > $v);
                   2367:         $returnhash{$symb}->{$param}=$value;
                   2368:         $returnhash{$symb}->{'v.'.$param}=$v;
                   2369:     }
                   2370:     #
                   2371:     # Remove all of the keys in the hashes which keep track of
                   2372:     # the version of the parameter.
                   2373:     while (my ($symb,$param_hash) = each(%returnhash)) {
                   2374:         # use a foreach because we are going to delete from the hash.
                   2375:         foreach my $key (keys(%$param_hash)) {
                   2376:             delete($param_hash->{$key}) if ($key =~ /^v\./);
                   2377:         }
                   2378:     }
                   2379:     return \%returnhash;
1.12      www      2380: }
                   2381: 
1.449     matthew  2382: # --------------------------------------------------------------- inc interface
                   2383: 
                   2384: sub inc {
                   2385:     my ($namespace,$store,$udomain,$uname) = @_;
                   2386:     if (!$udomain) { $udomain=$ENV{'user.domain'}; }
                   2387:     if (!$uname) { $uname=$ENV{'user.name'}; }
                   2388:     my $uhome=&homeserver($uname,$udomain);
                   2389:     my $items='';
                   2390:     if (! ref($store)) {
                   2391:         # got a single value, so use that instead
                   2392:         $items = &escape($store).'=&';
                   2393:     } elsif (ref($store) eq 'SCALAR') {
                   2394:         $items = &escape($$store).'=&';        
                   2395:     } elsif (ref($store) eq 'ARRAY') {
                   2396:         $items = join('=&',map {&escape($_);} @{$store});
                   2397:     } elsif (ref($store) eq 'HASH') {
                   2398:         while (my($key,$value) = each(%{$store})) {
                   2399:             $items.= &escape($key).'='.&escape($value).'&';
                   2400:         }
                   2401:     }
                   2402:     $items=~s/\&$//;
                   2403:     return &reply("inc:$udomain:$uname:$namespace:$items",$uhome);
                   2404: }
                   2405: 
1.12      www      2406: # --------------------------------------------------------------- put interface
                   2407: 
                   2408: sub put {
1.134     albertel 2409:    my ($namespace,$storehash,$udomain,$uname)=@_;
                   2410:    if (!$udomain) { $udomain=$ENV{'user.domain'}; }
                   2411:    if (!$uname) { $uname=$ENV{'user.name'}; }
                   2412:    my $uhome=&homeserver($uname,$udomain);
1.12      www      2413:    my $items='';
1.191     harris41 2414:    foreach (keys %$storehash) {
1.134     albertel 2415:        $items.=&escape($_).'='.&escape($$storehash{$_}).'&';
1.191     harris41 2416:    }
1.12      www      2417:    $items=~s/\&$//;
1.134     albertel 2418:    return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
1.47      www      2419: }
                   2420: 
                   2421: # ------------------------------------------------------ critical put interface
                   2422: 
                   2423: sub cput {
1.134     albertel 2424:    my ($namespace,$storehash,$udomain,$uname)=@_;
                   2425:    if (!$udomain) { $udomain=$ENV{'user.domain'}; }
                   2426:    if (!$uname) { $uname=$ENV{'user.name'}; }
                   2427:    my $uhome=&homeserver($uname,$udomain);
1.47      www      2428:    my $items='';
1.191     harris41 2429:    foreach (keys %$storehash) {
1.134     albertel 2430:        $items.=escape($_).'='.escape($$storehash{$_}).'&';
1.191     harris41 2431:    }
1.47      www      2432:    $items=~s/\&$//;
1.134     albertel 2433:    return &critical("put:$udomain:$uname:$namespace:$items",$uhome);
1.12      www      2434: }
                   2435: 
                   2436: # -------------------------------------------------------------- eget interface
                   2437: 
                   2438: sub eget {
1.133     albertel 2439:    my ($namespace,$storearr,$udomain,$uname)=@_;
1.12      www      2440:    my $items='';
1.191     harris41 2441:    foreach (@$storearr) {
1.12      www      2442:        $items.=escape($_).'&';
1.191     harris41 2443:    }
1.12      www      2444:    $items=~s/\&$//;
1.133     albertel 2445:    if (!$udomain) { $udomain=$ENV{'user.domain'}; }
                   2446:    if (!$uname) { $uname=$ENV{'user.name'}; }
                   2447:    my $uhome=&homeserver($uname,$udomain);
                   2448:    my $rep=&reply("eget:$udomain:$uname:$namespace:$items",$uhome);
1.12      www      2449:    my @pairs=split(/\&/,$rep);
                   2450:    my %returnhash=();
1.42      www      2451:    my $i=0;
1.191     harris41 2452:    foreach (@$storearr) {
1.42      www      2453:       $returnhash{$_}=unescape($pairs[$i]);
                   2454:       $i++;
1.191     harris41 2455:    }
1.12      www      2456:    return %returnhash;
                   2457: }
                   2458: 
1.341     www      2459: # ---------------------------------------------- Custom access rule evaluation
                   2460: 
                   2461: sub customaccess {
                   2462:     my ($priv,$uri)=@_;
1.342     www      2463:     my ($urole,$urealm)=split(/\./,$ENV{'request.role'});
1.343     www      2464:     $urealm=~s/^\W//;
                   2465:     my ($udom,$ucrs,$usec)=split(/\//,$urealm);
1.341     www      2466:     my $access=0;
                   2467:     foreach (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) {
1.342     www      2468: 	my ($effect,$realm,$role)=split(/\:/,$_);
1.343     www      2469:         if ($role) {
                   2470: 	   if ($role ne $urole) { next; }
                   2471:         }
                   2472:         foreach (split(/\s*\,\s*/,$realm)) {
                   2473:             my ($tdom,$tcrs,$tsec)=split(/\_/,$_);
                   2474:             if ($tdom) {
                   2475: 		if ($tdom ne $udom) { next; }
                   2476:             }
                   2477:             if ($tcrs) {
                   2478: 		if ($tcrs ne $ucrs) { next; }
                   2479:             }
                   2480:             if ($tsec) {
                   2481: 		if ($tsec ne $usec) { next; }
                   2482:             }
                   2483:             $access=($effect eq 'allow');
                   2484:             last;
1.342     www      2485:         }
1.402     bowersj2 2486: 	if ($realm eq '' && $role eq '') {
                   2487:             $access=($effect eq 'allow');
                   2488: 	}
1.341     www      2489:     }
                   2490:     return $access;
                   2491: }
                   2492: 
1.103     harris41 2493: # ------------------------------------------------- Check for a user privilege
1.12      www      2494: 
                   2495: sub allowed {
                   2496:     my ($priv,$uri)=@_;
1.439     www      2497:     $uri=&deversion($uri);
1.152     www      2498:     my $orguri=$uri;
1.52      www      2499:     $uri=&declutter($uri);
1.29      www      2500: 
1.398     albertel 2501:     if (defined($ENV{'allowed.'.$priv})) { return $ENV{'allowed.'.$priv}; }
1.54      www      2502: # Free bre access to adm and meta resources
1.29      www      2503: 
1.54      www      2504:     if ((($uri=~/^adm\//) || ($uri=~/\.meta$/)) && ($priv eq 'bre')) {
1.14      www      2505: 	return 'F';
1.159     www      2506:     }
                   2507: 
                   2508: # Free bre to public access
                   2509: 
                   2510:     if ($priv eq 'bre') {
1.238     www      2511:         my $copyright=&metadata($uri,'copyright');
1.301     www      2512: 	if (($copyright eq 'public') && (!$ENV{'request.course.id'})) { 
                   2513:            return 'F'; 
                   2514:         }
1.238     www      2515:         if ($copyright eq 'priv') {
                   2516:             $uri=~/([^\/]+)\/([^\/]+)\//;
                   2517: 	    unless (($ENV{'user.name'} eq $2) && ($ENV{'user.domain'} eq $1)) {
                   2518: 		return '';
                   2519:             }
                   2520:         }
                   2521:         if ($copyright eq 'domain') {
                   2522:             $uri=~/([^\/]+)\/([^\/]+)\//;
                   2523: 	    unless (($ENV{'user.domain'} eq $1) ||
                   2524:                  ($ENV{'course.'.$ENV{'request.course.id'}.'.domain'} eq $1)) {
                   2525: 		return '';
                   2526:             }
1.262     matthew  2527:         }
                   2528:         if ($ENV{'request.role'}=~ /li\.\//) {
                   2529:             # Library role, so allow browsing of resources in this domain.
                   2530:             return 'F';
1.238     www      2531:         }
1.341     www      2532:         if ($copyright eq 'custom') {
                   2533: 	    unless (&customaccess($priv,$uri)) { return ''; }
                   2534:         }
1.14      www      2535:     }
1.264     matthew  2536:     # Domain coordinator is trying to create a course
                   2537:     if (($priv eq 'ccc') && ($ENV{'request.role'} =~ /^dc\./)) {
                   2538:         # uri is the requested domain in this case.
                   2539:         # comparison to 'request.role.domain' shows if the user has selected
                   2540:         # a role of dc for the domain in question. 
                   2541:         return 'F' if ($uri eq $ENV{'request.role.domain'});
                   2542:     }
1.29      www      2543: 
1.52      www      2544:     my $thisallowed='';
                   2545:     my $statecond=0;
                   2546:     my $courseprivid='';
                   2547: 
                   2548: # Course
                   2549: 
                   2550:     if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'}=~/$priv\&([^\:]*)/) {
                   2551:        $thisallowed.=$1;
                   2552:     }
1.29      www      2553: 
1.52      www      2554: # Domain
                   2555: 
                   2556:     if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.(split(/\//,$uri))[0].'/'}
                   2557:        =~/$priv\&([^\:]*)/) {
1.12      www      2558:        $thisallowed.=$1;
                   2559:     }
1.52      www      2560: 
                   2561: # Course: uri itself is a course
1.66      www      2562:     my $courseuri=$uri;
                   2563:     $courseuri=~s/\_(\d)/\/$1/;
1.83      www      2564:     $courseuri=~s/^([^\/])/\/$1/;
1.81      www      2565: 
1.83      www      2566:     if ($ENV{'user.priv.'.$ENV{'request.role'}.'.'.$courseuri}
1.52      www      2567:        =~/$priv\&([^\:]*)/) {
1.12      www      2568:        $thisallowed.=$1;
                   2569:     }
1.29      www      2570: 
1.314     www      2571: # URI is an uploaded document for this course
                   2572: 
                   2573:     if (($priv eq 'bre') && 
                   2574:         ($uri=~/^uploaded\/$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}\/$ENV{'course.'.$ENV{'request.course.id'}.'.num'}/)) {
                   2575:         return 'F';
                   2576:     }
1.52      www      2577: # Full access at system, domain or course-wide level? Exit.
1.29      www      2578: 
                   2579:     if ($thisallowed=~/F/) {
                   2580: 	return 'F';
                   2581:     }
                   2582: 
1.52      www      2583: # If this is generating or modifying users, exit with special codes
1.29      www      2584: 
1.166     www      2585:     if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:'=~/\:$priv\:/) {
1.52      www      2586: 	return $thisallowed;
                   2587:     }
                   2588: #
1.103     harris41 2589: # Gathered so far: system, domain and course wide privileges
1.52      www      2590: #
                   2591: # Course: See if uri or referer is an individual resource that is part of 
                   2592: # the course
                   2593: 
                   2594:     if ($ENV{'request.course.id'}) {
1.232     www      2595: 
1.52      www      2596:        $courseprivid=$ENV{'request.course.id'};
                   2597:        if ($ENV{'request.course.sec'}) {
                   2598:           $courseprivid.='/'.$ENV{'request.course.sec'};
                   2599:        }
                   2600:        $courseprivid=~s/\_/\//;
                   2601:        my $checkreferer=1;
1.232     www      2602:        my ($match,$cond)=&is_on_map($uri);
                   2603:        if ($match) {
                   2604:            $statecond=$cond;
1.52      www      2605:            if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid}
                   2606:                =~/$priv\&([^\:]*)/) {
                   2607:                $thisallowed.=$1;
                   2608:                $checkreferer=0;
                   2609:            }
1.29      www      2610:        }
1.83      www      2611:        
1.148     www      2612:        if ($checkreferer) {
1.152     www      2613: 	  my $refuri=$ENV{'httpref.'.$orguri};
1.148     www      2614:             unless ($refuri) {
1.191     harris41 2615:                 foreach (keys %ENV) {
1.148     www      2616: 		    if ($_=~/^httpref\..*\*/) {
                   2617: 			my $pattern=$_;
1.156     www      2618:                         $pattern=~s/^httpref\.\/res\///;
1.148     www      2619:                         $pattern=~s/\*/\[\^\/\]\+/g;
                   2620:                         $pattern=~s/\//\\\//g;
1.152     www      2621:                         if ($orguri=~/$pattern/) {
1.148     www      2622: 			    $refuri=$ENV{$_};
                   2623:                         }
                   2624:                     }
1.191     harris41 2625:                 }
1.148     www      2626:             }
1.232     www      2627: 
1.148     www      2628:          if ($refuri) { 
1.152     www      2629: 	  $refuri=&declutter($refuri);
1.232     www      2630:           my ($match,$cond)=&is_on_map($refuri);
                   2631:             if ($match) {
                   2632:               my $refstatecond=$cond;
1.52      www      2633:               if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid}
                   2634:                   =~/$priv\&([^\:]*)/) {
                   2635:                   $thisallowed.=$1;
1.53      www      2636:                   $uri=$refuri;
                   2637:                   $statecond=$refstatecond;
1.52      www      2638:               }
                   2639:           }
1.148     www      2640:         }
1.29      www      2641:        }
1.52      www      2642:    }
1.29      www      2643: 
1.52      www      2644: #
1.103     harris41 2645: # Gathered now: all privileges that could apply, and condition number
1.52      www      2646: # 
                   2647: #
                   2648: # Full or no access?
                   2649: #
1.29      www      2650: 
1.52      www      2651:     if ($thisallowed=~/F/) {
                   2652: 	return 'F';
                   2653:     }
1.29      www      2654: 
1.52      www      2655:     unless ($thisallowed) {
                   2656:         return '';
                   2657:     }
1.29      www      2658: 
1.52      www      2659: # Restrictions exist, deal with them
                   2660: #
                   2661: #   C:according to course preferences
                   2662: #   R:according to resource settings
                   2663: #   L:unless locked
                   2664: #   X:according to user session state
                   2665: #
                   2666: 
                   2667: # Possibly locked functionality, check all courses
1.54      www      2668: # Locks might take effect only after 10 minutes cache expiration for other
                   2669: # courses, and 2 minutes for current course
1.52      www      2670: 
                   2671:     my $envkey;
                   2672:     if ($thisallowed=~/L/) {
                   2673:         foreach $envkey (keys %ENV) {
1.54      www      2674:            if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) {
                   2675:                my $courseid=$2;
                   2676:                my $roleid=$1.'.'.$2;
1.92      www      2677:                $courseid=~s/^\///;
1.54      www      2678:                my $expiretime=600;
                   2679:                if ($ENV{'request.role'} eq $roleid) {
                   2680: 		  $expiretime=120;
                   2681:                }
                   2682: 	       my ($cdom,$cnum,$csec)=split(/\//,$courseid);
                   2683:                my $prefix='course.'.$cdom.'_'.$cnum.'.';
                   2684:                if ((time-$ENV{$prefix.'last_cache'})>$expiretime) {
                   2685: 		   &coursedescription($courseid);
                   2686:                }
                   2687:                if (($ENV{$prefix.'res.'.$uri.'.lock.sections'}=~/\,$csec\,/)
                   2688:                 || ($ENV{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) {
                   2689: 		   if ($ENV{$prefix.'res.'.$uri.'.lock.expire'}>time) {
1.57      www      2690:                        &log($ENV{'user.domain'},$ENV{'user.name'},
1.239     www      2691:                             $ENV{'user.home'},
1.57      www      2692:                             'Locked by res: '.$priv.' for '.$uri.' due to '.
1.52      www      2693:                             $cdom.'/'.$cnum.'/'.$csec.' expire '.
1.54      www      2694:                             $ENV{$prefix.'priv.'.$priv.'.lock.expire'});
1.52      www      2695: 		       return '';
                   2696:                    }
                   2697:                }
1.54      www      2698:                if (($ENV{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,$csec\,/)
                   2699:                 || ($ENV{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) {
                   2700: 		   if ($ENV{'priv.'.$priv.'.lock.expire'}>time) {
1.57      www      2701:                        &log($ENV{'user.domain'},$ENV{'user.name'},
1.239     www      2702:                             $ENV{'user.home'},
1.57      www      2703:                             'Locked by priv: '.$priv.' for '.$uri.' due to '.
1.52      www      2704:                             $cdom.'/'.$cnum.'/'.$csec.' expire '.
1.54      www      2705:                             $ENV{$prefix.'priv.'.$priv.'.lock.expire'});
1.52      www      2706: 		       return '';
                   2707:                    }
                   2708:                }
                   2709: 	   }
1.29      www      2710:        }
1.52      www      2711:     }
                   2712:    
                   2713: #
                   2714: # Rest of the restrictions depend on selected course
                   2715: #
                   2716: 
                   2717:     unless ($ENV{'request.course.id'}) {
                   2718:        return '1';
                   2719:     }
1.29      www      2720: 
1.52      www      2721: #
                   2722: # Now user is definitely in a course
                   2723: #
1.53      www      2724: 
                   2725: 
                   2726: # Course preferences
                   2727: 
                   2728:    if ($thisallowed=~/C/) {
1.54      www      2729:        my $rolecode=(split(/\./,$ENV{'request.role'}))[0];
1.237     www      2730:        my $unamedom=$ENV{'user.name'}.':'.$ENV{'user.domain'};
1.54      www      2731:        if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.roles.denied'}
1.194     www      2732: 	   =~/$rolecode/) {
1.57      www      2733:            &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},
                   2734:                 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
1.237     www      2735:                 $ENV{'request.course.id'});
                   2736:            return '';
                   2737:        }
                   2738: 
                   2739:        if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.users.denied'}
                   2740: 	   =~/$unamedom/) {
                   2741:            &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},
                   2742:                 'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.
1.54      www      2743:                 $ENV{'request.course.id'});
                   2744:            return '';
                   2745:        }
1.53      www      2746:    }
                   2747: 
                   2748: # Resource preferences
                   2749: 
                   2750:    if ($thisallowed=~/R/) {
1.54      www      2751:        my $rolecode=(split(/\./,$ENV{'request.role'}))[0];
1.341     www      2752:        if (&metadata($uri,'roledeny')=~/$rolecode/) {
                   2753: 	  &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},
1.57      www      2754:                     'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
1.341     www      2755:           return '';
1.54      www      2756:        }
1.53      www      2757:    }
1.30      www      2758: 
1.246     www      2759: # Restricted by state or randomout?
1.30      www      2760: 
1.52      www      2761:    if ($thisallowed=~/X/) {
1.247     www      2762:       if ($ENV{'acc.randomout'}) {
1.249     www      2763:          my $symb=&symbread($uri,1);
1.248     www      2764:          if (($symb) && ($ENV{'acc.randomout'}=~/\&$symb\&/)) { 
                   2765:             return ''; 
                   2766:          }
1.247     www      2767:       }
                   2768:       if (&condval($statecond)) {
1.52      www      2769: 	 return '2';
                   2770:       } else {
                   2771:          return '';
                   2772:       }
                   2773:    }
1.30      www      2774: 
1.52      www      2775:    return 'F';
1.232     www      2776: }
                   2777: 
                   2778: # --------------------------------------------------- Is a resource on the map?
                   2779: 
                   2780: sub is_on_map {
                   2781:     my $uri=&declutter(shift);
1.435     www      2782:     $uri=~s/\.\d+\.(\w+)$/\.$1/;
1.232     www      2783:     my @uriparts=split(/\//,$uri);
                   2784:     my $filename=$uriparts[$#uriparts];
                   2785:     my $pathname=$uri;
1.289     bowersj2 2786:     $pathname=~s|/\Q$filename\E$||;
1.332     www      2787:     $pathname=~s/^adm\/wrapper\///;    
1.289     bowersj2 2788:     #Trying to find the conditional for the file
1.232     www      2789:     my $match=($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~
1.289     bowersj2 2790: 	       /\&\Q$filename\E\:([\d\|]+)\&/);
1.232     www      2791:     if ($match) {
1.289     bowersj2 2792: 	return (1,$1);
                   2793:     } else {
1.434     www      2794: 	return (0,0);
1.289     bowersj2 2795:     }
1.12      www      2796: }
                   2797: 
1.427     www      2798: # --------------------------------------------------------- Get symb from alias
                   2799: 
                   2800: sub get_symb_from_alias {
                   2801:     my $symb=shift;
                   2802:     my ($map,$resid,$url)=&decode_symb($symb);
                   2803: # Already is a symb
                   2804:     if ($url) { return $symb; }
                   2805: # Must be an alias
                   2806:     my $aliassymb='';
                   2807:     my %bighash;
                   2808:     if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
                   2809:                             &GDBM_READER(),0640)) {
                   2810:         my $rid=$bighash{'mapalias_'.$symb};
                   2811: 	if ($rid) {
                   2812: 	    my ($mapid,$resid)=split(/\./,$rid);
1.429     albertel 2813: 	    $aliassymb=&encode_symb($bighash{'map_id_'.$mapid},
                   2814: 				    $resid,$bighash{'src_'.$rid});
1.427     www      2815: 	}
                   2816:         untie %bighash;
                   2817:     }
                   2818:     return $aliassymb;
                   2819: }
                   2820: 
1.12      www      2821: # ----------------------------------------------------------------- Define Role
                   2822: 
                   2823: sub definerole {
                   2824:   if (allowed('mcr','/')) {
                   2825:     my ($rolename,$sysrole,$domrole,$courole)=@_;
1.392     www      2826:     foreach (split(':',$sysrole)) {
1.21      www      2827: 	my ($crole,$cqual)=split(/\&/,$_);
                   2828:         if ($pr{'cr:s'}!~/$crole/) { return "refused:s:$crole"; }
                   2829:         if ($pr{'cr:s'}=~/$crole\&/) {
                   2830: 	    if ($pr{'cr:s'}!~/$crole\&\w*$cqual/) { 
                   2831:                return "refused:s:$crole&$cqual"; 
                   2832:             }
                   2833:         }
1.191     harris41 2834:     }
1.392     www      2835:     foreach (split(':',$domrole)) {
1.21      www      2836: 	my ($crole,$cqual)=split(/\&/,$_);
                   2837:         if ($pr{'cr:d'}!~/$crole/) { return "refused:d:$crole"; }
                   2838:         if ($pr{'cr:d'}=~/$crole\&/) {
                   2839: 	    if ($pr{'cr:d'}!~/$crole\&\w*$cqual/) { 
                   2840:                return "refused:d:$crole&$cqual"; 
                   2841:             }
                   2842:         }
1.191     harris41 2843:     }
1.392     www      2844:     foreach (split(':',$courole)) {
1.21      www      2845: 	my ($crole,$cqual)=split(/\&/,$_);
                   2846:         if ($pr{'cr:c'}!~/$crole/) { return "refused:c:$crole"; }
                   2847:         if ($pr{'cr:c'}=~/$crole\&/) {
                   2848: 	    if ($pr{'cr:c'}!~/$crole\&\w*$cqual/) { 
                   2849:                return "refused:c:$crole&$cqual"; 
                   2850:             }
                   2851:         }
1.191     harris41 2852:     }
1.12      www      2853:     my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:".
                   2854:                 "$ENV{'user.domain'}:$ENV{'user.name'}:".
1.21      www      2855: 	        "rolesdef_$rolename=".
                   2856:                 escape($sysrole.'_'.$domrole.'_'.$courole);
1.12      www      2857:     return reply($command,$ENV{'user.home'});
                   2858:   } else {
                   2859:     return 'refused';
                   2860:   }
1.105     harris41 2861: }
                   2862: 
                   2863: # ---------------- Make a metadata query against the network of library servers
                   2864: 
                   2865: sub metadata_query {
1.244     matthew  2866:     my ($query,$custom,$customshow,$server_array)=@_;
1.120     harris41 2867:     my %rhash;
1.244     matthew  2868:     my @server_list = (defined($server_array) ? @$server_array
                   2869:                                               : keys(%libserv) );
                   2870:     for my $server (@server_list) {
1.118     harris41 2871: 	unless ($custom or $customshow) {
                   2872: 	    my $reply=&reply("querysend:".&escape($query),$server);
                   2873: 	    $rhash{$server}=$reply;
                   2874: 	}
                   2875: 	else {
                   2876: 	    my $reply=&reply("querysend:".&escape($query).':'.
                   2877: 			     &escape($custom).':'.&escape($customshow),
                   2878: 			     $server);
                   2879: 	    $rhash{$server}=$reply;
                   2880: 	}
1.112     harris41 2881:     }
1.118     harris41 2882:     return \%rhash;
1.240     www      2883: }
                   2884: 
                   2885: # ----------------------------------------- Send log queries and wait for reply
                   2886: 
                   2887: sub log_query {
                   2888:     my ($uname,$udom,$query,%filters)=@_;
                   2889:     my $uhome=&homeserver($uname,$udom);
                   2890:     if ($uhome eq 'no_host') { return 'error: no_host'; }
                   2891:     my $uhost=$hostname{$uhome};
1.241     www      2892:     my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys %filters));
1.240     www      2893:     my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command,
                   2894:                        $uhome);
                   2895:     unless ($queryid=~/^$uhost\_/) { return 'error: '.$queryid; }
1.242     www      2896:     return get_query_reply($queryid);
                   2897: }
                   2898: 
                   2899: sub get_query_reply {
                   2900:     my $queryid=shift;
1.240     www      2901:     my $replyfile=$perlvar{'lonDaemons'}.'/tmp/'.$queryid;
                   2902:     my $reply='';
                   2903:     for (1..100) {
                   2904: 	sleep 2;
                   2905:         if (-e $replyfile.'.end') {
1.448     albertel 2906: 	    if (open(my $fh,$replyfile)) {
1.240     www      2907:                $reply.=<$fh>;
1.448     albertel 2908:                close($fh);
1.240     www      2909: 	   } else { return 'error: reply_file_error'; }
1.242     www      2910:            return &unescape($reply);
                   2911: 	}
1.240     www      2912:     }
1.242     www      2913:     return 'timeout:'.$queryid;
1.240     www      2914: }
                   2915: 
                   2916: sub courselog_query {
1.241     www      2917: #
                   2918: # possible filters:
                   2919: # url: url or symb
                   2920: # username
                   2921: # domain
                   2922: # action: view, submit, grade
                   2923: # start: timestamp
                   2924: # end: timestamp
                   2925: #
1.240     www      2926:     my (%filters)=@_;
                   2927:     unless ($ENV{'request.course.id'}) { return 'no_course'; }
1.241     www      2928:     if ($filters{'url'}) {
                   2929: 	$filters{'url'}=&symbclean(&declutter($filters{'url'}));
                   2930:         $filters{'url'}=~s/\.(\w+)$/(\\.\\d+)*\\.$1/;
                   2931:         $filters{'url'}=~s/\.(\w+)\_\_\_/(\\.\\d+)*\\.$1/;
                   2932:     }
1.240     www      2933:     my $cname=$ENV{'course.'.$ENV{'request.course.id'}.'.num'};
                   2934:     my $cdom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'};
                   2935:     return &log_query($cname,$cdom,'courselog',%filters);
                   2936: }
                   2937: 
                   2938: sub userlog_query {
                   2939:     my ($uname,$udom,%filters)=@_;
                   2940:     return &log_query($uname,$udom,'userlog',%filters);
1.12      www      2941: }
                   2942: 
                   2943: # ------------------------------------------------------------------ Plain Text
                   2944: 
                   2945: sub plaintext {
1.22      www      2946:     my $short=shift;
1.414     www      2947:     return &mt($prp{$short});
1.12      www      2948: }
                   2949: 
                   2950: # ----------------------------------------------------------------- Assign Role
                   2951: 
                   2952: sub assignrole {
1.357     www      2953:     my ($udom,$uname,$url,$role,$end,$start,$deleteflag)=@_;
1.21      www      2954:     my $mrole;
                   2955:     if ($role =~ /^cr\//) {
1.393     www      2956:         my $cwosec=$url;
                   2957:         $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;
                   2958: 	unless (&allowed('ccr',$cwosec)) {
1.104     www      2959:            &logthis('Refused custom assignrole: '.
                   2960:              $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
                   2961: 		    $ENV{'user.name'}.' at '.$ENV{'user.domain'});
                   2962:            return 'refused'; 
                   2963:         }
1.21      www      2964:         $mrole='cr';
                   2965:     } else {
1.82      www      2966:         my $cwosec=$url;
1.83      www      2967:         $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;
1.373     www      2968:         unless ((&allowed('c'.$role,$cwosec)) || &allowed('c'.$role,$udom)) { 
1.104     www      2969:            &logthis('Refused assignrole: '.
                   2970:              $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
                   2971: 		    $ENV{'user.name'}.' at '.$ENV{'user.domain'});
                   2972:            return 'refused'; 
                   2973:         }
1.21      www      2974:         $mrole=$role;
                   2975:     }
                   2976:     my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:".
                   2977:                 "$udom:$uname:$url".'_'."$mrole=$role";
1.81      www      2978:     if ($end) { $command.='_'.$end; }
1.21      www      2979:     if ($start) {
                   2980: 	if ($end) { 
1.81      www      2981:            $command.='_'.$start; 
1.21      www      2982:         } else {
1.81      www      2983:            $command.='_0_'.$start;
1.21      www      2984:         }
                   2985:     }
1.357     www      2986: # actually delete
                   2987:     if ($deleteflag) {
1.373     www      2988: 	if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) {
1.357     www      2989: # modify command to delete the role
                   2990:            $command="encrypt:rolesdel:$ENV{'user.domain'}:$ENV{'user.name'}:".
                   2991:                 "$udom:$uname:$url".'_'."$mrole";
1.373     www      2992: 	   &logthis("$ENV{'user.name'} at $ENV{'user.domain'} deletes $mrole in $url for $uname at $udom"); 
1.357     www      2993: # set start and finish to negative values for userrolelog
                   2994:            $start=-1;
                   2995:            $end=-1;
                   2996:         }
                   2997:     }
                   2998: # send command
1.349     www      2999:     my $answer=&reply($command,&homeserver($uname,$udom));
1.357     www      3000: # log new user role if status is ok
1.349     www      3001:     if ($answer eq 'ok') {
                   3002: 	&userrolelog($mrole,$uname,$udom,$url,$start,$end);
                   3003:     }
                   3004:     return $answer;
1.169     harris41 3005: }
                   3006: 
                   3007: # -------------------------------------------------- Modify user authentication
1.197     www      3008: # Overrides without validation
                   3009: 
1.169     harris41 3010: sub modifyuserauth {
                   3011:     my ($udom,$uname,$umode,$upass)=@_;
                   3012:     my $uhome=&homeserver($uname,$udom);
1.197     www      3013:     unless (&allowed('mau',$udom)) { return 'refused'; }
                   3014:     &logthis('Call to modify user authentication '.$udom.', '.$uname.', '.
1.272     matthew  3015:              $umode.' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}.
                   3016:              ' in domain '.$ENV{'request.role.domain'});  
1.169     harris41 3017:     my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'.
                   3018: 		     &escape($upass),$uhome);
1.197     www      3019:     &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.home'},
                   3020:         'Authentication changed for '.$udom.', '.$uname.', '.$umode.
                   3021:          '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply);
                   3022:     &log($udom,,$uname,$uhome,
                   3023:         'Authentication changed by '.$ENV{'user.domain'}.', '.
                   3024:                                      $ENV{'user.name'}.', '.$umode.
                   3025:          '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply);
1.169     harris41 3026:     unless ($reply eq 'ok') {
1.197     www      3027:         &logthis('Authentication mode error: '.$reply);
1.169     harris41 3028: 	return 'error: '.$reply;
                   3029:     }   
1.170     harris41 3030:     return 'ok';
1.80      www      3031: }
                   3032: 
1.81      www      3033: # --------------------------------------------------------------- Modify a user
1.80      www      3034: 
1.81      www      3035: sub modifyuser {
1.206     matthew  3036:     my ($udom,    $uname, $uid,
                   3037:         $umode,   $upass, $first,
                   3038:         $middle,  $last,  $gene,
1.387     www      3039:         $forceid, $desiredhome, $email)=@_;
1.198     www      3040:     $udom=~s/\W//g;
                   3041:     $uname=~s/\W//g;
1.81      www      3042:     &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
1.80      www      3043:              $umode.', '.$first.', '.$middle.', '.
1.206     matthew  3044: 	     $last.', '.$gene.'(forceid: '.$forceid.')'.
                   3045:              (defined($desiredhome) ? ' desiredhome = '.$desiredhome :
                   3046:                                      ' desiredhome not specified'). 
1.272     matthew  3047:              ' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}.
                   3048:              ' in domain '.$ENV{'request.role.domain'});
1.230     stredwic 3049:     my $uhome=&homeserver($uname,$udom,'true');
1.80      www      3050: # ----------------------------------------------------------------- Create User
1.406     albertel 3051:     if (($uhome eq 'no_host') && 
                   3052: 	(($umode && $upass) || ($umode eq 'localauth'))) {
1.80      www      3053:         my $unhome='';
1.209     matthew  3054:         if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) { 
                   3055:             $unhome = $desiredhome;
                   3056: 	} elsif($ENV{'course.'.$ENV{'request.course.id'}.'.domain'} eq $udom) {
1.80      www      3057: 	    $unhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'};
1.209     matthew  3058:         } else { # load balancing routine for determining $unhome
1.80      www      3059:             my $tryserver;
1.81      www      3060:             my $loadm=10000000;
1.80      www      3061:             foreach $tryserver (keys %libserv) {
                   3062: 	       if ($hostdom{$tryserver} eq $udom) {
                   3063:                   my $answer=reply('load',$tryserver);
                   3064:                   if (($answer=~/\d+/) && ($answer<$loadm)) {
                   3065: 		      $loadm=$answer;
                   3066:                       $unhome=$tryserver;
                   3067:                   }
                   3068: 	       }
                   3069: 	    }
                   3070:         }
                   3071:         if (($unhome eq '') || ($unhome eq 'no_host')) {
1.206     matthew  3072: 	    return 'error: unable to find a home server for '.$uname.
                   3073:                    ' in domain '.$udom;
1.80      www      3074:         }
                   3075:         my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':'.$umode.':'.
                   3076:                          &escape($upass),$unhome);
                   3077: 	unless ($reply eq 'ok') {
                   3078:             return 'error: '.$reply;
                   3079:         }   
1.230     stredwic 3080:         $uhome=&homeserver($uname,$udom,'true');
1.80      www      3081:         if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) {
1.386     matthew  3082: 	    return 'error: unable verify users home machine.';
1.80      www      3083:         }
1.209     matthew  3084:     }   # End of creation of new user
1.80      www      3085: # ---------------------------------------------------------------------- Add ID
                   3086:     if ($uid) {
                   3087:        $uid=~tr/A-Z/a-z/;
                   3088:        my %uidhash=&idrget($udom,$uname);
1.196     www      3089:        if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/) 
                   3090:          && (!$forceid)) {
1.80      www      3091: 	  unless ($uid eq $uidhash{$uname}) {
1.386     matthew  3092: 	      return 'error: user id "'.$uid.'" does not match '.
                   3093:                   'current user id "'.$uidhash{$uname}.'".';
1.80      www      3094:           }
                   3095:        } else {
                   3096: 	  &idput($udom,($uname => $uid));
                   3097:        }
                   3098:     }
                   3099: # -------------------------------------------------------------- Add names, etc
1.313     matthew  3100:     my @tmp=&get('environment',
1.134     albertel 3101: 		   ['firstname','middlename','lastname','generation'],
                   3102: 		   $udom,$uname);
1.313     matthew  3103:     my %names;
                   3104:     if ($tmp[0] =~ m/^error:.*/) { 
                   3105:         %names=(); 
                   3106:     } else {
                   3107:         %names = @tmp;
                   3108:     }
1.388     www      3109: #
                   3110: # Make sure to not trash student environment if instructor does not bother
                   3111: # to supply name and email information
                   3112: #
                   3113:     if ($first)  { $names{'firstname'}  = $first; }
1.385     matthew  3114:     if (defined($middle)) { $names{'middlename'} = $middle; }
1.388     www      3115:     if ($last)   { $names{'lastname'}   = $last; }
1.385     matthew  3116:     if (defined($gene))   { $names{'generation'} = $gene; }
1.388     www      3117:     if ($email)  { $names{'notification'} = $email;
                   3118:                    $names{'critnotification'} = $email; }
1.387     www      3119: 
1.134     albertel 3120:     my $reply = &put('environment', \%names, $udom,$uname);
                   3121:     if ($reply ne 'ok') { return 'error: '.$reply; }
1.81      www      3122:     &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
1.80      www      3123:              $umode.', '.$first.', '.$middle.', '.
                   3124: 	     $last.', '.$gene.' by '.
                   3125:              $ENV{'user.name'}.' at '.$ENV{'user.domain'});
1.134     albertel 3126:     return 'ok';
1.80      www      3127: }
                   3128: 
1.81      www      3129: # -------------------------------------------------------------- Modify student
1.80      www      3130: 
1.81      www      3131: sub modifystudent {
                   3132:     my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
1.455     albertel 3133:         $end,$start,$forceid,$desiredhome,$email,$type,$cid)=@_;
                   3134:     if (!$cid) {
                   3135: 	unless ($cid=$ENV{'request.course.id'}) {
                   3136: 	    return 'not_in_class';
                   3137: 	}
1.80      www      3138:     }
                   3139: # --------------------------------------------------------------- Make the user
1.81      www      3140:     my $reply=&modifyuser
1.209     matthew  3141: 	($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid,
1.387     www      3142:          $desiredhome,$email);
1.80      www      3143:     unless ($reply eq 'ok') { return $reply; }
1.297     matthew  3144:     # This will cause &modify_student_enrollment to get the uid from the
                   3145:     # students environment
                   3146:     $uid = undef if (!$forceid);
1.455     albertel 3147:     $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,
                   3148: 					$gene,$usec,$end,$start,$type,$cid);
1.297     matthew  3149:     return $reply;
                   3150: }
                   3151: 
                   3152: sub modify_student_enrollment {
1.455     albertel 3153:     my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,
                   3154: 	$cid) = @_;
                   3155:     my ($cdom,$cnum,$chome);
                   3156:     if (!$cid) {
                   3157: 	unless ($cid=$ENV{'request.course.id'}) {
                   3158: 	    return 'not_in_class';
                   3159: 	}
                   3160: 	$cdom=$ENV{'course.'.$cid.'.domain'};
                   3161: 	$cnum=$ENV{'course.'.$cid.'.num'};
                   3162:     } else {
                   3163: 	($cdom,$cnum)=split(/_/,$cid);
                   3164:     }
                   3165:     $chome=$ENV{'course.'.$cid.'.home'};
                   3166:     if (!$chome) {
1.457     raeburn  3167: 	$chome=&homeserver($cnum,$cdom);
1.297     matthew  3168:     }
1.455     albertel 3169:     if (!$chome) { return 'unknown_course'; }
1.297     matthew  3170:     # Make sure the user exists
1.81      www      3171:     my $uhome=&homeserver($uname,$udom);
                   3172:     if (($uhome eq '') || ($uhome eq 'no_host')) { 
                   3173: 	return 'error: no such user';
                   3174:     }
1.297     matthew  3175:     # Get student data if we were not given enough information
                   3176:     if (!defined($first)  || $first  eq '' || 
                   3177:         !defined($last)   || $last   eq '' || 
                   3178:         !defined($uid)    || $uid    eq '' || 
                   3179:         !defined($middle) || $middle eq '' || 
                   3180:         !defined($gene)   || $gene   eq '') {
1.294     matthew  3181:         # They did not supply us with enough data to enroll the student, so
                   3182:         # we need to pick up more information.
1.297     matthew  3183:         my %tmp = &get('environment',
1.294     matthew  3184:                        ['firstname','middlename','lastname', 'generation','id']
1.297     matthew  3185:                        ,$udom,$uname);
                   3186: 
1.455     albertel 3187:         #foreach (keys(%tmp)) {
                   3188:         #    &logthis("key $_ = ".$tmp{$_});
                   3189:         #}
1.294     matthew  3190:         $first  = $tmp{'firstname'}  if (!defined($first)  || $first  eq '');
                   3191:         $middle = $tmp{'middlename'} if (!defined($middle) || $middle eq '');
                   3192:         $last   = $tmp{'lastname'}   if (!defined($last)   || $last eq '');
1.297     matthew  3193:         $gene   = $tmp{'generation'} if (!defined($gene)   || $gene eq '');
1.294     matthew  3194:         $uid    = $tmp{'id'}         if (!defined($uid)    || $uid  eq '');
                   3195:     }
                   3196:     my $fullname = &Apache::loncoursedata::ProcessFullName($last,$gene,
                   3197:                                                            $first,$middle);
1.455     albertel 3198:     my $value=&escape($uname.':'.$udom).'='.
1.457     raeburn  3199: 	&escape(join(':',$end,$start,$uid,$usec,$fullname,$type));
1.455     albertel 3200:     my $reply=critical('put:'.$cdom.':'.$cnum.':classlist:'.$value,$chome);
1.81      www      3201:     unless (($reply eq 'ok') || ($reply eq 'delayed')) {
                   3202: 	return 'error: '.$reply;
                   3203:     }
1.297     matthew  3204:     # Add student role to user
1.83      www      3205:     my $uurl='/'.$cid;
1.81      www      3206:     $uurl=~s/\_/\//g;
                   3207:     if ($usec) {
                   3208: 	$uurl.='/'.$usec;
                   3209:     }
                   3210:     return &assignrole($udom,$uname,$uurl,'st',$end,$start);
1.21      www      3211: }
                   3212: 
1.84      www      3213: # ------------------------------------------------- Write to course preferences
                   3214: 
                   3215: sub writecoursepref {
                   3216:     my ($courseid,%prefs)=@_;
                   3217:     $courseid=~s/^\///;
                   3218:     $courseid=~s/\_/\//g;
                   3219:     my ($cdomain,$cnum)=split(/\//,$courseid);
                   3220:     my $chome=homeserver($cnum,$cdomain);
                   3221:     if (($chome eq '') || ($chome eq 'no_host')) { 
                   3222: 	return 'error: no such course';
                   3223:     }
                   3224:     my $cstring='';
1.191     harris41 3225:     foreach (keys %prefs) {
1.84      www      3226: 	$cstring.=escape($_).'='.escape($prefs{$_}).'&';
1.191     harris41 3227:     }
1.84      www      3228:     $cstring=~s/\&$//;
                   3229:     return reply('put:'.$cdomain.':'.$cnum.':environment:'.$cstring,$chome);
                   3230: }
                   3231: 
                   3232: # ---------------------------------------------------------- Make/modify course
                   3233: 
                   3234: sub createcourse {
1.271     www      3235:     my ($udom,$description,$url,$course_server,$nonstandard)=@_;
1.84      www      3236:     $url=&declutter($url);
                   3237:     my $cid='';
1.264     matthew  3238:     unless (&allowed('ccc',$udom)) {
1.84      www      3239:         return 'refused';
                   3240:     }
                   3241: # ------------------------------------------------------------------- Create ID
                   3242:    my $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).
                   3243:        unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
                   3244: # ----------------------------------------------- Make sure that does not exist
1.230     stredwic 3245:    my $uhome=&homeserver($uname,$udom,'true');
1.84      www      3246:    unless (($uhome eq '') || ($uhome eq 'no_host')) {
                   3247:        $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).
                   3248:         unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
1.230     stredwic 3249:        $uhome=&homeserver($uname,$udom,'true');       
1.84      www      3250:        unless (($uhome eq '') || ($uhome eq 'no_host')) {
                   3251:            return 'error: unable to generate unique course-ID';
                   3252:        } 
                   3253:    }
1.264     matthew  3254: # ------------------------------------------------ Check supplied server name
                   3255:     $course_server = $ENV{'user.homeserver'} if (! defined($course_server));
                   3256:     if (! exists($libserv{$course_server})) {
                   3257:         return 'error:bad server name '.$course_server;
                   3258:     }
1.84      www      3259: # ------------------------------------------------------------- Make the course
                   3260:     my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',
1.264     matthew  3261:                       $course_server);
1.84      www      3262:     unless ($reply eq 'ok') { return 'error: '.$reply; }
1.230     stredwic 3263:     $uhome=&homeserver($uname,$udom,'true');
1.84      www      3264:     if (($uhome eq '') || ($uhome eq 'no_host')) { 
                   3265: 	return 'error: no such course';
                   3266:     }
1.271     www      3267: # ----------------------------------------------------------------- Course made
1.358     www      3268: # log existance
                   3269:     &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description),
                   3270:                  $uhome);
                   3271:     &flushcourselogs();
                   3272: # set toplevel url
1.271     www      3273:     my $topurl=$url;
                   3274:     unless ($nonstandard) {
                   3275: # ------------------------------------------ For standard courses, make top url
                   3276:         my $mapurl=&clutter($url);
1.278     www      3277:         if ($mapurl eq '/res/') { $mapurl=''; }
1.271     www      3278:         $ENV{'form.initmap'}=(<<ENDINITMAP);
                   3279: <map>
                   3280: <resource id="1" type="start"></resource>
                   3281: <resource id="2" src="$mapurl"></resource>
                   3282: <resource id="3" type="finish"></resource>
                   3283: <link index="1" from="1" to="2"></link>
                   3284: <link index="2" from="2" to="3"></link>
                   3285: </map>
                   3286: ENDINITMAP
                   3287:         $topurl=&declutter(
                   3288:         &finishuserfileupload($uname,$udom,$uhome,'initmap','default.sequence')
                   3289:                           );
                   3290:     }
                   3291: # ----------------------------------------------------------- Write preferences
1.84      www      3292:     &writecoursepref($udom.'_'.$uname,
                   3293:                      ('description' => $description,
1.271     www      3294:                       'url'         => $topurl));
1.84      www      3295:     return '/'.$udom.'/'.$uname;
                   3296: }
                   3297: 
1.21      www      3298: # ---------------------------------------------------------- Assign Custom Role
                   3299: 
                   3300: sub assigncustomrole {
1.357     www      3301:     my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag)=@_;
1.21      www      3302:     return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename,
1.357     www      3303:                        $end,$start,$deleteflag);
1.21      www      3304: }
                   3305: 
                   3306: # ----------------------------------------------------------------- Revoke Role
                   3307: 
                   3308: sub revokerole {
1.357     www      3309:     my ($udom,$uname,$url,$role,$deleteflag)=@_;
1.21      www      3310:     my $now=time;
1.357     www      3311:     return &assignrole($udom,$uname,$url,$role,$now,$deleteflag);
1.21      www      3312: }
                   3313: 
                   3314: # ---------------------------------------------------------- Revoke Custom Role
                   3315: 
                   3316: sub revokecustomrole {
1.357     www      3317:     my ($udom,$uname,$url,$rdom,$rnam,$rolename,$deleteflag)=@_;
1.21      www      3318:     my $now=time;
1.357     www      3319:     return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now,
                   3320:            $deleteflag);
1.17      www      3321: }
                   3322: 
                   3323: # ------------------------------------------------------------ Directory lister
                   3324: 
                   3325: sub dirlist {
1.253     stredwic 3326:     my ($uri,$userdomain,$username,$alternateDirectoryRoot)=@_;
                   3327: 
1.18      www      3328:     $uri=~s/^\///;
                   3329:     $uri=~s/\/$//;
1.253     stredwic 3330:     my ($udom, $uname);
                   3331:     (undef,$udom,$uname)=split(/\//,$uri);
                   3332:     if(defined($userdomain)) {
                   3333:         $udom = $userdomain;
                   3334:     }
                   3335:     if(defined($username)) {
                   3336:         $uname = $username;
                   3337:     }
                   3338: 
                   3339:     my $dirRoot = $perlvar{'lonDocRoot'};
                   3340:     if(defined($alternateDirectoryRoot)) {
                   3341:         $dirRoot = $alternateDirectoryRoot;
                   3342:         $dirRoot =~ s/\/$//;
                   3343:     }
                   3344: 
                   3345:     if($udom) {
                   3346:         if($uname) {
                   3347:             my $listing=reply('ls:'.$dirRoot.'/'.$uri,
                   3348:                               homeserver($uname,$udom));
                   3349:             return split(/:/,$listing);
                   3350:         } elsif(!defined($alternateDirectoryRoot)) {
                   3351:             my $tryserver;
                   3352:             my %allusers=();
                   3353:             foreach $tryserver (keys %libserv) {
                   3354:                 if($hostdom{$tryserver} eq $udom) {
                   3355:                     my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.
                   3356:                                       $udom, $tryserver);
                   3357:                     if (($listing ne 'no_such_dir') && ($listing ne 'empty')
                   3358:                         && ($listing ne 'con_lost')) {
                   3359:                         foreach (split(/:/,$listing)) {
                   3360:                             my ($entry,@stat)=split(/&/,$_);
                   3361:                             $allusers{$entry}=1;
                   3362:                         }
                   3363:                     }
1.191     harris41 3364:                 }
1.253     stredwic 3365:             }
                   3366:             my $alluserstr='';
                   3367:             foreach (sort keys %allusers) {
                   3368:                 $alluserstr.=$_.'&user:';
                   3369:             }
                   3370:             $alluserstr=~s/:$//;
                   3371:             return split(/:/,$alluserstr);
                   3372:         } else {
                   3373:             my @emptyResults = ();
                   3374:             push(@emptyResults, 'missing user name');
                   3375:             return split(':',@emptyResults);
                   3376:         }
                   3377:     } elsif(!defined($alternateDirectoryRoot)) {
                   3378:         my $tryserver;
                   3379:         my %alldom=();
                   3380:         foreach $tryserver (keys %libserv) {
                   3381:             $alldom{$hostdom{$tryserver}}=1;
                   3382:         }
                   3383:         my $alldomstr='';
                   3384:         foreach (sort keys %alldom) {
1.397     albertel 3385:             $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'/&domain:';
1.253     stredwic 3386:         }
                   3387:         $alldomstr=~s/:$//;
                   3388:         return split(/:/,$alldomstr);       
                   3389:     } else {
                   3390:         my @emptyResults = ();
                   3391:         push(@emptyResults, 'missing domain');
                   3392:         return split(':',@emptyResults);
1.275     stredwic 3393:     }
                   3394: }
                   3395: 
                   3396: # --------------------------------------------- GetFileTimestamp
                   3397: # This function utilizes dirlist and returns the date stamp for
                   3398: # when it was last modified.  It will also return an error of -1
                   3399: # if an error occurs
                   3400: 
1.410     matthew  3401: ##
                   3402: ## FIXME: This subroutine assumes its caller knows something about the
                   3403: ## directory structure of the home server for the student ($root).
                   3404: ## Not a good assumption to make.  Since this is for looking up files
                   3405: ## in user directories, the full path should be constructed by lond, not
                   3406: ## whatever machine we request data from.
                   3407: ##
1.275     stredwic 3408: sub GetFileTimestamp {
                   3409:     my ($studentDomain,$studentName,$filename,$root)=@_;
                   3410:     $studentDomain=~s/\W//g;
                   3411:     $studentName=~s/\W//g;
                   3412:     my $subdir=$studentName.'__';
                   3413:     $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
                   3414:     my $proname="$studentDomain/$subdir/$studentName";
                   3415:     $proname .= '/'.$filename;
1.375     matthew  3416:     my ($fileStat) = &Apache::lonnet::dirlist($proname, $studentDomain, 
                   3417:                                               $studentName, $root);
1.275     stredwic 3418:     my @stats = split('&', $fileStat);
                   3419:     if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {
1.375     matthew  3420:         # @stats contains first the filename, then the stat output
                   3421:         return $stats[10]; # so this is 10 instead of 9.
1.275     stredwic 3422:     } else {
                   3423:         return -1;
1.253     stredwic 3424:     }
1.26      www      3425: }
                   3426: 
                   3427: # -------------------------------------------------------- Value of a Condition
                   3428: 
1.40      www      3429: sub directcondval {
                   3430:     my $number=shift;
                   3431:     if ($ENV{'user.state.'.$ENV{'request.course.id'}}) {
                   3432:        return substr($ENV{'user.state.'.$ENV{'request.course.id'}},$number,1);
                   3433:     } else {
                   3434:        return 2;
                   3435:     }
                   3436: }
                   3437: 
1.26      www      3438: sub condval {
                   3439:     my $condidx=shift;
                   3440:     my $result=0;
1.54      www      3441:     my $allpathcond='';
1.191     harris41 3442:     foreach (split(/\|/,$condidx)) {
1.54      www      3443:        if (defined($ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_})) {
                   3444: 	   $allpathcond.=
                   3445:                '('.$ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_}.')|';
                   3446:        }
1.191     harris41 3447:     }
1.54      www      3448:     $allpathcond=~s/\|$//;
1.33      www      3449:     if ($ENV{'request.course.id'}) {
1.54      www      3450:        if ($allpathcond) {
1.26      www      3451:           my $operand='|';
                   3452: 	  my @stack;
1.191     harris41 3453:            foreach ($allpathcond=~/(\d+|\(|\)|\&|\|)/g) {
1.26      www      3454:               if ($_ eq '(') {
                   3455:                  push @stack,($operand,$result)
                   3456:               } elsif ($_ eq ')') {
                   3457:                   my $before=pop @stack;
                   3458: 		  if (pop @stack eq '&') {
                   3459: 		      $result=$result>$before?$before:$result;
                   3460:                   } else {
                   3461:                       $result=$result>$before?$result:$before;
                   3462:                   }
                   3463:               } elsif (($_ eq '&') || ($_ eq '|')) {
                   3464:                   $operand=$_;
                   3465:               } else {
1.40      www      3466:                   my $new=directcondval($_);
1.26      www      3467:                   if ($operand eq '&') {
                   3468:                      $result=$result>$new?$new:$result;
                   3469:                   } else {
                   3470:                      $result=$result>$new?$result:$new;
1.191     harris41 3471:                   }
1.26      www      3472:               }
1.191     harris41 3473:           }
1.26      www      3474:        }
                   3475:     }
                   3476:     return $result;
1.421     albertel 3477: }
                   3478: 
                   3479: # ---------------------------------------------------- Devalidate courseresdata
                   3480: 
                   3481: sub devalidatecourseresdata {
                   3482:     my ($coursenum,$coursedomain)=@_;
                   3483:     my $hashid=$coursenum.':'.$coursedomain;
1.428     albertel 3484:     &devalidate_cache(\%courseresdatacache,$hashid,'courseres');
1.28      www      3485: }
                   3486: 
1.200     www      3487: # --------------------------------------------------- Course Resourcedata Query
                   3488: 
                   3489: sub courseresdata {
                   3490:     my ($coursenum,$coursedomain,@which)=@_;
                   3491:     my $coursehom=&homeserver($coursenum,$coursedomain);
                   3492:     my $hashid=$coursenum.':'.$coursedomain;
1.425     albertel 3493:     my ($result,$cached)=&is_cached(\%courseresdatacache,$hashid,'courseres');
1.417     albertel 3494:     unless (defined($cached)) {
1.251     albertel 3495: 	my %dumpreply=&dump('resourcedata',$coursedomain,$coursenum);
1.417     albertel 3496: 	$result=\%dumpreply;
1.251     albertel 3497: 	my ($tmp) = keys(%dumpreply);
                   3498: 	if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
1.425     albertel 3499: 	    &do_cache(\%courseresdatacache,$hashid,$result,'courseres');
1.306     albertel 3500: 	} elsif ($tmp =~ /^(con_lost|no_such_host)/) {
                   3501: 	    return $tmp;
1.416     albertel 3502: 	} elsif ($tmp =~ /^(error)/) {
1.417     albertel 3503: 	    $result=undef;
1.425     albertel 3504: 	    &do_cache(\%courseresdatacache,$hashid,$result,'courseres');
1.250     albertel 3505: 	}
                   3506:     }
1.251     albertel 3507:     foreach my $item (@which) {
1.417     albertel 3508: 	if (defined($result->{$item})) {
                   3509: 	    return $result->{$item};
1.251     albertel 3510: 	}
1.250     albertel 3511:     }
1.291     albertel 3512:     return undef;
1.200     www      3513: }
                   3514: 
1.379     matthew  3515: #
                   3516: # EXT resource caching routines
                   3517: #
                   3518: 
                   3519: sub clear_EXT_cache_status {
1.383     albertel 3520:     &delenv('cache.EXT.');
1.379     matthew  3521: }
                   3522: 
                   3523: sub EXT_cache_status {
                   3524:     my ($target_domain,$target_user) = @_;
1.383     albertel 3525:     my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain;
1.389     www      3526:     if (exists($ENV{$cachename}) && ($ENV{$cachename}+600) > time) {
1.379     matthew  3527:         # We know already the user has no data
                   3528:         return 1;
                   3529:     } else {
                   3530:         return 0;
                   3531:     }
                   3532: }
                   3533: 
                   3534: sub EXT_cache_set {
                   3535:     my ($target_domain,$target_user) = @_;
1.383     albertel 3536:     my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain;
1.379     matthew  3537:     &appenv($cachename => time);
                   3538: }
                   3539: 
1.28      www      3540: # --------------------------------------------------------- Value of a Variable
1.58      www      3541: sub EXT {
1.395     albertel 3542:     my ($varname,$symbparm,$udom,$uname,$usection,$recurse)=@_;
1.218     albertel 3543: 
1.68      www      3544:     unless ($varname) { return ''; }
1.218     albertel 3545:     #get real user name/domain, courseid and symb
                   3546:     my $courseid;
1.359     albertel 3547:     my $publicuser;
1.427     www      3548:     if ($symbparm) {
                   3549: 	$symbparm=&get_symb_from_alias($symbparm);
                   3550:     }
1.218     albertel 3551:     if (!($uname && $udom)) {
1.360     albertel 3552:       (my $cursymb,$courseid,$udom,$uname,$publicuser)=
1.378     matthew  3553: 	  &Apache::lonxml::whichuser($symbparm);
1.218     albertel 3554:       if (!$symbparm) {	$symbparm=$cursymb; }
                   3555:     } else {
                   3556: 	$courseid=$ENV{'request.course.id'};
                   3557:     }
1.48      www      3558:     my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);
                   3559:     my $rest;
1.320     albertel 3560:     if (defined($therest[0])) {
1.48      www      3561:        $rest=join('.',@therest);
                   3562:     } else {
                   3563:        $rest='';
                   3564:     }
1.320     albertel 3565: 
1.57      www      3566:     my $qualifierrest=$qualifier;
                   3567:     if ($rest) { $qualifierrest.='.'.$rest; }
                   3568:     my $spacequalifierrest=$space;
                   3569:     if ($qualifierrest) { $spacequalifierrest.='.'.$qualifierrest; }
1.28      www      3570:     if ($realm eq 'user') {
1.48      www      3571: # --------------------------------------------------------------- user.resource
                   3572: 	if ($space eq 'resource') {
1.335     albertel 3573: 	    if (defined($Apache::lonhomework::parsing_a_problem)) {
                   3574: 		return $Apache::lonhomework::history{$qualifierrest};
                   3575: 	    } else {
1.359     albertel 3576: 		my %restored;
                   3577: 		if ($publicuser || $ENV{'request.state'} eq 'construct') {
                   3578: 		    %restored=&tmprestore($symbparm,$courseid,$udom,$uname);
                   3579: 		} else {
                   3580: 		    %restored=&restore($symbparm,$courseid,$udom,$uname);
                   3581: 		}
1.335     albertel 3582: 		return $restored{$qualifierrest};
                   3583: 	    }
1.48      www      3584: # ----------------------------------------------------------------- user.access
                   3585:         } elsif ($space eq 'access') {
1.218     albertel 3586: 	    # FIXME - not supporting calls for a specific user
1.48      www      3587:             return &allowed($qualifier,$rest);
                   3588: # ------------------------------------------ user.preferences, user.environment
                   3589:         } elsif (($space eq 'preferences') || ($space eq 'environment')) {
1.218     albertel 3590: 	    if (($uname eq $ENV{'user.name'}) &&
                   3591: 		($udom eq $ENV{'user.domain'})) {
                   3592: 		return $ENV{join('.',('environment',$qualifierrest))};
                   3593: 	    } else {
1.359     albertel 3594: 		my %returnhash;
                   3595: 		if (!$publicuser) {
                   3596: 		    %returnhash=&userenvironment($udom,$uname,
                   3597: 						 $qualifierrest);
                   3598: 		}
1.218     albertel 3599: 		return $returnhash{$qualifierrest};
                   3600: 	    }
1.48      www      3601: # ----------------------------------------------------------------- user.course
                   3602:         } elsif ($space eq 'course') {
1.218     albertel 3603: 	    # FIXME - not supporting calls for a specific user
1.48      www      3604:             return $ENV{join('.',('request.course',$qualifier))};
                   3605: # ------------------------------------------------------------------- user.role
                   3606:         } elsif ($space eq 'role') {
1.218     albertel 3607: 	    # FIXME - not supporting calls for a specific user
1.48      www      3608:             my ($role,$where)=split(/\./,$ENV{'request.role'});
                   3609:             if ($qualifier eq 'value') {
                   3610: 		return $role;
                   3611:             } elsif ($qualifier eq 'extent') {
                   3612:                 return $where;
                   3613:             }
                   3614: # ----------------------------------------------------------------- user.domain
                   3615:         } elsif ($space eq 'domain') {
1.218     albertel 3616:             return $udom;
1.48      www      3617: # ------------------------------------------------------------------- user.name
                   3618:         } elsif ($space eq 'name') {
1.218     albertel 3619:             return $uname;
1.48      www      3620: # ---------------------------------------------------- Any other user namespace
1.29      www      3621:         } else {
1.359     albertel 3622: 	    my %reply;
                   3623: 	    if (!$publicuser) {
                   3624: 		%reply=&get($space,[$qualifierrest],$udom,$uname);
                   3625: 	    }
                   3626: 	    return $reply{$qualifierrest};
1.48      www      3627:         }
1.236     www      3628:     } elsif ($realm eq 'query') {
                   3629: # ---------------------------------------------- pull stuff out of query string
1.384     albertel 3630:         &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'},
                   3631: 						[$spacequalifierrest]);
1.376     albertel 3632: 	return $ENV{'form.'.$spacequalifierrest}; 
1.236     www      3633:    } elsif ($realm eq 'request') {
1.48      www      3634: # ------------------------------------------------------------- request.browser
                   3635:         if ($space eq 'browser') {
1.430     www      3636: 	    if ($qualifier eq 'textremote') {
                   3637: 		if (&mt('textual_remote_display') eq 'on') {
                   3638: 		    return 1;
                   3639: 		} else {
                   3640: 		    return 0;
                   3641: 		}
                   3642: 	    } else {
                   3643: 		return $ENV{'browser.'.$qualifier};
                   3644: 	    }
1.57      www      3645: # ------------------------------------------------------------ request.filename
                   3646:         } else {
                   3647:             return $ENV{'request.'.$spacequalifierrest};
1.29      www      3648:         }
1.28      www      3649:     } elsif ($realm eq 'course') {
1.48      www      3650: # ---------------------------------------------------------- course.description
1.218     albertel 3651:         return $ENV{'course.'.$courseid.'.'.$spacequalifierrest};
1.57      www      3652:     } elsif ($realm eq 'resource') {
1.165     www      3653: 
1.395     albertel 3654: 	my $section;
1.359     albertel 3655: 	if (defined($courseid) && $courseid eq $ENV{'request.course.id'}) {
1.165     www      3656: 
1.218     albertel 3657: 	    #print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;
1.165     www      3658: 
1.60      www      3659: # ----------------------------------------------------- Cascading lookup scheme
1.218     albertel 3660: 	    if (!$symbparm) { $symbparm=&symbread(); }
                   3661: 	    my $symbp=$symbparm;
1.409     www      3662: 	    my $mapp=(&decode_symb($symbp))[0];
1.218     albertel 3663: 
                   3664: 	    my $symbparm=$symbp.'.'.$spacequalifierrest;
                   3665: 	    my $mapparm=$mapp.'___(all).'.$spacequalifierrest;
                   3666: 
                   3667: 	    if (($ENV{'user.name'} eq $uname) &&
                   3668: 		($ENV{'user.domain'} eq $udom)) {
1.255     albertel 3669: 		$section=$ENV{'request.course.sec'};
1.218     albertel 3670: 	    } else {
1.377     matthew  3671:                 if (! defined($usection)) {
                   3672:                     $section=&usection($udom,$uname,$courseid);
                   3673:                 } else {
                   3674:                     $section = $usection;
                   3675:                 }
1.218     albertel 3676: 	    }
                   3677: 
                   3678: 	    my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
                   3679: 	    my $seclevelr=$courseid.'.['.$section.'].'.$symbparm;
                   3680: 	    my $seclevelm=$courseid.'.['.$section.'].'.$mapparm;
                   3681: 
                   3682: 	    my $courselevel=$courseid.'.'.$spacequalifierrest;
                   3683: 	    my $courselevelr=$courseid.'.'.$symbparm;
                   3684: 	    my $courselevelm=$courseid.'.'.$mapparm;
1.69      www      3685: 
1.60      www      3686: # ----------------------------------------------------------- first, check user
1.379     matthew  3687: 	    #most student don\'t have any data set, check if there is some data
                   3688: 	    if (! &EXT_cache_status($udom,$uname)) {
1.420     albertel 3689: 		my $hashid="$udom:$uname";
1.425     albertel 3690: 		my ($result,$cached)=&is_cached(\%userresdatacache,$hashid,
                   3691: 						'userres');
1.454     albertel 3692: 		if (!defined($cached)) {
                   3693: 		    my %resourcedata=&dump('resourcedata',$udom,$uname);
1.420     albertel 3694: 		    $result=\%resourcedata;
1.425     albertel 3695: 		    &do_cache(\%userresdatacache,$hashid,$result,'userres');
1.420     albertel 3696: 		}
                   3697: 		my ($tmp)=keys(%$result);
1.308     albertel 3698: 		if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) {
1.420     albertel 3699: 		    if ($$result{$courselevelr}) {
                   3700: 			return $$result{$courselevelr}; }
                   3701: 		    if ($$result{$courselevelm}) {
                   3702: 			return $$result{$courselevelm}; }
                   3703: 		    if ($$result{$courselevel}) {
                   3704: 			return $$result{$courselevel}; }
1.308     albertel 3705: 		} else {
1.459   ! albertel 3706: 		    #error 2 occurs when the .db doesn't exist
        !          3707: 		    if ($tmp!~/error: 2 /) {
1.308     albertel 3708: 			&logthis("<font color=blue>WARNING:".
                   3709: 				 " Trying to get resource data for ".
                   3710: 				 $uname." at ".$udom.": ".
                   3711: 				 $tmp."</font>");
1.459   ! albertel 3712: 		    } elsif ($tmp=~/error: 2 /) {
1.379     matthew  3713:                         &EXT_cache_set($udom,$uname);
1.308     albertel 3714: 		    } elsif ($tmp =~ /^(con_lost|no_such_host)/) {
                   3715: 			return $tmp;
                   3716: 		    }
1.218     albertel 3717: 		}
                   3718: 	    }
1.95      www      3719: 
1.60      www      3720: # -------------------------------------------------------- second, check course
1.96      www      3721: 
1.218     albertel 3722: 	    my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'},
                   3723: 					  $ENV{'course.'.$courseid.'.domain'},
                   3724: 					  ($seclevelr,$seclevelm,$seclevel,
                   3725: 					   $courselevelr,$courselevelm,
                   3726: 					   $courselevel));
1.287     albertel 3727: 	    if (defined($coursereply)) { return $coursereply; }
1.200     www      3728: 
1.60      www      3729: # ------------------------------------------------------ third, check map parms
1.218     albertel 3730: 	    my %parmhash=();
                   3731: 	    my $thisparm='';
                   3732: 	    if (tie(%parmhash,'GDBM_File',
                   3733: 		    $ENV{'request.course.fn'}.'_parms.db',
1.256     albertel 3734: 		    &GDBM_READER(),0640)) {
1.218     albertel 3735: 		$thisparm=$parmhash{$symbparm};
                   3736: 		untie(%parmhash);
                   3737: 	    }
                   3738: 	    if ($thisparm) { return $thisparm; }
                   3739: 	}
1.60      www      3740: # --------------------------------------------- last, look in resource metadata
1.71      www      3741: 
1.218     albertel 3742: 	$spacequalifierrest=~s/\./\_/;
1.282     albertel 3743: 	my $filename;
                   3744: 	if (!$symbparm) { $symbparm=&symbread(); }
                   3745: 	if ($symbparm) {
1.409     www      3746: 	    $filename=(&decode_symb($symbparm))[2];
1.282     albertel 3747: 	} else {
                   3748: 	    $filename=$ENV{'request.filename'};
                   3749: 	}
                   3750: 	my $metadata=&metadata($filename,$spacequalifierrest);
1.288     albertel 3751: 	if (defined($metadata)) { return $metadata; }
1.282     albertel 3752: 	$metadata=&metadata($filename,'parameter_'.$spacequalifierrest);
1.288     albertel 3753: 	if (defined($metadata)) { return $metadata; }
1.142     www      3754: 
1.145     www      3755: # ------------------------------------------------------------------ Cascade up
1.218     albertel 3756: 	unless ($space eq '0') {
1.336     albertel 3757: 	    my @parts=split(/_/,$space);
                   3758: 	    my $id=pop(@parts);
                   3759: 	    my $part=join('_',@parts);
                   3760: 	    if ($part eq '') { $part='0'; }
                   3761: 	    my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,
1.395     albertel 3762: 				 $symbparm,$udom,$uname,$section,1);
1.337     albertel 3763: 	    if (defined($partgeneral)) { return $partgeneral; }
1.218     albertel 3764: 	}
1.395     albertel 3765: 	if ($recurse) { return undef; }
                   3766: 	my $pack_def=&packages_tab_default($filename,$varname);
                   3767: 	if (defined($pack_def)) { return $pack_def; }
1.71      www      3768: 
1.48      www      3769: # ---------------------------------------------------- Any other user namespace
                   3770:     } elsif ($realm eq 'environment') {
                   3771: # ----------------------------------------------------------------- environment
1.219     albertel 3772: 	if (($uname eq $ENV{'user.name'})&&($udom eq $ENV{'user.domain'})) {
                   3773: 	    return $ENV{'environment.'.$spacequalifierrest};
                   3774: 	} else {
                   3775: 	    my %returnhash=&userenvironment($udom,$uname,
                   3776: 					    $spacequalifierrest);
                   3777: 	    return $returnhash{$spacequalifierrest};
                   3778: 	}
1.28      www      3779:     } elsif ($realm eq 'system') {
1.48      www      3780: # ----------------------------------------------------------------- system.time
                   3781: 	if ($space eq 'time') {
                   3782: 	    return time;
                   3783:         }
1.28      www      3784:     }
1.48      www      3785:     return '';
1.61      www      3786: }
                   3787: 
1.395     albertel 3788: sub packages_tab_default {
                   3789:     my ($uri,$varname)=@_;
                   3790:     my (undef,$part,$name)=split(/\./,$varname);
                   3791:     my $packages=&metadata($uri,'packages');
                   3792:     foreach my $package (split(/,/,$packages)) {
                   3793: 	my ($pack_type,$pack_part)=split(/_/,$package,2);
                   3794: 	if ($pack_part eq $part) {
                   3795: 	    return $packagetab{"$pack_type&$name&default"};
                   3796: 	}
                   3797:     }
                   3798:     return undef;
                   3799: }
                   3800: 
1.334     albertel 3801: sub add_prefix_and_part {
                   3802:     my ($prefix,$part)=@_;
                   3803:     my $keyroot;
                   3804:     if (defined($prefix) && $prefix !~ /^__/) {
                   3805: 	# prefix that has a part already
                   3806: 	$keyroot=$prefix;
                   3807:     } elsif (defined($prefix)) {
                   3808: 	# prefix that is missing a part
                   3809: 	if (defined($part)) { $keyroot='_'.$part.substr($prefix,1); }
                   3810:     } else {
                   3811: 	# no prefix at all
                   3812: 	if (defined($part)) { $keyroot='_'.$part; }
                   3813:     }
                   3814:     return $keyroot;
                   3815: }
                   3816: 
1.71      www      3817: # ---------------------------------------------------------------- Get metadata
                   3818: 
                   3819: sub metadata {
1.176     www      3820:     my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
1.71      www      3821:     $uri=&declutter($uri);
1.288     albertel 3822:     # if it is a non metadata possible uri return quickly
1.293     matthew  3823:     if (($uri eq '') || (($uri =~ m|^/*adm/|) && ($uri !~ m|^adm/includes|)) ||
1.423     albertel 3824:         ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) ||
                   3825: 	($uri =~ m|home/[^/]+/public_html/|)) {
1.288     albertel 3826: 	return '';
                   3827:     }
1.73      www      3828:     my $filename=$uri;
                   3829:     $uri=~s/\.meta$//;
1.172     www      3830: #
                   3831: # Is the metadata already cached?
1.177     www      3832: # Look at timestamp of caching
1.172     www      3833: # Everything is cached by the main uri, libraries are never directly cached
                   3834: #
1.428     albertel 3835:     if (!defined($liburi)) {
                   3836: 	my ($result,$cached)=&is_cached(\%metacache,$uri,'meta');
                   3837: 	if (defined($cached)) { return $result->{':'.$what}; }
                   3838:     }
                   3839:     {
1.172     www      3840: #
                   3841: # Is this a recursive call for a library?
                   3842: #
1.453     albertel 3843: 	if (! exists($metacache{$uri})) {
                   3844: 	    $metacache{$uri}={};
                   3845: 	}
1.171     www      3846:         if ($liburi) {
                   3847: 	    $liburi=&declutter($liburi);
                   3848:             $filename=$liburi;
1.401     bowersj2 3849:         } else {
1.428     albertel 3850: 	    &devalidate_cache(\%metacache,$uri,'meta');
1.401     bowersj2 3851: 	}
1.140     www      3852:         my %metathesekeys=();
1.73      www      3853:         unless ($filename=~/\.meta$/) { $filename.='.meta'; }
1.335     albertel 3854: 	my $metastring=&getfile(&filelocation('',&clutter($filename)));
1.208     albertel 3855:         my $parser=HTML::LCParser->new(\$metastring);
1.71      www      3856:         my $token;
1.140     www      3857:         undef %metathesekeys;
1.71      www      3858:         while ($token=$parser->get_token) {
1.339     albertel 3859: 	    if ($token->[0] eq 'S') {
                   3860: 		if (defined($token->[2]->{'package'})) {
1.172     www      3861: #
                   3862: # This is a package - get package info
                   3863: #
1.339     albertel 3864: 		    my $package=$token->[2]->{'package'};
                   3865: 		    my $keyroot=&add_prefix_and_part($prefix,$token->[2]->{'part'});
                   3866: 		    if (defined($token->[2]->{'id'})) { 
                   3867: 			$keyroot.='_'.$token->[2]->{'id'}; 
                   3868: 		    }
1.453     albertel 3869: 		    if ($metacache{$uri}->{':packages'}) {
                   3870: 			$metacache{$uri}->{':packages'}.=','.$package.$keyroot;
1.339     albertel 3871: 		    } else {
1.453     albertel 3872: 			$metacache{$uri}->{':packages'}=$package.$keyroot;
1.339     albertel 3873: 		    }
                   3874: 		    foreach (keys %packagetab) {
1.432     albertel 3875: 			my $part=$keyroot;
                   3876: 			$part=~s/^\_//;
                   3877: 			if ($_=~/^\Q$package\E\&/ || 
                   3878: 			    $_=~/^\Q$package\E_0\&/) {
1.339     albertel 3879: 			    my ($pack,$name,$subp)=split(/\&/,$_);
1.395     albertel 3880: 			    # ignore package.tab specified default values
                   3881:                             # here &package_tab_default() will fetch those
                   3882: 			    if ($subp eq 'default') { next; }
1.339     albertel 3883: 			    my $value=$packagetab{$_};
1.432     albertel 3884: 			    my $unikey;
                   3885: 			    if ($pack =~ /_0$/) {
                   3886: 				$unikey='parameter_0_'.$name;
                   3887: 				$part=0;
                   3888: 			    } else {
                   3889: 				$unikey='parameter'.$keyroot.'_'.$name;
                   3890: 			    }
1.339     albertel 3891: 			    if ($subp eq 'display') {
                   3892: 				$value.=' [Part: '.$part.']';
                   3893: 			    }
1.453     albertel 3894: 			    $metacache{$uri}->{':'.$unikey.'.part'}=$part;
1.395     albertel 3895: 			    $metathesekeys{$unikey}=1;
1.453     albertel 3896: 			    unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) {
                   3897: 				$metacache{$uri}->{':'.$unikey.'.'.$subp}=$value;
1.339     albertel 3898: 			    }
1.453     albertel 3899: 			    if (defined($metacache{$uri}->{':'.$unikey.'.default'})) {
                   3900: 				$metacache{$uri}->{':'.$unikey}=
                   3901: 				    $metacache{$uri}->{':'.$unikey.'.default'};
1.356     albertel 3902: 			    }
1.339     albertel 3903: 			}
                   3904: 		    }
                   3905: 		} else {
1.172     www      3906: #
                   3907: # This is not a package - some other kind of start tag
1.339     albertel 3908: #
                   3909: 		    my $entry=$token->[1];
                   3910: 		    my $unikey;
                   3911: 		    if ($entry eq 'import') {
                   3912: 			$unikey='';
                   3913: 		    } else {
                   3914: 			$unikey=$entry;
                   3915: 		    }
                   3916: 		    $unikey.=&add_prefix_and_part($prefix,$token->[2]->{'part'});
                   3917: 
                   3918: 		    if (defined($token->[2]->{'id'})) { 
                   3919: 			$unikey.='_'.$token->[2]->{'id'}; 
                   3920: 		    }
1.175     www      3921: 
1.339     albertel 3922: 		    if ($entry eq 'import') {
1.175     www      3923: #
                   3924: # Importing a library here
1.339     albertel 3925: #
                   3926: 			if ($depthcount<20) {
                   3927: 			    my $location=$parser->get_text('/import');
                   3928: 			    my $dir=$filename;
                   3929: 			    $dir=~s|[^/]*$||;
                   3930: 			    $location=&filelocation($dir,$location);
                   3931: 			    foreach (sort(split(/\,/,&metadata($uri,'keys',
                   3932: 							       $location,$unikey,
                   3933: 							       $depthcount+1)))) {
1.453     albertel 3934: 				$metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_};
1.339     albertel 3935: 				$metathesekeys{$_}=1;
                   3936: 			    }
                   3937: 			}
                   3938: 		    } else { 
                   3939: 			
                   3940: 			if (defined($token->[2]->{'name'})) { 
                   3941: 			    $unikey.='_'.$token->[2]->{'name'}; 
                   3942: 			}
                   3943: 			$metathesekeys{$unikey}=1;
                   3944: 			foreach (@{$token->[3]}) {
1.453     albertel 3945: 			    $metacache{$uri}->{':'.$unikey.'.'.$_}=$token->[2]->{$_};
1.339     albertel 3946: 			}
                   3947: 			my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));
1.453     albertel 3948: 			my $default=$metacache{$uri}->{':'.$unikey.'.default'};
1.339     albertel 3949: 			if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) {
                   3950: 		 # only ws inside the tag, and not in default, so use default
                   3951: 		 # as value
1.453     albertel 3952: 			    $metacache{$uri}->{':'.$unikey}=$default;
1.339     albertel 3953: 			} else {
1.321     albertel 3954: 		  # either something interesting inside the tag or default
                   3955:                   # uninteresting
1.453     albertel 3956: 			    $metacache{$uri}->{':'.$unikey}=$internaltext;
1.339     albertel 3957: 			}
1.172     www      3958: # end of not-a-package not-a-library import
1.339     albertel 3959: 		    }
1.172     www      3960: # end of not-a-package start tag
1.339     albertel 3961: 		}
1.172     www      3962: # the next is the end of "start tag"
1.339     albertel 3963: 	    }
                   3964: 	}
1.338     www      3965: # are there custom rights to evaluate
1.453     albertel 3966: 	if ($metacache{$uri}->{':copyright'} eq 'custom') {
1.339     albertel 3967: 
1.338     www      3968:     #
                   3969:     # Importing a rights file here
1.339     albertel 3970:     #
                   3971: 	    unless ($depthcount) {
1.453     albertel 3972: 		my $location=$metacache{$uri}->{':customdistributionfile'};
1.339     albertel 3973: 		my $dir=$filename;
                   3974: 		$dir=~s|[^/]*$||;
                   3975: 		$location=&filelocation($dir,$location);
                   3976: 		foreach (sort(split(/\,/,&metadata($uri,'keys',
                   3977: 						   $location,'_rights',
                   3978: 						   $depthcount+1)))) {
1.453     albertel 3979: 		    $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_};
1.339     albertel 3980: 		    $metathesekeys{$_}=1;
                   3981: 		}
                   3982: 	    }
                   3983: 	}
1.453     albertel 3984: 	$metacache{$uri}->{':keys'}=join(',',keys %metathesekeys);
                   3985: 	&metadata_generate_part0(\%metathesekeys,$metacache{$uri},$uri);
                   3986: 	$metacache{$uri}->{':allpossiblekeys'}=join(',',keys %metathesekeys);
                   3987: 	&do_cache(\%metacache,$uri,$metacache{$uri},'meta');
1.177     www      3988: # this is the end of "was not already recently cached
1.71      www      3989:     }
1.428     albertel 3990:     return $metacache{$uri}->{':'.$what};
1.261     albertel 3991: }
                   3992: 
                   3993: sub metadata_generate_part0 {
                   3994:     my ($metadata,$metacache,$uri) = @_;
                   3995:     my %allnames;
                   3996:     foreach my $metakey (sort keys %$metadata) {
                   3997: 	if ($metakey=~/^parameter\_(.*)/) {
1.428     albertel 3998: 	  my $part=$$metacache{':'.$metakey.'.part'};
                   3999: 	  my $name=$$metacache{':'.$metakey.'.name'};
1.356     albertel 4000: 	  if (! exists($$metadata{'parameter_0_'.$name.'.name'})) {
1.261     albertel 4001: 	    $allnames{$name}=$part;
                   4002: 	  }
                   4003: 	}
                   4004:     }
                   4005:     foreach my $name (keys(%allnames)) {
                   4006:       $$metadata{"parameter_0_$name"}=1;
1.428     albertel 4007:       my $key=":parameter_0_$name";
1.261     albertel 4008:       $$metacache{"$key.part"}='0';
                   4009:       $$metacache{"$key.name"}=$name;
1.428     albertel 4010:       $$metacache{"$key.type"}=$$metacache{':parameter_'.
1.261     albertel 4011: 					   $allnames{$name}.'_'.$name.
                   4012: 					   '.type'};
1.428     albertel 4013:       my $olddis=$$metacache{':parameter_'.$allnames{$name}.'_'.$name.
1.261     albertel 4014: 			     '.display'};
                   4015:       my $expr='\\[Part: '.$allnames{$name}.'\\]';
                   4016:       $olddis=~s/$expr/\[Part: 0\]/;
                   4017:       $$metacache{"$key.display"}=$olddis;
                   4018:     }
1.71      www      4019: }
                   4020: 
1.301     www      4021: # ------------------------------------------------- Get the title of a resource
                   4022: 
                   4023: sub gettitle {
                   4024:     my $urlsymb=shift;
                   4025:     my $symb=&symbread($urlsymb);
                   4026:     unless ($symb) {
                   4027: 	unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; }
                   4028:         return &metadata($urlsymb,'title'); 
                   4029:     }
1.425     albertel 4030:     my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600);
1.419     albertel 4031:     if (defined($cached)) { return $result; }
1.409     www      4032:     my ($map,$resid,$url)=&decode_symb($symb);
1.301     www      4033:     my $title='';
                   4034:     my %bighash;
                   4035:     if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
                   4036:                             &GDBM_READER(),0640)) {
                   4037:         my $mapid=$bighash{'map_pc_'.&clutter($map)};
                   4038:         $title=$bighash{'title_'.$mapid.'.'.$resid};
                   4039:         untie %bighash;
                   4040:     }
1.363     www      4041:     $title=~s/\&colon\;/\:/gs;
1.301     www      4042:     if ($title) {
1.425     albertel 4043:         return &do_cache(\%titlecache,$symb,$title,'title');
1.301     www      4044:     } else {
                   4045: 	return &metadata($urlsymb,'title');
                   4046:     }
                   4047: }
                   4048:     
1.31      www      4049: # ------------------------------------------------- Update symbolic store links
                   4050: 
                   4051: sub symblist {
                   4052:     my ($mapname,%newhash)=@_;
1.438     www      4053:     $mapname=&deversion(&declutter($mapname));
1.31      www      4054:     my %hash;
                   4055:     if (($ENV{'request.course.fn'}) && (%newhash)) {
                   4056:         if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',
1.256     albertel 4057:                       &GDBM_WRCREAT(),0640)) {
1.191     harris41 4058: 	    foreach (keys %newhash) {
1.438     www      4059:                 $hash{declutter($_)}=$mapname.'___'.&deversion($newhash{$_});
1.191     harris41 4060:             }
1.31      www      4061:             if (untie(%hash)) {
                   4062: 		return 'ok';
                   4063:             }
                   4064:         }
                   4065:     }
                   4066:     return 'error';
1.212     www      4067: }
                   4068: 
                   4069: # --------------------------------------------------------------- Verify a symb
                   4070: 
                   4071: sub symbverify {
                   4072:     my ($symb,$thisfn)=@_;
1.439     www      4073:     $thisfn=&declutter($thisfn);
1.215     www      4074: # direct jump to resource in page or to a sequence - will construct own symbs
                   4075:     if ($thisfn=~/\.(page|sequence)$/) { return 1; }
                   4076: # check URL part
1.409     www      4077:     my ($map,$resid,$url)=&decode_symb($symb);
1.439     www      4078: 
1.431     www      4079:     unless ($url eq $thisfn) { return 0; }
1.213     www      4080: 
1.216     www      4081:     $symb=&symbclean($symb);
1.439     www      4082:     $thisfn=&deversion($thisfn);
1.213     www      4083: 
                   4084:     my %bighash;
                   4085:     my $okay=0;
1.431     www      4086: 
1.213     www      4087:     if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
1.256     albertel 4088:                             &GDBM_READER(),0640)) {
1.280     www      4089:         my $ids=$bighash{'ids_'.&clutter($thisfn)};
1.216     www      4090:         unless ($ids) { 
                   4091:            $ids=$bighash{'ids_/'.$thisfn};
                   4092:         }
                   4093:         if ($ids) {
                   4094: # ------------------------------------------------------------------- Has ID(s)
                   4095: 	    foreach (split(/\,/,$ids)) {
                   4096:                my ($mapid,$resid)=split(/\./,$_);
                   4097:                if (
                   4098:   &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)
                   4099:    eq $symb) { 
                   4100:                   $okay=1; 
                   4101:                }
                   4102: 	   }
                   4103:         }
1.213     www      4104: 	untie(%bighash);
                   4105:     }
                   4106:     return $okay;
1.31      www      4107: }
                   4108: 
1.210     www      4109: # --------------------------------------------------------------- Clean-up symb
                   4110: 
                   4111: sub symbclean {
                   4112:     my $symb=shift;
1.213     www      4113: 
1.210     www      4114: # remove version from map
                   4115:     $symb=~s/\.(\d+)\.(\w+)\_\_\_/\.$2\_\_\_/;
1.215     www      4116: 
1.210     www      4117: # remove version from URL
                   4118:     $symb=~s/\.(\d+)\.(\w+)$/\.$2/;
1.213     www      4119: 
1.210     www      4120:     return $symb;
1.409     www      4121: }
                   4122: 
                   4123: # ---------------------------------------------- Split symb to find map and url
1.429     albertel 4124: 
                   4125: sub encode_symb {
                   4126:     my ($map,$resid,$url)=@_;
                   4127:     return &symbclean(&declutter($map).'___'.$resid.'___'.&declutter($url));
                   4128: }
1.409     www      4129: 
                   4130: sub decode_symb {
1.413     www      4131:     my ($map,$resid,$url)=split(/\_\_\_/,shift);
                   4132:     return (&fixversion($map),$resid,&fixversion($url));
                   4133: }
                   4134: 
                   4135: sub fixversion {
                   4136:     my $fn=shift;
                   4137:     if ($fn=~/^(adm|uploaded|public)/) { return $fn; }
1.435     www      4138:     my %bighash;
                   4139:     my $uri=&clutter($fn);
1.440     www      4140:     my $key=$ENV{'request.course.id'}.'_'.$uri;
                   4141: # is this cached?
                   4142:     my ($result,$cached)=&is_cached(\%courseresversioncache,$key,
                   4143: 				    'courseresversion',600);
                   4144:     if (defined($cached)) { return $result; }
                   4145: # unfortunately not cached, or expired
1.435     www      4146:     if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
1.440     www      4147: 	    &GDBM_READER(),0640)) {
                   4148:  	if ($bighash{'version_'.$uri}) {
                   4149:  	    my $version=$bighash{'version_'.$uri};
1.444     www      4150:  	    unless (($version eq 'mostrecent') || 
                   4151: 		    ($version==&getversion($uri))) {
1.440     www      4152:  		$uri=~s/\.(\w+)$/\.$version\.$1/;
                   4153:  	    }
                   4154:  	}
                   4155:  	untie %bighash;
1.413     www      4156:     }
1.440     www      4157:     return &do_cache
                   4158: 	(\%courseresversioncache,$key,&declutter($uri),'courseresversion');
1.438     www      4159: }
                   4160: 
                   4161: sub deversion {
                   4162:     my $url=shift;
                   4163:     $url=~s/\.\d+\.(\w+)$/\.$1/;
                   4164:     return $url;
1.210     www      4165: }
                   4166: 
1.31      www      4167: # ------------------------------------------------------ Return symb list entry
                   4168: 
                   4169: sub symbread {
1.249     www      4170:     my ($thisfn,$donotrecurse)=@_;
1.242     www      4171: # no filename provided? try from environment
1.44      www      4172:     unless ($thisfn) {
1.210     www      4173:         if ($ENV{'request.symb'}) { return &symbclean($ENV{'request.symb'}); }
1.44      www      4174: 	$thisfn=$ENV{'request.filename'};
                   4175:     }
1.242     www      4176: # is that filename actually a symb? Verify, clean, and return
                   4177:     if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) {
                   4178: 	if (&symbverify($thisfn,$1)) { return &symbclean($thisfn); }
                   4179:     }
1.44      www      4180:     $thisfn=declutter($thisfn);
1.31      www      4181:     my %hash;
1.37      www      4182:     my %bighash;
                   4183:     my $syval='';
1.45      www      4184:     if (($ENV{'request.course.fn'}) && ($thisfn)) {
1.31      www      4185:         if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',
1.256     albertel 4186:                       &GDBM_READER(),0640)) {
1.31      www      4187: 	    $syval=$hash{$thisfn};
1.37      www      4188:             untie(%hash);
                   4189:         }
                   4190: # ---------------------------------------------------------- There was an entry
                   4191:         if ($syval) {
                   4192:            unless ($syval=~/\_\d+$/) {
                   4193: 	       unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) {
1.44      www      4194:                   &appenv('request.ambiguous' => $thisfn);
1.37      www      4195:                   return '';
                   4196:                }    
                   4197:                $syval.=$1;
                   4198: 	   }
                   4199:         } else {
                   4200: # ------------------------------------------------------- Was not in symb table
                   4201:            if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
1.256     albertel 4202:                             &GDBM_READER(),0640)) {
1.37      www      4203: # ---------------------------------------------- Get ID(s) for current resource
1.280     www      4204:               my $ids=$bighash{'ids_'.&clutter($thisfn)};
1.65      www      4205:               unless ($ids) { 
                   4206:                  $ids=$bighash{'ids_/'.$thisfn};
1.242     www      4207:               }
                   4208:               unless ($ids) {
                   4209: # alias?
                   4210: 		  $ids=$bighash{'mapalias_'.$thisfn};
1.65      www      4211:               }
1.37      www      4212:               if ($ids) {
                   4213: # ------------------------------------------------------------------- Has ID(s)
                   4214:                  my @possibilities=split(/\,/,$ids);
1.39      www      4215:                  if ($#possibilities==0) {
                   4216: # ----------------------------------------------- There is only one possibility
1.37      www      4217: 		     my ($mapid,$resid)=split(/\./,$ids);
                   4218:                      $syval=declutter($bighash{'map_id_'.$mapid}).'___'.$resid;
1.249     www      4219:                  } elsif (!$donotrecurse) {
1.39      www      4220: # ------------------------------------------ There is more than one possibility
                   4221:                      my $realpossible=0;
1.191     harris41 4222:                      foreach (@possibilities) {
1.39      www      4223: 			 my $file=$bighash{'src_'.$_};
                   4224:                          if (&allowed('bre',$file)) {
                   4225:          		    my ($mapid,$resid)=split(/\./,$_);
                   4226:                             if ($bighash{'map_type_'.$mapid} ne 'page') {
                   4227: 				$realpossible++;
                   4228:                                 $syval=declutter($bighash{'map_id_'.$mapid}).
                   4229:                                        '___'.$resid;
                   4230:                             }
                   4231: 			 }
1.191     harris41 4232:                      }
1.39      www      4233: 		     if ($realpossible!=1) { $syval=''; }
1.249     www      4234:                  } else {
                   4235:                      $syval='';
1.37      www      4236:                  }
                   4237: 	      }
                   4238:               untie(%bighash)
                   4239:            } 
1.31      www      4240:         }
1.62      www      4241:         if ($syval) {
1.210     www      4242:            return &symbclean($syval.'___'.$thisfn); 
1.62      www      4243:         }
1.31      www      4244:     }
1.44      www      4245:     &appenv('request.ambiguous' => $thisfn);
1.31      www      4246:     return '';
                   4247: }
                   4248: 
                   4249: # ---------------------------------------------------------- Return random seed
                   4250: 
1.32      www      4251: sub numval {
                   4252:     my $txt=shift;
                   4253:     $txt=~tr/A-J/0-9/;
                   4254:     $txt=~tr/a-j/0-9/;
                   4255:     $txt=~tr/K-T/0-9/;
                   4256:     $txt=~tr/k-t/0-9/;
                   4257:     $txt=~tr/U-Z/0-5/;
                   4258:     $txt=~tr/u-z/0-5/;
                   4259:     $txt=~s/\D//g;
                   4260:     return int($txt);
1.368     albertel 4261: }
                   4262: 
                   4263: sub latest_rnd_algorithm_id {
1.443     albertel 4264:     return '64bit2';
1.366     albertel 4265: }
1.32      www      4266: 
1.31      www      4267: sub rndseed {
1.155     albertel 4268:     my ($symb,$courseid,$domain,$username)=@_;
1.366     albertel 4269: 
                   4270:     my ($wsymb,$wcourseid,$wdomain,$wusername)=&Apache::lonxml::whichuser();
1.155     albertel 4271:     if (!$symb) {
1.366     albertel 4272: 	unless ($symb=$wsymb) { return time; }
                   4273:     }
                   4274:     if (!$courseid) { $courseid=$wcourseid; }
                   4275:     if (!$domain) { $domain=$wdomain; }
                   4276:     if (!$username) { $username=$wusername }
                   4277:     my $which=$ENV{"course.$courseid.rndseed"};
                   4278:     my $CODE=$ENV{'scantron.CODE'};
                   4279:     if (defined($CODE)) {
                   4280: 	&rndseed_CODE_64bit($symb,$courseid,$domain,$username);
1.443     albertel 4281:     } elsif ($which eq '64bit2') {
                   4282: 	return &rndseed_64bit2($symb,$courseid,$domain,$username);
1.366     albertel 4283:     } elsif ($which eq '64bit') {
                   4284: 	return &rndseed_64bit($symb,$courseid,$domain,$username);
                   4285:     }
                   4286:     return &rndseed_32bit($symb,$courseid,$domain,$username);
                   4287: }
                   4288: 
                   4289: sub rndseed_32bit {
                   4290:     my ($symb,$courseid,$domain,$username)=@_;
                   4291:     {
                   4292: 	use integer;
                   4293: 	my $symbchck=unpack("%32C*",$symb) << 27;
                   4294: 	my $symbseed=numval($symb) << 22;
                   4295: 	my $namechck=unpack("%32C*",$username) << 17;
                   4296: 	my $nameseed=numval($username) << 12;
                   4297: 	my $domainseed=unpack("%32C*",$domain) << 7;
                   4298: 	my $courseseed=unpack("%32C*",$courseid);
                   4299: 	my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;
                   4300: 	#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
                   4301: 	#&Apache::lonxml::debug("rndseed :$num:$symb");
                   4302: 	return $num;
                   4303:     }
                   4304: }
                   4305: 
                   4306: sub rndseed_64bit {
                   4307:     my ($symb,$courseid,$domain,$username)=@_;
                   4308:     {
                   4309: 	use integer;
                   4310: 	my $symbchck=unpack("%32S*",$symb) << 21;
                   4311: 	my $symbseed=numval($symb) << 10;
                   4312: 	my $namechck=unpack("%32S*",$username);
                   4313: 	
                   4314: 	my $nameseed=numval($username) << 21;
                   4315: 	my $domainseed=unpack("%32S*",$domain) << 10;
                   4316: 	my $courseseed=unpack("%32S*",$courseid);
                   4317: 	
                   4318: 	my $num1=$symbchck+$symbseed+$namechck;
                   4319: 	my $num2=$nameseed+$domainseed+$courseseed;
                   4320: 	#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
                   4321: 	#&Apache::lonxml::debug("rndseed :$num:$symb");
                   4322: 	return "$num1,$num2";
1.155     albertel 4323:     }
1.366     albertel 4324: }
                   4325: 
1.443     albertel 4326: sub rndseed_64bit2 {
                   4327:     my ($symb,$courseid,$domain,$username)=@_;
                   4328:     {
                   4329: 	use integer;
                   4330: 	# strings need to be an even # of cahracters long, it it is odd the
                   4331:         # last characters gets thrown away
                   4332: 	my $symbchck=unpack("%32S*",$symb.' ') << 21;
                   4333: 	my $symbseed=numval($symb) << 10;
                   4334: 	my $namechck=unpack("%32S*",$username.' ');
                   4335: 	
                   4336: 	my $nameseed=numval($username) << 21;
                   4337: 	my $domainseed=unpack("%32S*",$domain.' ') << 10;
                   4338: 	my $courseseed=unpack("%32S*",$courseid.' ');
                   4339: 	
                   4340: 	my $num1=$symbchck+$symbseed+$namechck;
                   4341: 	my $num2=$nameseed+$domainseed+$courseseed;
                   4342: 	#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
                   4343: 	#&Apache::lonxml::debug("rndseed :$num:$symb");
                   4344: 	return "$num1,$num2";
                   4345:     }
                   4346: }
                   4347: 
1.366     albertel 4348: sub rndseed_CODE_64bit {
                   4349:     my ($symb,$courseid,$domain,$username)=@_;
1.155     albertel 4350:     {
1.366     albertel 4351: 	use integer;
1.443     albertel 4352: 	my $symbchck=unpack("%32S*",$symb.' ') << 16;
1.366     albertel 4353: 	my $symbseed=numval($symb);
                   4354: 	my $CODEseed=numval($ENV{'scantron.CODE'}) << 16;
1.443     albertel 4355: 	my $courseseed=unpack("%32S*",$courseid.' ');
1.366     albertel 4356: 	my $num1=$symbseed+$CODEseed;
                   4357: 	my $num2=$courseseed+$symbchck;
                   4358: 	#&Apache::lonxml::debug("$symbseed:$CODEseed|$courseseed:$symbchck");
                   4359: 	#&Apache::lonxml::debug("rndseed :$num1:$num2:$symb");
                   4360: 	return "$num1,$num2";
                   4361:     }
                   4362: }
                   4363: 
                   4364: sub setup_random_from_rndseed {
                   4365:     my ($rndseed)=@_;
                   4366:     if ($rndseed =~/,/) {
                   4367: 	my ($num1,$num2)=split(/,/,$rndseed);
                   4368: 	&Math::Random::random_set_seed(abs($num1),abs($num2));
                   4369:     } else {
                   4370: 	&Math::Random::random_set_seed_from_phrase($rndseed);
1.98      albertel 4371:     }
1.36      albertel 4372: }
                   4373: 
1.76      www      4374: sub ireceipt {
                   4375:     my ($funame,$fudom,$fucourseid,$fusymb)=@_;
                   4376:     my $cuname=unpack("%32C*",$funame);
                   4377:     my $cudom=unpack("%32C*",$fudom);
                   4378:     my $cucourseid=unpack("%32C*",$fucourseid);
                   4379:     my $cusymb=unpack("%32C*",$fusymb);
1.77      www      4380:     my $cunique=unpack("%32C*",$perlvar{'lonReceipt'});
1.76      www      4381:     return unpack("%32C*",$perlvar{'lonHostID'}).'-'.
                   4382:            ($cunique%$cuname+
                   4383:             $cunique%$cudom+
                   4384:             $cusymb%$cuname+
                   4385:             $cusymb%$cudom+
                   4386:             $cucourseid%$cuname+
                   4387:             $cucourseid%$cudom);
                   4388: }
                   4389: 
                   4390: sub receipt {
1.260     ng       4391:   my ($symb,$courseid,$domain,$name) = &Apache::lonxml::whichuser();
                   4392:   return &ireceipt($name,$domain,$courseid,$symb);
1.76      www      4393: }
1.260     ng       4394: 
1.36      albertel 4395: # ------------------------------------------------------------ Serves up a file
                   4396: # returns either the contents of the file or a -1
                   4397: sub getfile {
1.269     www      4398:  my $file=shift;
                   4399:  if ($file=~/^\/*uploaded\//) { # user file
                   4400:     my $ua=new LWP::UserAgent;
                   4401:     my $request=new HTTP::Request('GET',&tokenwrapper($file));
                   4402:     my $response=$ua->request($request);
                   4403:     if ($response->is_success()) {
                   4404:        return $response->content;
                   4405:     } else { 
                   4406:        return -1; 
                   4407:     }
                   4408:  } else { # normal file from res space
1.37      www      4409:   &repcopy($file);
1.36      albertel 4410:   if (! -e $file ) { return -1; };
1.448     albertel 4411:   my $fh;
                   4412:   open($fh,"<$file");
1.36      albertel 4413:   my $a='';
                   4414:   while (<$fh>) { $a .=$_; }
1.269     www      4415:   return $a;
                   4416:  }
1.36      albertel 4417: }
                   4418: 
                   4419: sub filelocation {
                   4420:   my ($dir,$file) = @_;
                   4421:   my $location;
                   4422:   $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces
1.59      albertel 4423:   if ($file=~m:^/~:) { # is a contruction space reference
                   4424:     $location = $file;
                   4425:     $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;
1.270     www      4426:   } elsif ($file=~/^\/*uploaded/) { # is an uploaded file
                   4427:     $location=$file;
1.36      albertel 4428:   } else {
1.59      albertel 4429:     $file=~s/^$perlvar{'lonDocRoot'}//;
                   4430:     $file=~s:^/*res::;
                   4431:     if ( !( $file =~ m:^/:) ) {
                   4432:       $location = $dir. '/'.$file;
                   4433:     } else {
                   4434:       $location = '/home/httpd/html/res'.$file;
                   4435:     }
1.36      albertel 4436:   }
                   4437:   $location=~s://+:/:g; # remove duplicate /
1.46      www      4438:   while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..
                   4439:   return $location;
                   4440: }
1.36      albertel 4441: 
1.46      www      4442: sub hreflocation {
                   4443:     my ($dir,$file)=@_;
1.191     harris41 4444:     unless (($file=~/^http:\/\//i) || ($file=~/^\//)) {
1.46      www      4445:        my $finalpath=filelocation($dir,$file);
                   4446:        $finalpath=~s/^\/home\/httpd\/html//;
1.225     albertel 4447:        $finalpath=~s-/home/(\w+)/public_html/-/~$1/-;
1.46      www      4448:        return $finalpath;
                   4449:     } else {
                   4450:        return $file;
                   4451:     }
1.31      www      4452: }
                   4453: 
                   4454: # ------------------------------------------------------------- Declutters URLs
                   4455: 
                   4456: sub declutter {
                   4457:     my $thisfn=shift;
                   4458:     $thisfn=~s/^$perlvar{'lonDocRoot'}//;
                   4459:     $thisfn=~s/^\///;
                   4460:     $thisfn=~s/^res\///;
1.235     www      4461:     $thisfn=~s/\?.+$//;
1.268     www      4462:     return $thisfn;
                   4463: }
                   4464: 
                   4465: # ------------------------------------------------------------- Clutter up URLs
                   4466: 
                   4467: sub clutter {
                   4468:     my $thisfn='/'.&declutter(shift);
1.270     www      4469:     unless ($thisfn=~/^\/(uploaded|adm|userfiles|ext|raw|priv)\//) { 
                   4470:        $thisfn='/res'.$thisfn; 
                   4471:     }
1.31      www      4472:     return $thisfn;
1.12      www      4473: }
                   4474: 
                   4475: # -------------------------------------------------------- Escape Special Chars
                   4476: 
                   4477: sub escape {
                   4478:     my $str=shift;
                   4479:     $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
                   4480:     return $str;
                   4481: }
                   4482: 
                   4483: # ----------------------------------------------------- Un-Escape Special Chars
                   4484: 
                   4485: sub unescape {
                   4486:     my $str=shift;
                   4487:     $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
                   4488:     return $str;
                   4489: }
1.11      www      4490: 
1.415     albertel 4491: sub mod_perl_version {
                   4492:     if (defined($perlvar{'MODPERL2'})) {
                   4493: 	return 2;
                   4494:     }
                   4495:     return 1;
1.436     albertel 4496: }
                   4497: 
                   4498: sub correct_line_ends {
                   4499:     my ($result)=@_;
                   4500:     $$result =~s/\r\n/\n/mg;
                   4501:     $$result =~s/\r/\n/mg;
1.415     albertel 4502: }
1.1       albertel 4503: # ================================================================ Main Program
                   4504: 
1.184     www      4505: sub goodbye {
1.204     albertel 4506:    &logthis("Starting Shut down");
1.443     albertel 4507: #not converted to using infrastruture and probably shouldn't be
1.425     albertel 4508:    &logthis(sprintf("%-20s is %s",'%badServerCache',scalar(%badServerCache)));
1.443     albertel 4509: #converted
1.425     albertel 4510:    &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));
1.443     albertel 4511:    &logthis(sprintf("%-20s is %s",'%homecache',scalar(%homecache)));
1.425     albertel 4512:    &logthis(sprintf("%-20s is %s",'%titlecache',scalar(%titlecache)));
                   4513:    &logthis(sprintf("%-20s is %s",'%courseresdatacache',scalar(%courseresdatacache)));
                   4514: #1.1 only
                   4515:    &logthis(sprintf("%-20s is %s",'%userresdatacache',scalar(%userresdatacache)));
                   4516:    &logthis(sprintf("%-20s is %s",'%usectioncache',scalar(%usectioncache)));
1.440     www      4517:    &logthis(sprintf("%-20s is %s",'%courseresversioncache',scalar(%courseresversioncache)));
                   4518:    &logthis(sprintf("%-20s is %s",'%resversioncache',scalar(%resversioncache)));
1.184     www      4519:    &flushcourselogs();
                   4520:    &logthis("Shutting down");
1.362     albertel 4521:    return DONE;
1.184     www      4522: }
                   4523: 
1.179     www      4524: BEGIN {
1.228     harris41 4525: # ----------------------------------- Read loncapa.conf and loncapa_apache.conf
1.195     www      4526:     unless ($readit) {
1.217     harris41 4527: {
1.448     albertel 4528:     open(my $config,"</etc/httpd/conf/loncapa.conf");
1.217     harris41 4529: 
                   4530:     while (my $configline=<$config>) {
                   4531:         if ($configline =~ /^[^\#]*PerlSetVar/) {
1.1       albertel 4532: 	   my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
1.8       www      4533:            chomp($varvalue);
1.1       albertel 4534:            $perlvar{$varname}=$varvalue;
                   4535:         }
                   4536:     }
1.448     albertel 4537:     close($config);
1.1       albertel 4538: }
1.227     harris41 4539: {
1.448     albertel 4540:     open(my $config,"</etc/httpd/conf/loncapa_apache.conf");
1.227     harris41 4541: 
                   4542:     while (my $configline=<$config>) {
                   4543:         if ($configline =~ /^[^\#]*PerlSetVar/) {
                   4544: 	   my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
                   4545:            chomp($varvalue);
                   4546:            $perlvar{$varname}=$varvalue;
                   4547:         }
                   4548:     }
1.448     albertel 4549:     close($config);
1.227     harris41 4550: }
1.1       albertel 4551: 
1.327     albertel 4552: # ------------------------------------------------------------ Read domain file
                   4553: {
                   4554:     %domaindescription = ();
                   4555:     %domain_auth_def = ();
                   4556:     %domain_auth_arg_def = ();
1.448     albertel 4557:     my $fh;
                   4558:     if (open($fh,"<".$Apache::lonnet::perlvar{'lonTabDir'}.'/domain.tab')) {
1.327     albertel 4559:        while (<$fh>) {
1.390     matthew  4560:            next if (/^(\#|\s*$)/);
                   4561: #           next if /^\#/;
1.327     albertel 4562:            chomp;
1.403     www      4563:            my ($domain, $domain_description, $def_auth, $def_auth_arg,
                   4564: 	       $def_lang, $city, $longi, $lati) = split(/:/,$_);
                   4565: 	   $domain_auth_def{$domain}=$def_auth;
1.327     albertel 4566:            $domain_auth_arg_def{$domain}=$def_auth_arg;
1.403     www      4567: 	   $domaindescription{$domain}=$domain_description;
                   4568: 	   $domain_lang_def{$domain}=$def_lang;
                   4569: 	   $domain_city{$domain}=$city;
                   4570: 	   $domain_longi{$domain}=$longi;
                   4571: 	   $domain_lati{$domain}=$lati;
                   4572: 
1.448     albertel 4573:  #         &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}");
1.327     albertel 4574: #          &logthis("Domain.tab: $domain ".$domaindescription{$domain} );
1.448     albertel 4575: 	}
1.327     albertel 4576:     }
1.448     albertel 4577:     close ($fh);
1.327     albertel 4578: }
                   4579: 
                   4580: 
1.1       albertel 4581: # ------------------------------------------------------------- Read hosts file
                   4582: {
1.448     albertel 4583:     open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
1.1       albertel 4584: 
                   4585:     while (my $configline=<$config>) {
1.303     matthew  4586:        next if ($configline =~ /^(\#|\s*$)/);
1.154     www      4587:        chomp($configline);
1.245     www      4588:        my ($id,$domain,$role,$name,$ip,$domdescr)=split(/:/,$configline);
1.252     albertel 4589:        if ($id && $domain && $role && $name && $ip) {
                   4590: 	 $hostname{$id}=$name;
                   4591: 	 $hostdom{$id}=$domain;
                   4592: 	 $hostip{$id}=$ip;
1.300     albertel 4593: 	 $iphost{$ip}=$id;
1.252     albertel 4594: 	 if ($role eq 'library') { $libserv{$id}=$name; }
                   4595:        } else {
                   4596: 	 if ($configline) {
                   4597: 	   &logthis("Skipping hosts.tab line -$configline-");
                   4598: 	 }
1.245     www      4599:        }
1.1       albertel 4600:     }
1.448     albertel 4601:     close($config);
1.1       albertel 4602: }
                   4603: 
                   4604: # ------------------------------------------------------ Read spare server file
                   4605: {
1.448     albertel 4606:     open(my $config,"<$perlvar{'lonTabDir'}/spare.tab");
1.1       albertel 4607: 
                   4608:     while (my $configline=<$config>) {
                   4609:        chomp($configline);
1.284     matthew  4610:        if ($configline) {
1.1       albertel 4611:           $spareid{$configline}=1;
                   4612:        }
                   4613:     }
1.448     albertel 4614:     close($config);
1.1       albertel 4615: }
1.11      www      4616: # ------------------------------------------------------------ Read permissions
                   4617: {
1.448     albertel 4618:     open(my $config,"<$perlvar{'lonTabDir'}/roles.tab");
1.11      www      4619: 
                   4620:     while (my $configline=<$config>) {
1.448     albertel 4621: 	chomp($configline);
                   4622: 	if ($configline) {
                   4623: 	    my ($role,$perm)=split(/ /,$configline);
                   4624: 	    if ($perm ne '') { $pr{$role}=$perm; }
                   4625: 	}
1.11      www      4626:     }
1.448     albertel 4627:     close($config);
1.11      www      4628: }
                   4629: 
                   4630: # -------------------------------------------- Read plain texts for permissions
                   4631: {
1.448     albertel 4632:     open(my $config,"<$perlvar{'lonTabDir'}/rolesplain.tab");
1.11      www      4633: 
                   4634:     while (my $configline=<$config>) {
1.448     albertel 4635: 	chomp($configline);
                   4636: 	if ($configline) {
                   4637: 	    my ($short,$plain)=split(/:/,$configline);
                   4638: 	    if ($plain ne '') { $prp{$short}=$plain; }
                   4639: 	}
1.135     www      4640:     }
1.448     albertel 4641:     close($config);
1.135     www      4642: }
                   4643: 
                   4644: # ---------------------------------------------------------- Read package table
                   4645: {
1.448     albertel 4646:     open(my $config,"<$perlvar{'lonTabDir'}/packages.tab");
1.135     www      4647: 
                   4648:     while (my $configline=<$config>) {
1.448     albertel 4649: 	chomp($configline);
                   4650: 	my ($short,$plain)=split(/:/,$configline);
                   4651: 	my ($pack,$name)=split(/\&/,$short);
                   4652: 	if ($plain ne '') {
                   4653: 	    $packagetab{$pack.'&'.$name.'&name'}=$name; 
                   4654: 	    $packagetab{$short}=$plain; 
                   4655: 	}
1.11      www      4656:     }
1.448     albertel 4657:     close($config);
1.329     matthew  4658: }
                   4659: 
                   4660: # ------------- set up temporary directory
                   4661: {
                   4662:     $tmpdir = $perlvar{'lonDaemons'}.'/tmp/';
                   4663: 
1.11      www      4664: }
                   4665: 
1.71      www      4666: %metacache=();
1.185     www      4667: 
1.281     www      4668: $processmarker='_'.time.'_'.$perlvar{'lonHostID'};
1.186     www      4669: $dumpcount=0;
1.22      www      4670: 
1.163     harris41 4671: &logtouch();
1.12      www      4672: &logthis('<font color=yellow>INFO: Read configuration</font>');
1.195     www      4673: $readit=1;
                   4674: }
1.1       albertel 4675: }
1.179     www      4676: 
1.1       albertel 4677: 1;
1.191     harris41 4678: __END__
                   4679: 
1.243     albertel 4680: =pod
                   4681: 
1.191     harris41 4682: =head1 NAME
                   4683: 
1.243     albertel 4684: Apache::lonnet - Subroutines to ask questions about things in the network.
1.191     harris41 4685: 
                   4686: =head1 SYNOPSIS
                   4687: 
1.243     albertel 4688: Invoked by other LON-CAPA modules, when they need to talk to or about objects in the network.
1.191     harris41 4689: 
                   4690:  &Apache::lonnet::SUBROUTINENAME(ARGUMENTS);
                   4691: 
1.243     albertel 4692: Common parameters:
                   4693: 
                   4694: =over 4
                   4695: 
                   4696: =item *
                   4697: 
                   4698: $uname : an internal username (if $cname expecting a course Id specifically)
                   4699: 
                   4700: =item *
                   4701: 
                   4702: $udom : a domain (if $cdom expecting a course's domain specifically)
                   4703: 
                   4704: =item *
                   4705: 
                   4706: $symb : a resource instance identifier
                   4707: 
                   4708: =item *
                   4709: 
                   4710: $namespace : the name of a .db file that contains the data needed or
                   4711: being set.
                   4712: 
                   4713: =back
                   4714: 
1.394     bowersj2 4715: =head1 OVERVIEW
1.191     harris41 4716: 
1.394     bowersj2 4717: lonnet provides subroutines which interact with the
                   4718: lonc/lond (TCP) network layer of LON-CAPA. They can be used to ask
                   4719: about classes, users, and resources.
1.243     albertel 4720: 
                   4721: For many of these objects you can also use this to store data about
                   4722: them or modify them in various ways.
1.191     harris41 4723: 
1.394     bowersj2 4724: =head2 Symbs
1.191     harris41 4725: 
1.394     bowersj2 4726: To identify a specific instance of a resource, LON-CAPA uses symbols
                   4727: or "symbs"X<symb>. These identifiers are built from the URL of the
                   4728: map, the resource number of the resource in the map, and the URL of
                   4729: the resource itself. The latter is somewhat redundant, but might help
                   4730: if maps change.
                   4731: 
                   4732: An example is
                   4733: 
                   4734:  msu/korte/parts/part1.sequence___19___msu/korte/tests/part12.problem
                   4735: 
                   4736: The respective map entry is
                   4737: 
                   4738:  <resource id="19" src="/res/msu/korte/tests/part12.problem"
                   4739:   title="Problem 2">
                   4740:  </resource>
                   4741: 
                   4742: Symbs are used by the random number generator, as well as to store and
                   4743: restore data specific to a certain instance of for example a problem.
                   4744: 
                   4745: =head2 Storing And Retrieving Data
                   4746: 
                   4747: X<store()>X<cstore()>X<restore()>Three of the most important functions
                   4748: in C<lonnet.pm> are C<&Apache::lonnet::cstore()>,
                   4749: C<&Apache::lonnet:restore()>, and C<&Apache::lonnet::store()>, which
                   4750: is is the non-critical message twin of cstore. These functions are for
                   4751: handlers to store a perl hash to a user's permanent data space in an
                   4752: easy manner, and to retrieve it again on another call. It is expected
                   4753: that a handler would use this once at the beginning to retrieve data,
                   4754: and then again once at the end to send only the new data back.
                   4755: 
                   4756: The data is stored in the user's data directory on the user's
                   4757: homeserver under the ID of the course.
                   4758: 
                   4759: The hash that is returned by restore will have all of the previous
                   4760: value for all of the elements of the hash.
                   4761: 
                   4762: Example:
                   4763: 
                   4764:  #creating a hash
                   4765:  my %hash;
                   4766:  $hash{'foo'}='bar';
                   4767: 
                   4768:  #storing it
                   4769:  &Apache::lonnet::cstore(\%hash);
                   4770: 
                   4771:  #changing a value
                   4772:  $hash{'foo'}='notbar';
                   4773: 
                   4774:  #adding a new value
                   4775:  $hash{'bar'}='foo';
                   4776:  &Apache::lonnet::cstore(\%hash);
                   4777: 
                   4778:  #retrieving the hash
                   4779:  my %history=&Apache::lonnet::restore();
                   4780: 
                   4781:  #print the hash
                   4782:  foreach my $key (sort(keys(%history))) {
                   4783:    print("\%history{$key} = $history{$key}");
                   4784:  }
                   4785: 
                   4786: Will print out:
1.191     harris41 4787: 
1.394     bowersj2 4788:  %history{1:foo} = bar
                   4789:  %history{1:keys} = foo:timestamp
                   4790:  %history{1:timestamp} = 990455579
                   4791:  %history{2:bar} = foo
                   4792:  %history{2:foo} = notbar
                   4793:  %history{2:keys} = foo:bar:timestamp
                   4794:  %history{2:timestamp} = 990455580
                   4795:  %history{bar} = foo
                   4796:  %history{foo} = notbar
                   4797:  %history{timestamp} = 990455580
                   4798:  %history{version} = 2
                   4799: 
                   4800: Note that the special hash entries C<keys>, C<version> and
                   4801: C<timestamp> were added to the hash. C<version> will be equal to the
                   4802: total number of versions of the data that have been stored. The
                   4803: C<timestamp> attribute will be the UNIX time the hash was
                   4804: stored. C<keys> is available in every historical section to list which
                   4805: keys were added or changed at a specific historical revision of a
                   4806: hash.
                   4807: 
                   4808: B<Warning>: do not store the hash that restore returns directly. This
                   4809: will cause a mess since it will restore the historical keys as if the
                   4810: were new keys. I.E. 1:foo will become 1:1:foo etc.
1.191     harris41 4811: 
1.394     bowersj2 4812: Calling convention:
1.191     harris41 4813: 
1.394     bowersj2 4814:  my %record=&Apache::lonnet::restore($symb,$courseid,$domain,$uname,$home);
                   4815:  &Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname,$home);
1.191     harris41 4816: 
1.394     bowersj2 4817: For more detailed information, see lonnet specific documentation.
1.191     harris41 4818: 
1.394     bowersj2 4819: =head1 RETURN MESSAGES
1.191     harris41 4820: 
1.394     bowersj2 4821: =over 4
1.191     harris41 4822: 
1.394     bowersj2 4823: =item * B<con_lost>: unable to contact remote host
1.191     harris41 4824: 
1.394     bowersj2 4825: =item * B<con_delayed>: unable to contact remote host, message will be delivered
                   4826: when the connection is brought back up
1.191     harris41 4827: 
1.394     bowersj2 4828: =item * B<con_failed>: unable to contact remote host and unable to save message
                   4829: for later delivery
1.191     harris41 4830: 
1.394     bowersj2 4831: =item * B<error:>: an error a occured, a description of the error follows the :
1.191     harris41 4832: 
1.394     bowersj2 4833: =item * B<no_such_host>: unable to fund a host associated with the user/domain
1.243     albertel 4834: that was requested
1.191     harris41 4835: 
1.243     albertel 4836: =back
1.191     harris41 4837: 
1.243     albertel 4838: =head1 PUBLIC SUBROUTINES
1.191     harris41 4839: 
1.243     albertel 4840: =head2 Session Environment Functions
1.191     harris41 4841: 
1.243     albertel 4842: =over 4
1.191     harris41 4843: 
1.394     bowersj2 4844: =item * 
                   4845: X<appenv()>
                   4846: B<appenv(%hash)>: the value of %hash is written to
                   4847: the user envirnoment file, and will be restored for each access this
                   4848: user makes during this session, also modifies the %ENV for the current
                   4849: process
1.191     harris41 4850: 
                   4851: =item *
1.394     bowersj2 4852: X<delenv()>
                   4853: B<delenv($regexp)>: removes all items from the session
                   4854: environment file that matches the regular expression in $regexp. The
                   4855: values are also delted from the current processes %ENV.
1.191     harris41 4856: 
1.243     albertel 4857: =back
                   4858: 
                   4859: =head2 User Information
1.191     harris41 4860: 
1.243     albertel 4861: =over 4
1.191     harris41 4862: 
                   4863: =item *
1.394     bowersj2 4864: X<queryauthenticate()>
                   4865: B<queryauthenticate($uname,$udom)>: try to determine user's current 
1.191     harris41 4866: authentication scheme
                   4867: 
                   4868: =item *
1.394     bowersj2 4869: X<authenticate()>
                   4870: B<authenticate($uname,$upass,$udom)>: try to
                   4871: authenticate user from domain's lib servers (first use the current
                   4872: one). C<$upass> should be the users password.
1.191     harris41 4873: 
                   4874: =item *
1.394     bowersj2 4875: X<homeserver()>
                   4876: B<homeserver($uname,$udom)>: find the server which has
                   4877: the user's directory and files (there must be only one), this caches
                   4878: the answer, and also caches if there is a borken connection.
1.191     harris41 4879: 
                   4880: =item *
1.394     bowersj2 4881: X<idget()>
                   4882: B<idget($udom,@ids)>: find the usernames behind a list of IDs
                   4883: (IDs are a unique resource in a domain, there must be only 1 ID per
                   4884: username, and only 1 username per ID in a specific domain) (returns
                   4885: hash: id=>name,id=>name)
1.191     harris41 4886: 
                   4887: =item *
1.394     bowersj2 4888: X<idrget()>
                   4889: B<idrget($udom,@unames)>: find the IDs behind a list of
                   4890: usernames (returns hash: name=>id,name=>id)
1.191     harris41 4891: 
                   4892: =item *
1.394     bowersj2 4893: X<idput()>
                   4894: B<idput($udom,%ids)>: store away a list of names and associated IDs
1.191     harris41 4895: 
                   4896: =item *
1.394     bowersj2 4897: X<rolesinit()>
                   4898: B<rolesinit($udom,$username,$authhost)>: get user privileges
1.243     albertel 4899: 
                   4900: =item *
1.394     bowersj2 4901: X<usection()>
                   4902: B<usection($udom,$uname,$cname)>: finds the section of student in the
1.243     albertel 4903: course $cname, return section name/number or '' for "not in course"
                   4904: and '-1' for "no section"
                   4905: 
                   4906: =item *
1.394     bowersj2 4907: X<userenvironment()>
                   4908: B<userenvironment($udom,$uname,@what)>: gets the values of the keys
1.243     albertel 4909: passed in @what from the requested user's environment, returns a hash
                   4910: 
                   4911: =back
                   4912: 
                   4913: =head2 User Roles
                   4914: 
                   4915: =over 4
                   4916: 
                   4917: =item *
                   4918: 
                   4919: allowed($priv,$uri) : check for a user privilege; returns codes for allowed
                   4920: actions
                   4921:  F: full access
                   4922:  U,I,K: authentication modes (cxx only)
                   4923:  '': forbidden
                   4924:  1: user needs to choose course
                   4925:  2: browse allowed
                   4926: 
                   4927: =item *
                   4928: 
                   4929: definerole($rolename,$sysrole,$domrole,$courole) : define role; define a custom
                   4930: role rolename set privileges in format of lonTabs/roles.tab for system, domain,
                   4931: and course level
                   4932: 
                   4933: =item *
                   4934: 
                   4935: plaintext($short) : return value in %prp hash (rolesplain.tab); plain text
                   4936: explanation of a user role term
                   4937: 
                   4938: =back
                   4939: 
                   4940: =head2 User Modification
                   4941: 
                   4942: =over 4
                   4943: 
                   4944: =item *
                   4945: 
                   4946: assignrole($udom,$uname,$url,$role,$end,$start) : assign role; give a role to a
                   4947: user for the level given by URL.  Optional start and end dates (leave empty
                   4948: string or zero for "no date")
1.191     harris41 4949: 
                   4950: =item *
                   4951: 
1.243     albertel 4952: changepass($uname,$udom,$currentpass,$newpass,$server) : attempts to
                   4953: change a users, password, possible return values are: ok,
                   4954: pwchange_failure, non_authorized, auth_mode_error, unknown_user,
                   4955: refused
1.191     harris41 4956: 
                   4957: =item *
                   4958: 
1.243     albertel 4959: modifyuserauth($udom,$uname,$umode,$upass) : modify user authentication
1.191     harris41 4960: 
                   4961: =item *
                   4962: 
1.243     albertel 4963: modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene) : 
                   4964: modify user
1.191     harris41 4965: 
                   4966: =item *
                   4967: 
1.286     matthew  4968: modifystudent
                   4969: 
                   4970: modify a students enrollment and identification information.
                   4971: The course id is resolved based on the current users environment.  
                   4972: This means the envoking user must be a course coordinator or otherwise
                   4973: associated with a course.
                   4974: 
1.297     matthew  4975: This call is essentially a wrapper for lonnet::modifyuser and
                   4976: lonnet::modify_student_enrollment
1.286     matthew  4977: 
                   4978: Inputs: 
                   4979: 
                   4980: =over 4
                   4981: 
                   4982: =item B<$udom> Students loncapa domain
                   4983: 
                   4984: =item B<$uname> Students loncapa login name
                   4985: 
                   4986: =item B<$uid> Students id/student number
                   4987: 
                   4988: =item B<$umode> Students authentication mode
                   4989: 
                   4990: =item B<$upass> Students password
                   4991: 
                   4992: =item B<$first> Students first name
                   4993: 
                   4994: =item B<$middle> Students middle name
                   4995: 
                   4996: =item B<$last> Students last name
                   4997: 
                   4998: =item B<$gene> Students generation
                   4999: 
                   5000: =item B<$usec> Students section in course
                   5001: 
                   5002: =item B<$end> Unix time of the roles expiration
                   5003: 
                   5004: =item B<$start> Unix time of the roles start date
                   5005: 
                   5006: =item B<$forceid> If defined, allow $uid to be changed
                   5007: 
                   5008: =item B<$desiredhome> server to use as home server for student
                   5009: 
                   5010: =back
1.297     matthew  5011: 
                   5012: =item *
                   5013: 
                   5014: modify_student_enrollment
                   5015: 
                   5016: Change a students enrollment status in a class.  The environment variable
                   5017: 'role.request.course' must be defined for this function to proceed.
                   5018: 
                   5019: Inputs:
                   5020: 
                   5021: =over 4
                   5022: 
                   5023: =item $udom, students domain
                   5024: 
                   5025: =item $uname, students name
                   5026: 
                   5027: =item $uid, students user id
                   5028: 
                   5029: =item $first, students first name
                   5030: 
                   5031: =item $middle
                   5032: 
                   5033: =item $last
                   5034: 
                   5035: =item $gene
                   5036: 
                   5037: =item $usec
                   5038: 
                   5039: =item $end
                   5040: 
                   5041: =item $start
                   5042: 
                   5043: =back
                   5044: 
1.191     harris41 5045: 
                   5046: =item *
                   5047: 
1.243     albertel 5048: assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start) : assign
                   5049: custom role; give a custom role to a user for the level given by URL.  Specify
                   5050: name and domain of role author, and role name
1.191     harris41 5051: 
                   5052: =item *
                   5053: 
1.243     albertel 5054: revokerole($udom,$uname,$url,$role) : revoke a role for url
1.191     harris41 5055: 
                   5056: =item *
                   5057: 
1.243     albertel 5058: revokecustomrole($udom,$uname,$url,$role) : revoke a custom role
                   5059: 
                   5060: =back
                   5061: 
                   5062: =head2 Course Infomation
                   5063: 
                   5064: =over 4
1.191     harris41 5065: 
                   5066: =item *
                   5067: 
1.243     albertel 5068: coursedescription($courseid) : course description
1.191     harris41 5069: 
                   5070: =item *
                   5071: 
1.243     albertel 5072: courseresdata($coursenum,$coursedomain,@which) : request for current
                   5073: parameter setting for a specific course, @what should be a list of
                   5074: parameters to ask about. This routine caches answers for 5 minutes.
                   5075: 
                   5076: =back
                   5077: 
                   5078: =head2 Course Modification
                   5079: 
                   5080: =over 4
1.191     harris41 5081: 
                   5082: =item *
                   5083: 
1.243     albertel 5084: writecoursepref($courseid,%prefs) : write preferences (environment
                   5085: database) for a course
1.191     harris41 5086: 
                   5087: =item *
                   5088: 
1.243     albertel 5089: createcourse($udom,$description,$url) : make/modify course
                   5090: 
                   5091: =back
                   5092: 
                   5093: =head2 Resource Subroutines
                   5094: 
                   5095: =over 4
1.191     harris41 5096: 
                   5097: =item *
                   5098: 
1.243     albertel 5099: subscribe($fname) : subscribe to a resource, returns URL if possible (probably should use repcopy instead)
1.191     harris41 5100: 
                   5101: =item *
                   5102: 
1.243     albertel 5103: repcopy($filename) : subscribes to the requested file, and attempts to
                   5104: replicate from the owning library server, Might return
                   5105: HTTP_SERVICE_UNAVAILABLE, HTTP_NOT_FOUND, FORBIDDEN, OK, or
                   5106: HTTP_BAD_REQUEST, also attempts to grab the metadata for the
                   5107: resource. Expects the local filesystem pathname
                   5108: (/home/httpd/html/res/....)
                   5109: 
                   5110: =back
                   5111: 
                   5112: =head2 Resource Information
                   5113: 
                   5114: =over 4
1.191     harris41 5115: 
                   5116: =item *
                   5117: 
1.243     albertel 5118: EXT($varname,$symb,$udom,$uname) : evaluates and returns the value of
                   5119: a vairety of different possible values, $varname should be a request
                   5120: string, and the other parameters can be used to specify who and what
                   5121: one is asking about.
                   5122: 
                   5123: Possible values for $varname are environment.lastname (or other item
                   5124: from the envirnment hash), user.name (or someother aspect about the
                   5125: user), resource.0.maxtries (or some other part and parameter of a
                   5126: resource)
1.204     albertel 5127: 
                   5128: =item *
                   5129: 
1.243     albertel 5130: directcondval($number) : get current value of a condition; reads from a state
                   5131: string
1.204     albertel 5132: 
                   5133: =item *
                   5134: 
1.243     albertel 5135: condval($condidx) : value of condition index based on state
1.204     albertel 5136: 
                   5137: =item *
                   5138: 
1.243     albertel 5139: metadata($uri,$what,$liburi,$prefix,$depthcount) : request a
                   5140: resource's metadata, $what should be either a specific key, or either
                   5141: 'keys' (to get a list of possible keys) or 'packages' to get a list of
                   5142: packages that this resource currently uses, the last 3 arguments are only used internally for recursive metadata.
                   5143: 
                   5144: this function automatically caches all requests
1.191     harris41 5145: 
                   5146: =item *
                   5147: 
1.243     albertel 5148: metadata_query($query,$custom,$customshow) : make a metadata query against the
                   5149: network of library servers; returns file handle of where SQL and regex results
                   5150: will be stored for query
1.191     harris41 5151: 
                   5152: =item *
                   5153: 
1.243     albertel 5154: symbread($filename) : return symbolic list entry (filename argument optional);
                   5155: returns the data handle
1.191     harris41 5156: 
                   5157: =item *
                   5158: 
1.243     albertel 5159: symbverify($symb,$thisfn) : verifies that $symb actually exists and is
                   5160: a possible symb for the URL in $thisfn, returns a 1 on success, 0 on
                   5161: failure, user must be in a course, as it assumes the existance of the
                   5162: course initi hash, and uses $ENV('request.course.id'}
                   5163: 
1.191     harris41 5164: 
                   5165: =item *
                   5166: 
1.243     albertel 5167: symbclean($symb) : removes versions numbers from a symb, returns the
                   5168: cleaned symb
1.191     harris41 5169: 
                   5170: =item *
                   5171: 
1.243     albertel 5172: is_on_map($uri) : checks if the $uri is somewhere on the current
                   5173: course map, user must be in a course for it to work.
1.191     harris41 5174: 
                   5175: =item *
                   5176: 
1.243     albertel 5177: numval($salt) : return random seed value (addend for rndseed)
1.191     harris41 5178: 
                   5179: =item *
                   5180: 
1.243     albertel 5181: rndseed($symb,$courseid,$udom,$uname) : create a random sum; returns
                   5182: a random seed, all arguments are optional, if they aren't sent it uses the
                   5183: environment to derive them. Note: if symb isn't sent and it can't get one
                   5184: from &symbread it will use the current time as its return value
1.191     harris41 5185: 
                   5186: =item *
                   5187: 
1.243     albertel 5188: ireceipt($funame,$fudom,$fucourseid,$fusymb) : return unique,
                   5189: unfakeable, receipt
1.191     harris41 5190: 
                   5191: =item *
                   5192: 
1.243     albertel 5193: receipt() : API to ireceipt working off of ENV values; given out to users
1.191     harris41 5194: 
                   5195: =item *
                   5196: 
1.243     albertel 5197: countacc($url) : count the number of accesses to a given URL
1.191     harris41 5198: 
                   5199: =item *
                   5200: 
1.243     albertel 5201: 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
1.191     harris41 5202: 
                   5203: =item *
                   5204: 
1.243     albertel 5205: 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)
1.191     harris41 5206: 
                   5207: =item *
                   5208: 
1.243     albertel 5209: expirespread($uname,$udom,$stype,$usymb) : set expire date for spreadsheet
1.191     harris41 5210: 
                   5211: =item *
                   5212: 
1.243     albertel 5213: devalidate($symb) : devalidate temporary spreadsheet calculations,
                   5214: forcing spreadsheet to reevaluate the resource scores next time.
                   5215: 
                   5216: =back
                   5217: 
                   5218: =head2 Storing/Retreiving Data
                   5219: 
                   5220: =over 4
1.191     harris41 5221: 
                   5222: =item *
                   5223: 
1.243     albertel 5224: store($storehash,$symb,$namespace,$udom,$uname) : stores hash permanently
                   5225: for this url; hashref needs to be given and should be a \%hashname; the
                   5226: remaining args aren't required and if they aren't passed or are '' they will
                   5227: be derived from the ENV
1.191     harris41 5228: 
                   5229: =item *
                   5230: 
1.243     albertel 5231: cstore($storehash,$symb,$namespace,$udom,$uname) : same as store but
                   5232: uses critical subroutine
1.191     harris41 5233: 
                   5234: =item *
                   5235: 
1.243     albertel 5236: restore($symb,$namespace,$udom,$uname) : returns hash for this symb;
                   5237: all args are optional
1.191     harris41 5238: 
                   5239: =item *
                   5240: 
1.243     albertel 5241: tmpstore($storehash,$symb,$namespace,$udom,$uname) : storage that
                   5242: works very similar to store/cstore, but all data is stored in a
                   5243: temporary location and can be reset using tmpreset, $storehash should
                   5244: be a hash reference, returns nothing on success
1.191     harris41 5245: 
                   5246: =item *
                   5247: 
1.243     albertel 5248: tmprestore($symb,$namespace,$udom,$uname) : storage that works very
                   5249: similar to restore, but all data is stored in a temporary location and
                   5250: can be reset using tmpreset. Returns a hash of values on success,
                   5251: error string otherwise.
1.191     harris41 5252: 
                   5253: =item *
                   5254: 
1.243     albertel 5255: tmpreset($symb,$namespace,$udom,$uname) : temporary storage reset,
                   5256: deltes all keys for $symb form the temporary storage hash.
1.191     harris41 5257: 
                   5258: =item *
                   5259: 
1.243     albertel 5260: get($namespace,$storearr,$udom,$uname) : returns hash with keys from array
                   5261: reference filled in from namesp ($udom and $uname are optional)
1.191     harris41 5262: 
                   5263: =item *
                   5264: 
1.243     albertel 5265: del($namespace,$storearr,$udom,$uname) : deletes keys out of array from
                   5266: namesp ($udom and $uname are optional)
1.191     harris41 5267: 
                   5268: =item *
                   5269: 
1.243     albertel 5270: dump($namespace,$udom,$uname,$regexp) : 
                   5271: dumps the complete (or key matching regexp) namespace into a hash
                   5272: ($udom, $uname and $regexp are optional)
1.449     matthew  5273: 
                   5274: =item *
                   5275: 
                   5276: inc($namespace,$store,$udom,$uname) : increments $store in $namespace.
                   5277: $store can be a scalar, an array reference, or if the amount to be 
                   5278: incremented is > 1, a hash reference.
                   5279: 
                   5280: ($udom and $uname are optional)
1.191     harris41 5281: 
                   5282: =item *
                   5283: 
1.243     albertel 5284: put($namespace,$storehash,$udom,$uname) : stores hash in namesp
                   5285: ($udom and $uname are optional)
1.191     harris41 5286: 
                   5287: =item *
                   5288: 
1.243     albertel 5289: cput($namespace,$storehash,$udom,$uname) : critical put
                   5290: ($udom and $uname are optional)
1.191     harris41 5291: 
                   5292: =item *
                   5293: 
1.243     albertel 5294: eget($namespace,$storearr,$udom,$uname) : returns hash with keys from array
                   5295: reference filled in from namesp (encrypts the return communication)
                   5296: ($udom and $uname are optional)
1.191     harris41 5297: 
                   5298: =item *
                   5299: 
1.243     albertel 5300: log($udom,$name,$home,$message) : write to permanent log for user; use
                   5301: critical subroutine
                   5302: 
                   5303: =back
                   5304: 
                   5305: =head2 Network Status Functions
                   5306: 
                   5307: =over 4
1.191     harris41 5308: 
                   5309: =item *
                   5310: 
                   5311: dirlist($uri) : return directory list based on URI
                   5312: 
                   5313: =item *
                   5314: 
1.243     albertel 5315: spareserver() : find server with least workload from spare.tab
                   5316: 
                   5317: =back
                   5318: 
                   5319: =head2 Apache Request
                   5320: 
                   5321: =over 4
1.191     harris41 5322: 
                   5323: =item *
                   5324: 
1.243     albertel 5325: ssi($url,%hash) : server side include, does a complete request cycle on url to
                   5326: localhost, posts hash
                   5327: 
                   5328: =back
                   5329: 
                   5330: =head2 Data to String to Data
                   5331: 
                   5332: =over 4
1.191     harris41 5333: 
                   5334: =item *
                   5335: 
1.243     albertel 5336: hash2str(%hash) : convert a hash into a string complete with escaping and '='
                   5337: and '&' separators, supports elements that are arrayrefs and hashrefs
1.191     harris41 5338: 
                   5339: =item *
                   5340: 
1.243     albertel 5341: hashref2str($hashref) : convert a hashref into a string complete with
                   5342: escaping and '=' and '&' separators, supports elements that are
                   5343: arrayrefs and hashrefs
1.191     harris41 5344: 
                   5345: =item *
                   5346: 
1.243     albertel 5347: arrayref2str($arrayref) : convert an arrayref into a string complete
                   5348: with escaping and '&' separators, supports elements that are arrayrefs
                   5349: and hashrefs
1.191     harris41 5350: 
                   5351: =item *
                   5352: 
1.243     albertel 5353: str2hash($string) : convert string to hash using unescaping and
                   5354: splitting on '=' and '&', supports elements that are arrayrefs and
                   5355: hashrefs
1.191     harris41 5356: 
                   5357: =item *
                   5358: 
1.243     albertel 5359: str2array($string) : convert string to hash using unescaping and
                   5360: splitting on '&', supports elements that are arrayrefs and hashrefs
                   5361: 
                   5362: =back
                   5363: 
                   5364: =head2 Logging Routines
                   5365: 
                   5366: =over 4
                   5367: 
                   5368: These routines allow one to make log messages in the lonnet.log and
                   5369: lonnet.perm logfiles.
1.191     harris41 5370: 
                   5371: =item *
                   5372: 
1.243     albertel 5373: logtouch() : make sure the logfile, lonnet.log, exists
1.191     harris41 5374: 
                   5375: =item *
                   5376: 
1.243     albertel 5377: logthis() : append message to the normal lonnet.log file, it gets
                   5378: preiodically rolled over and deleted.
1.191     harris41 5379: 
                   5380: =item *
                   5381: 
1.243     albertel 5382: logperm() : append a permanent message to lonnet.perm.log, this log
                   5383: file never gets deleted by any automated portion of the system, only
                   5384: messages of critical importance should go in here.
                   5385: 
                   5386: =back
                   5387: 
                   5388: =head2 General File Helper Routines
                   5389: 
                   5390: =over 4
1.191     harris41 5391: 
                   5392: =item *
                   5393: 
1.243     albertel 5394: getfile($file) : returns the entire contents of a file or -1; it
                   5395: properly subscribes to and replicates the file if neccessary.
1.191     harris41 5396: 
                   5397: =item *
                   5398: 
1.243     albertel 5399: filelocation($dir,$file) : returns file system location of a file
                   5400: based on URI; meant to be "fairly clean" absolute reference, $dir is a
                   5401: directory that relative $file lookups are to looked in ($dir of /a/dir
                   5402: and a file of ../bob will become /a/bob)
1.191     harris41 5403: 
                   5404: =item *
                   5405: 
                   5406: hreflocation($dir,$file) : returns file system location or a URL; same as
                   5407: filelocation except for hrefs
                   5408: 
                   5409: =item *
                   5410: 
                   5411: declutter() : declutters URLs (remove docroot, beginning slashes, 'res' etc)
                   5412: 
1.243     albertel 5413: =back
                   5414: 
                   5415: =head2 HTTP Helper Routines
                   5416: 
                   5417: =over 4
                   5418: 
1.191     harris41 5419: =item *
                   5420: 
                   5421: escape() : unpack non-word characters into CGI-compatible hex codes
                   5422: 
                   5423: =item *
                   5424: 
                   5425: unescape() : pack CGI-compatible hex codes into actual non-word ASCII character
                   5426: 
1.243     albertel 5427: =back
                   5428: 
                   5429: =head1 PRIVATE SUBROUTINES
                   5430: 
                   5431: =head2 Underlying communication routines (Shouldn't call)
                   5432: 
                   5433: =over 4
                   5434: 
                   5435: =item *
                   5436: 
                   5437: subreply() : tries to pass a message to lonc, returns con_lost if incapable
                   5438: 
                   5439: =item *
                   5440: 
                   5441: reply() : uses subreply to send a message to remote machine, logs all failures
                   5442: 
                   5443: =item *
                   5444: 
                   5445: critical() : passes a critical message to another server; if cannot
                   5446: get through then place message in connection buffer directory and
                   5447: returns con_delayed, if incapable of saving message, returns
                   5448: con_failed
                   5449: 
                   5450: =item *
                   5451: 
                   5452: reconlonc() : tries to reconnect lonc client processes.
                   5453: 
                   5454: =back
                   5455: 
                   5456: =head2 Resource Access Logging
                   5457: 
                   5458: =over 4
                   5459: 
                   5460: =item *
                   5461: 
                   5462: flushcourselogs() : flush (save) buffer logs and access logs
                   5463: 
                   5464: =item *
                   5465: 
                   5466: courselog($what) : save message for course in hash
                   5467: 
                   5468: =item *
                   5469: 
                   5470: courseacclog($what) : save message for course using &courselog().  Perform
                   5471: special processing for specific resource types (problems, exams, quizzes, etc).
                   5472: 
1.191     harris41 5473: =item *
                   5474: 
                   5475: goodbye() : flush course logs and log shutting down; it is called in srm.conf
                   5476: as a PerlChildExitHandler
1.243     albertel 5477: 
                   5478: =back
                   5479: 
                   5480: =head2 Other
                   5481: 
                   5482: =over 4
                   5483: 
                   5484: =item *
                   5485: 
                   5486: symblist($mapname,%newhash) : update symbolic storage links
1.191     harris41 5487: 
                   5488: =back
                   5489: 
                   5490: =cut

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