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

1.1       albertel    1: # The LearningOnline Network
                      2: # TCP networking package
1.12      www         3: #
1.864   ! albertel    4: # $Id: lonnet.pm,v 1.863 2007/04/04 00:10:15 albertel 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.486     www        35: use HTTP::Date;
                     36: # use Date::Parse;
1.11      www        37: use vars 
1.847     albertel   38: qw(%perlvar %badServerCache %spareid 
1.845     albertel   39:    %pr %prp $memcache %packagetab 
1.662     raeburn    40:    %courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount 
1.741     raeburn    41:    %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %coursetypebuf
1.685     raeburn    42:    $tmpdir $_64bit %env);
1.403     www        43: 
1.1       albertel   44: use IO::Socket;
1.31      www        45: use GDBM_File;
1.208     albertel   46: use HTML::LCParser;
1.637     raeburn    47: use HTML::Parser;
1.88      www        48: use Fcntl qw(:flock);
1.557     albertel   49: use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze);
1.539     albertel   50: use Time::HiRes qw( gettimeofday tv_interval );
1.599     albertel   51: use Cache::Memcached;
1.676     albertel   52: use Digest::MD5;
1.790     albertel   53: use Math::Random;
1.807     albertel   54: use LONCAPA qw(:DEFAULT :match);
1.740     www        55: use LONCAPA::Configuration;
1.676     albertel   56: 
1.195     www        57: my $readit;
1.550     foxr       58: my $max_connection_retries = 10;     # Or some such value.
1.1       albertel   59: 
1.619     albertel   60: require Exporter;
                     61: 
                     62: our @ISA = qw (Exporter);
                     63: our @EXPORT = qw(%env);
                     64: 
1.449     matthew    65: =pod
                     66: 
                     67: =head1 Package Variables
                     68: 
                     69: These are largely undocumented, so if you decipher one please note it here.
                     70: 
                     71: =over 4
                     72: 
                     73: =item $processmarker
                     74: 
                     75: Contains the time this process was started and this servers host id.
                     76: 
                     77: =item $dumpcount
                     78: 
                     79: Counts the number of times a message log flush has been attempted (regardless
                     80: of success) by this process.  Used as part of the filename when messages are
                     81: delayed.
                     82: 
                     83: =back
                     84: 
                     85: =cut
                     86: 
                     87: 
1.1       albertel   88: # --------------------------------------------------------------------- Logging
1.729     www        89: {
                     90:     my $logid;
                     91:     sub instructor_log {
                     92: 	my ($hash_name,$storehash,$delflag,$uname,$udom)=@_;
                     93: 	$logid++;
                     94: 	my $id=time().'00000'.$$.'00000'.$logid;
                     95: 	return &Apache::lonnet::put('nohist_'.$hash_name,
1.730     www        96: 				    { $id => {
                     97: 					'exe_uname' => $env{'user.name'},
                     98: 					'exe_udom'  => $env{'user.domain'},
                     99: 					'exe_time'  => time(),
                    100: 					'exe_ip'    => $ENV{'REMOTE_ADDR'},
                    101: 					'delflag'   => $delflag,
                    102: 					'logentry'  => $storehash,
                    103: 					'uname'     => $uname,
                    104: 					'udom'      => $udom,
                    105: 				    }
                    106: 				  },
1.729     www       107: 				    $env{'course.'.$env{'request.course.id'}.'.domain'},
                    108: 				    $env{'course.'.$env{'request.course.id'}.'.num'}
                    109: 				    );
                    110:     }
                    111: }
1.1       albertel  112: 
1.163     harris41  113: sub logtouch {
                    114:     my $execdir=$perlvar{'lonDaemons'};
1.448     albertel  115:     unless (-e "$execdir/logs/lonnet.log") {	
                    116: 	open(my $fh,">>$execdir/logs/lonnet.log");
1.163     harris41  117: 	close $fh;
                    118:     }
                    119:     my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3];
                    120:     chown($wwwuid,$wwwgid,$execdir.'/logs/lonnet.log');
                    121: }
                    122: 
1.1       albertel  123: sub logthis {
                    124:     my $message=shift;
                    125:     my $execdir=$perlvar{'lonDaemons'};
                    126:     my $now=time;
                    127:     my $local=localtime($now);
1.448     albertel  128:     if (open(my $fh,">>$execdir/logs/lonnet.log")) {
                    129: 	print $fh "$local ($$): $message\n";
                    130: 	close($fh);
                    131:     }
1.1       albertel  132:     return 1;
                    133: }
                    134: 
                    135: sub logperm {
                    136:     my $message=shift;
                    137:     my $execdir=$perlvar{'lonDaemons'};
                    138:     my $now=time;
                    139:     my $local=localtime($now);
1.448     albertel  140:     if (open(my $fh,">>$execdir/logs/lonnet.perm.log")) {
                    141: 	print $fh "$now:$message:$local\n";
                    142: 	close($fh);
                    143:     }
1.1       albertel  144:     return 1;
                    145: }
                    146: 
1.850     albertel  147: sub create_connection {
1.853     albertel  148:     my ($hostname,$lonid) = @_;
1.851     albertel  149:     my $client=IO::Socket::UNIX->new(Peer    => $perlvar{'lonSockCreate'},
1.850     albertel  150: 				     Type    => SOCK_STREAM,
                    151: 				     Timeout => 10);
                    152:     return 0 if (!$client);
1.854     albertel  153:     print $client (join(':',$hostname,$lonid,&machine_ids($lonid))."\n");
1.850     albertel  154:     my $result = <$client>;
                    155:     chomp($result);
                    156:     return 1 if ($result eq 'done');
                    157:     return 0;
                    158: }
                    159: 
                    160: 
1.1       albertel  161: # -------------------------------------------------- Non-critical communication
                    162: sub subreply {
                    163:     my ($cmd,$server)=@_;
1.838     albertel  164:     my $peerfile="$perlvar{'lonSockDir'}/".&hostname($server);
1.549     foxr      165:     #
                    166:     #  With loncnew process trimming, there's a timing hole between lonc server
                    167:     #  process exit and the master server picking up the listen on the AF_UNIX
                    168:     #  socket.  In that time interval, a lock file will exist:
                    169: 
                    170:     my $lockfile=$peerfile.".lock";
                    171:     while (-e $lockfile) {	# Need to wait for the lockfile to disappear.
                    172: 	sleep(1);
                    173:     }
                    174:     # At this point, either a loncnew parent is listening or an old lonc
1.550     foxr      175:     # or loncnew child is listening so we can connect or everything's dead.
1.549     foxr      176:     #
1.550     foxr      177:     #   We'll give the connection a few tries before abandoning it.  If
                    178:     #   connection is not possible, we'll con_lost back to the client.
                    179:     #   
                    180:     my $client;
                    181:     for (my $retries = 0; $retries < $max_connection_retries; $retries++) {
                    182: 	$client=IO::Socket::UNIX->new(Peer    =>"$peerfile",
                    183: 				      Type    => SOCK_STREAM,
                    184: 				      Timeout => 10);
                    185: 	if($client) {
                    186: 	    last;		# Connected!
1.850     albertel  187: 	} else {
1.853     albertel  188: 	    &create_connection(&hostname($server),$server);
1.550     foxr      189: 	}
1.850     albertel  190:         sleep(1);		# Try again later if failed connection.
1.550     foxr      191:     }
                    192:     my $answer;
                    193:     if ($client) {
1.704     albertel  194: 	print $client "sethost:$server:$cmd\n";
1.550     foxr      195: 	$answer=<$client>;
                    196: 	if (!$answer) { $answer="con_lost"; }
                    197: 	chomp($answer);
                    198:     } else {
                    199: 	$answer = 'con_lost';	# Failed connection.
                    200:     }
1.1       albertel  201:     return $answer;
                    202: }
                    203: 
                    204: sub reply {
                    205:     my ($cmd,$server)=@_;
1.838     albertel  206:     unless (defined(&hostname($server))) { return 'no_such_host'; }
1.1       albertel  207:     my $answer=subreply($cmd,$server);
1.65      www       208:     if (($answer=~/^refused/) || ($answer=~/^rejected/)) {
1.672     albertel  209:        &logthis("<font color=\"blue\">WARNING:".
1.12      www       210:                 " $cmd to $server returned $answer</font>");
                    211:     }
1.1       albertel  212:     return $answer;
                    213: }
                    214: 
                    215: # ----------------------------------------------------------- Send USR1 to lonc
                    216: 
                    217: sub reconlonc {
1.836     www       218:     &logthis("Trying to reconnect lonc");
1.1       albertel  219:     my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
1.448     albertel  220:     if (open(my $fh,"<$loncfile")) {
1.1       albertel  221: 	my $loncpid=<$fh>;
                    222:         chomp($loncpid);
                    223:         if (kill 0 => $loncpid) {
                    224: 	    &logthis("lonc at pid $loncpid responding, sending USR1");
                    225:             kill USR1 => $loncpid;
                    226:             sleep 1;
1.836     www       227:          } else {
1.12      www       228: 	    &logthis(
1.672     albertel  229:                "<font color=\"blue\">WARNING:".
1.12      www       230:                " lonc at pid $loncpid not responding, giving up</font>");
1.1       albertel  231:         }
                    232:     } else {
1.836     www       233: 	&logthis('<font color="blue">WARNING: lonc not running, giving up</font>');
1.1       albertel  234:     }
                    235: }
                    236: 
                    237: # ------------------------------------------------------ Critical communication
1.12      www       238: 
1.1       albertel  239: sub critical {
                    240:     my ($cmd,$server)=@_;
1.838     albertel  241:     unless (&hostname($server)) {
1.672     albertel  242:         &logthis("<font color=\"blue\">WARNING:".
1.89      www       243:                " Critical message to unknown server ($server)</font>");
                    244:         return 'no_such_host';
                    245:     }
1.1       albertel  246:     my $answer=reply($cmd,$server);
                    247:     if ($answer eq 'con_lost') {
                    248: 	&reconlonc("$perlvar{'lonSockDir'}/$server");
1.589     albertel  249: 	my $answer=reply($cmd,$server);
1.1       albertel  250:         if ($answer eq 'con_lost') {
                    251:             my $now=time;
                    252:             my $middlename=$cmd;
1.5       www       253:             $middlename=substr($middlename,0,16);
1.1       albertel  254:             $middlename=~s/\W//g;
                    255:             my $dfilename=
1.305     www       256:       "$perlvar{'lonSockDir'}/delayed/$now.$dumpcount.$$.$middlename.$server";
                    257:             $dumpcount++;
1.1       albertel  258:             {
1.448     albertel  259: 		my $dfh;
                    260: 		if (open($dfh,">$dfilename")) {
                    261: 		    print $dfh "$cmd\n"; 
                    262: 		    close($dfh);
                    263: 		}
1.1       albertel  264:             }
                    265:             sleep 2;
                    266:             my $wcmd='';
                    267:             {
1.448     albertel  268: 		my $dfh;
                    269: 		if (open($dfh,"<$dfilename")) {
                    270: 		    $wcmd=<$dfh>; 
                    271: 		    close($dfh);
                    272: 		}
1.1       albertel  273:             }
                    274:             chomp($wcmd);
1.7       www       275:             if ($wcmd eq $cmd) {
1.672     albertel  276: 		&logthis("<font color=\"blue\">WARNING: ".
1.12      www       277:                          "Connection buffer $dfilename: $cmd</font>");
1.1       albertel  278:                 &logperm("D:$server:$cmd");
                    279: 	        return 'con_delayed';
                    280:             } else {
1.672     albertel  281:                 &logthis("<font color=\"red\">CRITICAL:"
1.12      www       282:                         ." Critical connection failed: $server $cmd</font>");
1.1       albertel  283:                 &logperm("F:$server:$cmd");
                    284:                 return 'con_failed';
                    285:             }
                    286:         }
                    287:     }
                    288:     return $answer;
1.405     albertel  289: }
                    290: 
1.755     albertel  291: # ------------------------------------------- check if return value is an error
                    292: 
                    293: sub error {
                    294:     my ($result) = @_;
1.756     albertel  295:     if ($result =~ /^(con_lost|no_such_host|error: (\d+) (.*))/) {
1.755     albertel  296: 	if ($2 == 2) { return undef; }
                    297: 	return $1;
                    298:     }
                    299:     return undef;
                    300: }
                    301: 
1.783     albertel  302: sub convert_and_load_session_env {
                    303:     my ($lonidsdir,$handle)=@_;
                    304:     my @profile;
                    305:     {
                    306: 	open(my $idf,"$lonidsdir/$handle.id");
                    307: 	flock($idf,LOCK_SH);
                    308: 	@profile=<$idf>;
                    309: 	close($idf);
                    310:     }
                    311:     my %temp_env;
                    312:     foreach my $line (@profile) {
1.786     albertel  313: 	if ($line !~ m/=/) {
                    314: 	    return 0;
                    315: 	}
1.783     albertel  316: 	chomp($line);
                    317: 	my ($envname,$envvalue)=split(/=/,$line,2);
                    318: 	$temp_env{&unescape($envname)} = &unescape($envvalue);
                    319:     }
                    320:     unlink("$lonidsdir/$handle.id");
                    321:     if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",&GDBM_WRCREAT(),
                    322: 	    0640)) {
                    323: 	%disk_env = %temp_env;
                    324: 	@env{keys(%temp_env)} = @disk_env{keys(%temp_env)};
                    325: 	untie(%disk_env);
                    326:     }
1.786     albertel  327:     return 1;
1.783     albertel  328: }
                    329: 
1.374     www       330: # ------------------------------------------- Transfer profile into environment
1.780     albertel  331: my $env_loaded;
                    332: sub transfer_profile_to_env {
1.788     albertel  333:     my ($lonidsdir,$handle,$force_transfer) = @_;
                    334:     if (!$force_transfer && $env_loaded) { return; } 
1.374     www       335: 
1.720     albertel  336:     if (!defined($lonidsdir)) {
                    337: 	$lonidsdir = $perlvar{'lonIDsDir'};
                    338:     }
                    339:     if (!defined($handle)) {
                    340:         ($handle) = ($env{'user.environment'} =~m|/([^/]+)\.id$| );
                    341:     }
                    342: 
1.786     albertel  343:     my $convert;
                    344:     {
                    345:     	open(my $idf,"$lonidsdir/$handle.id");
                    346: 	flock($idf,LOCK_SH);
                    347: 	if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",
                    348: 		&GDBM_READER(),0640)) {
                    349: 	    @env{keys(%disk_env)} = @disk_env{keys(%disk_env)};
                    350: 	    untie(%disk_env);
                    351: 	} else {
                    352: 	    $convert = 1;
                    353: 	}
                    354:     }
                    355:     if ($convert) {
                    356: 	if (!&convert_and_load_session_env($lonidsdir,$handle)) {
                    357: 	    &logthis("Failed to load session, or convert session.");
                    358: 	}
1.374     www       359:     }
1.783     albertel  360: 
1.786     albertel  361:     my %remove;
1.783     albertel  362:     while ( my $envname = each(%env) ) {
1.433     matthew   363:         if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {
                    364:             if ($time < time-300) {
1.783     albertel  365:                 $remove{$key}++;
1.433     matthew   366:             }
                    367:         }
                    368:     }
1.783     albertel  369: 
1.619     albertel  370:     $env{'user.environment'} = "$lonidsdir/$handle.id";
1.780     albertel  371:     $env_loaded=1;
1.783     albertel  372:     foreach my $expired_key (keys(%remove)) {
1.433     matthew   373:         &delenv($expired_key);
1.374     www       374:     }
1.1       albertel  375: }
                    376: 
1.830     albertel  377: sub timed_flock {
                    378:     my ($file,$lock_type) = @_;
                    379:     my $failed=0;
                    380:     eval {
                    381: 	local $SIG{__DIE__}='DEFAULT';
                    382: 	local $SIG{ALRM}=sub {
                    383: 	    $failed=1;
                    384: 	    die("failed lock");
                    385: 	};
                    386: 	alarm(13);
                    387: 	flock($file,$lock_type);
                    388: 	alarm(0);
                    389:     };
                    390:     if ($failed) {
                    391: 	return undef;
                    392:     } else {
                    393: 	return 1;
                    394:     }
                    395: }
                    396: 
1.5       www       397: # ---------------------------------------------------------- Append Environment
                    398: 
                    399: sub appenv {
1.6       www       400:     my %newenv=@_;
1.692     albertel  401:     foreach my $key (keys(%newenv)) {
                    402: 	if (($newenv{$key}=~/^user\.role/) || ($newenv{$key}=~/^user\.priv/)) {
1.672     albertel  403:             &logthis("<font color=\"blue\">WARNING: ".
1.692     albertel  404:                 "Attempt to modify environment ".$key." to ".$newenv{$key}
1.151     www       405:                 .'</font>');
1.692     albertel  406: 	    delete($newenv{$key});
1.35      www       407:         } else {
1.692     albertel  408:             $env{$key}=$newenv{$key};
1.35      www       409:         }
1.191     harris41  410:     }
1.830     albertel  411:     open(my $env_file,$env{'user.environment'});
                    412:     if (&timed_flock($env_file,LOCK_EX)
                    413: 	&&
                    414: 	tie(my %disk_env,'GDBM_File',$env{'user.environment'},
                    415: 	    (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
1.783     albertel  416: 	while (my ($key,$value) = each(%newenv)) {
                    417: 	    $disk_env{$key} = $value;
1.448     albertel  418: 	}
1.783     albertel  419: 	untie(%disk_env);
1.56      www       420:     }
                    421:     return 'ok';
                    422: }
                    423: # ----------------------------------------------------- Delete from Environment
                    424: 
                    425: sub delenv {
                    426:     my $delthis=shift;
                    427:     if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {
1.672     albertel  428:         &logthis("<font color=\"blue\">WARNING: ".
1.56      www       429:                 "Attempt to delete from environment ".$delthis);
                    430:         return 'error';
                    431:     }
1.830     albertel  432:     open(my $env_file,$env{'user.environment'});
                    433:     if (&timed_flock($env_file,LOCK_EX)
                    434: 	&&
                    435: 	tie(my %disk_env,'GDBM_File',$env{'user.environment'},
                    436: 	    (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
1.783     albertel  437: 	foreach my $key (keys(%disk_env)) {
                    438: 	    if ($key=~/^$delthis/) { 
1.619     albertel  439:                 delete($env{$key});
1.783     albertel  440:                 delete($disk_env{$key});
1.473     matthew   441:             }
1.448     albertel  442: 	}
1.783     albertel  443: 	untie(%disk_env);
1.5       www       444:     }
                    445:     return 'ok';
1.369     albertel  446: }
                    447: 
1.790     albertel  448: sub get_env_multiple {
                    449:     my ($name) = @_;
                    450:     my @values;
                    451:     if (defined($env{$name})) {
                    452:         # exists is it an array
                    453:         if (ref($env{$name})) {
                    454:             @values=@{ $env{$name} };
                    455:         } else {
                    456:             $values[0]=$env{$name};
                    457:         }
                    458:     }
                    459:     return(@values);
                    460: }
                    461: 
1.369     albertel  462: # ------------------------------------------ Find out current server userload
                    463: # there is a copy in lond
                    464: sub userload {
                    465:     my $numusers=0;
                    466:     {
                    467: 	opendir(LONIDS,$perlvar{'lonIDsDir'});
                    468: 	my $filename;
                    469: 	my $curtime=time;
                    470: 	while ($filename=readdir(LONIDS)) {
                    471: 	    if ($filename eq '.' || $filename eq '..') {next;}
1.404     albertel  472: 	    my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];
1.437     albertel  473: 	    if ($curtime-$mtime < 1800) { $numusers++; }
1.369     albertel  474: 	}
                    475: 	closedir(LONIDS);
                    476:     }
                    477:     my $userloadpercent=0;
                    478:     my $maxuserload=$perlvar{'lonUserLoadLim'};
                    479:     if ($maxuserload) {
1.371     albertel  480: 	$userloadpercent=100*$numusers/$maxuserload;
1.369     albertel  481:     }
1.372     albertel  482:     $userloadpercent=sprintf("%.2f",$userloadpercent);
1.369     albertel  483:     return $userloadpercent;
1.283     www       484: }
                    485: 
                    486: # ------------------------------------------ Fight off request when overloaded
                    487: 
                    488: sub overloaderror {
                    489:     my ($r,$checkserver)=@_;
                    490:     unless ($checkserver) { $checkserver=$perlvar{'lonHostID'}; }
                    491:     my $loadavg;
                    492:     if ($checkserver eq $perlvar{'lonHostID'}) {
1.448     albertel  493:        open(my $loadfile,'/proc/loadavg');
1.283     www       494:        $loadavg=<$loadfile>;
                    495:        $loadavg =~ s/\s.*//g;
1.285     matthew   496:        $loadavg = 100*$loadavg/$perlvar{'lonLoadLim'};
1.448     albertel  497:        close($loadfile);
1.283     www       498:     } else {
                    499:        $loadavg=&reply('load',$checkserver);
                    500:     }
1.285     matthew   501:     my $overload=$loadavg-100;
1.283     www       502:     if ($overload>0) {
1.285     matthew   503: 	$r->err_headers_out->{'Retry-After'}=$overload;
1.283     www       504:         $r->log_error('Overload of '.$overload.' on '.$checkserver);
1.554     www       505:         return 413;
1.283     www       506:     }    
                    507:     return '';
1.5       www       508: }
1.1       albertel  509: 
                    510: # ------------------------------ Find server with least workload from spare.tab
1.11      www       511: 
1.1       albertel  512: sub spareserver {
1.670     albertel  513:     my ($loadpercent,$userloadpercent,$want_server_name) = @_;
1.784     albertel  514:     my $spare_server;
1.370     albertel  515:     if ($userloadpercent !~ /\d/) { $userloadpercent=0; }
1.784     albertel  516:     my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent 
                    517:                                                      :  $userloadpercent;
                    518:     
                    519:     foreach my $try_server (@{ $spareid{'primary'} }) {
                    520: 	($spare_server, $lowest_load) =
                    521: 	    &compare_server_load($try_server, $spare_server, $lowest_load);
                    522:     }
                    523: 
                    524:     my $found_server = ($spare_server ne '' && $lowest_load < 100);
                    525: 
                    526:     if (!$found_server) {
                    527: 	foreach my $try_server (@{ $spareid{'default'} }) {
                    528: 	    ($spare_server, $lowest_load) =
                    529: 		&compare_server_load($try_server, $spare_server, $lowest_load);
                    530: 	}
                    531:     }
                    532: 
                    533:     if (!$want_server_name) {
1.838     albertel  534: 	$spare_server="http://".&hostname($spare_server);
1.784     albertel  535:     }
                    536:     return $spare_server;
                    537: }
                    538: 
                    539: sub compare_server_load {
                    540:     my ($try_server, $spare_server, $lowest_load) = @_;
                    541: 
                    542:     my $loadans     = &reply('load',    $try_server);
                    543:     my $userloadans = &reply('userload',$try_server);
                    544: 
                    545:     if ($loadans !~ /\d/ && $userloadans !~ /\d/) {
                    546: 	next; #didn't get a number from the server
                    547:     }
                    548: 
                    549:     my $load;
                    550:     if ($loadans =~ /\d/) {
                    551: 	if ($userloadans =~ /\d/) {
                    552: 	    #both are numbers, pick the bigger one
                    553: 	    $load = ($loadans > $userloadans) ? $loadans 
                    554: 		                              : $userloadans;
1.411     albertel  555: 	} else {
1.784     albertel  556: 	    $load = $loadans;
1.411     albertel  557: 	}
1.784     albertel  558:     } else {
                    559: 	$load = $userloadans;
                    560:     }
                    561: 
                    562:     if (($load =~ /\d/) && ($load < $lowest_load)) {
                    563: 	$spare_server = $try_server;
                    564: 	$lowest_load  = $load;
1.370     albertel  565:     }
1.784     albertel  566:     return ($spare_server,$lowest_load);
1.202     matthew   567: }
                    568: # --------------------------------------------- Try to change a user's password
                    569: 
                    570: sub changepass {
1.799     raeburn   571:     my ($uname,$udom,$currentpass,$newpass,$server,$context)=@_;
1.202     matthew   572:     $currentpass = &escape($currentpass);
                    573:     $newpass     = &escape($newpass);
1.799     raeburn   574:     my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass:$context",
1.202     matthew   575: 		       $server);
                    576:     if (! $answer) {
                    577: 	&logthis("No reply on password change request to $server ".
                    578: 		 "by $uname in domain $udom.");
                    579:     } elsif ($answer =~ "^ok") {
                    580:         &logthis("$uname in $udom successfully changed their password ".
                    581: 		 "on $server.");
                    582:     } elsif ($answer =~ "^pwchange_failure") {
                    583: 	&logthis("$uname in $udom was unable to change their password ".
                    584: 		 "on $server.  The action was blocked by either lcpasswd ".
                    585: 		 "or pwchange");
                    586:     } elsif ($answer =~ "^non_authorized") {
                    587:         &logthis("$uname in $udom did not get their password correct when ".
                    588: 		 "attempting to change it on $server.");
                    589:     } elsif ($answer =~ "^auth_mode_error") {
                    590:         &logthis("$uname in $udom attempted to change their password despite ".
                    591: 		 "not being locally or internally authenticated on $server.");
                    592:     } elsif ($answer =~ "^unknown_user") {
                    593:         &logthis("$uname in $udom attempted to change their password ".
                    594: 		 "on $server but were unable to because $server is not ".
                    595: 		 "their home server.");
                    596:     } elsif ($answer =~ "^refused") {
                    597: 	&logthis("$server refused to change $uname in $udom password because ".
                    598: 		 "it was sent an unencrypted request to change the password.");
                    599:     }
                    600:     return $answer;
1.1       albertel  601: }
                    602: 
1.169     harris41  603: # ----------------------- Try to determine user's current authentication scheme
                    604: 
                    605: sub queryauthenticate {
                    606:     my ($uname,$udom)=@_;
1.456     albertel  607:     my $uhome=&homeserver($uname,$udom);
                    608:     if (!$uhome) {
                    609: 	&logthis("User $uname at $udom is unknown when looking for authentication mechanism");
                    610: 	return 'no_host';
                    611:     }
                    612:     my $answer=reply("encrypt:currentauth:$udom:$uname",$uhome);
                    613:     if ($answer =~ /^(unknown_user|refused|con_lost)/) {
                    614: 	&logthis("User $uname at $udom threw error $answer when checking authentication mechanism");
1.169     harris41  615:     }
1.456     albertel  616:     return $answer;
1.169     harris41  617: }
                    618: 
1.1       albertel  619: # --------- Try to authenticate user from domain's lib servers (first this one)
1.11      www       620: 
1.1       albertel  621: sub authenticate {
                    622:     my ($uname,$upass,$udom)=@_;
1.807     albertel  623:     $upass=&escape($upass);
                    624:     $uname= &LONCAPA::clean_username($uname);
1.836     www       625:     my $uhome=&homeserver($uname,$udom,1);
                    626:     if ((!$uhome) || ($uhome eq 'no_host')) {
                    627: # Maybe the machine was offline and only re-appeared again recently?
                    628:         &reconlonc();
                    629: # One more
                    630: 	my $uhome=&homeserver($uname,$udom,1);
                    631: 	if ((!$uhome) || ($uhome eq 'no_host')) {
                    632: 	    &logthis("User $uname at $udom is unknown in authenticate");
                    633: 	}
1.471     albertel  634: 	return 'no_host';
1.1       albertel  635:     }
1.471     albertel  636:     my $answer=reply("encrypt:auth:$udom:$uname:$upass",$uhome);
                    637:     if ($answer eq 'authorized') {
                    638: 	&logthis("User $uname at $udom authorized by $uhome"); 
                    639: 	return $uhome; 
                    640:     }
                    641:     if ($answer eq 'non_authorized') {
                    642: 	&logthis("User $uname at $udom rejected by $uhome");
                    643: 	return 'no_host'; 
1.9       www       644:     }
1.471     albertel  645:     &logthis("User $uname at $udom threw error $answer when checking authentication mechanism");
1.1       albertel  646:     return 'no_host';
                    647: }
                    648: 
                    649: # ---------------------- Find the homebase for a user from domain's lib servers
1.11      www       650: 
1.599     albertel  651: my %homecache;
1.1       albertel  652: sub homeserver {
1.230     stredwic  653:     my ($uname,$udom,$ignoreBadCache)=@_;
1.1       albertel  654:     my $index="$uname:$udom";
1.426     albertel  655: 
1.599     albertel  656:     if (exists($homecache{$index})) { return $homecache{$index}; }
1.841     albertel  657: 
                    658:     my %servers = &get_servers($udom,'library');
                    659:     foreach my $tryserver (keys(%servers)) {
1.230     stredwic  660:         next if ($ignoreBadCache ne 'true' && 
1.231     stredwic  661: 		 exists($badServerCache{$tryserver}));
1.841     albertel  662: 
                    663: 	my $answer=reply("home:$udom:$uname",$tryserver);
                    664: 	if ($answer eq 'found') {
                    665: 	    delete($badServerCache{$tryserver}); 
                    666: 	    return $homecache{$index}=$tryserver;
                    667: 	} elsif ($answer eq 'no_host') {
                    668: 	    $badServerCache{$tryserver}=1;
                    669: 	}
1.1       albertel  670:     }    
                    671:     return 'no_host';
1.70      www       672: }
                    673: 
                    674: # ------------------------------------- Find the usernames behind a list of IDs
                    675: 
                    676: sub idget {
                    677:     my ($udom,@ids)=@_;
                    678:     my %returnhash=();
                    679:     
1.841     albertel  680:     my %servers = &get_servers($udom,'library');
                    681:     foreach my $tryserver (keys(%servers)) {
                    682: 	my $idlist=join('&',@ids);
                    683: 	$idlist=~tr/A-Z/a-z/; 
                    684: 	my $reply=&reply("idget:$udom:".$idlist,$tryserver);
                    685: 	my @answer=();
                    686: 	if (($reply ne 'con_lost') && ($reply!~/^error\:/)) {
                    687: 	    @answer=split(/\&/,$reply);
                    688: 	}                    ;
                    689: 	my $i;
                    690: 	for ($i=0;$i<=$#ids;$i++) {
                    691: 	    if ($answer[$i]) {
                    692: 		$returnhash{$ids[$i]}=$answer[$i];
                    693: 	    } 
                    694: 	}
                    695:     } 
1.70      www       696:     return %returnhash;
                    697: }
                    698: 
                    699: # ------------------------------------- Find the IDs behind a list of usernames
                    700: 
                    701: sub idrget {
                    702:     my ($udom,@unames)=@_;
                    703:     my %returnhash=();
1.800     albertel  704:     foreach my $uname (@unames) {
                    705:         $returnhash{$uname}=(&userenvironment($udom,$uname,'id'))[1];
1.191     harris41  706:     }
1.70      www       707:     return %returnhash;
                    708: }
                    709: 
                    710: # ------------------------------- Store away a list of names and associated IDs
                    711: 
                    712: sub idput {
                    713:     my ($udom,%ids)=@_;
                    714:     my %servers=();
1.800     albertel  715:     foreach my $uname (keys(%ids)) {
                    716: 	&cput('environment',{'id'=>$ids{$uname}},$udom,$uname);
                    717:         my $uhom=&homeserver($uname,$udom);
1.70      www       718:         if ($uhom ne 'no_host') {
1.800     albertel  719:             my $id=&escape($ids{$uname});
1.70      www       720:             $id=~tr/A-Z/a-z/;
1.800     albertel  721:             my $esc_unam=&escape($uname);
1.70      www       722: 	    if ($servers{$uhom}) {
1.800     albertel  723: 		$servers{$uhom}.='&'.$id.'='.$esc_unam;
1.70      www       724:             } else {
1.800     albertel  725:                 $servers{$uhom}=$id.'='.$esc_unam;
1.70      www       726:             }
                    727:         }
1.191     harris41  728:     }
1.800     albertel  729:     foreach my $server (keys(%servers)) {
                    730:         &critical('idput:'.$udom.':'.$servers{$server},$server);
1.191     harris41  731:     }
1.344     www       732: }
                    733: 
1.806     raeburn   734: # ------------------------------------------- get items from domain db files   
                    735: 
                    736: sub get_dom {
1.860     raeburn   737:     my ($namespace,$storearr,$udom,$uhome)=@_;
1.806     raeburn   738:     my $items='';
                    739:     foreach my $item (@$storearr) {
                    740:         $items.=&escape($item).'&';
                    741:     }
                    742:     $items=~s/\&$//;
1.860     raeburn   743:     if (!$udom) {
                    744:         $udom=$env{'user.domain'};
                    745:         if (defined(&domain($udom,'primary'))) {
                    746:             $uhome=&domain($udom,'primary');
                    747:         } else {
                    748:             $uhome eq '';
                    749:         }
                    750:     } else {
                    751:         if (!$uhome) {
                    752:             if (defined(&domain($udom,'primary'))) {
                    753:                 $uhome=&domain($udom,'primary');
                    754:             }
                    755:         }
                    756:     }
                    757:     if ($udom && $uhome && ($uhome ne 'no_host')) {
1.806     raeburn   758:         my $rep=&reply("getdom:$udom:$namespace:$items",$uhome);
                    759:         my @pairs=split(/\&/,$rep);
                    760:         if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) {
                    761:             return @pairs;
                    762:         }
                    763:         my %returnhash=();
                    764:         my $i=0;
                    765:         foreach my $item (@$storearr) {
                    766:             $returnhash{$item}=&thaw_unescape($pairs[$i]);
                    767:             $i++;
                    768:         }
                    769:         return %returnhash;
                    770:     } else {
1.860     raeburn   771:         &logthis("get_dom failed - no homeserver and/or domain");
1.806     raeburn   772:     }
                    773: }
                    774: 
                    775: # -------------------------------------------- put items in domain db files 
                    776: 
                    777: sub put_dom {
1.860     raeburn   778:     my ($namespace,$storehash,$udom,$uhome)=@_;
                    779:     if (!$udom) {
                    780:         $udom=$env{'user.domain'};
                    781:         if (defined(&domain($udom,'primary'))) {
                    782:             $uhome=&domain($udom,'primary');
                    783:         } else {
                    784:             $uhome eq '';
                    785:         }
                    786:     } else {
                    787:         if (!$uhome) {
                    788:             if (defined(&domain($udom,'primary'))) {
                    789:                 $uhome=&domain($udom,'primary');
                    790:             }
                    791:         }
                    792:     } 
                    793:     if ($udom && $uhome && ($uhome ne 'no_host')) {
1.806     raeburn   794:         my $items='';
                    795:         foreach my $item (keys(%$storehash)) {
                    796:             $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
                    797:         }
                    798:         $items=~s/\&$//;
                    799:         return &reply("putdom:$udom:$namespace:$items",$uhome);
                    800:     } else {
1.860     raeburn   801:         &logthis("put_dom failed - no homeserver and/or domain");
1.806     raeburn   802:     }
                    803: }
                    804: 
1.837     raeburn   805: sub retrieve_inst_usertypes {
                    806:     my ($udom) = @_;
                    807:     my (%returnhash,@order);
1.846     albertel  808:     if (defined(&domain($udom,'primary'))) {
                    809:         my $uhome=&domain($udom,'primary');
1.837     raeburn   810:         my $rep=&reply("inst_usertypes:$udom",$uhome);
                    811:         my ($hashitems,$orderitems) = split(/:/,$rep); 
                    812:         my @pairs=split(/\&/,$hashitems);
                    813:         foreach my $item (@pairs) {
                    814:             my ($key,$value)=split(/=/,$item,2);
                    815:             $key = &unescape($key);
                    816:             next if ($key =~ /^error: 2 /);
                    817:             $returnhash{$key}=&thaw_unescape($value);
                    818:         }
                    819:         my @esc_order = split(/\&/,$orderitems);
                    820:         foreach my $item (@esc_order) {
                    821:             push(@order,&unescape($item));
                    822:         }
                    823:     } else {
                    824:         &logthis("get_dom failed - no primary domain server for $udom");
                    825:     }
                    826:     return (\%returnhash,\@order);
                    827: }
                    828: 
1.344     www       829: # --------------------------------------------------- Assign a key to a student
                    830: 
                    831: sub assign_access_key {
1.364     www       832: #
                    833: # a valid key looks like uname:udom#comments
                    834: # comments are being appended
                    835: #
1.498     www       836:     my ($ckey,$kdom,$knum,$cdom,$cnum,$udom,$uname,$logentry)=@_;
                    837:     $kdom=
1.620     albertel  838:    $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($kdom));
1.498     www       839:     $knum=
1.620     albertel  840:    $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($knum));
1.344     www       841:     $cdom=
1.620     albertel  842:    $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($cdom));
1.344     www       843:     $cnum=
1.620     albertel  844:    $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($cnum));
                    845:     $udom=$env{'user.name'} unless (defined($udom));
                    846:     $uname=$env{'user.domain'} unless (defined($uname));
1.498     www       847:     my %existing=&get('accesskeys',[$ckey],$kdom,$knum);
1.364     www       848:     if (($existing{$ckey}=~/^\#(.*)$/) || # - new key
1.479     albertel  849:         ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#(.*)$/)) { 
1.364     www       850:                                                   # assigned to this person
                    851:                                                   # - this should not happen,
1.345     www       852:                                                   # unless something went wrong
                    853:                                                   # the first time around
                    854: # ready to assign
1.364     www       855:         $logentry=$1.'; '.$logentry;
1.496     www       856:         if (&put('accesskeys',{$ckey=>$uname.':'.$udom.'#'.$logentry},
1.498     www       857:                                                  $kdom,$knum) eq 'ok') {
1.345     www       858: # key now belongs to user
1.346     www       859: 	    my $envkey='key.'.$cdom.'_'.$cnum;
1.345     www       860:             if (&put('environment',{$envkey => $ckey}) eq 'ok') {
                    861:                 &appenv('environment.'.$envkey => $ckey);
                    862:                 return 'ok';
                    863:             } else {
                    864:                 return 
                    865:   'error: Count not permanently assign key, will need to be re-entered later.';
                    866: 	    }
                    867:         } else {
                    868:             return 'error: Could not assign key, try again later.';
                    869:         }
1.364     www       870:     } elsif (!$existing{$ckey}) {
1.345     www       871: # the key does not exist
                    872: 	return 'error: The key does not exist';
                    873:     } else {
                    874: # the key is somebody else's
                    875: 	return 'error: The key is already in use';
                    876:     }
1.344     www       877: }
                    878: 
1.364     www       879: # ------------------------------------------ put an additional comment on a key
                    880: 
                    881: sub comment_access_key {
                    882: #
                    883: # a valid key looks like uname:udom#comments
                    884: # comments are being appended
                    885: #
                    886:     my ($ckey,$cdom,$cnum,$logentry)=@_;
                    887:     $cdom=
1.620     albertel  888:    $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($cdom));
1.364     www       889:     $cnum=
1.620     albertel  890:    $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($cnum));
1.364     www       891:     my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
                    892:     if ($existing{$ckey}) {
                    893:         $existing{$ckey}.='; '.$logentry;
                    894: # ready to assign
1.367     www       895:         if (&put('accesskeys',{$ckey=>$existing{$ckey}},
1.364     www       896:                                                  $cdom,$cnum) eq 'ok') {
                    897: 	    return 'ok';
                    898:         } else {
                    899: 	    return 'error: Count not store comment.';
                    900:         }
                    901:     } else {
                    902: # the key does not exist
                    903: 	return 'error: The key does not exist';
                    904:     }
                    905: }
                    906: 
1.344     www       907: # ------------------------------------------------------ Generate a set of keys
                    908: 
                    909: sub generate_access_keys {
1.364     www       910:     my ($number,$cdom,$cnum,$logentry)=@_;
1.344     www       911:     $cdom=
1.620     albertel  912:    $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($cdom));
1.344     www       913:     $cnum=
1.620     albertel  914:    $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($cnum));
1.361     www       915:     unless (&allowed('mky',$cdom)) { return 0; }
1.344     www       916:     unless (($cdom) && ($cnum)) { return 0; }
                    917:     if ($number>10000) { return 0; }
                    918:     sleep(2); # make sure don't get same seed twice
                    919:     srand(time()^($$+($$<<15))); # from "Programming Perl"
                    920:     my $total=0;
                    921:     for (my $i=1;$i<=$number;$i++) {
                    922:        my $newkey=sprintf("%lx",int(100000*rand)).'-'.
                    923:                   sprintf("%lx",int(100000*rand)).'-'.
                    924:                   sprintf("%lx",int(100000*rand));
                    925:        $newkey=~s/1/g/g; # folks mix up 1 and l
                    926:        $newkey=~s/0/h/g; # and also 0 and O
                    927:        my %existing=&get('accesskeys',[$newkey],$cdom,$cnum);
                    928:        if ($existing{$newkey}) {
                    929:            $i--;
                    930:        } else {
1.364     www       931: 	  if (&put('accesskeys',
                    932:               { $newkey => '# generated '.localtime().
1.620     albertel  933:                            ' by '.$env{'user.name'}.'@'.$env{'user.domain'}.
1.364     www       934:                            '; '.$logentry },
                    935: 		   $cdom,$cnum) eq 'ok') {
1.344     www       936:               $total++;
                    937: 	  }
                    938:        }
                    939:     }
1.620     albertel  940:     &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},
1.344     www       941:          'Generated '.$total.' keys for '.$cnum.' at '.$cdom);
                    942:     return $total;
                    943: }
                    944: 
                    945: # ------------------------------------------------------- Validate an accesskey
                    946: 
                    947: sub validate_access_key {
                    948:     my ($ckey,$cdom,$cnum,$udom,$uname)=@_;
                    949:     $cdom=
1.620     albertel  950:    $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($cdom));
1.344     www       951:     $cnum=
1.620     albertel  952:    $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($cnum));
                    953:     $udom=$env{'user.domain'} unless (defined($udom));
                    954:     $uname=$env{'user.name'} unless (defined($uname));
1.345     www       955:     my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
1.479     albertel  956:     return ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#/);
1.70      www       957: }
                    958: 
                    959: # ------------------------------------- Find the section of student in a course
1.652     albertel  960: sub devalidate_getsection_cache {
                    961:     my ($udom,$unam,$courseid)=@_;
                    962:     my $hashid="$udom:$unam:$courseid";
                    963:     &devalidate_cache_new('getsection',$hashid);
                    964: }
1.298     matthew   965: 
1.815     albertel  966: sub courseid_to_courseurl {
                    967:     my ($courseid) = @_;
                    968:     #already url style courseid
                    969:     return $courseid if ($courseid =~ m{^/});
                    970: 
                    971:     if (exists($env{'course.'.$courseid.'.num'})) {
                    972: 	my $cnum = $env{'course.'.$courseid.'.num'};
                    973: 	my $cdom = $env{'course.'.$courseid.'.domain'};
                    974: 	return "/$cdom/$cnum";
                    975:     }
                    976: 
                    977:     my %courseinfo=&Apache::lonnet::coursedescription($courseid);
                    978:     if (exists($courseinfo{'num'})) {
                    979: 	return "/$courseinfo{'domain'}/$courseinfo{'num'}";
                    980:     }
                    981: 
                    982:     return undef;
                    983: }
                    984: 
1.298     matthew   985: sub getsection {
                    986:     my ($udom,$unam,$courseid)=@_;
1.599     albertel  987:     my $cachetime=1800;
1.551     albertel  988: 
                    989:     my $hashid="$udom:$unam:$courseid";
1.599     albertel  990:     my ($result,$cached)=&is_cached_new('getsection',$hashid);
1.551     albertel  991:     if (defined($cached)) { return $result; }
                    992: 
1.298     matthew   993:     my %Pending; 
                    994:     my %Expired;
                    995:     #
                    996:     # Each role can either have not started yet (pending), be active, 
                    997:     #    or have expired.
                    998:     #
                    999:     # If there is an active role, we are done.
                   1000:     #
                   1001:     # If there is more than one role which has not started yet, 
                   1002:     #     choose the one which will start sooner
                   1003:     # If there is one role which has not started yet, return it.
                   1004:     #
                   1005:     # If there is more than one expired role, choose the one which ended last.
                   1006:     # If there is a role which has expired, return it.
                   1007:     #
1.815     albertel 1008:     $courseid = &courseid_to_courseurl($courseid);
1.817     raeburn  1009:     my %roleshash = &dump('roles',$udom,$unam,$courseid);
                   1010:     foreach my $key (keys(%roleshash)) {
1.479     albertel 1011:         next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/);
1.298     matthew  1012:         my $section=$1;
                   1013:         if ($key eq $courseid.'_st') { $section=''; }
1.817     raeburn  1014:         my ($dummy,$end,$start)=split(/\_/,&unescape($roleshash{$key}));
1.298     matthew  1015:         my $now=time;
1.548     albertel 1016:         if (defined($end) && $end && ($now > $end)) {
1.298     matthew  1017:             $Expired{$end}=$section;
                   1018:             next;
                   1019:         }
1.548     albertel 1020:         if (defined($start) && $start && ($now < $start)) {
1.298     matthew  1021:             $Pending{$start}=$section;
                   1022:             next;
                   1023:         }
1.599     albertel 1024:         return &do_cache_new('getsection',$hashid,$section,$cachetime);
1.298     matthew  1025:     }
                   1026:     #
                   1027:     # Presumedly there will be few matching roles from the above
                   1028:     # loop and the sorting time will be negligible.
                   1029:     if (scalar(keys(%Pending))) {
                   1030:         my ($time) = sort {$a <=> $b} keys(%Pending);
1.599     albertel 1031:         return &do_cache_new('getsection',$hashid,$Pending{$time},$cachetime);
1.298     matthew  1032:     } 
                   1033:     if (scalar(keys(%Expired))) {
                   1034:         my @sorted = sort {$a <=> $b} keys(%Expired);
                   1035:         my $time = pop(@sorted);
1.599     albertel 1036:         return &do_cache_new('getsection',$hashid,$Expired{$time},$cachetime);
1.298     matthew  1037:     }
1.599     albertel 1038:     return &do_cache_new('getsection',$hashid,'-1',$cachetime);
1.298     matthew  1039: }
1.70      www      1040: 
1.599     albertel 1041: sub save_cache {
                   1042:     &purge_remembered();
1.722     albertel 1043:     #&Apache::loncommon::validate_page();
1.620     albertel 1044:     undef(%env);
1.780     albertel 1045:     undef($env_loaded);
1.599     albertel 1046: }
1.452     albertel 1047: 
1.599     albertel 1048: my $to_remember=-1;
                   1049: my %remembered;
                   1050: my %accessed;
                   1051: my $kicks=0;
                   1052: my $hits=0;
1.849     albertel 1053: sub make_key {
                   1054:     my ($name,$id) = @_;
                   1055:     if (length($id) > 200) { $id=length($id).':'.&Digest::MD5::md5_hex($id); }
                   1056:     return &escape($name.':'.$id);
                   1057: }
                   1058: 
1.599     albertel 1059: sub devalidate_cache_new {
                   1060:     my ($name,$id,$debug) = @_;
                   1061:     if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); }
1.849     albertel 1062:     $id=&make_key($name,$id);
1.599     albertel 1063:     $memcache->delete($id);
                   1064:     delete($remembered{$id});
                   1065:     delete($accessed{$id});
                   1066: }
                   1067: 
                   1068: sub is_cached_new {
                   1069:     my ($name,$id,$debug) = @_;
1.849     albertel 1070:     $id=&make_key($name,$id);
1.599     albertel 1071:     if (exists($remembered{$id})) {
                   1072: 	if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); }
                   1073: 	$accessed{$id}=[&gettimeofday()];
                   1074: 	$hits++;
                   1075: 	return ($remembered{$id},1);
                   1076:     }
                   1077:     my $value = $memcache->get($id);
                   1078:     if (!(defined($value))) {
                   1079: 	if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); }
1.417     albertel 1080: 	return (undef,undef);
1.416     albertel 1081:     }
1.599     albertel 1082:     if ($value eq '__undef__') {
                   1083: 	if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); }
                   1084: 	$value=undef;
                   1085:     }
                   1086:     &make_room($id,$value,$debug);
                   1087:     if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); }
                   1088:     return ($value,1);
                   1089: }
                   1090: 
                   1091: sub do_cache_new {
                   1092:     my ($name,$id,$value,$time,$debug) = @_;
1.849     albertel 1093:     $id=&make_key($name,$id);
1.599     albertel 1094:     my $setvalue=$value;
                   1095:     if (!defined($setvalue)) {
                   1096: 	$setvalue='__undef__';
                   1097:     }
1.623     albertel 1098:     if (!defined($time) ) {
                   1099: 	$time=600;
                   1100:     }
1.599     albertel 1101:     if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); }
1.600     albertel 1102:     $memcache->set($id,$setvalue,$time);
                   1103:     # need to make a copy of $value
                   1104:     #&make_room($id,$value,$debug);
1.599     albertel 1105:     return $value;
                   1106: }
                   1107: 
                   1108: sub make_room {
                   1109:     my ($id,$value,$debug)=@_;
                   1110:     $remembered{$id}=$value;
                   1111:     if ($to_remember<0) { return; }
                   1112:     $accessed{$id}=[&gettimeofday()];
                   1113:     if (scalar(keys(%remembered)) <= $to_remember) { return; }
                   1114:     my $to_kick;
                   1115:     my $max_time=0;
                   1116:     foreach my $other (keys(%accessed)) {
                   1117: 	if (&tv_interval($accessed{$other}) > $max_time) {
                   1118: 	    $to_kick=$other;
                   1119: 	    $max_time=&tv_interval($accessed{$other});
                   1120: 	}
                   1121:     }
                   1122:     delete($remembered{$to_kick});
                   1123:     delete($accessed{$to_kick});
                   1124:     $kicks++;
                   1125:     if ($debug) { &logthis("kicking $to_kick $max_time $kicks\n"); }
1.541     albertel 1126:     return;
                   1127: }
                   1128: 
1.599     albertel 1129: sub purge_remembered {
1.604     albertel 1130:     #&logthis("Tossing ".scalar(keys(%remembered)));
                   1131:     #&logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered))));
1.599     albertel 1132:     undef(%remembered);
                   1133:     undef(%accessed);
1.428     albertel 1134: }
1.70      www      1135: # ------------------------------------- Read an entry from a user's environment
                   1136: 
                   1137: sub userenvironment {
                   1138:     my ($udom,$unam,@what)=@_;
                   1139:     my %returnhash=();
                   1140:     my @answer=split(/\&/,
                   1141:                 &reply('get:'.$udom.':'.$unam.':environment:'.join('&',@what),
                   1142:                       &homeserver($unam,$udom)));
                   1143:     my $i;
                   1144:     for ($i=0;$i<=$#what;$i++) {
                   1145: 	$returnhash{$what[$i]}=&unescape($answer[$i]);
                   1146:     }
                   1147:     return %returnhash;
1.1       albertel 1148: }
                   1149: 
1.617     albertel 1150: # ---------------------------------------------------------- Get a studentphoto
                   1151: sub studentphoto {
                   1152:     my ($udom,$unam,$ext) = @_;
                   1153:     my $home=&Apache::lonnet::homeserver($unam,$udom);
1.706     raeburn  1154:     if (defined($env{'request.course.id'})) {
1.708     raeburn  1155:         if ($env{'course.'.$env{'request.course.id'}.'.internal.showphoto'}) {
1.706     raeburn  1156:             if ($udom eq $env{'course.'.$env{'request.course.id'}.'.domain'}) {
                   1157:                 return(&retrievestudentphoto($udom,$unam,$ext)); 
                   1158:             } else {
                   1159:                 my ($result,$perm_reqd)=
1.707     albertel 1160: 		    &Apache::lonnet::auto_photo_permission($unam,$udom);
1.706     raeburn  1161:                 if ($result eq 'ok') {
                   1162:                     if (!($perm_reqd eq 'yes')) {
                   1163:                         return(&retrievestudentphoto($udom,$unam,$ext));
                   1164:                     }
                   1165:                 }
                   1166:             }
                   1167:         }
                   1168:     } else {
                   1169:         my ($result,$perm_reqd) = 
1.707     albertel 1170: 	    &Apache::lonnet::auto_photo_permission($unam,$udom);
1.706     raeburn  1171:         if ($result eq 'ok') {
                   1172:             if (!($perm_reqd eq 'yes')) {
                   1173:                 return(&retrievestudentphoto($udom,$unam,$ext));
                   1174:             }
                   1175:         }
                   1176:     }
                   1177:     return '/adm/lonKaputt/lonlogo_broken.gif';
                   1178: }
                   1179: 
                   1180: sub retrievestudentphoto {
                   1181:     my ($udom,$unam,$ext,$type) = @_;
                   1182:     my $home=&Apache::lonnet::homeserver($unam,$udom);
                   1183:     my $ret=&Apache::lonnet::reply("studentphoto:$udom:$unam:$ext:$type",$home);
                   1184:     if ($ret eq 'ok') {
                   1185:         my $url="/uploaded/$udom/$unam/internal/studentphoto.$ext";
                   1186:         if ($type eq 'thumbnail') {
                   1187:             $url="/uploaded/$udom/$unam/internal/studentphoto_tn.$ext"; 
                   1188:         }
                   1189:         my $tokenurl=&Apache::lonnet::tokenwrapper($url);
                   1190:         return $tokenurl;
                   1191:     } else {
                   1192:         if ($type eq 'thumbnail') {
                   1193:             return '/adm/lonKaputt/genericstudent_tn.gif';
                   1194:         } else { 
                   1195:             return '/adm/lonKaputt/lonlogo_broken.gif';
                   1196:         }
1.617     albertel 1197:     }
                   1198: }
                   1199: 
1.263     www      1200: # -------------------------------------------------------------------- New chat
                   1201: 
                   1202: sub chatsend {
1.724     raeburn  1203:     my ($newentry,$anon,$group)=@_;
1.620     albertel 1204:     my $cnum=$env{'course.'.$env{'request.course.id'}.'.num'};
                   1205:     my $cdom=$env{'course.'.$env{'request.course.id'}.'.domain'};
                   1206:     my $chome=$env{'course.'.$env{'request.course.id'}.'.home'};
1.263     www      1207:     &reply('chatsend:'.$cdom.':'.$cnum.':'.
1.620     albertel 1208: 	   &escape($env{'user.domain'}.':'.$env{'user.name'}.':'.$anon.':'.
1.724     raeburn  1209: 		   &escape($newentry)).':'.$group,$chome);
1.292     www      1210: }
                   1211: 
                   1212: # ------------------------------------------ Find current version of a resource
                   1213: 
                   1214: sub getversion {
                   1215:     my $fname=&clutter(shift);
                   1216:     unless ($fname=~/^\/res\//) { return -1; }
                   1217:     return &currentversion(&filelocation('',$fname));
                   1218: }
                   1219: 
                   1220: sub currentversion {
                   1221:     my $fname=shift;
1.599     albertel 1222:     my ($result,$cached)=&is_cached_new('resversion',$fname);
1.440     www      1223:     if (defined($cached)) { return $result; }
1.292     www      1224:     my $author=$fname;
                   1225:     $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
                   1226:     my ($udom,$uname)=split(/\//,$author);
                   1227:     my $home=homeserver($uname,$udom);
                   1228:     if ($home eq 'no_host') { 
                   1229:         return -1; 
                   1230:     }
                   1231:     my $answer=reply("currentversion:$fname",$home);
                   1232:     if (($answer eq 'con_lost') || ($answer eq 'rejected')) {
                   1233: 	return -1;
                   1234:     }
1.599     albertel 1235:     return &do_cache_new('resversion',$fname,$answer,600);
1.263     www      1236: }
                   1237: 
1.1       albertel 1238: # ----------------------------- Subscribe to a resource, return URL if possible
1.11      www      1239: 
1.1       albertel 1240: sub subscribe {
                   1241:     my $fname=shift;
1.761     raeburn  1242:     if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return ''; }
1.532     albertel 1243:     $fname=~s/[\n\r]//g;
1.1       albertel 1244:     my $author=$fname;
                   1245:     $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
                   1246:     my ($udom,$uname)=split(/\//,$author);
                   1247:     my $home=homeserver($uname,$udom);
1.335     albertel 1248:     if ($home eq 'no_host') {
                   1249:         return 'not_found';
1.1       albertel 1250:     }
                   1251:     my $answer=reply("sub:$fname",$home);
1.64      www      1252:     if (($answer eq 'con_lost') || ($answer eq 'rejected')) {
                   1253: 	$answer.=' by '.$home;
                   1254:     }
1.1       albertel 1255:     return $answer;
                   1256: }
                   1257:     
1.8       www      1258: # -------------------------------------------------------------- Replicate file
                   1259: 
                   1260: sub repcopy {
                   1261:     my $filename=shift;
1.23      www      1262:     $filename=~s/\/+/\//g;
1.607     raeburn  1263:     if ($filename=~m|^/home/httpd/html/adm/|) { return 'ok'; }
                   1264:     if ($filename=~m|^/home/httpd/html/lonUsers/|) { return 'ok'; }
1.538     albertel 1265:     if ($filename=~m|^/home/httpd/html/userfiles/| or
1.609     banghart 1266: 	$filename=~m -^/*(uploaded|editupload)/-) { 
1.538     albertel 1267: 	return &repcopy_userfile($filename);
                   1268:     }
1.532     albertel 1269:     $filename=~s/[\n\r]//g;
1.8       www      1270:     my $transname="$filename.in.transfer";
1.828     www      1271: # FIXME: this should flock
1.607     raeburn  1272:     if ((-e $filename) || (-e $transname)) { return 'ok'; }
1.8       www      1273:     my $remoteurl=subscribe($filename);
1.64      www      1274:     if ($remoteurl =~ /^con_lost by/) {
                   1275: 	   &logthis("Subscribe returned $remoteurl: $filename");
1.607     raeburn  1276:            return 'unavailable';
1.8       www      1277:     } elsif ($remoteurl eq 'not_found') {
1.441     albertel 1278: 	   #&logthis("Subscribe returned not_found: $filename");
1.607     raeburn  1279: 	   return 'not_found';
1.64      www      1280:     } elsif ($remoteurl =~ /^rejected by/) {
                   1281: 	   &logthis("Subscribe returned $remoteurl: $filename");
1.607     raeburn  1282:            return 'forbidden';
1.20      www      1283:     } elsif ($remoteurl eq 'directory') {
1.607     raeburn  1284:            return 'ok';
1.8       www      1285:     } else {
1.290     www      1286:         my $author=$filename;
                   1287:         $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
                   1288:         my ($udom,$uname)=split(/\//,$author);
                   1289:         my $home=homeserver($uname,$udom);
                   1290:         unless ($home eq $perlvar{'lonHostID'}) {
1.8       www      1291:            my @parts=split(/\//,$filename);
                   1292:            my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";
                   1293:            if ($path ne "$perlvar{'lonDocRoot'}/res") {
                   1294:                &logthis("Malconfiguration for replication: $filename");
1.607     raeburn  1295: 	       return 'bad_request';
1.8       www      1296:            }
                   1297:            my $count;
                   1298:            for ($count=5;$count<$#parts;$count++) {
                   1299:                $path.="/$parts[$count]";
                   1300:                if ((-e $path)!=1) {
                   1301: 		   mkdir($path,0777);
                   1302:                }
                   1303:            }
                   1304:            my $ua=new LWP::UserAgent;
                   1305:            my $request=new HTTP::Request('GET',"$remoteurl");
                   1306:            my $response=$ua->request($request,$transname);
                   1307:            if ($response->is_error()) {
                   1308: 	       unlink($transname);
                   1309:                my $message=$response->status_line;
1.672     albertel 1310:                &logthis("<font color=\"blue\">WARNING:"
1.12      www      1311:                        ." LWP get: $message: $filename</font>");
1.607     raeburn  1312:                return 'unavailable';
1.8       www      1313:            } else {
1.16      www      1314: 	       if ($remoteurl!~/\.meta$/) {
                   1315:                   my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');
                   1316:                   my $mresponse=$ua->request($mrequest,$filename.'.meta');
                   1317:                   if ($mresponse->is_error()) {
                   1318: 		      unlink($filename.'.meta');
                   1319:                       &logthis(
1.672     albertel 1320:                      "<font color=\"yellow\">INFO: No metadata: $filename</font>");
1.16      www      1321:                   }
                   1322: 	       }
1.8       www      1323:                rename($transname,$filename);
1.607     raeburn  1324:                return 'ok';
1.8       www      1325:            }
1.290     www      1326:        }
1.8       www      1327:     }
1.330     www      1328: }
                   1329: 
                   1330: # ------------------------------------------------ Get server side include body
                   1331: sub ssi_body {
1.381     albertel 1332:     my ($filelink,%form)=@_;
1.606     matthew  1333:     if (! exists($form{'LONCAPA_INTERNAL_no_discussion'})) {
                   1334:         $form{'LONCAPA_INTERNAL_no_discussion'}='true';
                   1335:     }
1.330     www      1336:     my $output=($filelink=~/^http\:/?&externalssi($filelink):
1.381     albertel 1337:                                      &ssi($filelink,%form));
1.778     albertel 1338:     $output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+?// END LON-CAPA Internal\s*(-->)?\s||gs;
1.451     albertel 1339:     $output=~s/^.*?\<body[^\>]*\>//si;
                   1340:     $output=~s/(.*)\<\/body\s*\>.*?$/$1/si;
1.330     www      1341:     return $output;
1.8       www      1342: }
                   1343: 
1.15      www      1344: # --------------------------------------------------------- Server Side Include
                   1345: 
1.782     albertel 1346: sub absolute_url {
                   1347:     my ($host_name) = @_;
                   1348:     my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://');
                   1349:     if ($host_name eq '') {
                   1350: 	$host_name = $ENV{'SERVER_NAME'};
                   1351:     }
                   1352:     return $protocol.$host_name;
                   1353: }
                   1354: 
1.15      www      1355: sub ssi {
                   1356: 
1.23      www      1357:     my ($fn,%form)=@_;
1.15      www      1358: 
                   1359:     my $ua=new LWP::UserAgent;
1.23      www      1360:     
                   1361:     my $request;
1.711     albertel 1362: 
                   1363:     $form{'no_update_last_known'}=1;
                   1364: 
1.23      www      1365:     if (%form) {
1.782     albertel 1366:       $request=new HTTP::Request('POST',&absolute_url().$fn);
1.201     albertel 1367:       $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form));
1.23      www      1368:     } else {
1.782     albertel 1369:       $request=new HTTP::Request('GET',&absolute_url().$fn);
1.23      www      1370:     }
                   1371: 
1.15      www      1372:     $request->header(Cookie => $ENV{'HTTP_COOKIE'});
                   1373:     my $response=$ua->request($request);
                   1374: 
1.324     www      1375:     return $response->content;
                   1376: }
                   1377: 
                   1378: sub externalssi {
                   1379:     my ($url)=@_;
                   1380:     my $ua=new LWP::UserAgent;
                   1381:     my $request=new HTTP::Request('GET',$url);
                   1382:     my $response=$ua->request($request);
1.15      www      1383:     return $response->content;
                   1384: }
1.254     www      1385: 
1.492     albertel 1386: # -------------------------------- Allow a /uploaded/ URI to be vouched for
                   1387: 
                   1388: sub allowuploaded {
                   1389:     my ($srcurl,$url)=@_;
                   1390:     $url=&clutter(&declutter($url));
                   1391:     my $dir=$url;
                   1392:     $dir=~s/\/[^\/]+$//;
                   1393:     my %httpref=();
                   1394:     my $httpurl=&hreflocation('',$url);
                   1395:     $httpref{'httpref.'.$httpurl}=$srcurl;
                   1396:     &Apache::lonnet::appenv(%httpref);
1.254     www      1397: }
1.477     raeburn  1398: 
1.478     albertel 1399: # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course
1.638     albertel 1400: # input: action, courseID, current domain, intended
1.637     raeburn  1401: #        path to file, source of file, instruction to parse file for objects,
                   1402: #        ref to hash for embedded objects,
                   1403: #        ref to hash for codebase of java objects.
                   1404: #
1.485     raeburn  1405: # output: url to file (if action was uploaddoc), 
                   1406: #         ok if successful, or diagnostic message otherwise (if action was propagate or copy)
1.477     raeburn  1407: #
1.478     albertel 1408: # Allows directory structure to be used within lonUsers/../userfiles/ for a 
                   1409: # course.
1.477     raeburn  1410: #
1.478     albertel 1411: # action = propagate - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
                   1412: #          will be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles in
                   1413: #          course's home server.
1.477     raeburn  1414: #
1.478     albertel 1415: # action = copy - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file will
                   1416: #          be copied from $source (current location) to 
                   1417: #          /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
                   1418: #         and will then be copied to
                   1419: #          /home/httpd/lonUsers/$domain/1/2/3/$course/userfiles/$file in
                   1420: #         course's home server.
1.485     raeburn  1421: #
1.481     raeburn  1422: # action = uploaddoc - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
1.620     albertel 1423: #         will be retrived from $env{form.uploaddoc} (from DOCS interface) to
1.481     raeburn  1424: #         /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
                   1425: #         and will then be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles/$file
                   1426: #         in course's home server.
1.637     raeburn  1427: #
1.477     raeburn  1428: 
                   1429: sub process_coursefile {
1.638     albertel 1430:     my ($action,$docuname,$docudom,$file,$source,$parser,$allfiles,$codebase)=@_;
1.477     raeburn  1431:     my $fetchresult;
1.638     albertel 1432:     my $home=&homeserver($docuname,$docudom);
1.477     raeburn  1433:     if ($action eq 'propagate') {
1.638     albertel 1434:         $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
                   1435: 			     $home);
1.481     raeburn  1436:     } else {
1.477     raeburn  1437:         my $fpath = '';
                   1438:         my $fname = $file;
1.478     albertel 1439:         ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|);
1.477     raeburn  1440:         $fpath=$docudom.'/'.$docuname.'/'.$fpath;
1.637     raeburn  1441:         my $filepath = &build_filepath($fpath);
1.481     raeburn  1442:         if ($action eq 'copy') {
                   1443:             if ($source eq '') {
                   1444:                 $fetchresult = 'no source file';
                   1445:                 return $fetchresult;
                   1446:             } else {
                   1447:                 my $destination = $filepath.'/'.$fname;
                   1448:                 rename($source,$destination);
                   1449:                 $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
1.638     albertel 1450:                                  $home);
1.481     raeburn  1451:             }
                   1452:         } elsif ($action eq 'uploaddoc') {
                   1453:             open(my $fh,'>'.$filepath.'/'.$fname);
1.620     albertel 1454:             print $fh $env{'form.'.$source};
1.481     raeburn  1455:             close($fh);
1.637     raeburn  1456:             if ($parser eq 'parse') {
                   1457:                 my $parse_result = &extract_embedded_items($filepath,$fname,$allfiles,$codebase);
                   1458:                 unless ($parse_result eq 'ok') {
                   1459:                     &logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result);
                   1460:                 }
                   1461:             }
1.477     raeburn  1462:             $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
1.638     albertel 1463:                                  $home);
1.481     raeburn  1464:             if ($fetchresult eq 'ok') {
                   1465:                 return '/uploaded/'.$fpath.'/'.$fname;
                   1466:             } else {
                   1467:                 &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.
1.638     albertel 1468:                         ' to host '.$home.': '.$fetchresult);
1.481     raeburn  1469:                 return '/adm/notfound.html';
                   1470:             }
1.477     raeburn  1471:         }
                   1472:     }
1.485     raeburn  1473:     unless ( $fetchresult eq 'ok') {
1.477     raeburn  1474:         &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.
1.638     albertel 1475:              ' to host '.$home.': '.$fetchresult);
1.477     raeburn  1476:     }
                   1477:     return $fetchresult;
                   1478: }
                   1479: 
1.637     raeburn  1480: sub build_filepath {
                   1481:     my ($fpath) = @_;
                   1482:     my $filepath=$perlvar{'lonDocRoot'}.'/userfiles';
                   1483:     unless ($fpath eq '') {
                   1484:         my @parts=split('/',$fpath);
                   1485:         foreach my $part (@parts) {
                   1486:             $filepath.= '/'.$part;
                   1487:             if ((-e $filepath)!=1) {
                   1488:                 mkdir($filepath,0777);
                   1489:             }
                   1490:         }
                   1491:     }
                   1492:     return $filepath;
                   1493: }
                   1494: 
                   1495: sub store_edited_file {
1.638     albertel 1496:     my ($primary_url,$content,$docudom,$docuname,$fetchresult) = @_;
1.637     raeburn  1497:     my $file = $primary_url;
                   1498:     $file =~ s#^/uploaded/$docudom/$docuname/##;
                   1499:     my $fpath = '';
                   1500:     my $fname = $file;
                   1501:     ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|);
                   1502:     $fpath=$docudom.'/'.$docuname.'/'.$fpath;
                   1503:     my $filepath = &build_filepath($fpath);
                   1504:     open(my $fh,'>'.$filepath.'/'.$fname);
                   1505:     print $fh $content;
                   1506:     close($fh);
1.638     albertel 1507:     my $home=&homeserver($docuname,$docudom);
1.637     raeburn  1508:     $$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
1.638     albertel 1509: 			  $home);
1.637     raeburn  1510:     if ($$fetchresult eq 'ok') {
                   1511:         return '/uploaded/'.$fpath.'/'.$fname;
                   1512:     } else {
1.638     albertel 1513:         &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.
                   1514: 		 ' to host '.$home.': '.$$fetchresult);
1.637     raeburn  1515:         return '/adm/notfound.html';
                   1516:     }
                   1517: }
                   1518: 
1.531     albertel 1519: sub clean_filename {
1.831     albertel 1520:     my ($fname,$args)=@_;
1.315     www      1521: # Replace Windows backslashes by forward slashes
1.257     www      1522:     $fname=~s/\\/\//g;
1.831     albertel 1523:     if (!$args->{'keep_path'}) {
                   1524:         # Get rid of everything but the actual filename
                   1525: 	$fname=~s/^.*\/([^\/]+)$/$1/;
                   1526:     }
1.315     www      1527: # Replace spaces by underscores
                   1528:     $fname=~s/\s+/\_/g;
                   1529: # Replace all other weird characters by nothing
1.831     albertel 1530:     $fname=~s{[^/\w\.\-]}{}g;
1.540     albertel 1531: # Replace all .\d. sequences with _\d. so they no longer look like version
                   1532: # numbers
                   1533:     $fname=~s/\.(\d+)(?=\.)/_$1/g;
1.531     albertel 1534:     return $fname;
                   1535: }
                   1536: 
1.608     albertel 1537: # --------------- Take an uploaded file and put it into the userfiles directory
1.686     albertel 1538: # input: $formname - the contents of the file are in $env{"form.$formname"}
1.719     banghart 1539: #                    the desired filenam is in $env{"form.$formname.filename"}
1.686     albertel 1540: #        $coursedoc - if true up to the current course
                   1541: #                     if false
                   1542: #        $subdir - directory in userfile to store the file into
1.858     raeburn  1543: #        $parser - instruction to parse file for objects ($parser = parse)    
                   1544: #        $allfiles - reference to hash for embedded objects
                   1545: #        $codebase - reference to hash for codebase of java objects
                   1546: #        $desuname - username for permanent storage of uploaded file
                   1547: #        $dsetudom - domain for permanaent storage of uploaded file
1.860     raeburn  1548: #        $thumbwidth - width (pixels) of thumbnail to make for uploaded image 
                   1549: #        $thumbheight - height (pixels) of thumbnail to make for uploaded image
1.858     raeburn  1550: # 
1.686     albertel 1551: # output: url of file in userspace, or error: <message> 
                   1552: #             or /adm/notfound.html if failure to upload occurse
1.608     albertel 1553: 
                   1554: 
1.531     albertel 1555: sub userfileupload {
1.860     raeburn  1556:     my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname,
                   1557:         $destudom,$thumbwidth,$thumbheight)=@_;
1.531     albertel 1558:     if (!defined($subdir)) { $subdir='unknown'; }
1.620     albertel 1559:     my $fname=$env{'form.'.$formname.'.filename'};
1.531     albertel 1560:     $fname=&clean_filename($fname);
1.315     www      1561: # See if there is anything left
1.257     www      1562:     unless ($fname) { return 'error: no uploaded file'; }
1.620     albertel 1563:     chop($env{'form.'.$formname});
1.523     raeburn  1564:     if (($formname eq 'screenshot') && ($subdir eq 'helprequests')) { #files uploaded to help request form are handled differently
                   1565:         my $now = time;
                   1566:         my $filepath = 'tmp/helprequests/'.$now;
                   1567:         my @parts=split(/\//,$filepath);
                   1568:         my $fullpath = $perlvar{'lonDaemons'};
                   1569:         for (my $i=0;$i<@parts;$i++) {
                   1570:             $fullpath .= '/'.$parts[$i];
                   1571:             if ((-e $fullpath)!=1) {
                   1572:                 mkdir($fullpath,0777);
                   1573:             }
                   1574:         }
                   1575:         open(my $fh,'>'.$fullpath.'/'.$fname);
1.620     albertel 1576:         print $fh $env{'form.'.$formname};
1.523     raeburn  1577:         close($fh);
1.741     raeburn  1578:         return $fullpath.'/'.$fname;
                   1579:     } elsif (($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) { #files uploaded to create course page are handled differently
                   1580:         my $filepath = 'tmp/addcourse/'.$destudom.'/web/'.$env{'user.name'}.
                   1581:                        '_'.$env{'user.domain'}.'/pending';
                   1582:         my @parts=split(/\//,$filepath);
                   1583:         my $fullpath = $perlvar{'lonDaemons'};
                   1584:         for (my $i=0;$i<@parts;$i++) {
                   1585:             $fullpath .= '/'.$parts[$i];
                   1586:             if ((-e $fullpath)!=1) {
                   1587:                 mkdir($fullpath,0777);
                   1588:             }
                   1589:         }
                   1590:         open(my $fh,'>'.$fullpath.'/'.$fname);
                   1591:         print $fh $env{'form.'.$formname};
                   1592:         close($fh);
                   1593:         return $fullpath.'/'.$fname;
1.523     raeburn  1594:     }
1.719     banghart 1595:     
1.258     www      1596: # Create the directory if not present
1.493     albertel 1597:     $fname="$subdir/$fname";
1.259     www      1598:     if ($coursedoc) {
1.638     albertel 1599: 	my $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
                   1600: 	my $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
1.646     raeburn  1601:         if ($env{'form.folder'} =~ m/^(default|supplemental)/) {
1.638     albertel 1602:             return &finishuserfileupload($docuname,$docudom,
                   1603: 					 $formname,$fname,$parser,$allfiles,
1.860     raeburn  1604: 					 $codebase,$thumbwidth,$thumbheight);
1.481     raeburn  1605:         } else {
1.620     albertel 1606:             $fname=$env{'form.folder'}.'/'.$fname;
1.638     albertel 1607:             return &process_coursefile('uploaddoc',$docuname,$docudom,
                   1608: 				       $fname,$formname,$parser,
                   1609: 				       $allfiles,$codebase);
1.481     raeburn  1610:         }
1.719     banghart 1611:     } elsif (defined($destuname)) {
                   1612:         my $docuname=$destuname;
                   1613:         my $docudom=$destudom;
1.860     raeburn  1614: 	return &finishuserfileupload($docuname,$docudom,$formname,$fname,
                   1615: 				     $parser,$allfiles,$codebase,
                   1616:                                      $thumbwidth,$thumbheight);
1.719     banghart 1617:         
1.259     www      1618:     } else {
1.638     albertel 1619:         my $docuname=$env{'user.name'};
                   1620:         my $docudom=$env{'user.domain'};
1.714     raeburn  1621:         if (exists($env{'form.group'})) {
                   1622:             $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
                   1623:             $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
                   1624:         }
1.860     raeburn  1625: 	return &finishuserfileupload($docuname,$docudom,$formname,$fname,
                   1626: 				     $parser,$allfiles,$codebase,
                   1627:                                      $thumbwidth,$thumbheight);
1.259     www      1628:     }
1.271     www      1629: }
                   1630: 
                   1631: sub finishuserfileupload {
1.860     raeburn  1632:     my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase,
                   1633:         $thumbwidth,$thumbheight) = @_;
1.477     raeburn  1634:     my $path=$docudom.'/'.$docuname.'/';
1.258     www      1635:     my $filepath=$perlvar{'lonDocRoot'};
1.860     raeburn  1636:     my ($fnamepath,$file,$fetchthumb);
1.494     albertel 1637:     $file=$fname;
                   1638:     if ($fname=~m|/|) {
                   1639:         ($fnamepath,$file) = ($fname =~ m|^(.*)/([^/]+)$|);
                   1640: 	$path.=$fnamepath.'/';
                   1641:     }
1.259     www      1642:     my @parts=split(/\//,$filepath.'/userfiles/'.$path);
1.258     www      1643:     my $count;
                   1644:     for ($count=4;$count<=$#parts;$count++) {
                   1645:         $filepath.="/$parts[$count]";
                   1646:         if ((-e $filepath)!=1) {
                   1647: 	    mkdir($filepath,0777);
                   1648:         }
                   1649:     }
                   1650: # Save the file
                   1651:     {
1.701     albertel 1652: 	if (!open(FH,'>'.$filepath.'/'.$file)) {
                   1653: 	    &logthis('Failed to create '.$filepath.'/'.$file);
                   1654: 	    print STDERR ('Failed to create '.$filepath.'/'.$file."\n");
                   1655: 	    return '/adm/notfound.html';
                   1656: 	}
                   1657: 	if (!print FH ($env{'form.'.$formname})) {
                   1658: 	    &logthis('Failed to write to '.$filepath.'/'.$file);
                   1659: 	    print STDERR ('Failed to write to '.$filepath.'/'.$file."\n");
                   1660: 	    return '/adm/notfound.html';
                   1661: 	}
1.570     albertel 1662: 	close(FH);
1.258     www      1663:     }
1.637     raeburn  1664:     if ($parser eq 'parse') {
1.638     albertel 1665:         my $parse_result = &extract_embedded_items($filepath,$file,$allfiles,
                   1666: 						   $codebase);
1.637     raeburn  1667:         unless ($parse_result eq 'ok') {
1.638     albertel 1668:             &logthis('Failed to parse '.$filepath.$file.
                   1669: 		     ' for embedded media: '.$parse_result); 
1.637     raeburn  1670:         }
                   1671:     }
1.860     raeburn  1672:     if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {
                   1673:         my $input = $filepath.'/'.$file;
                   1674:         my $output = $filepath.'/'.'tn-'.$file;
                   1675:         my $thumbsize = $thumbwidth.'x'.$thumbheight;
                   1676:         system("convert -sample $thumbsize $input $output");
                   1677:         if (-e $filepath.'/'.'tn-'.$file) {
                   1678:             $fetchthumb  = 1; 
                   1679:         }
                   1680:     }
1.858     raeburn  1681:  
1.259     www      1682: # Notify homeserver to grep it
                   1683: #
1.638     albertel 1684:     my $docuhome=&homeserver($docuname,$docudom);
1.494     albertel 1685:     my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);
1.295     www      1686:     if ($fetchresult eq 'ok') {
1.860     raeburn  1687:         if ($fetchthumb) {
                   1688:             my $thumbresult= &reply('fetchuserfile:'.$path.'tn-'.$file,$docuhome);
                   1689:             if ($thumbresult ne 'ok') {
                   1690:                 &logthis('Failed to transfer '.$path.'tn-'.$file.' to host '.
                   1691:                          $docuhome.': '.$thumbresult);
                   1692:             }
                   1693:         }
1.259     www      1694: #
1.258     www      1695: # Return the URL to it
1.494     albertel 1696:         return '/uploaded/'.$path.$file;
1.263     www      1697:     } else {
1.494     albertel 1698:         &logthis('Failed to transfer '.$path.$file.' to host '.$docuhome.
                   1699: 		 ': '.$fetchresult);
1.263     www      1700:         return '/adm/notfound.html';
1.858     raeburn  1701:     }
1.493     albertel 1702: }
                   1703: 
1.637     raeburn  1704: sub extract_embedded_items {
1.648     raeburn  1705:     my ($filepath,$file,$allfiles,$codebase,$content) = @_;
1.637     raeburn  1706:     my @state = ();
                   1707:     my %javafiles = (
                   1708:                       codebase => '',
                   1709:                       code => '',
                   1710:                       archive => ''
                   1711:                     );
                   1712:     my %mediafiles = (
                   1713:                       src => '',
                   1714:                       movie => '',
                   1715:                      );
1.648     raeburn  1716:     my $p;
                   1717:     if ($content) {
                   1718:         $p = HTML::LCParser->new($content);
                   1719:     } else {
                   1720:         $p = HTML::LCParser->new($filepath.'/'.$file);
                   1721:     }
1.641     albertel 1722:     while (my $t=$p->get_token()) {
1.640     albertel 1723: 	if ($t->[0] eq 'S') {
                   1724: 	    my ($tagname, $attr) = ($t->[1],$t->[2]);
                   1725: 	    push (@state, $tagname);
1.648     raeburn  1726:             if (lc($tagname) eq 'allow') {
                   1727:                 &add_filetype($allfiles,$attr->{'src'},'src');
                   1728:             }
1.640     albertel 1729: 	    if (lc($tagname) eq 'img') {
                   1730: 		&add_filetype($allfiles,$attr->{'src'},'src');
                   1731: 	    }
1.645     raeburn  1732:             if (lc($tagname) eq 'script') {
                   1733:                 if ($attr->{'archive'} =~ /\.jar$/i) {
                   1734:                     &add_filetype($allfiles,$attr->{'archive'},'archive');
                   1735:                 } else {
                   1736:                     &add_filetype($allfiles,$attr->{'src'},'src');
                   1737:                 }
                   1738:             }
                   1739:             if (lc($tagname) eq 'link') {
                   1740:                 if (lc($attr->{'rel'}) eq 'stylesheet') { 
                   1741:                     &add_filetype($allfiles,$attr->{'href'},'href');
                   1742:                 }
                   1743:             }
1.640     albertel 1744: 	    if (lc($tagname) eq 'object' ||
                   1745: 		(lc($tagname) eq 'embed' && lc($state[-2]) ne 'object')) {
                   1746: 		foreach my $item (keys(%javafiles)) {
                   1747: 		    $javafiles{$item} = '';
                   1748: 		}
                   1749: 	    }
                   1750: 	    if (lc($state[-2]) eq 'object' && lc($tagname) eq 'param') {
                   1751: 		my $name = lc($attr->{'name'});
                   1752: 		foreach my $item (keys(%javafiles)) {
                   1753: 		    if ($name eq $item) {
                   1754: 			$javafiles{$item} = $attr->{'value'};
                   1755: 			last;
                   1756: 		    }
                   1757: 		}
                   1758: 		foreach my $item (keys(%mediafiles)) {
                   1759: 		    if ($name eq $item) {
                   1760: 			&add_filetype($allfiles, $attr->{'value'}, 'value');
                   1761: 			last;
                   1762: 		    }
                   1763: 		}
                   1764: 	    }
                   1765: 	    if (lc($tagname) eq 'embed' || lc($tagname) eq 'applet') {
                   1766: 		foreach my $item (keys(%javafiles)) {
                   1767: 		    if ($attr->{$item}) {
                   1768: 			$javafiles{$item} = $attr->{$item};
                   1769: 			last;
                   1770: 		    }
                   1771: 		}
                   1772: 		foreach my $item (keys(%mediafiles)) {
                   1773: 		    if ($attr->{$item}) {
                   1774: 			&add_filetype($allfiles,$attr->{$item},$item);
                   1775: 			last;
                   1776: 		    }
                   1777: 		}
                   1778: 	    }
                   1779: 	} elsif ($t->[0] eq 'E') {
                   1780: 	    my ($tagname) = ($t->[1]);
                   1781: 	    if ($javafiles{'codebase'} ne '') {
                   1782: 		$javafiles{'codebase'} .= '/';
                   1783: 	    }  
                   1784: 	    if (lc($tagname) eq 'applet' ||
                   1785: 		lc($tagname) eq 'object' ||
                   1786: 		(lc($tagname) eq 'embed' && lc($state[-2]) ne 'object')
                   1787: 		) {
                   1788: 		foreach my $item (keys(%javafiles)) {
                   1789: 		    if ($item ne 'codebase' && $javafiles{$item} ne '') {
                   1790: 			my $file=$javafiles{'codebase'}.$javafiles{$item};
                   1791: 			&add_filetype($allfiles,$file,$item);
                   1792: 		    }
                   1793: 		}
                   1794: 	    } 
                   1795: 	    pop @state;
                   1796: 	}
                   1797:     }
1.637     raeburn  1798:     return 'ok';
                   1799: }
                   1800: 
1.639     albertel 1801: sub add_filetype {
                   1802:     my ($allfiles,$file,$type)=@_;
                   1803:     if (exists($allfiles->{$file})) {
                   1804: 	unless (grep/^\Q$type\E$/, @{$allfiles->{$file}}) {
                   1805: 	    push(@{$allfiles->{$file}}, &escape($type));
                   1806: 	}
                   1807:     } else {
                   1808: 	@{$allfiles->{$file}} = (&escape($type));
1.637     raeburn  1809:     }
                   1810: }
                   1811: 
1.493     albertel 1812: sub removeuploadedurl {
                   1813:     my ($url)=@_;
                   1814:     my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);
1.613     albertel 1815:     return &removeuserfile($uname,$udom,$fname);
1.490     albertel 1816: }
                   1817: 
                   1818: sub removeuserfile {
                   1819:     my ($docuname,$docudom,$fname)=@_;
                   1820:     my $home=&homeserver($docuname,$docudom);
1.798     raeburn  1821:     my $result = &reply("removeuserfile:$docudom/$docuname/$fname",$home);
                   1822:     if ($result eq 'ok') {
                   1823:         if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) {
                   1824:             my $metafile = $fname.'.meta';
                   1825:             my $metaresult = &removeuserfile($docuname,$docudom,$metafile); 
1.823     albertel 1826: 	    my $url = "/uploaded/$docudom/$docuname/$fname";
                   1827:             my ($file,$group) = (&parse_portfolio_url($url))[3,4];
1.821     raeburn  1828:             my $sqlresult = 
1.823     albertel 1829:                 &update_portfolio_table($docuname,$docudom,$file,
1.821     raeburn  1830:                                         'portfolio_metadata',$group,
                   1831:                                         'delete');
1.798     raeburn  1832:         }
                   1833:     }
                   1834:     return $result;
1.257     www      1835: }
1.15      www      1836: 
1.530     albertel 1837: sub mkdiruserfile {
                   1838:     my ($docuname,$docudom,$dir)=@_;
                   1839:     my $home=&homeserver($docuname,$docudom);
                   1840:     return &reply("mkdiruserfile:".&escape("$docudom/$docuname/$dir"),$home);
                   1841: }
                   1842: 
1.531     albertel 1843: sub renameuserfile {
                   1844:     my ($docuname,$docudom,$old,$new)=@_;
                   1845:     my $home=&homeserver($docuname,$docudom);
1.798     raeburn  1846:     my $result = &reply("renameuserfile:$docudom:$docuname:".
                   1847:                         &escape("$old").':'.&escape("$new"),$home);
                   1848:     if ($result eq 'ok') {
                   1849:         if (($old !~ /\.meta$/) && (&is_portfolio_file($old))) {
                   1850:             my $oldmeta = $old.'.meta';
                   1851:             my $newmeta = $new.'.meta';
                   1852:             my $metaresult = 
                   1853:                 &renameuserfile($docuname,$docudom,$oldmeta,$newmeta);
1.823     albertel 1854: 	    my $url = "/uploaded/$docudom/$docuname/$old";
                   1855:             my ($file,$group) = (&parse_portfolio_url($url))[3,4];
1.821     raeburn  1856:             my $sqlresult = 
1.823     albertel 1857:                 &update_portfolio_table($docuname,$docudom,$file,
1.821     raeburn  1858:                                         'portfolio_metadata',$group,
                   1859:                                         'delete');
1.798     raeburn  1860:         }
                   1861:     }
                   1862:     return $result;
1.531     albertel 1863: }
                   1864: 
1.14      www      1865: # ------------------------------------------------------------------------- Log
                   1866: 
                   1867: sub log {
                   1868:     my ($dom,$nam,$hom,$what)=@_;
1.47      www      1869:     return critical("log:$dom:$nam:$what",$hom);
1.157     www      1870: }
                   1871: 
                   1872: # ------------------------------------------------------------------ Course Log
1.352     www      1873: #
                   1874: # This routine flushes several buffers of non-mission-critical nature
                   1875: #
1.157     www      1876: 
                   1877: sub flushcourselogs {
1.352     www      1878:     &logthis('Flushing log buffers');
                   1879: #
                   1880: # course logs
                   1881: # This is a log of all transactions in a course, which can be used
                   1882: # for data mining purposes
                   1883: #
                   1884: # It also collects the courseid database, which lists last transaction
                   1885: # times and course titles for all courseids
                   1886: #
                   1887:     my %courseidbuffer=();
1.800     albertel 1888:     foreach my $crsid (keys %courselogs) {
1.352     www      1889:         if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$crsid}.':'.
1.188     www      1890: 		          &escape($courselogs{$crsid}),
                   1891: 		          $coursehombuf{$crsid}) eq 'ok') {
1.157     www      1892: 	    delete $courselogs{$crsid};
                   1893:         } else {
                   1894:             &logthis('Failed to flush log buffer for '.$crsid);
                   1895:             if (length($courselogs{$crsid})>40000) {
1.672     albertel 1896:                &logthis("<font color=\"blue\">WARNING: Buffer for ".$crsid.
1.157     www      1897:                         " exceeded maximum size, deleting.</font>");
                   1898:                delete $courselogs{$crsid};
                   1899:             }
1.352     www      1900:         }
                   1901:         if ($courseidbuffer{$coursehombuf{$crsid}}) {
                   1902:            $courseidbuffer{$coursehombuf{$crsid}}.='&'.
1.516     raeburn  1903: 			 &escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
1.741     raeburn  1904:                          ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}).':'.&escape($coursetypebuf{$crsid});
1.352     www      1905:         } else {
                   1906:            $courseidbuffer{$coursehombuf{$crsid}}=
1.516     raeburn  1907: 			 &escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
1.741     raeburn  1908:                          ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}).':'.&escape($coursetypebuf{$crsid});
1.571     raeburn  1909:         }
1.191     harris41 1910:     }
1.352     www      1911: #
                   1912: # Write course id database (reverse lookup) to homeserver of courses 
                   1913: # Is used in pickcourse
                   1914: #
1.840     albertel 1915:     foreach my $crs_home (keys(%courseidbuffer)) {
1.844     albertel 1916:         &courseidput(&host_domain($crs_home),$courseidbuffer{$crs_home},
1.840     albertel 1917: 		     $crs_home);
1.352     www      1918:     }
                   1919: #
                   1920: # File accesses
                   1921: # Writes to the dynamic metadata of resources to get hit counts, etc.
                   1922: #
1.449     matthew  1923:     foreach my $entry (keys(%accesshash)) {
1.458     matthew  1924:         if ($entry =~ /___count$/) {
                   1925:             my ($dom,$name);
1.807     albertel 1926:             ($dom,$name,undef)=
1.811     albertel 1927: 		($entry=~m{___($match_domain)/($match_name)/(.*)___count$});
1.458     matthew  1928:             if (! defined($dom) || $dom eq '' || 
                   1929:                 ! defined($name) || $name eq '') {
1.620     albertel 1930:                 my $cid = $env{'request.course.id'};
                   1931:                 $dom  = $env{'request.'.$cid.'.domain'};
                   1932:                 $name = $env{'request.'.$cid.'.num'};
1.458     matthew  1933:             }
1.450     matthew  1934:             my $value = $accesshash{$entry};
                   1935:             my (undef,$url,undef) = ($entry =~ /^(.*)___(.*)___count$/);
                   1936:             my %temphash=($url => $value);
1.449     matthew  1937:             my $result = &inc('nohist_accesscount',\%temphash,$dom,$name);
                   1938:             if ($result eq 'ok') {
                   1939:                 delete $accesshash{$entry};
                   1940:             } elsif ($result eq 'unknown_cmd') {
                   1941:                 # Target server has old code running on it.
1.450     matthew  1942:                 my %temphash=($entry => $value);
1.449     matthew  1943:                 if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {
                   1944:                     delete $accesshash{$entry};
                   1945:                 }
                   1946:             }
                   1947:         } else {
1.811     albertel 1948:             my ($dom,$name) = ($entry=~m{___($match_domain)/($match_name)/(.*)___(\w+)$});
1.450     matthew  1949:             my %temphash=($entry => $accesshash{$entry});
1.449     matthew  1950:             if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {
                   1951:                 delete $accesshash{$entry};
                   1952:             }
1.185     www      1953:         }
1.191     harris41 1954:     }
1.352     www      1955: #
                   1956: # Roles
                   1957: # Reverse lookup of user roles for course faculty/staff and co-authorship
                   1958: #
1.800     albertel 1959:     foreach my $entry (keys(%userrolehash)) {
1.351     www      1960:         my ($role,$uname,$udom,$runame,$rudom,$rsec)=
1.349     www      1961: 	    split(/\:/,$entry);
                   1962:         if (&Apache::lonnet::put('nohist_userroles',
1.351     www      1963:              { $role.':'.$uname.':'.$udom.':'.$rsec => $userrolehash{$entry} },
1.349     www      1964:                 $rudom,$runame) eq 'ok') {
                   1965: 	    delete $userrolehash{$entry};
                   1966:         }
                   1967:     }
1.662     raeburn  1968: #
                   1969: # Reverse lookup of domain roles (dc, ad, li, sc, au)
                   1970: #
                   1971:     my %domrolebuffer = ();
                   1972:     foreach my $entry (keys %domainrolehash) {
                   1973:         my ($role,$uname,$udom,$runame,$rudom,$rsec)=split/:/,$entry;
                   1974:         if ($domrolebuffer{$rudom}) {
                   1975:             $domrolebuffer{$rudom}.='&'.&escape($entry).
                   1976:                       '='.&escape($domainrolehash{$entry});
                   1977:         } else {
                   1978:             $domrolebuffer{$rudom}.=&escape($entry).
                   1979:                       '='.&escape($domainrolehash{$entry});
                   1980:         }
                   1981:         delete $domainrolehash{$entry};
                   1982:     }
                   1983:     foreach my $dom (keys(%domrolebuffer)) {
1.841     albertel 1984: 	my %servers = &get_servers($dom,'library');
                   1985: 	foreach my $tryserver (keys(%servers)) {
                   1986: 	    unless (&reply('domroleput:'.$dom.':'.
                   1987: 			   $domrolebuffer{$dom},$tryserver) eq 'ok') {
                   1988: 		&logthis('Put of domain roles failed for '.$dom.' and  '.$tryserver);
                   1989: 	    }
1.662     raeburn  1990:         }
                   1991:     }
1.186     www      1992:     $dumpcount++;
1.157     www      1993: }
                   1994: 
                   1995: sub courselog {
                   1996:     my $what=shift;
1.158     www      1997:     $what=time.':'.$what;
1.620     albertel 1998:     unless ($env{'request.course.id'}) { return ''; }
                   1999:     $coursedombuf{$env{'request.course.id'}}=
                   2000:        $env{'course.'.$env{'request.course.id'}.'.domain'};
                   2001:     $coursenumbuf{$env{'request.course.id'}}=
                   2002:        $env{'course.'.$env{'request.course.id'}.'.num'};
                   2003:     $coursehombuf{$env{'request.course.id'}}=
                   2004:        $env{'course.'.$env{'request.course.id'}.'.home'};
                   2005:     $coursedescrbuf{$env{'request.course.id'}}=
                   2006:        $env{'course.'.$env{'request.course.id'}.'.description'};
                   2007:     $courseinstcodebuf{$env{'request.course.id'}}=
                   2008:        $env{'course.'.$env{'request.course.id'}.'.internal.coursecode'};
                   2009:     $courseownerbuf{$env{'request.course.id'}}=
                   2010:        $env{'course.'.$env{'request.course.id'}.'.internal.courseowner'};
1.741     raeburn  2011:     $coursetypebuf{$env{'request.course.id'}}=
                   2012:        $env{'course.'.$env{'request.course.id'}.'.type'};
1.620     albertel 2013:     if (defined $courselogs{$env{'request.course.id'}}) {
                   2014: 	$courselogs{$env{'request.course.id'}}.='&'.$what;
1.157     www      2015:     } else {
1.620     albertel 2016: 	$courselogs{$env{'request.course.id'}}.=$what;
1.157     www      2017:     }
1.620     albertel 2018:     if (length($courselogs{$env{'request.course.id'}})>4048) {
1.157     www      2019: 	&flushcourselogs();
                   2020:     }
1.158     www      2021: }
                   2022: 
                   2023: sub courseacclog {
                   2024:     my $fnsymb=shift;
1.620     albertel 2025:     unless ($env{'request.course.id'}) { return ''; }
                   2026:     my $what=$fnsymb.':'.$env{'user.name'}.':'.$env{'user.domain'};
1.657     albertel 2027:     if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|task|page)$/) {
1.187     www      2028:         $what.=':POST';
1.583     matthew  2029:         # FIXME: Probably ought to escape things....
1.800     albertel 2030: 	foreach my $key (keys(%env)) {
                   2031:             if ($key=~/^form\.(.*)/) {
                   2032: 		$what.=':'.$1.'='.$env{$key};
1.158     www      2033:             }
1.191     harris41 2034:         }
1.583     matthew  2035:     } elsif ($fnsymb =~ m:^/adm/searchcat:) {
                   2036:         # FIXME: We should not be depending on a form parameter that someone
                   2037:         # editing lonsearchcat.pm might change in the future.
1.620     albertel 2038:         if ($env{'form.phase'} eq 'course_search') {
1.583     matthew  2039:             $what.= ':POST';
                   2040:             # FIXME: Probably ought to escape things....
                   2041:             foreach my $element ('courseexp','crsfulltext','crsrelated',
                   2042:                                  'crsdiscuss') {
1.620     albertel 2043:                 $what.=':'.$element.'='.$env{'form.'.$element};
1.583     matthew  2044:             }
                   2045:         }
1.158     www      2046:     }
                   2047:     &courselog($what);
1.149     www      2048: }
                   2049: 
1.185     www      2050: sub countacc {
                   2051:     my $url=&declutter(shift);
1.458     matthew  2052:     return if (! defined($url) || $url eq '');
1.620     albertel 2053:     unless ($env{'request.course.id'}) { return ''; }
                   2054:     $accesshash{$env{'request.course.id'}.'___'.$url.'___course'}=1;
1.281     www      2055:     my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count';
1.450     matthew  2056:     $accesshash{$key}++;
1.185     www      2057: }
1.349     www      2058: 
1.361     www      2059: sub linklog {
                   2060:     my ($from,$to)=@_;
                   2061:     $from=&declutter($from);
                   2062:     $to=&declutter($to);
                   2063:     $accesshash{$from.'___'.$to.'___comefrom'}=1;
                   2064:     $accesshash{$to.'___'.$from.'___goto'}=1;
                   2065: }
                   2066:   
1.349     www      2067: sub userrolelog {
                   2068:     my ($trole,$username,$domain,$area,$tstart,$tend)=@_;
1.661     raeburn  2069:     if (($trole=~/^ca/) || ($trole=~/^aa/) ||
1.662     raeburn  2070:         ($trole=~/^in/) || ($trole=~/^cc/) ||
1.661     raeburn  2071:         ($trole=~/^ep/) || ($trole=~/^cr/) ||
                   2072:         ($trole=~/^ta/)) {
1.350     www      2073:        my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
                   2074:        $userrolehash
                   2075:          {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
1.349     www      2076:                     =$tend.':'.$tstart;
1.662     raeburn  2077:     }
                   2078:     if (($trole=~/^dc/) || ($trole=~/^ad/) ||
                   2079:         ($trole=~/^li/) || ($trole=~/^li/) ||
                   2080:         ($trole=~/^au/) || ($trole=~/^dg/) ||
                   2081:         ($trole=~/^sc/)) {
                   2082:        my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
                   2083:        $domainrolehash
                   2084:          {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
                   2085:                     = $tend.':'.$tstart;
                   2086:     }
1.351     www      2087: }
                   2088: 
                   2089: sub get_course_adv_roles {
                   2090:     my $cid=shift;
1.620     albertel 2091:     $cid=$env{'request.course.id'} unless (defined($cid));
1.351     www      2092:     my %coursehash=&coursedescription($cid);
1.470     www      2093:     my %nothide=();
1.800     albertel 2094:     foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
                   2095: 	$nothide{join(':',split(/[\@\:]/,$user))}=1;
1.470     www      2096:     }
1.351     www      2097:     my %returnhash=();
                   2098:     my %dumphash=
                   2099:             &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});
                   2100:     my $now=time;
1.800     albertel 2101:     foreach my $entry (keys %dumphash) {
                   2102: 	my ($tend,$tstart)=split(/\:/,$dumphash{$entry});
1.351     www      2103:         if (($tstart) && ($tstart<0)) { next; }
                   2104:         if (($tend) && ($tend<$now)) { next; }
                   2105:         if (($tstart) && ($now<$tstart)) { next; }
1.800     albertel 2106:         my ($role,$username,$domain,$section)=split(/\:/,$entry);
1.576     albertel 2107: 	if ($username eq '' || $domain eq '') { next; }
1.470     www      2108: 	if ((&privileged($username,$domain)) && 
                   2109: 	    (!$nothide{$username.':'.$domain})) { next; }
1.656     albertel 2110: 	if ($role eq 'cr') { next; }
1.351     www      2111:         my $key=&plaintext($role);
                   2112:         if ($section) { $key.=' (Sec/Grp '.$section.')'; }
                   2113:         if ($returnhash{$key}) {
                   2114: 	    $returnhash{$key}.=','.$username.':'.$domain;
                   2115:         } else {
                   2116:             $returnhash{$key}=$username.':'.$domain;
                   2117:         }
1.400     www      2118:      }
                   2119:     return %returnhash;
                   2120: }
                   2121: 
                   2122: sub get_my_roles {
1.858     raeburn  2123:     my ($uname,$udom,$context,$types,$roles,$roledoms)=@_;
1.620     albertel 2124:     unless (defined($uname)) { $uname=$env{'user.name'}; }
                   2125:     unless (defined($udom)) { $udom=$env{'user.domain'}; }
1.858     raeburn  2126:     my %dumphash;
                   2127:     if ($context eq 'userroles') { 
                   2128:         %dumphash = &dump('roles',$udom,$uname);
                   2129:     } else {
                   2130:         %dumphash=
1.400     www      2131:             &dump('nohist_userroles',$udom,$uname);
1.858     raeburn  2132:     }
1.400     www      2133:     my %returnhash=();
                   2134:     my $now=time;
1.800     albertel 2135:     foreach my $entry (keys(%dumphash)) {
                   2136: 	my ($tend,$tstart)=split(/\:/,$dumphash{$entry});
1.400     www      2137:         if (($tstart) && ($tstart<0)) { next; }
1.832     raeburn  2138:         my $status = 'active';
                   2139:         if (($tend) && ($tend<$now)) {
                   2140:             $status = 'previous';
                   2141:         } 
                   2142:         if (($tstart) && ($now<$tstart)) {
                   2143:             $status = 'future';
                   2144:         }
                   2145:         if (ref($types) eq 'ARRAY') {
                   2146:             if (!grep(/^\Q$status\E$/,@{$types})) {
                   2147:                 next;
                   2148:             } 
                   2149:         } else {
                   2150:             if ($status ne 'active') {
                   2151:                 next;
                   2152:             }
                   2153:         }
1.800     albertel 2154:         my ($role,$username,$domain,$section)=split(/\:/,$entry);
1.832     raeburn  2155:         if (ref($roledoms) eq 'ARRAY') {
                   2156:             if (!grep(/^\Q$domain\E$/,@{$roledoms})) {
                   2157:                 next;
                   2158:             }
                   2159:         }
                   2160:         if (ref($roles) eq 'ARRAY') {
                   2161:             if (!grep(/^\Q$role\E$/,@{$roles})) {
                   2162:                 next;
                   2163:             }
                   2164:         } 
1.400     www      2165: 	$returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;
1.832     raeburn  2166:     }
1.373     www      2167:     return %returnhash;
1.399     www      2168: }
                   2169: 
                   2170: # ----------------------------------------------------- Frontpage Announcements
                   2171: #
                   2172: #
                   2173: 
                   2174: sub postannounce {
                   2175:     my ($server,$text)=@_;
1.844     albertel 2176:     unless (&allowed('psa',&host_domain($server))) { return 'refused'; }
1.399     www      2177:     unless ($text=~/\w/) { $text=''; }
                   2178:     return &reply('setannounce:'.&escape($text),$server);
                   2179: }
                   2180: 
                   2181: sub getannounce {
1.448     albertel 2182: 
                   2183:     if (open(my $fh,$perlvar{'lonDocRoot'}.'/announcement.txt')) {
1.399     www      2184: 	my $announcement='';
1.800     albertel 2185: 	while (my $line = <$fh>) { $announcement .= $line; }
1.448     albertel 2186: 	close($fh);
1.399     www      2187: 	if ($announcement=~/\w/) { 
                   2188: 	    return 
                   2189:    '<table bgcolor="#FF5555" cellpadding="5" cellspacing="3">'.
1.518     albertel 2190:    '<tr><td bgcolor="#FFFFFF"><tt>'.$announcement.'</tt></td></tr></table>'; 
1.399     www      2191: 	} else {
                   2192: 	    return '';
                   2193: 	}
                   2194:     } else {
                   2195: 	return '';
                   2196:     }
1.351     www      2197: }
1.353     www      2198: 
                   2199: # ---------------------------------------------------------- Course ID routines
                   2200: # Deal with domain's nohist_courseid.db files
                   2201: #
                   2202: 
                   2203: sub courseidput {
                   2204:     my ($domain,$what,$coursehome)=@_;
                   2205:     return &reply('courseidput:'.$domain.':'.$what,$coursehome);
                   2206: }
                   2207: 
                   2208: sub courseiddump {
1.791     raeburn  2209:     my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_;
1.353     www      2210:     my %returnhash=();
1.355     www      2211:     unless ($domfilter) { $domfilter=''; }
1.845     albertel 2212:     my %libserv = &all_library();
                   2213:     foreach my $tryserver (keys(%libserv)) {
                   2214:         if ( (  $hostidflag == 1 
                   2215: 	        && grep(/^\Q$tryserver\E$/,@{$hostidref}) ) 
                   2216: 	     || (!defined($hostidflag)) ) {
                   2217: 
                   2218: 	    if ($domfilter eq ''
                   2219: 		|| (&host_domain($tryserver) eq $domfilter)) {
1.800     albertel 2220: 	        foreach my $line (
1.844     albertel 2221:                  split(/\&/,&reply('courseiddump:'.&host_domain($tryserver).':'.
1.571     raeburn  2222: 			       $sincefilter.':'.&escape($descfilter).':'.
1.791     raeburn  2223:                                &escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter).':'.&escape($typefilter).':'.&escape($regexp_ok),
1.354     www      2224:                                $tryserver))) {
1.800     albertel 2225: 		    my ($key,$value)=split(/\=/,$line,2);
1.506     raeburn  2226:                     if (($key) && ($value)) {
1.516     raeburn  2227: 		        $returnhash{&unescape($key)}=$value;
1.506     raeburn  2228:                     }
1.353     www      2229:                 }
                   2230:             }
                   2231:         }
                   2232:     }
                   2233:     return %returnhash;
                   2234: }
                   2235: 
1.658     raeburn  2236: # ---------------------------------------------------------- DC e-mail
1.662     raeburn  2237: 
                   2238: sub dcmailput {
1.685     raeburn  2239:     my ($domain,$msgid,$message,$server)=@_;
1.662     raeburn  2240:     my $status = &Apache::lonnet::critical(
1.740     www      2241:        'dcmailput:'.$domain.':'.&escape($msgid).'='.
                   2242:        &escape($message),$server);
1.662     raeburn  2243:     return $status;
                   2244: }
                   2245: 
1.658     raeburn  2246: sub dcmaildump {
                   2247:     my ($dom,$startdate,$enddate,$senders) = @_;
1.685     raeburn  2248:     my %returnhash=();
1.846     albertel 2249: 
                   2250:     if (defined(&domain($dom,'primary'))) {
1.685     raeburn  2251:         my $cmd='dcmaildump:'.$dom.':'.&escape($startdate).':'.
                   2252:                                                          &escape($enddate).':';
                   2253: 	my @esc_senders=map { &escape($_)} @$senders;
                   2254: 	$cmd.=&escape(join('&',@esc_senders));
1.846     albertel 2255: 	foreach my $line (split(/\&/,&reply($cmd,&domain($dom,'primary')))) {
1.800     albertel 2256:             my ($key,$value) = split(/\=/,$line,2);
1.685     raeburn  2257:             if (($key) && ($value)) {
                   2258:                 $returnhash{&unescape($key)} = &unescape($value);
1.658     raeburn  2259:             }
                   2260:         }
                   2261:     }
                   2262:     return %returnhash;
                   2263: }
1.662     raeburn  2264: # ---------------------------------------------------------- Domain roles
                   2265: 
                   2266: sub get_domain_roles {
                   2267:     my ($dom,$roles,$startdate,$enddate)=@_;
                   2268:     if (undef($startdate) || $startdate eq '') {
                   2269:         $startdate = '.';
                   2270:     }
                   2271:     if (undef($enddate) || $enddate eq '') {
                   2272:         $enddate = '.';
                   2273:     }
                   2274:     my $rolelist = join(':',@{$roles});
                   2275:     my %personnel = ();
1.841     albertel 2276: 
                   2277:     my %servers = &get_servers($dom,'library');
                   2278:     foreach my $tryserver (keys(%servers)) {
                   2279: 	%{$personnel{$tryserver}}=();
                   2280: 	foreach my $line (split(/\&/,&reply('domrolesdump:'.$dom.':'.
                   2281: 					    &escape($startdate).':'.
                   2282: 					    &escape($enddate).':'.
                   2283: 					    &escape($rolelist), $tryserver))) {
                   2284: 	    my ($key,$value) = split(/\=/,$line,2);
                   2285: 	    if (($key) && ($value)) {
                   2286: 		$personnel{$tryserver}{&unescape($key)} = &unescape($value);
                   2287: 	    }
                   2288: 	}
1.662     raeburn  2289:     }
                   2290:     return %personnel;
                   2291: }
1.658     raeburn  2292: 
1.149     www      2293: # ----------------------------------------------------------- Check out an item
                   2294: 
1.504     albertel 2295: sub get_first_access {
                   2296:     my ($type,$argsymb)=@_;
1.790     albertel 2297:     my ($symb,$courseid,$udom,$uname)=&whichuser();
1.504     albertel 2298:     if ($argsymb) { $symb=$argsymb; }
                   2299:     my ($map,$id,$res)=&decode_symb($symb);
1.588     albertel 2300:     if ($type eq 'map') {
                   2301: 	$res=&symbread($map);
                   2302:     } else {
                   2303: 	$res=$symb;
                   2304:     }
                   2305:     my %times=&get('firstaccesstimes',["$courseid\0$res"],$udom,$uname);
                   2306:     return $times{"$courseid\0$res"};
1.504     albertel 2307: }
                   2308: 
                   2309: sub set_first_access {
                   2310:     my ($type)=@_;
1.790     albertel 2311:     my ($symb,$courseid,$udom,$uname)=&whichuser();
1.504     albertel 2312:     my ($map,$id,$res)=&decode_symb($symb);
1.588     albertel 2313:     if ($type eq 'map') {
                   2314: 	$res=&symbread($map);
                   2315:     } else {
                   2316: 	$res=$symb;
                   2317:     }
                   2318:     my $firstaccess=&get_first_access($type,$symb);
1.505     albertel 2319:     if (!$firstaccess) {
1.588     albertel 2320: 	return &put('firstaccesstimes',{"$courseid\0$res"=>time},$udom,$uname);
1.505     albertel 2321:     }
                   2322:     return 'already_set';
1.504     albertel 2323: }
                   2324: 
1.149     www      2325: sub checkout {
                   2326:     my ($symb,$tuname,$tudom,$tcrsid)=@_;
                   2327:     my $now=time;
                   2328:     my $lonhost=$perlvar{'lonHostID'};
                   2329:     my $infostr=&escape(
1.234     www      2330:                  'CHECKOUTTOKEN&'.
1.149     www      2331:                  $tuname.'&'.
                   2332:                  $tudom.'&'.
                   2333:                  $tcrsid.'&'.
                   2334:                  $symb.'&'.
                   2335: 		 $now.'&'.$ENV{'REMOTE_ADDR'});
                   2336:     my $token=&reply('tmpput:'.$infostr,$lonhost);
1.151     www      2337:     if ($token=~/^error\:/) { 
1.672     albertel 2338:         &logthis("<font color=\"blue\">WARNING: ".
1.151     www      2339:                 "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.
                   2340:                  "</font>");
                   2341:         return ''; 
                   2342:     }
                   2343: 
1.149     www      2344:     $token=~s/^(\d+)\_.*\_(\d+)$/$1\*$2\*$lonhost/;
                   2345:     $token=~tr/a-z/A-Z/;
                   2346: 
1.153     www      2347:     my %infohash=('resource.0.outtoken' => $token,
                   2348:                   'resource.0.checkouttime' => $now,
                   2349:                   'resource.0.outremote' => $ENV{'REMOTE_ADDR'});
1.149     www      2350: 
                   2351:     unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
                   2352:        return '';
1.151     www      2353:     } else {
1.672     albertel 2354:         &logthis("<font color=\"blue\">WARNING: ".
1.151     www      2355:                 "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.
                   2356:                  "</font>");
1.149     www      2357:     }    
                   2358: 
                   2359:     if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
                   2360:                          &escape('Checkout '.$infostr.' - '.
                   2361:                                                  $token)) ne 'ok') {
                   2362: 	return '';
1.151     www      2363:     } else {
1.672     albertel 2364:         &logthis("<font color=\"blue\">WARNING: ".
1.151     www      2365:                 "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.
                   2366:                  "</font>");
1.149     www      2367:     }
1.151     www      2368:     return $token;
1.149     www      2369: }
                   2370: 
                   2371: # ------------------------------------------------------------ Check in an item
                   2372: 
                   2373: sub checkin {
                   2374:     my $token=shift;
1.150     www      2375:     my $now=time;
                   2376:     my ($ta,$tb,$lonhost)=split(/\*/,$token);
                   2377:     $lonhost=~tr/A-Z/a-z/;
1.838     albertel 2378:     my $dtoken=$ta.'_'.&hostname($lonhost).'_'.$tb;
1.150     www      2379:     $dtoken=~s/\W/\_/g;
1.234     www      2380:     my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
1.150     www      2381:                  split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));
                   2382: 
1.154     www      2383:     unless (($tuname) && ($tudom)) {
                   2384:         &logthis('Check in '.$token.' ('.$dtoken.') failed');
                   2385:         return '';
                   2386:     }
                   2387:     
                   2388:     unless (&allowed('mgr',$tcrsid)) {
                   2389:         &logthis('Check in '.$token.' ('.$dtoken.') unauthorized: '.
1.620     albertel 2390:                  $env{'user.name'}.' - '.$env{'user.domain'});
1.154     www      2391:         return '';
                   2392:     }
                   2393: 
1.153     www      2394:     my %infohash=('resource.0.intoken' => $token,
                   2395:                   'resource.0.checkintime' => $now,
                   2396:                   'resource.0.inremote' => $ENV{'REMOTE_ADDR'});
1.150     www      2397: 
                   2398:     unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
                   2399:        return '';
                   2400:     }    
                   2401: 
                   2402:     if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
                   2403:                          &escape('Checkin - '.$token)) ne 'ok') {
                   2404: 	return '';
                   2405:     }
                   2406: 
                   2407:     return ($symb,$tuname,$tudom,$tcrsid);    
1.110     www      2408: }
                   2409: 
                   2410: # --------------------------------------------- Set Expire Date for Spreadsheet
                   2411: 
                   2412: sub expirespread {
                   2413:     my ($uname,$udom,$stype,$usymb)=@_;
1.620     albertel 2414:     my $cid=$env{'request.course.id'}; 
1.110     www      2415:     if ($cid) {
                   2416:        my $now=time;
                   2417:        my $key=$uname.':'.$udom.':'.$stype.':'.$usymb;
1.620     albertel 2418:        return &reply('put:'.$env{'course.'.$cid.'.domain'}.':'.
                   2419:                             $env{'course.'.$cid.'.num'}.
1.110     www      2420: 	        	    ':nohist_expirationdates:'.
                   2421:                             &escape($key).'='.$now,
1.620     albertel 2422:                             $env{'course.'.$cid.'.home'})
1.110     www      2423:     }
                   2424:     return 'ok';
1.14      www      2425: }
                   2426: 
1.109     www      2427: # ----------------------------------------------------- Devalidate Spreadsheets
                   2428: 
                   2429: sub devalidate {
1.325     www      2430:     my ($symb,$uname,$udom)=@_;
1.620     albertel 2431:     my $cid=$env{'request.course.id'}; 
1.109     www      2432:     if ($cid) {
1.391     matthew  2433:         # delete the stored spreadsheets for
                   2434:         # - the student level sheet of this user in course's homespace
                   2435:         # - the assessment level sheet for this resource 
                   2436:         #   for this user in user's homespace
1.553     albertel 2437: 	# - current conditional state info
1.325     www      2438: 	my $key=$uname.':'.$udom.':';
1.109     www      2439:         my $status=
1.299     matthew  2440: 	    &del('nohist_calculatedsheets',
1.391     matthew  2441: 		 [$key.'studentcalc:'],
1.620     albertel 2442: 		 $env{'course.'.$cid.'.domain'},
                   2443: 		 $env{'course.'.$cid.'.num'})
1.133     albertel 2444: 		.' '.
                   2445: 	    &del('nohist_calculatedsheets_'.$cid,
1.391     matthew  2446: 		 [$key.'assesscalc:'.$symb],$udom,$uname);
1.109     www      2447:         unless ($status eq 'ok ok') {
                   2448:            &logthis('Could not devalidate spreadsheet '.
1.325     www      2449:                     $uname.' at '.$udom.' for '.
1.109     www      2450: 		    $symb.': '.$status);
1.133     albertel 2451:         }
1.553     albertel 2452: 	&delenv('user.state.'.$cid);
1.109     www      2453:     }
                   2454: }
                   2455: 
1.265     albertel 2456: sub get_scalar {
                   2457:     my ($string,$end) = @_;
                   2458:     my $value;
                   2459:     if ($$string =~ s/^([^&]*?)($end)/$2/) {
                   2460: 	$value = $1;
                   2461:     } elsif ($$string =~ s/^([^&]*?)&//) {
                   2462: 	$value = $1;
                   2463:     }
                   2464:     return &unescape($value);
                   2465: }
                   2466: 
                   2467: sub array2str {
                   2468:   my (@array) = @_;
                   2469:   my $result=&arrayref2str(\@array);
                   2470:   $result=~s/^__ARRAY_REF__//;
                   2471:   $result=~s/__END_ARRAY_REF__$//;
                   2472:   return $result;
                   2473: }
                   2474: 
1.204     albertel 2475: sub arrayref2str {
                   2476:   my ($arrayref) = @_;
1.265     albertel 2477:   my $result='__ARRAY_REF__';
1.204     albertel 2478:   foreach my $elem (@$arrayref) {
1.265     albertel 2479:     if(ref($elem) eq 'ARRAY') {
                   2480:       $result.=&arrayref2str($elem).'&';
                   2481:     } elsif(ref($elem) eq 'HASH') {
                   2482:       $result.=&hashref2str($elem).'&';
                   2483:     } elsif(ref($elem)) {
                   2484:       #print("Got a ref of ".(ref($elem))." skipping.");
1.204     albertel 2485:     } else {
                   2486:       $result.=&escape($elem).'&';
                   2487:     }
                   2488:   }
                   2489:   $result=~s/\&$//;
1.265     albertel 2490:   $result .= '__END_ARRAY_REF__';
1.204     albertel 2491:   return $result;
                   2492: }
                   2493: 
1.168     albertel 2494: sub hash2str {
1.204     albertel 2495:   my (%hash) = @_;
                   2496:   my $result=&hashref2str(\%hash);
1.265     albertel 2497:   $result=~s/^__HASH_REF__//;
                   2498:   $result=~s/__END_HASH_REF__$//;
1.204     albertel 2499:   return $result;
                   2500: }
                   2501: 
                   2502: sub hashref2str {
                   2503:   my ($hashref)=@_;
1.265     albertel 2504:   my $result='__HASH_REF__';
1.800     albertel 2505:   foreach my $key (sort(keys(%$hashref))) {
                   2506:     if (ref($key) eq 'ARRAY') {
                   2507:       $result.=&arrayref2str($key).'=';
                   2508:     } elsif (ref($key) eq 'HASH') {
                   2509:       $result.=&hashref2str($key).'=';
                   2510:     } elsif (ref($key)) {
1.265     albertel 2511:       $result.='=';
1.800     albertel 2512:       #print("Got a ref of ".(ref($key))." skipping.");
1.204     albertel 2513:     } else {
1.800     albertel 2514: 	if ($key) {$result.=&escape($key).'=';} else { last; }
1.204     albertel 2515:     }
                   2516: 
1.800     albertel 2517:     if(ref($hashref->{$key}) eq 'ARRAY') {
                   2518:       $result.=&arrayref2str($hashref->{$key}).'&';
                   2519:     } elsif(ref($hashref->{$key}) eq 'HASH') {
                   2520:       $result.=&hashref2str($hashref->{$key}).'&';
                   2521:     } elsif(ref($hashref->{$key})) {
1.265     albertel 2522:        $result.='&';
1.800     albertel 2523:       #print("Got a ref of ".(ref($hashref->{$key}))." skipping.");
1.204     albertel 2524:     } else {
1.800     albertel 2525:       $result.=&escape($hashref->{$key}).'&';
1.204     albertel 2526:     }
                   2527:   }
1.168     albertel 2528:   $result=~s/\&$//;
1.265     albertel 2529:   $result .= '__END_HASH_REF__';
1.168     albertel 2530:   return $result;
                   2531: }
                   2532: 
                   2533: sub str2hash {
1.265     albertel 2534:     my ($string)=@_;
                   2535:     my ($hash)=&str2hashref('__HASH_REF__'.$string.'__END_HASH_REF__');
                   2536:     return %$hash;
                   2537: }
                   2538: 
                   2539: sub str2hashref {
1.168     albertel 2540:   my ($string) = @_;
1.265     albertel 2541: 
                   2542:   my %hash;
                   2543: 
                   2544:   if($string !~ /^__HASH_REF__/) {
                   2545:       if (! ($string eq '' || !defined($string))) {
                   2546: 	  $hash{'error'}='Not hash reference';
                   2547:       }
                   2548:       return (\%hash, $string);
                   2549:   }
                   2550: 
                   2551:   $string =~ s/^__HASH_REF__//;
                   2552: 
                   2553:   while($string !~ /^__END_HASH_REF__/) {
                   2554:       #key
                   2555:       my $key='';
                   2556:       if($string =~ /^__HASH_REF__/) {
                   2557:           ($key, $string)=&str2hashref($string);
                   2558:           if(defined($key->{'error'})) {
                   2559:               $hash{'error'}='Bad data';
                   2560:               return (\%hash, $string);
                   2561:           }
                   2562:       } elsif($string =~ /^__ARRAY_REF__/) {
                   2563:           ($key, $string)=&str2arrayref($string);
                   2564:           if($key->[0] eq 'Array reference error') {
                   2565:               $hash{'error'}='Bad data';
                   2566:               return (\%hash, $string);
                   2567:           }
                   2568:       } else {
                   2569:           $string =~ s/^(.*?)=//;
1.267     albertel 2570: 	  $key=&unescape($1);
1.265     albertel 2571:       }
                   2572:       $string =~ s/^=//;
                   2573: 
                   2574:       #value
                   2575:       my $value='';
                   2576:       if($string =~ /^__HASH_REF__/) {
                   2577:           ($value, $string)=&str2hashref($string);
                   2578:           if(defined($value->{'error'})) {
                   2579:               $hash{'error'}='Bad data';
                   2580:               return (\%hash, $string);
                   2581:           }
                   2582:       } elsif($string =~ /^__ARRAY_REF__/) {
                   2583:           ($value, $string)=&str2arrayref($string);
                   2584:           if($value->[0] eq 'Array reference error') {
                   2585:               $hash{'error'}='Bad data';
                   2586:               return (\%hash, $string);
                   2587:           }
                   2588:       } else {
                   2589: 	  $value=&get_scalar(\$string,'__END_HASH_REF__');
                   2590:       }
                   2591:       $string =~ s/^&//;
                   2592: 
                   2593:       $hash{$key}=$value;
1.204     albertel 2594:   }
1.265     albertel 2595: 
                   2596:   $string =~ s/^__END_HASH_REF__//;
                   2597: 
                   2598:   return (\%hash, $string);
1.204     albertel 2599: }
                   2600: 
                   2601: sub str2array {
1.265     albertel 2602:     my ($string)=@_;
                   2603:     my ($array)=&str2arrayref('__ARRAY_REF__'.$string.'__END_ARRAY_REF__');
                   2604:     return @$array;
                   2605: }
                   2606: 
                   2607: sub str2arrayref {
1.204     albertel 2608:   my ($string) = @_;
1.265     albertel 2609:   my @array;
                   2610: 
                   2611:   if($string !~ /^__ARRAY_REF__/) {
                   2612:       if (! ($string eq '' || !defined($string))) {
                   2613: 	  $array[0]='Array reference error';
                   2614:       }
                   2615:       return (\@array, $string);
                   2616:   }
                   2617: 
                   2618:   $string =~ s/^__ARRAY_REF__//;
                   2619: 
                   2620:   while($string !~ /^__END_ARRAY_REF__/) {
                   2621:       my $value='';
                   2622:       if($string =~ /^__HASH_REF__/) {
                   2623:           ($value, $string)=&str2hashref($string);
                   2624:           if(defined($value->{'error'})) {
                   2625:               $array[0] ='Array reference error';
                   2626:               return (\@array, $string);
                   2627:           }
                   2628:       } elsif($string =~ /^__ARRAY_REF__/) {
                   2629:           ($value, $string)=&str2arrayref($string);
                   2630:           if($value->[0] eq 'Array reference error') {
                   2631:               $array[0] ='Array reference error';
                   2632:               return (\@array, $string);
                   2633:           }
                   2634:       } else {
                   2635: 	  $value=&get_scalar(\$string,'__END_ARRAY_REF__');
                   2636:       }
                   2637:       $string =~ s/^&//;
                   2638: 
                   2639:       push(@array, $value);
1.191     harris41 2640:   }
1.265     albertel 2641: 
                   2642:   $string =~ s/^__END_ARRAY_REF__//;
                   2643: 
                   2644:   return (\@array, $string);
1.168     albertel 2645: }
                   2646: 
1.167     albertel 2647: # -------------------------------------------------------------------Temp Store
                   2648: 
1.168     albertel 2649: sub tmpreset {
                   2650:   my ($symb,$namespace,$domain,$stuname) = @_;
                   2651:   if (!$symb) {
                   2652:     $symb=&symbread();
1.620     albertel 2653:     if (!$symb) { $symb= $env{'request.url'}; }
1.168     albertel 2654:   }
                   2655:   $symb=escape($symb);
                   2656: 
1.620     albertel 2657:   if (!$namespace) { $namespace=$env{'request.state'}; }
1.168     albertel 2658:   $namespace=~s/\//\_/g;
                   2659:   $namespace=~s/\W//g;
                   2660: 
1.620     albertel 2661:   if (!$domain) { $domain=$env{'user.domain'}; }
                   2662:   if (!$stuname) { $stuname=$env{'user.name'}; }
1.591     albertel 2663:   if ($domain eq 'public' && $stuname eq 'public') {
                   2664:       $stuname=$ENV{'REMOTE_ADDR'};
                   2665:   }
1.168     albertel 2666:   my $path=$perlvar{'lonDaemons'}.'/tmp';
                   2667:   my %hash;
                   2668:   if (tie(%hash,'GDBM_File',
                   2669: 	  $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
1.256     albertel 2670: 	  &GDBM_WRCREAT(),0640)) {
1.168     albertel 2671:     foreach my $key (keys %hash) {
1.180     albertel 2672:       if ($key=~ /:$symb/) {
1.168     albertel 2673: 	delete($hash{$key});
                   2674:       }
                   2675:     }
                   2676:   }
                   2677: }
                   2678: 
1.167     albertel 2679: sub tmpstore {
1.168     albertel 2680:   my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
                   2681: 
                   2682:   if (!$symb) {
                   2683:     $symb=&symbread();
1.620     albertel 2684:     if (!$symb) { $symb= $env{'request.url'}; }
1.168     albertel 2685:   }
                   2686:   $symb=escape($symb);
                   2687: 
                   2688:   if (!$namespace) {
                   2689:     # I don't think we would ever want to store this for a course.
                   2690:     # it seems this will only be used if we don't have a course.
1.620     albertel 2691:     #$namespace=$env{'request.course.id'};
1.168     albertel 2692:     #if (!$namespace) {
1.620     albertel 2693:       $namespace=$env{'request.state'};
1.168     albertel 2694:     #}
                   2695:   }
                   2696:   $namespace=~s/\//\_/g;
                   2697:   $namespace=~s/\W//g;
1.620     albertel 2698:   if (!$domain) { $domain=$env{'user.domain'}; }
                   2699:   if (!$stuname) { $stuname=$env{'user.name'}; }
1.591     albertel 2700:   if ($domain eq 'public' && $stuname eq 'public') {
                   2701:       $stuname=$ENV{'REMOTE_ADDR'};
                   2702:   }
1.168     albertel 2703:   my $now=time;
                   2704:   my %hash;
                   2705:   my $path=$perlvar{'lonDaemons'}.'/tmp';
                   2706:   if (tie(%hash,'GDBM_File',
                   2707: 	  $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
1.256     albertel 2708: 	  &GDBM_WRCREAT(),0640)) {
1.168     albertel 2709:     $hash{"version:$symb"}++;
                   2710:     my $version=$hash{"version:$symb"};
                   2711:     my $allkeys=''; 
                   2712:     foreach my $key (keys(%$storehash)) {
                   2713:       $allkeys.=$key.':';
1.591     albertel 2714:       $hash{"$version:$symb:$key"}=&freeze_escape($$storehash{$key});
1.168     albertel 2715:     }
                   2716:     $hash{"$version:$symb:timestamp"}=$now;
                   2717:     $allkeys.='timestamp';
                   2718:     $hash{"$version:keys:$symb"}=$allkeys;
                   2719:     if (untie(%hash)) {
                   2720:       return 'ok';
                   2721:     } else {
                   2722:       return "error:$!";
                   2723:     }
                   2724:   } else {
                   2725:     return "error:$!";
                   2726:   }
                   2727: }
1.167     albertel 2728: 
1.168     albertel 2729: # -----------------------------------------------------------------Temp Restore
1.167     albertel 2730: 
1.168     albertel 2731: sub tmprestore {
                   2732:   my ($symb,$namespace,$domain,$stuname) = @_;
1.167     albertel 2733: 
1.168     albertel 2734:   if (!$symb) {
                   2735:     $symb=&symbread();
1.620     albertel 2736:     if (!$symb) { $symb= $env{'request.url'}; }
1.168     albertel 2737:   }
                   2738:   $symb=escape($symb);
                   2739: 
1.620     albertel 2740:   if (!$namespace) { $namespace=$env{'request.state'}; }
1.591     albertel 2741: 
1.620     albertel 2742:   if (!$domain) { $domain=$env{'user.domain'}; }
                   2743:   if (!$stuname) { $stuname=$env{'user.name'}; }
1.591     albertel 2744:   if ($domain eq 'public' && $stuname eq 'public') {
                   2745:       $stuname=$ENV{'REMOTE_ADDR'};
                   2746:   }
1.168     albertel 2747:   my %returnhash;
                   2748:   $namespace=~s/\//\_/g;
                   2749:   $namespace=~s/\W//g;
                   2750:   my %hash;
                   2751:   my $path=$perlvar{'lonDaemons'}.'/tmp';
                   2752:   if (tie(%hash,'GDBM_File',
                   2753: 	  $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
1.256     albertel 2754: 	  &GDBM_READER(),0640)) {
1.168     albertel 2755:     my $version=$hash{"version:$symb"};
                   2756:     $returnhash{'version'}=$version;
                   2757:     my $scope;
                   2758:     for ($scope=1;$scope<=$version;$scope++) {
                   2759:       my $vkeys=$hash{"$scope:keys:$symb"};
                   2760:       my @keys=split(/:/,$vkeys);
                   2761:       my $key;
                   2762:       $returnhash{"$scope:keys"}=$vkeys;
                   2763:       foreach $key (@keys) {
1.591     albertel 2764: 	$returnhash{"$scope:$key"}=&thaw_unescape($hash{"$scope:$symb:$key"});
                   2765: 	$returnhash{"$key"}=&thaw_unescape($hash{"$scope:$symb:$key"});
1.167     albertel 2766:       }
                   2767:     }
1.168     albertel 2768:     if (!(untie(%hash))) {
                   2769:       return "error:$!";
                   2770:     }
                   2771:   } else {
                   2772:     return "error:$!";
                   2773:   }
                   2774:   return %returnhash;
1.167     albertel 2775: }
                   2776: 
1.9       www      2777: # ----------------------------------------------------------------------- Store
                   2778: 
                   2779: sub store {
1.124     www      2780:     my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
                   2781:     my $home='';
                   2782: 
1.168     albertel 2783:     if ($stuname) { $home=&homeserver($stuname,$domain); }
1.124     www      2784: 
1.213     www      2785:     $symb=&symbclean($symb);
1.122     albertel 2786:     if (!$symb) { unless ($symb=&symbread()) { return ''; } }
1.109     www      2787: 
1.620     albertel 2788:     if (!$domain) { $domain=$env{'user.domain'}; }
                   2789:     if (!$stuname) { $stuname=$env{'user.name'}; }
1.325     www      2790: 
                   2791:     &devalidate($symb,$stuname,$domain);
1.109     www      2792: 
                   2793:     $symb=escape($symb);
1.187     www      2794:     if (!$namespace) { 
1.620     albertel 2795:        unless ($namespace=$env{'request.course.id'}) { 
1.187     www      2796:           return ''; 
                   2797:        } 
                   2798:     }
1.620     albertel 2799:     if (!$home) { $home=$env{'user.home'}; }
1.447     www      2800: 
                   2801:     $$storehash{'ip'}=$ENV{'REMOTE_ADDR'};
                   2802:     $$storehash{'host'}=$perlvar{'lonHostID'};
                   2803: 
1.12      www      2804:     my $namevalue='';
1.800     albertel 2805:     foreach my $key (keys(%$storehash)) {
                   2806:         $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
1.191     harris41 2807:     }
1.12      www      2808:     $namevalue=~s/\&$//;
1.187     www      2809:     &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue);
1.124     www      2810:     return reply("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");
1.9       www      2811: }
                   2812: 
1.47      www      2813: # -------------------------------------------------------------- Critical Store
                   2814: 
                   2815: sub cstore {
1.124     www      2816:     my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
                   2817:     my $home='';
                   2818: 
1.168     albertel 2819:     if ($stuname) { $home=&homeserver($stuname,$domain); }
1.124     www      2820: 
1.213     www      2821:     $symb=&symbclean($symb);
1.122     albertel 2822:     if (!$symb) { unless ($symb=&symbread()) { return ''; } }
1.109     www      2823: 
1.620     albertel 2824:     if (!$domain) { $domain=$env{'user.domain'}; }
                   2825:     if (!$stuname) { $stuname=$env{'user.name'}; }
1.325     www      2826: 
                   2827:     &devalidate($symb,$stuname,$domain);
1.109     www      2828: 
                   2829:     $symb=escape($symb);
1.187     www      2830:     if (!$namespace) { 
1.620     albertel 2831:        unless ($namespace=$env{'request.course.id'}) { 
1.187     www      2832:           return ''; 
                   2833:        } 
                   2834:     }
1.620     albertel 2835:     if (!$home) { $home=$env{'user.home'}; }
1.447     www      2836: 
                   2837:     $$storehash{'ip'}=$ENV{'REMOTE_ADDR'};
                   2838:     $$storehash{'host'}=$perlvar{'lonHostID'};
1.122     albertel 2839: 
1.47      www      2840:     my $namevalue='';
1.800     albertel 2841:     foreach my $key (keys(%$storehash)) {
                   2842:         $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
1.191     harris41 2843:     }
1.47      www      2844:     $namevalue=~s/\&$//;
1.187     www      2845:     &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue);
1.188     www      2846:     return critical
                   2847:                 ("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");
1.47      www      2848: }
                   2849: 
1.9       www      2850: # --------------------------------------------------------------------- Restore
                   2851: 
                   2852: sub restore {
1.124     www      2853:     my ($symb,$namespace,$domain,$stuname) = @_;
                   2854:     my $home='';
                   2855: 
1.168     albertel 2856:     if ($stuname) { $home=&homeserver($stuname,$domain); }
1.124     www      2857: 
1.122     albertel 2858:     if (!$symb) {
                   2859:       unless ($symb=escape(&symbread())) { return ''; }
                   2860:     } else {
1.213     www      2861:       $symb=&escape(&symbclean($symb));
1.122     albertel 2862:     }
1.188     www      2863:     if (!$namespace) { 
1.620     albertel 2864:        unless ($namespace=$env{'request.course.id'}) { 
1.188     www      2865:           return ''; 
                   2866:        } 
                   2867:     }
1.620     albertel 2868:     if (!$domain) { $domain=$env{'user.domain'}; }
                   2869:     if (!$stuname) { $stuname=$env{'user.name'}; }
                   2870:     if (!$home) { $home=$env{'user.home'}; }
1.122     albertel 2871:     my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home");
                   2872: 
1.12      www      2873:     my %returnhash=();
1.800     albertel 2874:     foreach my $line (split(/\&/,$answer)) {
                   2875: 	my ($name,$value)=split(/\=/,$line);
1.591     albertel 2876:         $returnhash{&unescape($name)}=&thaw_unescape($value);
1.191     harris41 2877:     }
1.75      www      2878:     my $version;
                   2879:     for ($version=1;$version<=$returnhash{'version'};$version++) {
1.800     albertel 2880:        foreach my $item (split(/\:/,$returnhash{$version.':keys'})) {
                   2881:           $returnhash{$item}=$returnhash{$version.':'.$item};
1.191     harris41 2882:        }
1.75      www      2883:     }
1.13      www      2884:     return %returnhash;
1.34      www      2885: }
                   2886: 
                   2887: # ---------------------------------------------------------- Course Description
                   2888: 
                   2889: sub coursedescription {
1.731     albertel 2890:     my ($courseid,$args)=@_;
1.34      www      2891:     $courseid=~s/^\///;
1.49      www      2892:     $courseid=~s/\_/\//g;
1.34      www      2893:     my ($cdomain,$cnum)=split(/\//,$courseid);
1.129     albertel 2894:     my $chome=&homeserver($cnum,$cdomain);
1.302     albertel 2895:     my $normalid=$cdomain.'_'.$cnum;
                   2896:     # need to always cache even if we get errors otherwise we keep 
                   2897:     # trying and trying and trying to get the course description.
                   2898:     my %envhash=();
                   2899:     my %returnhash=();
1.731     albertel 2900:     
                   2901:     my $expiretime=600;
                   2902:     if ($env{'request.course.id'} eq $normalid) {
                   2903: 	$expiretime=120;
                   2904:     }
                   2905: 
                   2906:     my $prefix='course.'.$cdomain.'_'.$cnum.'.';
                   2907:     if (!$args->{'freshen_cache'}
                   2908: 	&& ((time-$env{$prefix.'last_cache'}) < $expiretime) ) {
                   2909: 	foreach my $key (keys(%env)) {
                   2910: 	    next if ($key !~ /^\Q$prefix\E(.*)/);
                   2911: 	    my ($setting) = $1;
                   2912: 	    $returnhash{$setting} = $env{$key};
                   2913: 	}
                   2914: 	return %returnhash;
                   2915:     }
                   2916: 
                   2917:     # get the data agin
                   2918:     if (!$args->{'one_time'}) {
                   2919: 	$envhash{'course.'.$normalid.'.last_cache'}=time;
                   2920:     }
1.811     albertel 2921: 
1.34      www      2922:     if ($chome ne 'no_host') {
1.302     albertel 2923:        %returnhash=&dump('environment',$cdomain,$cnum);
1.129     albertel 2924:        if (!exists($returnhash{'con_lost'})) {
                   2925:            $returnhash{'home'}= $chome;
                   2926: 	   $returnhash{'domain'} = $cdomain;
                   2927: 	   $returnhash{'num'} = $cnum;
1.741     raeburn  2928:            if (!defined($returnhash{'type'})) {
                   2929:                $returnhash{'type'} = 'Course';
                   2930:            }
1.130     albertel 2931:            while (my ($name,$value) = each %returnhash) {
1.53      www      2932:                $envhash{'course.'.$normalid.'.'.$name}=$value;
1.129     albertel 2933:            }
1.270     www      2934:            $returnhash{'url'}=&clutter($returnhash{'url'});
1.34      www      2935:            $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'.
1.620     albertel 2936: 	       $env{'user.name'}.'_'.$cdomain.'_'.$cnum;
1.60      www      2937:            $envhash{'course.'.$normalid.'.home'}=$chome;
                   2938:            $envhash{'course.'.$normalid.'.domain'}=$cdomain;
                   2939:            $envhash{'course.'.$normalid.'.num'}=$cnum;
1.34      www      2940:        }
                   2941:     }
1.731     albertel 2942:     if (!$args->{'one_time'}) {
                   2943: 	&appenv(%envhash);
                   2944:     }
1.302     albertel 2945:     return %returnhash;
1.461     www      2946: }
                   2947: 
                   2948: # -------------------------------------------------See if a user is privileged
                   2949: 
                   2950: sub privileged {
                   2951:     my ($username,$domain)=@_;
                   2952:     my $rolesdump=&reply("dump:$domain:$username:roles",
                   2953: 			&homeserver($username,$domain));
                   2954:     if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return 0; }
                   2955:     my $now=time;
                   2956:     if ($rolesdump ne '') {
1.800     albertel 2957:         foreach my $entry (split(/&/,$rolesdump)) {
                   2958: 	    if ($entry!~/^rolesdef_/) {
                   2959: 		my ($area,$role)=split(/=/,$entry);
1.461     www      2960: 		$area=~s/\_\w\w$//;
                   2961: 		my ($trole,$tend,$tstart)=split(/_/,$role);
                   2962: 		if (($trole eq 'dc') || ($trole eq 'su')) {
                   2963: 		    my $active=1;
                   2964: 		    if ($tend) {
                   2965: 			if ($tend<$now) { $active=0; }
                   2966: 		    }
                   2967: 		    if ($tstart) {
                   2968: 			if ($tstart>$now) { $active=0; }
                   2969: 		    }
                   2970: 		    if ($active) { return 1; }
                   2971: 		}
                   2972: 	    }
                   2973: 	}
                   2974:     }
                   2975:     return 0;
1.9       www      2976: }
1.1       albertel 2977: 
1.103     harris41 2978: # -------------------------------------------------------- Get user privileges
1.11      www      2979: 
                   2980: sub rolesinit {
                   2981:     my ($domain,$username,$authhost)=@_;
                   2982:     my $rolesdump=reply("dump:$domain:$username:roles",$authhost);
1.12      www      2983:     if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; }
1.11      www      2984:     my %allroles=();
1.678     raeburn  2985:     my %allgroups=();   
1.11      www      2986:     my $now=time;
1.743     albertel 2987:     my %userroles = ('user.login.time' => $now);
1.678     raeburn  2988:     my $group_privs;
1.11      www      2989: 
                   2990:     if ($rolesdump ne '') {
1.800     albertel 2991:         foreach my $entry (split(/&/,$rolesdump)) {
                   2992: 	  if ($entry!~/^rolesdef_/) {
                   2993:             my ($area,$role)=split(/=/,$entry);
1.587     albertel 2994: 	    $area=~s/\_\w\w$//;
1.678     raeburn  2995:             my ($trole,$tend,$tstart,$group_privs);
1.587     albertel 2996: 	    if ($role=~/^cr/) { 
1.807     albertel 2997: 		if ($role=~m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|) {
                   2998: 		    ($trole,my $trest)=($role=~m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|);
1.655     albertel 2999: 		    ($tend,$tstart)=split('_',$trest);
                   3000: 		} else {
                   3001: 		    $trole=$role;
                   3002: 		}
1.678     raeburn  3003:             } elsif ($role =~ m|^gr/|) {
                   3004:                 ($trole,$tend,$tstart) = split(/_/,$role);
                   3005:                 ($trole,$group_privs) = split(/\//,$trole);
                   3006:                 $group_privs = &unescape($group_privs);
1.587     albertel 3007: 	    } else {
                   3008: 		($trole,$tend,$tstart)=split(/_/,$role);
                   3009: 	    }
1.743     albertel 3010: 	    my %new_role = &set_arearole($trole,$area,$tstart,$tend,$domain,
                   3011: 					 $username);
                   3012: 	    @userroles{keys(%new_role)} = @new_role{keys(%new_role)};
1.567     raeburn  3013:             if (($tend!=0) && ($tend<$now)) { $trole=''; }
                   3014:             if (($tstart!=0) && ($tstart>$now)) { $trole=''; }
1.11      www      3015:             if (($area ne '') && ($trole ne '')) {
1.347     albertel 3016: 		my $spec=$trole.'.'.$area;
                   3017: 		my ($tdummy,$tdomain,$trest)=split(/\//,$area);
                   3018: 		if ($trole =~ /^cr\//) {
1.567     raeburn  3019:                     &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);
1.678     raeburn  3020:                 } elsif ($trole eq 'gr') {
                   3021:                     &group_roleprivs(\%allgroups,$area,$group_privs,$tend,$tstart);
1.347     albertel 3022: 		} else {
1.567     raeburn  3023:                     &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
1.347     albertel 3024: 		}
1.12      www      3025:             }
1.662     raeburn  3026:           }
1.191     harris41 3027:         }
1.743     albertel 3028:         my ($author,$adv) = &set_userprivs(\%userroles,\%allroles,\%allgroups);
                   3029:         $userroles{'user.adv'}    = $adv;
                   3030: 	$userroles{'user.author'} = $author;
1.620     albertel 3031:         $env{'user.adv'}=$adv;
1.11      www      3032:     }
1.743     albertel 3033:     return \%userroles;  
1.11      www      3034: }
                   3035: 
1.567     raeburn  3036: sub set_arearole {
                   3037:     my ($trole,$area,$tstart,$tend,$domain,$username) = @_;
                   3038: # log the associated role with the area
                   3039:     &userrolelog($trole,$username,$domain,$area,$tstart,$tend);
1.743     albertel 3040:     return ('user.role.'.$trole.'.'.$area => $tstart.'.'.$tend);
1.567     raeburn  3041: }
                   3042: 
                   3043: sub custom_roleprivs {
                   3044:     my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_;
                   3045:     my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
                   3046:     my $homsvr=homeserver($rauthor,$rdomain);
1.838     albertel 3047:     if (&hostname($homsvr) ne '') {
1.567     raeburn  3048:         my ($rdummy,$roledef)=
                   3049:             &get('roles',["rolesdef_$rrole"],$rdomain,$rauthor);
                   3050:         if (($rdummy ne 'con_lost') && ($roledef ne '')) {
                   3051:             my ($syspriv,$dompriv,$coursepriv)=split(/\_/,$roledef);
                   3052:             if (defined($syspriv)) {
                   3053:                 $$allroles{'cm./'}.=':'.$syspriv;
                   3054:                 $$allroles{$spec.'./'}.=':'.$syspriv;
                   3055:             }
                   3056:             if ($tdomain ne '') {
                   3057:                 if (defined($dompriv)) {
                   3058:                     $$allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv;
                   3059:                     $$allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv;
                   3060:                 }
                   3061:                 if (($trest ne '') && (defined($coursepriv))) {
                   3062:                     $$allroles{'cm.'.$area}.=':'.$coursepriv;
                   3063:                     $$allroles{$spec.'.'.$area}.=':'.$coursepriv;
                   3064:                 }
                   3065:             }
                   3066:         }
                   3067:     }
                   3068: }
                   3069: 
1.678     raeburn  3070: sub group_roleprivs {
                   3071:     my ($allgroups,$area,$group_privs,$tend,$tstart) = @_;
                   3072:     my $access = 1;
                   3073:     my $now = time;
                   3074:     if (($tend!=0) && ($tend<$now)) { $access = 0; }
                   3075:     if (($tstart!=0) && ($tstart>$now)) { $access=0; }
                   3076:     if ($access) {
1.811     albertel 3077:         my ($course,$group) = ($area =~ m|(/$match_domain/$match_courseid)/([^/]+)$|);
1.678     raeburn  3078:         $$allgroups{$course}{$group} .=':'.$group_privs;
                   3079:     }
                   3080: }
1.567     raeburn  3081: 
                   3082: sub standard_roleprivs {
                   3083:     my ($allroles,$trole,$tdomain,$spec,$trest,$area) = @_;
                   3084:     if (defined($pr{$trole.':s'})) {
                   3085:         $$allroles{'cm./'}.=':'.$pr{$trole.':s'};
                   3086:         $$allroles{$spec.'./'}.=':'.$pr{$trole.':s'};
                   3087:     }
                   3088:     if ($tdomain ne '') {
                   3089:         if (defined($pr{$trole.':d'})) {
                   3090:             $$allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
                   3091:             $$allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
                   3092:         }
                   3093:         if (($trest ne '') && (defined($pr{$trole.':c'}))) {
                   3094:             $$allroles{'cm.'.$area}.=':'.$pr{$trole.':c'};
                   3095:             $$allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'};
                   3096:         }
                   3097:     }
                   3098: }
                   3099: 
                   3100: sub set_userprivs {
1.678     raeburn  3101:     my ($userroles,$allroles,$allgroups) = @_; 
1.567     raeburn  3102:     my $author=0;
                   3103:     my $adv=0;
1.678     raeburn  3104:     my %grouproles = ();
                   3105:     if (keys(%{$allgroups}) > 0) {
                   3106:         foreach my $role (keys %{$allroles}) {
1.681     raeburn  3107:             my ($trole,$area,$sec,$extendedarea);
1.811     albertel 3108:             if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)-) {
1.678     raeburn  3109:                 $trole = $1;
                   3110:                 $area = $2;
1.681     raeburn  3111:                 $sec = $3;
                   3112:                 $extendedarea = $area.$sec;
                   3113:                 if (exists($$allgroups{$area})) {
                   3114:                     foreach my $group (keys(%{$$allgroups{$area}})) {
                   3115:                         my $spec = $trole.'.'.$extendedarea;
                   3116:                         $grouproles{$spec.'.'.$area.'/'.$group} = 
                   3117:                                                 $$allgroups{$area}{$group};
1.678     raeburn  3118:                     }
                   3119:                 }
                   3120:             }
                   3121:         }
                   3122:     }
1.800     albertel 3123:     foreach my $group (keys(%grouproles)) {
                   3124:         $$allroles{$group} = $grouproles{$group};
1.678     raeburn  3125:     }
1.800     albertel 3126:     foreach my $role (keys(%{$allroles})) {
                   3127:         my %thesepriv;
                   3128:         if (($role=~/^au/) || ($role=~/^ca/)) { $author=1; }
                   3129:         foreach my $item (split(/:/,$$allroles{$role})) {
                   3130:             if ($item ne '') {
                   3131:                 my ($privilege,$restrictions)=split(/&/,$item);
1.567     raeburn  3132:                 if ($restrictions eq '') {
                   3133:                     $thesepriv{$privilege}='F';
                   3134:                 } elsif ($thesepriv{$privilege} ne 'F') {
                   3135:                     $thesepriv{$privilege}.=$restrictions;
                   3136:                 }
                   3137:                 if ($thesepriv{'adv'} eq 'F') { $adv=1; }
                   3138:             }
                   3139:         }
                   3140:         my $thesestr='';
1.800     albertel 3141:         foreach my $priv (keys(%thesepriv)) {
                   3142: 	    $thesestr.=':'.$priv.'&'.$thesepriv{$priv};
                   3143: 	}
                   3144:         $userroles->{'user.priv.'.$role} = $thesestr;
1.567     raeburn  3145:     }
                   3146:     return ($author,$adv);
                   3147: }
                   3148: 
1.12      www      3149: # --------------------------------------------------------------- get interface
                   3150: 
                   3151: sub get {
1.131     albertel 3152:    my ($namespace,$storearr,$udomain,$uname)=@_;
1.12      www      3153:    my $items='';
1.800     albertel 3154:    foreach my $item (@$storearr) {
                   3155:        $items.=&escape($item).'&';
1.191     harris41 3156:    }
1.12      www      3157:    $items=~s/\&$//;
1.620     albertel 3158:    if (!$udomain) { $udomain=$env{'user.domain'}; }
                   3159:    if (!$uname) { $uname=$env{'user.name'}; }
1.131     albertel 3160:    my $uhome=&homeserver($uname,$udomain);
                   3161: 
1.133     albertel 3162:    my $rep=&reply("get:$udomain:$uname:$namespace:$items",$uhome);
1.15      www      3163:    my @pairs=split(/\&/,$rep);
1.273     albertel 3164:    if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) {
                   3165:      return @pairs;
                   3166:    }
1.15      www      3167:    my %returnhash=();
1.42      www      3168:    my $i=0;
1.800     albertel 3169:    foreach my $item (@$storearr) {
                   3170:       $returnhash{$item}=&thaw_unescape($pairs[$i]);
1.42      www      3171:       $i++;
1.191     harris41 3172:    }
1.15      www      3173:    return %returnhash;
1.27      www      3174: }
                   3175: 
                   3176: # --------------------------------------------------------------- del interface
                   3177: 
                   3178: sub del {
1.133     albertel 3179:    my ($namespace,$storearr,$udomain,$uname)=@_;
1.27      www      3180:    my $items='';
1.800     albertel 3181:    foreach my $item (@$storearr) {
                   3182:        $items.=&escape($item).'&';
1.191     harris41 3183:    }
1.27      www      3184:    $items=~s/\&$//;
1.620     albertel 3185:    if (!$udomain) { $udomain=$env{'user.domain'}; }
                   3186:    if (!$uname) { $uname=$env{'user.name'}; }
1.133     albertel 3187:    my $uhome=&homeserver($uname,$udomain);
                   3188: 
                   3189:    return &reply("del:$udomain:$uname:$namespace:$items",$uhome);
1.15      www      3190: }
                   3191: 
                   3192: # -------------------------------------------------------------- dump interface
                   3193: 
                   3194: sub dump {
1.755     albertel 3195:     my ($namespace,$udomain,$uname,$regexp,$range)=@_;
                   3196:     if (!$udomain) { $udomain=$env{'user.domain'}; }
                   3197:     if (!$uname) { $uname=$env{'user.name'}; }
                   3198:     my $uhome=&homeserver($uname,$udomain);
                   3199:     if ($regexp) {
                   3200: 	$regexp=&escape($regexp);
                   3201:     } else {
                   3202: 	$regexp='.';
                   3203:     }
                   3204:     my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
                   3205:     my @pairs=split(/\&/,$rep);
                   3206:     my %returnhash=();
                   3207:     foreach my $item (@pairs) {
                   3208: 	my ($key,$value)=split(/=/,$item,2);
                   3209: 	$key = &unescape($key);
                   3210: 	next if ($key =~ /^error: 2 /);
                   3211: 	$returnhash{$key}=&thaw_unescape($value);
                   3212:     }
                   3213:     return %returnhash;
1.407     www      3214: }
                   3215: 
1.717     albertel 3216: # --------------------------------------------------------- dumpstore interface
                   3217: 
                   3218: sub dumpstore {
                   3219:    my ($namespace,$udomain,$uname,$regexp,$range)=@_;
1.822     albertel 3220:    if (!$udomain) { $udomain=$env{'user.domain'}; }
                   3221:    if (!$uname) { $uname=$env{'user.name'}; }
                   3222:    my $uhome=&homeserver($uname,$udomain);
                   3223:    if ($regexp) {
                   3224:        $regexp=&escape($regexp);
                   3225:    } else {
                   3226:        $regexp='.';
                   3227:    }
                   3228:    my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
                   3229:    my @pairs=split(/\&/,$rep);
                   3230:    my %returnhash=();
                   3231:    foreach my $item (@pairs) {
                   3232:        my ($key,$value)=split(/=/,$item,2);
                   3233:        next if ($key =~ /^error: 2 /);
                   3234:        $returnhash{$key}=&thaw_unescape($value);
                   3235:    }
                   3236:    return %returnhash;
1.717     albertel 3237: }
                   3238: 
1.407     www      3239: # -------------------------------------------------------------- keys interface
                   3240: 
                   3241: sub getkeys {
                   3242:    my ($namespace,$udomain,$uname)=@_;
1.620     albertel 3243:    if (!$udomain) { $udomain=$env{'user.domain'}; }
                   3244:    if (!$uname) { $uname=$env{'user.name'}; }
1.407     www      3245:    my $uhome=&homeserver($uname,$udomain);
                   3246:    my $rep=reply("keys:$udomain:$uname:$namespace",$uhome);
                   3247:    my @keyarray=();
1.800     albertel 3248:    foreach my $key (split(/\&/,$rep)) {
1.812     raeburn  3249:       next if ($key =~ /^error: 2 /);
1.800     albertel 3250:       push(@keyarray,&unescape($key));
1.407     www      3251:    }
                   3252:    return @keyarray;
1.318     matthew  3253: }
                   3254: 
1.319     matthew  3255: # --------------------------------------------------------------- currentdump
                   3256: sub currentdump {
1.328     matthew  3257:    my ($courseid,$sdom,$sname)=@_;
1.620     albertel 3258:    $courseid = $env{'request.course.id'} if (! defined($courseid));
                   3259:    $sdom     = $env{'user.domain'}       if (! defined($sdom));
                   3260:    $sname    = $env{'user.name'}         if (! defined($sname));
1.326     matthew  3261:    my $uhome = &homeserver($sname,$sdom);
                   3262:    my $rep=reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome);
1.318     matthew  3263:    return if ($rep =~ /^(error:|no_such_host)/);
1.319     matthew  3264:    #
1.318     matthew  3265:    my %returnhash=();
1.319     matthew  3266:    #
                   3267:    if ($rep eq "unknown_cmd") { 
                   3268:        # an old lond will not know currentdump
                   3269:        # Do a dump and make it look like a currentdump
1.822     albertel 3270:        my @tmp = &dumpstore($courseid,$sdom,$sname,'.');
1.319     matthew  3271:        return if ($tmp[0] =~ /^(error:|no_such_host)/);
                   3272:        my %hash = @tmp;
                   3273:        @tmp=();
1.424     matthew  3274:        %returnhash = %{&convert_dump_to_currentdump(\%hash)};
1.319     matthew  3275:    } else {
                   3276:        my @pairs=split(/\&/,$rep);
1.800     albertel 3277:        foreach my $pair (@pairs) {
                   3278:            my ($key,$value)=split(/=/,$pair,2);
1.319     matthew  3279:            my ($symb,$param) = split(/:/,$key);
                   3280:            $returnhash{&unescape($symb)}->{&unescape($param)} = 
1.557     albertel 3281:                                                         &thaw_unescape($value);
1.319     matthew  3282:        }
1.191     harris41 3283:    }
1.12      www      3284:    return %returnhash;
1.424     matthew  3285: }
                   3286: 
                   3287: sub convert_dump_to_currentdump{
                   3288:     my %hash = %{shift()};
                   3289:     my %returnhash;
                   3290:     # Code ripped from lond, essentially.  The only difference
                   3291:     # here is the unescaping done by lonnet::dump().  Conceivably
                   3292:     # we might run in to problems with parameter names =~ /^v\./
                   3293:     while (my ($key,$value) = each(%hash)) {
                   3294:         my ($v,$symb,$param) = split(/:/,$key);
1.822     albertel 3295: 	$symb  = &unescape($symb);
                   3296: 	$param = &unescape($param);
1.424     matthew  3297:         next if ($v eq 'version' || $symb eq 'keys');
                   3298:         next if (exists($returnhash{$symb}) &&
                   3299:                  exists($returnhash{$symb}->{$param}) &&
                   3300:                  $returnhash{$symb}->{'v.'.$param} > $v);
                   3301:         $returnhash{$symb}->{$param}=$value;
                   3302:         $returnhash{$symb}->{'v.'.$param}=$v;
                   3303:     }
                   3304:     #
                   3305:     # Remove all of the keys in the hashes which keep track of
                   3306:     # the version of the parameter.
                   3307:     while (my ($symb,$param_hash) = each(%returnhash)) {
                   3308:         # use a foreach because we are going to delete from the hash.
                   3309:         foreach my $key (keys(%$param_hash)) {
                   3310:             delete($param_hash->{$key}) if ($key =~ /^v\./);
                   3311:         }
                   3312:     }
                   3313:     return \%returnhash;
1.12      www      3314: }
                   3315: 
1.627     albertel 3316: # ------------------------------------------------------ critical inc interface
                   3317: 
                   3318: sub cinc {
                   3319:     return &inc(@_,'critical');
                   3320: }
                   3321: 
1.449     matthew  3322: # --------------------------------------------------------------- inc interface
                   3323: 
                   3324: sub inc {
1.627     albertel 3325:     my ($namespace,$store,$udomain,$uname,$critical) = @_;
1.620     albertel 3326:     if (!$udomain) { $udomain=$env{'user.domain'}; }
                   3327:     if (!$uname) { $uname=$env{'user.name'}; }
1.449     matthew  3328:     my $uhome=&homeserver($uname,$udomain);
                   3329:     my $items='';
                   3330:     if (! ref($store)) {
                   3331:         # got a single value, so use that instead
                   3332:         $items = &escape($store).'=&';
                   3333:     } elsif (ref($store) eq 'SCALAR') {
                   3334:         $items = &escape($$store).'=&';        
                   3335:     } elsif (ref($store) eq 'ARRAY') {
                   3336:         $items = join('=&',map {&escape($_);} @{$store});
                   3337:     } elsif (ref($store) eq 'HASH') {
                   3338:         while (my($key,$value) = each(%{$store})) {
                   3339:             $items.= &escape($key).'='.&escape($value).'&';
                   3340:         }
                   3341:     }
                   3342:     $items=~s/\&$//;
1.627     albertel 3343:     if ($critical) {
                   3344: 	return &critical("inc:$udomain:$uname:$namespace:$items",$uhome);
                   3345:     } else {
                   3346: 	return &reply("inc:$udomain:$uname:$namespace:$items",$uhome);
                   3347:     }
1.449     matthew  3348: }
                   3349: 
1.12      www      3350: # --------------------------------------------------------------- put interface
                   3351: 
                   3352: sub put {
1.134     albertel 3353:    my ($namespace,$storehash,$udomain,$uname)=@_;
1.620     albertel 3354:    if (!$udomain) { $udomain=$env{'user.domain'}; }
                   3355:    if (!$uname) { $uname=$env{'user.name'}; }
1.134     albertel 3356:    my $uhome=&homeserver($uname,$udomain);
1.12      www      3357:    my $items='';
1.800     albertel 3358:    foreach my $item (keys(%$storehash)) {
                   3359:        $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
1.191     harris41 3360:    }
1.12      www      3361:    $items=~s/\&$//;
1.134     albertel 3362:    return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
1.47      www      3363: }
                   3364: 
1.631     albertel 3365: # ------------------------------------------------------------ newput interface
                   3366: 
                   3367: sub newput {
                   3368:    my ($namespace,$storehash,$udomain,$uname)=@_;
                   3369:    if (!$udomain) { $udomain=$env{'user.domain'}; }
                   3370:    if (!$uname) { $uname=$env{'user.name'}; }
                   3371:    my $uhome=&homeserver($uname,$udomain);
                   3372:    my $items='';
                   3373:    foreach my $key (keys(%$storehash)) {
                   3374:        $items.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
                   3375:    }
                   3376:    $items=~s/\&$//;
                   3377:    return &reply("newput:$udomain:$uname:$namespace:$items",$uhome);
                   3378: }
                   3379: 
                   3380: # ---------------------------------------------------------  putstore interface
                   3381: 
1.524     raeburn  3382: sub putstore {
1.715     albertel 3383:    my ($namespace,$symb,$version,$storehash,$udomain,$uname)=@_;
1.620     albertel 3384:    if (!$udomain) { $udomain=$env{'user.domain'}; }
                   3385:    if (!$uname) { $uname=$env{'user.name'}; }
1.524     raeburn  3386:    my $uhome=&homeserver($uname,$udomain);
                   3387:    my $items='';
1.715     albertel 3388:    foreach my $key (keys(%$storehash)) {
                   3389:        $items.= &escape($key).'='.&freeze_escape($storehash->{$key}).'&';
1.524     raeburn  3390:    }
1.715     albertel 3391:    $items=~s/\&$//;
1.716     albertel 3392:    my $esc_symb=&escape($symb);
                   3393:    my $esc_v=&escape($version);
1.715     albertel 3394:    my $reply =
1.716     albertel 3395:        &reply("putstore:$udomain:$uname:$namespace:$esc_symb:$esc_v:$items",
1.715     albertel 3396: 	      $uhome);
                   3397:    if ($reply eq 'unknown_cmd') {
1.716     albertel 3398:        # gfall back to way things use to be done
1.715     albertel 3399:        return &old_putstore($namespace,$symb,$version,$storehash,$udomain,
                   3400: 			    $uname);
1.524     raeburn  3401:    }
1.715     albertel 3402:    return $reply;
                   3403: }
                   3404: 
                   3405: sub old_putstore {
1.716     albertel 3406:     my ($namespace,$symb,$version,$storehash,$udomain,$uname)=@_;
                   3407:     if (!$udomain) { $udomain=$env{'user.domain'}; }
                   3408:     if (!$uname) { $uname=$env{'user.name'}; }
                   3409:     my $uhome=&homeserver($uname,$udomain);
                   3410:     my %newstorehash;
1.800     albertel 3411:     foreach my $item (keys(%$storehash)) {
                   3412: 	my $key = $version.':'.&escape($symb).':'.$item;
                   3413: 	$newstorehash{$key} = $storehash->{$item};
1.716     albertel 3414:     }
                   3415:     my $items='';
                   3416:     my %allitems = ();
1.800     albertel 3417:     foreach my $item (keys(%newstorehash)) {
                   3418: 	if ($item =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) {
1.716     albertel 3419: 	    my $key = $1.':keys:'.$2;
                   3420: 	    $allitems{$key} .= $3.':';
                   3421: 	}
1.800     albertel 3422: 	$items.=$item.'='.&freeze_escape($newstorehash{$item}).'&';
1.716     albertel 3423:     }
1.800     albertel 3424:     foreach my $item (keys(%allitems)) {
                   3425: 	$allitems{$item} =~ s/\:$//;
                   3426: 	$items.= $item.'='.$allitems{$item}.'&';
1.716     albertel 3427:     }
                   3428:     $items=~s/\&$//;
                   3429:     return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
1.524     raeburn  3430: }
                   3431: 
1.47      www      3432: # ------------------------------------------------------ critical put interface
                   3433: 
                   3434: sub cput {
1.134     albertel 3435:    my ($namespace,$storehash,$udomain,$uname)=@_;
1.620     albertel 3436:    if (!$udomain) { $udomain=$env{'user.domain'}; }
                   3437:    if (!$uname) { $uname=$env{'user.name'}; }
1.134     albertel 3438:    my $uhome=&homeserver($uname,$udomain);
1.47      www      3439:    my $items='';
1.800     albertel 3440:    foreach my $item (keys(%$storehash)) {
                   3441:        $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
1.191     harris41 3442:    }
1.47      www      3443:    $items=~s/\&$//;
1.134     albertel 3444:    return &critical("put:$udomain:$uname:$namespace:$items",$uhome);
1.12      www      3445: }
                   3446: 
                   3447: # -------------------------------------------------------------- eget interface
                   3448: 
                   3449: sub eget {
1.133     albertel 3450:    my ($namespace,$storearr,$udomain,$uname)=@_;
1.12      www      3451:    my $items='';
1.800     albertel 3452:    foreach my $item (@$storearr) {
                   3453:        $items.=&escape($item).'&';
1.191     harris41 3454:    }
1.12      www      3455:    $items=~s/\&$//;
1.620     albertel 3456:    if (!$udomain) { $udomain=$env{'user.domain'}; }
                   3457:    if (!$uname) { $uname=$env{'user.name'}; }
1.133     albertel 3458:    my $uhome=&homeserver($uname,$udomain);
                   3459:    my $rep=&reply("eget:$udomain:$uname:$namespace:$items",$uhome);
1.12      www      3460:    my @pairs=split(/\&/,$rep);
                   3461:    my %returnhash=();
1.42      www      3462:    my $i=0;
1.800     albertel 3463:    foreach my $item (@$storearr) {
                   3464:       $returnhash{$item}=&thaw_unescape($pairs[$i]);
1.42      www      3465:       $i++;
1.191     harris41 3466:    }
1.12      www      3467:    return %returnhash;
                   3468: }
                   3469: 
1.667     albertel 3470: # ------------------------------------------------------------ tmpput interface
                   3471: sub tmpput {
1.802     raeburn  3472:     my ($storehash,$server,$context)=@_;
1.667     albertel 3473:     my $items='';
1.800     albertel 3474:     foreach my $item (keys(%$storehash)) {
                   3475: 	$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
1.667     albertel 3476:     }
                   3477:     $items=~s/\&$//;
1.802     raeburn  3478:     if (defined($context)) {
                   3479:         $items .= ':'.&escape($context);
                   3480:     }
1.667     albertel 3481:     return &reply("tmpput:$items",$server);
                   3482: }
                   3483: 
                   3484: # ------------------------------------------------------------ tmpget interface
                   3485: sub tmpget {
1.688     albertel 3486:     my ($token,$server)=@_;
                   3487:     if (!defined($server)) { $server = $perlvar{'lonHostID'}; }
                   3488:     my $rep=&reply("tmpget:$token",$server);
1.667     albertel 3489:     my %returnhash;
                   3490:     foreach my $item (split(/\&/,$rep)) {
                   3491: 	my ($key,$value)=split(/=/,$item);
                   3492: 	$returnhash{&unescape($key)}=&thaw_unescape($value);
                   3493:     }
                   3494:     return %returnhash;
                   3495: }
                   3496: 
1.688     albertel 3497: # ------------------------------------------------------------ tmpget interface
                   3498: sub tmpdel {
                   3499:     my ($token,$server)=@_;
                   3500:     if (!defined($server)) { $server = $perlvar{'lonHostID'}; }
                   3501:     return &reply("tmpdel:$token",$server);
                   3502: }
                   3503: 
1.765     albertel 3504: # -------------------------------------------------- portfolio access checking
                   3505: 
                   3506: sub portfolio_access {
1.766     albertel 3507:     my ($requrl) = @_;
1.765     albertel 3508:     my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl);
                   3509:     my $result = &get_portfolio_access($udom,$unum,$file_name,$group);
1.814     raeburn  3510:     if ($result) {
                   3511:         my %setters;
                   3512:         if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
                   3513:             my ($startblock,$endblock) =
                   3514:                 &Apache::loncommon::blockcheck(\%setters,'port',$unum,$udom);
                   3515:             if ($startblock && $endblock) {
                   3516:                 return 'B';
                   3517:             }
                   3518:         } else {
                   3519:             my ($startblock,$endblock) =
                   3520:                 &Apache::loncommon::blockcheck(\%setters,'port');
                   3521:             if ($startblock && $endblock) {
                   3522:                 return 'B';
                   3523:             }
                   3524:         }
                   3525:     }
1.765     albertel 3526:     if ($result eq 'ok') {
1.766     albertel 3527:        return 'F';
1.765     albertel 3528:     } elsif ($result =~ /^[^:]+:guest_/) {
1.766     albertel 3529:        return 'A';
1.765     albertel 3530:     }
1.766     albertel 3531:     return '';
1.765     albertel 3532: }
                   3533: 
                   3534: sub get_portfolio_access {
1.767     albertel 3535:     my ($udom,$unum,$file_name,$group,$access_hash) = @_;
                   3536: 
                   3537:     if (!ref($access_hash)) {
                   3538: 	my $current_perms = &get_portfile_permissions($udom,$unum);
                   3539: 	my %access_controls = &get_access_controls($current_perms,$group,
                   3540: 						   $file_name);
                   3541: 	$access_hash = $access_controls{$file_name};
                   3542:     }
                   3543: 
1.765     albertel 3544:     my ($public,$guest,@domains,@users,@courses,@groups);
                   3545:     my $now = time;
                   3546:     if (ref($access_hash) eq 'HASH') {
                   3547:         foreach my $key (keys(%{$access_hash})) {
                   3548:             my ($num,$scope,$end,$start) = ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/);
                   3549:             if ($start > $now) {
                   3550:                 next;
                   3551:             }
                   3552:             if ($end && $end<$now) {
                   3553:                 next;
                   3554:             }
                   3555:             if ($scope eq 'public') {
                   3556:                 $public = $key;
                   3557:                 last;
                   3558:             } elsif ($scope eq 'guest') {
                   3559:                 $guest = $key;
                   3560:             } elsif ($scope eq 'domains') {
                   3561:                 push(@domains,$key);
                   3562:             } elsif ($scope eq 'users') {
                   3563:                 push(@users,$key);
                   3564:             } elsif ($scope eq 'course') {
                   3565:                 push(@courses,$key);
                   3566:             } elsif ($scope eq 'group') {
                   3567:                 push(@groups,$key);
                   3568:             }
                   3569:         }
                   3570:         if ($public) {
                   3571:             return 'ok';
                   3572:         }
                   3573:         if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
                   3574:             if ($guest) {
                   3575:                 return $guest;
                   3576:             }
                   3577:         } else {
                   3578:             if (@domains > 0) {
                   3579:                 foreach my $domkey (@domains) {
                   3580:                     if (ref($access_hash->{$domkey}{'dom'}) eq 'ARRAY') {
                   3581:                         if (grep(/^\Q$env{'user.domain'}\E$/,@{$access_hash->{$domkey}{'dom'}})) {
                   3582:                             return 'ok';
                   3583:                         }
                   3584:                     }
                   3585:                 }
                   3586:             }
                   3587:             if (@users > 0) {
                   3588:                 foreach my $userkey (@users) {
                   3589:                     if (exists($access_hash->{$userkey}{'users'}{$env{'user.name'}.':'.$env{'user.domain'}})) {
                   3590:                         return 'ok';
                   3591:                     }
                   3592:                 }
                   3593:             }
                   3594:             my %roleshash;
                   3595:             my @courses_and_groups = @courses;
                   3596:             push(@courses_and_groups,@groups); 
                   3597:             if (@courses_and_groups > 0) {
                   3598:                 my (%allgroups,%allroles); 
                   3599:                 my ($start,$end,$role,$sec,$group);
                   3600:                 foreach my $envkey (%env) {
1.811     albertel 3601:                     if ($envkey =~ m-^user\.role\.(gr|cc|in|ta|ep|st)\./($match_domain)/($match_courseid)/?([^/]*)$-) {
1.765     albertel 3602:                         my $cid = $2.'_'.$3; 
                   3603:                         if ($1 eq 'gr') {
                   3604:                             $group = $4;
                   3605:                             $allgroups{$cid}{$group} = $env{$envkey};
                   3606:                         } else {
                   3607:                             if ($4 eq '') {
                   3608:                                 $sec = 'none';
                   3609:                             } else {
                   3610:                                 $sec = $4;
                   3611:                             }
                   3612:                             $allroles{$cid}{$1}{$sec} = $env{$envkey};
                   3613:                         }
1.811     albertel 3614:                     } elsif ($envkey =~ m-^user\.role\./cr/($match_domain/$match_username/\w*)./($match_domain)/($match_courseid)/?([^/]*)$-) {
1.765     albertel 3615:                         my $cid = $2.'_'.$3;
                   3616:                         if ($4 eq '') {
                   3617:                             $sec = 'none';
                   3618:                         } else {
                   3619:                             $sec = $4;
                   3620:                         }
                   3621:                         $allroles{$cid}{$1}{$sec} = $env{$envkey};
                   3622:                     }
                   3623:                 }
                   3624:                 if (keys(%allroles) == 0) {
                   3625:                     return;
                   3626:                 }
                   3627:                 foreach my $key (@courses_and_groups) {
                   3628:                     my %content = %{$$access_hash{$key}};
                   3629:                     my $cnum = $content{'number'};
                   3630:                     my $cdom = $content{'domain'};
                   3631:                     my $cid = $cdom.'_'.$cnum;
                   3632:                     if (!exists($allroles{$cid})) {
                   3633:                         next;
                   3634:                     }    
                   3635:                     foreach my $role_id (keys(%{$content{'roles'}})) {
                   3636:                         my @sections = @{$content{'roles'}{$role_id}{'section'}};
                   3637:                         my @groups = @{$content{'roles'}{$role_id}{'group'}};
                   3638:                         my @status = @{$content{'roles'}{$role_id}{'access'}};
                   3639:                         my @roles = @{$content{'roles'}{$role_id}{'role'}};
                   3640:                         foreach my $role (keys(%{$allroles{$cid}})) {
                   3641:                             if ((grep/^all$/,@roles) || (grep/^\Q$role\E$/,@roles)) {
                   3642:                                 foreach my $sec (keys(%{$allroles{$cid}{$role}})) {
                   3643:                                     if (&course_group_datechecker($allroles{$cid}{$role}{$sec},$now,\@status) eq 'ok') {
                   3644:                                         if (grep/^all$/,@sections) {
                   3645:                                             return 'ok';
                   3646:                                         } else {
                   3647:                                             if (grep/^$sec$/,@sections) {
                   3648:                                                 return 'ok';
                   3649:                                             }
                   3650:                                         }
                   3651:                                     }
                   3652:                                 }
                   3653:                                 if (keys(%{$allgroups{$cid}}) == 0) {
                   3654:                                     if (grep/^none$/,@groups) {
                   3655:                                         return 'ok';
                   3656:                                     }
                   3657:                                 } else {
                   3658:                                     if (grep/^all$/,@groups) {
                   3659:                                         return 'ok';
                   3660:                                     } 
                   3661:                                     foreach my $group (keys(%{$allgroups{$cid}})) {
                   3662:                                         if (grep/^$group$/,@groups) {
                   3663:                                             return 'ok';
                   3664:                                         }
                   3665:                                     }
                   3666:                                 } 
                   3667:                             }
                   3668:                         }
                   3669:                     }
                   3670:                 }
                   3671:             }
                   3672:             if ($guest) {
                   3673:                 return $guest;
                   3674:             }
                   3675:         }
                   3676:     }
                   3677:     return;
                   3678: }
                   3679: 
                   3680: sub course_group_datechecker {
                   3681:     my ($dates,$now,$status) = @_;
                   3682:     my ($start,$end) = split(/\./,$dates);
                   3683:     if (!$start && !$end) {
                   3684:         return 'ok';
                   3685:     }
                   3686:     if (grep/^active$/,@{$status}) {
                   3687:         if (((!$start) || ($start && $start <= $now)) && ((!$end) || ($end && $end >= $now))) {
                   3688:             return 'ok';
                   3689:         }
                   3690:     }
                   3691:     if (grep/^previous$/,@{$status}) {
                   3692:         if ($end > $now ) {
                   3693:             return 'ok';
                   3694:         }
                   3695:     }
                   3696:     if (grep/^future$/,@{$status}) {
                   3697:         if ($start > $now) {
                   3698:             return 'ok';
                   3699:         }
                   3700:     }
                   3701:     return; 
                   3702: }
                   3703: 
                   3704: sub parse_portfolio_url {
                   3705:     my ($url) = @_;
                   3706: 
                   3707:     my ($type,$udom,$unum,$group,$file_name);
                   3708:     
1.823     albertel 3709:     if ($url =~  m-^/*(?:uploaded|editupload)/($match_domain)/($match_username)/portfolio(/.+)$-) {
1.765     albertel 3710: 	$type = 1;
                   3711:         $udom = $1;
                   3712:         $unum = $2;
                   3713:         $file_name = $3;
1.823     albertel 3714:     } elsif ($url =~ m-^/*(?:uploaded|editupload)/($match_domain)/($match_courseid)/groups/([^/]+)/portfolio/(.+)$-) {
1.765     albertel 3715: 	$type = 2;
                   3716:         $udom = $1;
                   3717:         $unum = $2;
                   3718:         $group = $3;
                   3719:         $file_name = $3.'/'.$4;
                   3720:     }
                   3721:     if (wantarray) {
                   3722: 	return ($type,$udom,$unum,$file_name,$group);
                   3723:     }
                   3724:     return $type;
                   3725: }
                   3726: 
                   3727: sub is_portfolio_url {
                   3728:     my ($url) = @_;
                   3729:     return scalar(&parse_portfolio_url($url));
                   3730: }
                   3731: 
1.798     raeburn  3732: sub is_portfolio_file {
                   3733:     my ($file) = @_;
1.820     raeburn  3734:     if (($file =~ /^portfolio/) || ($file =~ /^groups\/\w+\/portfolio/)) {
1.798     raeburn  3735:         return 1;
                   3736:     }
                   3737:     return;
                   3738: }
                   3739: 
                   3740: 
1.341     www      3741: # ---------------------------------------------- Custom access rule evaluation
                   3742: 
                   3743: sub customaccess {
                   3744:     my ($priv,$uri)=@_;
1.807     albertel 3745:     my ($urole,$urealm)=split(/\./,$env{'request.role'},2);
1.819     www      3746:     my (undef,$udom,$ucrs,$usec)=split(/\//,$urealm);
1.807     albertel 3747:     $udom = &LONCAPA::clean_domain($udom);
                   3748:     $ucrs = &LONCAPA::clean_username($ucrs);
1.341     www      3749:     my $access=0;
1.800     albertel 3750:     foreach my $right (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) {
                   3751: 	my ($effect,$realm,$role)=split(/\:/,$right);
1.343     www      3752:         if ($role) {
                   3753: 	   if ($role ne $urole) { next; }
                   3754:         }
1.800     albertel 3755:         foreach my $scope (split(/\s*\,\s*/,$realm)) {
                   3756:             my ($tdom,$tcrs,$tsec)=split(/\_/,$scope);
1.343     www      3757:             if ($tdom) {
                   3758: 		if ($tdom ne $udom) { next; }
                   3759:             }
                   3760:             if ($tcrs) {
                   3761: 		if ($tcrs ne $ucrs) { next; }
                   3762:             }
                   3763:             if ($tsec) {
                   3764: 		if ($tsec ne $usec) { next; }
                   3765:             }
                   3766:             $access=($effect eq 'allow');
                   3767:             last;
1.342     www      3768:         }
1.402     bowersj2 3769: 	if ($realm eq '' && $role eq '') {
                   3770:             $access=($effect eq 'allow');
                   3771: 	}
1.341     www      3772:     }
                   3773:     return $access;
                   3774: }
                   3775: 
1.103     harris41 3776: # ------------------------------------------------- Check for a user privilege
1.12      www      3777: 
                   3778: sub allowed {
1.810     raeburn  3779:     my ($priv,$uri,$symb,$role)=@_;
1.705     albertel 3780:     my $ver_orguri=$uri;
1.439     www      3781:     $uri=&deversion($uri);
1.152     www      3782:     my $orguri=$uri;
1.52      www      3783:     $uri=&declutter($uri);
1.809     raeburn  3784: 
1.810     raeburn  3785:     if ($priv eq 'evb') {
                   3786: # Evade communication block restrictions for specified role in a course
                   3787:         if ($env{'user.priv.'.$role} =~/evb\&([^\:]*)/) {
                   3788:             return $1;
                   3789:         } else {
                   3790:             return;
                   3791:         }
                   3792:     }
                   3793: 
1.620     albertel 3794:     if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }
1.54      www      3795: # Free bre access to adm and meta resources
1.775     albertel 3796:     if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard)$})) 
1.769     albertel 3797: 	 || (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) )) 
                   3798: 	&& ($priv eq 'bre')) {
1.14      www      3799: 	return 'F';
1.159     www      3800:     }
                   3801: 
1.545     banghart 3802: # Free bre access to user's own portfolio contents
1.714     raeburn  3803:     my ($space,$domain,$name,@dir)=split('/',$uri);
1.647     raeburn  3804:     if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) && 
1.714     raeburn  3805: 	($env{'user.domain'} eq $domain) && ('portfolio' eq $dir[0])) {
1.814     raeburn  3806:         my %setters;
                   3807:         my ($startblock,$endblock) = 
                   3808:             &Apache::loncommon::blockcheck(\%setters,'port');
                   3809:         if ($startblock && $endblock) {
                   3810:             return 'B';
                   3811:         } else {
                   3812:             return 'F';
                   3813:         }
1.545     banghart 3814:     }
                   3815: 
1.762     raeburn  3816: # bre access to group portfolio for rgf priv in group, or mdg or vcg in course.
1.714     raeburn  3817:     if (($space=~/^(uploaded|editupload)$/) && ($dir[0] eq 'groups') 
                   3818:          && ($dir[2] eq 'portfolio') && ($priv eq 'bre')) {
                   3819:         if (exists($env{'request.course.id'})) {
                   3820:             my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
                   3821:             my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
                   3822:             if (($domain eq $cdom) && ($name eq $cnum)) {
                   3823:                 my $courseprivid=$env{'request.course.id'};
                   3824:                 $courseprivid=~s/\_/\//;
                   3825:                 if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid
                   3826:                     .'/'.$dir[1]} =~/rgf\&([^\:]*)/) {
                   3827:                     return $1; 
1.762     raeburn  3828:                 } else {
                   3829:                     if ($env{'request.course.sec'}) {
                   3830:                         $courseprivid.='/'.$env{'request.course.sec'};
                   3831:                     }
                   3832:                     if ($env{'user.priv.'.$env{'request.role'}.'./'.
                   3833:                         $courseprivid} =~/(mdg|vcg)\&([^\:]*)/) {
                   3834:                         return $2;
                   3835:                     }
1.714     raeburn  3836:                 }
                   3837:             }
                   3838:         }
                   3839:     }
                   3840: 
1.159     www      3841: # Free bre to public access
                   3842: 
                   3843:     if ($priv eq 'bre') {
1.238     www      3844:         my $copyright=&metadata($uri,'copyright');
1.620     albertel 3845: 	if (($copyright eq 'public') && (!$env{'request.course.id'})) { 
1.301     www      3846:            return 'F'; 
                   3847:         }
1.238     www      3848:         if ($copyright eq 'priv') {
                   3849:             $uri=~/([^\/]+)\/([^\/]+)\//;
1.620     albertel 3850: 	    unless (($env{'user.name'} eq $2) && ($env{'user.domain'} eq $1)) {
1.238     www      3851: 		return '';
                   3852:             }
                   3853:         }
                   3854:         if ($copyright eq 'domain') {
                   3855:             $uri=~/([^\/]+)\/([^\/]+)\//;
1.620     albertel 3856: 	    unless (($env{'user.domain'} eq $1) ||
                   3857:                  ($env{'course.'.$env{'request.course.id'}.'.domain'} eq $1)) {
1.238     www      3858: 		return '';
                   3859:             }
1.262     matthew  3860:         }
1.620     albertel 3861:         if ($env{'request.role'}=~ /li\.\//) {
1.262     matthew  3862:             # Library role, so allow browsing of resources in this domain.
                   3863:             return 'F';
1.238     www      3864:         }
1.341     www      3865:         if ($copyright eq 'custom') {
                   3866: 	    unless (&customaccess($priv,$uri)) { return ''; }
                   3867:         }
1.14      www      3868:     }
1.264     matthew  3869:     # Domain coordinator is trying to create a course
1.620     albertel 3870:     if (($priv eq 'ccc') && ($env{'request.role'} =~ /^dc\./)) {
1.264     matthew  3871:         # uri is the requested domain in this case.
                   3872:         # comparison to 'request.role.domain' shows if the user has selected
1.678     raeburn  3873:         # a role of dc for the domain in question.
1.620     albertel 3874:         return 'F' if ($uri eq $env{'request.role.domain'});
1.264     matthew  3875:     }
1.29      www      3876: 
1.52      www      3877:     my $thisallowed='';
                   3878:     my $statecond=0;
                   3879:     my $courseprivid='';
                   3880: 
                   3881: # Course
                   3882: 
1.620     albertel 3883:     if ($env{'user.priv.'.$env{'request.role'}.'./'}=~/\Q$priv\E\&([^\:]*)/) {
1.52      www      3884:        $thisallowed.=$1;
                   3885:     }
1.29      www      3886: 
1.52      www      3887: # Domain
                   3888: 
1.620     albertel 3889:     if ($env{'user.priv.'.$env{'request.role'}.'./'.(split(/\//,$uri))[0].'/'}
1.479     albertel 3890:        =~/\Q$priv\E\&([^\:]*)/) {
1.12      www      3891:        $thisallowed.=$1;
                   3892:     }
1.52      www      3893: 
                   3894: # Course: uri itself is a course
1.66      www      3895:     my $courseuri=$uri;
                   3896:     $courseuri=~s/\_(\d)/\/$1/;
1.83      www      3897:     $courseuri=~s/^([^\/])/\/$1/;
1.81      www      3898: 
1.620     albertel 3899:     if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseuri}
1.479     albertel 3900:        =~/\Q$priv\E\&([^\:]*)/) {
1.12      www      3901:        $thisallowed.=$1;
                   3902:     }
1.29      www      3903: 
1.665     albertel 3904: # URI is an uploaded document for this course, default permissions don't matter
1.611     albertel 3905: # not allowing 'edit' access (editupload) to uploaded course docs
1.492     albertel 3906:     if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) {
1.665     albertel 3907: 	$thisallowed='';
1.671     raeburn  3908:         my ($match)=&is_on_map($uri);
                   3909:         if ($match) {
                   3910:             if ($env{'user.priv.'.$env{'request.role'}.'./'}
                   3911:                   =~/\Q$priv\E\&([^\:]*)/) {
                   3912:                 $thisallowed.=$1;
                   3913:             }
                   3914:         } else {
1.705     albertel 3915:             my $refuri = $env{'httpref.'.$orguri} || $env{'httpref.'.$ver_orguri};
1.671     raeburn  3916:             if ($refuri) {
                   3917:                 if ($refuri =~ m|^/adm/|) {
1.669     raeburn  3918:                     $thisallowed='F';
1.671     raeburn  3919:                 } else {
                   3920:                     $refuri=&declutter($refuri);
                   3921:                     my ($match) = &is_on_map($refuri);
                   3922:                     if ($match) {
                   3923:                         $thisallowed='F';
                   3924:                     }
1.669     raeburn  3925:                 }
1.671     raeburn  3926:             }
                   3927:         }
1.314     www      3928:     }
1.492     albertel 3929: 
1.766     albertel 3930:     if ($priv eq 'bre'
                   3931: 	&& $thisallowed ne 'F' 
                   3932: 	&& $thisallowed ne '2'
                   3933: 	&& &is_portfolio_url($uri)) {
                   3934: 	$thisallowed = &portfolio_access($uri);
                   3935:     }
                   3936:     
1.52      www      3937: # Full access at system, domain or course-wide level? Exit.
1.29      www      3938: 
                   3939:     if ($thisallowed=~/F/) {
                   3940: 	return 'F';
                   3941:     }
                   3942: 
1.52      www      3943: # If this is generating or modifying users, exit with special codes
1.29      www      3944: 
1.643     www      3945:     if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:caa:'=~/\:\Q$priv\E\:/) {
                   3946: 	if (($priv eq 'cca') || ($priv eq 'caa')) {
1.642     albertel 3947: 	    my ($audom,$auname)=split('/',$uri);
1.643     www      3948: # no author name given, so this just checks on the general right to make a co-author in this domain
                   3949: 	    unless ($auname) { return $thisallowed; }
                   3950: # an author name is given, so we are about to actually make a co-author for a certain account
1.642     albertel 3951: 	    if (($auname ne $env{'user.name'} && $env{'request.role'} !~ /^dc\./) ||
                   3952: 		(($audom ne $env{'user.domain'} && $env{'request.role'} !~ /^dc\./) &&
                   3953: 		 ($audom ne $env{'request.role.domain'}))) { return ''; }
                   3954: 	}
1.52      www      3955: 	return $thisallowed;
                   3956:     }
                   3957: #
1.103     harris41 3958: # Gathered so far: system, domain and course wide privileges
1.52      www      3959: #
                   3960: # Course: See if uri or referer is an individual resource that is part of 
                   3961: # the course
                   3962: 
1.620     albertel 3963:     if ($env{'request.course.id'}) {
1.232     www      3964: 
1.620     albertel 3965:        $courseprivid=$env{'request.course.id'};
                   3966:        if ($env{'request.course.sec'}) {
                   3967:           $courseprivid.='/'.$env{'request.course.sec'};
1.52      www      3968:        }
                   3969:        $courseprivid=~s/\_/\//;
                   3970:        my $checkreferer=1;
1.232     www      3971:        my ($match,$cond)=&is_on_map($uri);
                   3972:        if ($match) {
                   3973:            $statecond=$cond;
1.620     albertel 3974:            if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid}
1.479     albertel 3975:                =~/\Q$priv\E\&([^\:]*)/) {
1.52      www      3976:                $thisallowed.=$1;
                   3977:                $checkreferer=0;
                   3978:            }
1.29      www      3979:        }
1.83      www      3980:        
1.148     www      3981:        if ($checkreferer) {
1.620     albertel 3982: 	  my $refuri=$env{'httpref.'.$orguri};
1.148     www      3983:             unless ($refuri) {
1.800     albertel 3984:                 foreach my $key (keys(%env)) {
                   3985: 		    if ($key=~/^httpref\..*\*/) {
                   3986: 			my $pattern=$key;
1.156     www      3987:                         $pattern=~s/^httpref\.\/res\///;
1.148     www      3988:                         $pattern=~s/\*/\[\^\/\]\+/g;
                   3989:                         $pattern=~s/\//\\\//g;
1.152     www      3990:                         if ($orguri=~/$pattern/) {
1.800     albertel 3991: 			    $refuri=$env{$key};
1.148     www      3992:                         }
                   3993:                     }
1.191     harris41 3994:                 }
1.148     www      3995:             }
1.232     www      3996: 
1.148     www      3997:          if ($refuri) { 
1.152     www      3998: 	  $refuri=&declutter($refuri);
1.232     www      3999:           my ($match,$cond)=&is_on_map($refuri);
                   4000:             if ($match) {
                   4001:               my $refstatecond=$cond;
1.620     albertel 4002:               if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid}
1.479     albertel 4003:                   =~/\Q$priv\E\&([^\:]*)/) {
1.52      www      4004:                   $thisallowed.=$1;
1.53      www      4005:                   $uri=$refuri;
                   4006:                   $statecond=$refstatecond;
1.52      www      4007:               }
                   4008:           }
1.148     www      4009:         }
1.29      www      4010:        }
1.52      www      4011:    }
1.29      www      4012: 
1.52      www      4013: #
1.103     harris41 4014: # Gathered now: all privileges that could apply, and condition number
1.52      www      4015: # 
                   4016: #
                   4017: # Full or no access?
                   4018: #
1.29      www      4019: 
1.52      www      4020:     if ($thisallowed=~/F/) {
                   4021: 	return 'F';
                   4022:     }
1.29      www      4023: 
1.52      www      4024:     unless ($thisallowed) {
                   4025:         return '';
                   4026:     }
1.29      www      4027: 
1.52      www      4028: # Restrictions exist, deal with them
                   4029: #
                   4030: #   C:according to course preferences
                   4031: #   R:according to resource settings
                   4032: #   L:unless locked
                   4033: #   X:according to user session state
                   4034: #
                   4035: 
                   4036: # Possibly locked functionality, check all courses
1.54      www      4037: # Locks might take effect only after 10 minutes cache expiration for other
                   4038: # courses, and 2 minutes for current course
1.52      www      4039: 
                   4040:     my $envkey;
                   4041:     if ($thisallowed=~/L/) {
1.620     albertel 4042:         foreach $envkey (keys %env) {
1.54      www      4043:            if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) {
                   4044:                my $courseid=$2;
                   4045:                my $roleid=$1.'.'.$2;
1.92      www      4046:                $courseid=~s/^\///;
1.54      www      4047:                my $expiretime=600;
1.620     albertel 4048:                if ($env{'request.role'} eq $roleid) {
1.54      www      4049: 		  $expiretime=120;
                   4050:                }
                   4051: 	       my ($cdom,$cnum,$csec)=split(/\//,$courseid);
                   4052:                my $prefix='course.'.$cdom.'_'.$cnum.'.';
1.620     albertel 4053:                if ((time-$env{$prefix.'last_cache'})>$expiretime) {
1.731     albertel 4054: 		   &coursedescription($courseid,{'freshen_cache' => 1});
1.54      www      4055:                }
1.620     albertel 4056:                if (($env{$prefix.'res.'.$uri.'.lock.sections'}=~/\,\Q$csec\E\,/)
                   4057:                 || ($env{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) {
                   4058: 		   if ($env{$prefix.'res.'.$uri.'.lock.expire'}>time) {
                   4059:                        &log($env{'user.domain'},$env{'user.name'},
                   4060:                             $env{'user.home'},
1.57      www      4061:                             'Locked by res: '.$priv.' for '.$uri.' due to '.
1.52      www      4062:                             $cdom.'/'.$cnum.'/'.$csec.' expire '.
1.620     albertel 4063:                             $env{$prefix.'priv.'.$priv.'.lock.expire'});
1.52      www      4064: 		       return '';
                   4065:                    }
                   4066:                }
1.620     albertel 4067:                if (($env{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,\Q$csec\E\,/)
                   4068:                 || ($env{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) {
                   4069: 		   if ($env{'priv.'.$priv.'.lock.expire'}>time) {
                   4070:                        &log($env{'user.domain'},$env{'user.name'},
                   4071:                             $env{'user.home'},
1.57      www      4072:                             'Locked by priv: '.$priv.' for '.$uri.' due to '.
1.52      www      4073:                             $cdom.'/'.$cnum.'/'.$csec.' expire '.
1.620     albertel 4074:                             $env{$prefix.'priv.'.$priv.'.lock.expire'});
1.52      www      4075: 		       return '';
                   4076:                    }
                   4077:                }
                   4078: 	   }
1.29      www      4079:        }
1.52      www      4080:     }
                   4081:    
                   4082: #
                   4083: # Rest of the restrictions depend on selected course
                   4084: #
                   4085: 
1.620     albertel 4086:     unless ($env{'request.course.id'}) {
1.766     albertel 4087: 	if ($thisallowed eq 'A') {
                   4088: 	    return 'A';
1.814     raeburn  4089:         } elsif ($thisallowed eq 'B') {
                   4090:             return 'B';
1.766     albertel 4091: 	} else {
                   4092: 	    return '1';
                   4093: 	}
1.52      www      4094:     }
1.29      www      4095: 
1.52      www      4096: #
                   4097: # Now user is definitely in a course
                   4098: #
1.53      www      4099: 
                   4100: 
                   4101: # Course preferences
                   4102: 
                   4103:    if ($thisallowed=~/C/) {
1.620     albertel 4104:        my $rolecode=(split(/\./,$env{'request.role'}))[0];
                   4105:        my $unamedom=$env{'user.name'}.':'.$env{'user.domain'};
                   4106:        if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'}
1.479     albertel 4107: 	   =~/\Q$rolecode\E/) {
1.689     albertel 4108: 	   if ($priv ne 'pch') { 
                   4109: 	       &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
                   4110: 			'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
                   4111: 			$env{'request.course.id'});
                   4112: 	   }
1.237     www      4113:            return '';
                   4114:        }
                   4115: 
1.620     albertel 4116:        if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'}
1.479     albertel 4117: 	   =~/\Q$unamedom\E/) {
1.689     albertel 4118: 	   if ($priv ne 'pch') { 
                   4119: 	       &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.
                   4120: 			'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.
                   4121: 			$env{'request.course.id'});
                   4122: 	   }
1.54      www      4123:            return '';
                   4124:        }
1.53      www      4125:    }
                   4126: 
                   4127: # Resource preferences
                   4128: 
                   4129:    if ($thisallowed=~/R/) {
1.620     albertel 4130:        my $rolecode=(split(/\./,$env{'request.role'}))[0];
1.479     albertel 4131:        if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) {
1.689     albertel 4132: 	   if ($priv ne 'pch') { 
                   4133: 	       &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
                   4134: 			'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
                   4135: 	   }
                   4136: 	   return '';
1.54      www      4137:        }
1.53      www      4138:    }
1.30      www      4139: 
1.246     www      4140: # Restricted by state or randomout?
1.30      www      4141: 
1.52      www      4142:    if ($thisallowed=~/X/) {
1.620     albertel 4143:       if ($env{'acc.randomout'}) {
1.579     albertel 4144: 	 if (!$symb) { $symb=&symbread($uri,1); }
1.620     albertel 4145:          if (($symb) && ($env{'acc.randomout'}=~/\&\Q$symb\E\&/)) { 
1.248     www      4146:             return ''; 
                   4147:          }
1.247     www      4148:       }
                   4149:       if (&condval($statecond)) {
1.52      www      4150: 	 return '2';
                   4151:       } else {
                   4152:          return '';
                   4153:       }
                   4154:    }
1.30      www      4155: 
1.766     albertel 4156:     if ($thisallowed eq 'A') {
                   4157: 	return 'A';
1.814     raeburn  4158:     } elsif ($thisallowed eq 'B') {
                   4159:         return 'B';
1.766     albertel 4160:     }
1.52      www      4161:    return 'F';
1.232     www      4162: }
                   4163: 
1.710     albertel 4164: sub split_uri_for_cond {
                   4165:     my $uri=&deversion(&declutter(shift));
                   4166:     my @uriparts=split(/\//,$uri);
                   4167:     my $filename=pop(@uriparts);
                   4168:     my $pathname=join('/',@uriparts);
                   4169:     return ($pathname,$filename);
                   4170: }
1.232     www      4171: # --------------------------------------------------- Is a resource on the map?
                   4172: 
                   4173: sub is_on_map {
1.710     albertel 4174:     my ($pathname,$filename) = &split_uri_for_cond(shift);
1.289     bowersj2 4175:     #Trying to find the conditional for the file
1.620     albertel 4176:     my $match=($env{'acc.res.'.$env{'request.course.id'}.'.'.$pathname}=~
1.289     bowersj2 4177: 	       /\&\Q$filename\E\:([\d\|]+)\&/);
1.232     www      4178:     if ($match) {
1.289     bowersj2 4179: 	return (1,$1);
                   4180:     } else {
1.434     www      4181: 	return (0,0);
1.289     bowersj2 4182:     }
1.12      www      4183: }
                   4184: 
1.427     www      4185: # --------------------------------------------------------- Get symb from alias
                   4186: 
                   4187: sub get_symb_from_alias {
                   4188:     my $symb=shift;
                   4189:     my ($map,$resid,$url)=&decode_symb($symb);
                   4190: # Already is a symb
                   4191:     if ($url) { return $symb; }
                   4192: # Must be an alias
                   4193:     my $aliassymb='';
                   4194:     my %bighash;
1.620     albertel 4195:     if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
1.427     www      4196:                             &GDBM_READER(),0640)) {
                   4197:         my $rid=$bighash{'mapalias_'.$symb};
                   4198: 	if ($rid) {
                   4199: 	    my ($mapid,$resid)=split(/\./,$rid);
1.429     albertel 4200: 	    $aliassymb=&encode_symb($bighash{'map_id_'.$mapid},
                   4201: 				    $resid,$bighash{'src_'.$rid});
1.427     www      4202: 	}
                   4203:         untie %bighash;
                   4204:     }
                   4205:     return $aliassymb;
                   4206: }
                   4207: 
1.12      www      4208: # ----------------------------------------------------------------- Define Role
                   4209: 
                   4210: sub definerole {
                   4211:   if (allowed('mcr','/')) {
                   4212:     my ($rolename,$sysrole,$domrole,$courole)=@_;
1.800     albertel 4213:     foreach my $role (split(':',$sysrole)) {
                   4214: 	my ($crole,$cqual)=split(/\&/,$role);
1.479     albertel 4215:         if ($pr{'cr:s'}!~/\Q$crole\E/) { return "refused:s:$crole"; }
                   4216:         if ($pr{'cr:s'}=~/\Q$crole\E\&/) {
                   4217: 	    if ($pr{'cr:s'}!~/\Q$crole\E\&\w*\Q$cqual\E/) { 
1.21      www      4218:                return "refused:s:$crole&$cqual"; 
                   4219:             }
                   4220:         }
1.191     harris41 4221:     }
1.800     albertel 4222:     foreach my $role (split(':',$domrole)) {
                   4223: 	my ($crole,$cqual)=split(/\&/,$role);
1.479     albertel 4224:         if ($pr{'cr:d'}!~/\Q$crole\E/) { return "refused:d:$crole"; }
                   4225:         if ($pr{'cr:d'}=~/\Q$crole\E\&/) {
                   4226: 	    if ($pr{'cr:d'}!~/\Q$crole\W\&\w*\Q$cqual\E/) { 
1.21      www      4227:                return "refused:d:$crole&$cqual"; 
                   4228:             }
                   4229:         }
1.191     harris41 4230:     }
1.800     albertel 4231:     foreach my $role (split(':',$courole)) {
                   4232: 	my ($crole,$cqual)=split(/\&/,$role);
1.479     albertel 4233:         if ($pr{'cr:c'}!~/\Q$crole\E/) { return "refused:c:$crole"; }
                   4234:         if ($pr{'cr:c'}=~/\Q$crole\E\&/) {
                   4235: 	    if ($pr{'cr:c'}!~/\Q$crole\E\&\w*\Q$cqual\E/) { 
1.21      www      4236:                return "refused:c:$crole&$cqual"; 
                   4237:             }
                   4238:         }
1.191     harris41 4239:     }
1.620     albertel 4240:     my $command="encrypt:rolesput:$env{'user.domain'}:$env{'user.name'}:".
                   4241:                 "$env{'user.domain'}:$env{'user.name'}:".
1.21      www      4242: 	        "rolesdef_$rolename=".
                   4243:                 escape($sysrole.'_'.$domrole.'_'.$courole);
1.620     albertel 4244:     return reply($command,$env{'user.home'});
1.12      www      4245:   } else {
                   4246:     return 'refused';
                   4247:   }
1.105     harris41 4248: }
                   4249: 
                   4250: # ---------------- Make a metadata query against the network of library servers
                   4251: 
                   4252: sub metadata_query {
1.244     matthew  4253:     my ($query,$custom,$customshow,$server_array)=@_;
1.120     harris41 4254:     my %rhash;
1.845     albertel 4255:     my %libserv = &all_library();
1.244     matthew  4256:     my @server_list = (defined($server_array) ? @$server_array
                   4257:                                               : keys(%libserv) );
                   4258:     for my $server (@server_list) {
1.118     harris41 4259: 	unless ($custom or $customshow) {
                   4260: 	    my $reply=&reply("querysend:".&escape($query),$server);
                   4261: 	    $rhash{$server}=$reply;
                   4262: 	}
                   4263: 	else {
                   4264: 	    my $reply=&reply("querysend:".&escape($query).':'.
                   4265: 			     &escape($custom).':'.&escape($customshow),
                   4266: 			     $server);
                   4267: 	    $rhash{$server}=$reply;
                   4268: 	}
1.112     harris41 4269:     }
1.118     harris41 4270:     return \%rhash;
1.240     www      4271: }
                   4272: 
                   4273: # ----------------------------------------- Send log queries and wait for reply
                   4274: 
                   4275: sub log_query {
                   4276:     my ($uname,$udom,$query,%filters)=@_;
                   4277:     my $uhome=&homeserver($uname,$udom);
                   4278:     if ($uhome eq 'no_host') { return 'error: no_host'; }
1.838     albertel 4279:     my $uhost=&hostname($uhome);
1.800     albertel 4280:     my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys(%filters)));
1.240     www      4281:     my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command,
                   4282:                        $uhome);
1.479     albertel 4283:     unless ($queryid=~/^\Q$uhost\E\_/) { return 'error: '.$queryid; }
1.242     www      4284:     return get_query_reply($queryid);
                   4285: }
                   4286: 
1.818     raeburn  4287: # -------------------------- Update MySQL table for portfolio file
                   4288: 
                   4289: sub update_portfolio_table {
1.821     raeburn  4290:     my ($uname,$udom,$file_name,$query,$group,$action) = @_;
1.818     raeburn  4291:     my $homeserver = &homeserver($uname,$udom);
                   4292:     my $queryid=
1.821     raeburn  4293:         &reply("querysend:".$query.':'.&escape($uname.':'.$udom.':'.$group).
                   4294:                ':'.&escape($file_name).':'.$action,$homeserver);
1.818     raeburn  4295:     my $reply = &get_query_reply($queryid);
                   4296:     return $reply;
                   4297: }
                   4298: 
1.508     raeburn  4299: # ------- Request retrieval of institutional classlists for course(s)
1.506     raeburn  4300: 
                   4301: sub fetch_enrollment_query {
1.511     raeburn  4302:     my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_;
1.508     raeburn  4303:     my $homeserver;
1.547     raeburn  4304:     my $maxtries = 1;
1.508     raeburn  4305:     if ($context eq 'automated') {
                   4306:         $homeserver = $perlvar{'lonHostID'};
1.547     raeburn  4307:         $maxtries = 10; # will wait for up to 2000s for retrieval of classlist data before timeout
1.508     raeburn  4308:     } else {
                   4309:         $homeserver = &homeserver($cnum,$dom);
                   4310:     }
1.838     albertel 4311:     my $host=&hostname($homeserver);
1.506     raeburn  4312:     my $cmd = '';
1.800     albertel 4313:     foreach my $affiliate (keys %{$affiliatesref}) {
                   4314:         $cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';
1.506     raeburn  4315:     }
                   4316:     $cmd =~ s/%%$//;
                   4317:     $cmd = &escape($cmd);
                   4318:     my $query = 'fetchenrollment';
1.620     albertel 4319:     my $queryid=&reply("querysend:".$query.':'.$dom.':'.$env{'user.name'}.':'.$cmd,$homeserver);
1.526     raeburn  4320:     unless ($queryid=~/^\Q$host\E\_/) { 
                   4321:         &logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum); 
                   4322:         return 'error: '.$queryid;
                   4323:     }
1.506     raeburn  4324:     my $reply = &get_query_reply($queryid);
1.547     raeburn  4325:     my $tries = 1;
                   4326:     while (($reply=~/^timeout/) && ($tries < $maxtries)) {
                   4327:         $reply = &get_query_reply($queryid);
                   4328:         $tries ++;
                   4329:     }
1.526     raeburn  4330:     if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
1.620     albertel 4331:         &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);
1.526     raeburn  4332:     } else {
1.515     raeburn  4333:         my @responses = split/:/,$reply;
                   4334:         if ($homeserver eq $perlvar{'lonHostID'}) {
1.800     albertel 4335:             foreach my $line (@responses) {
                   4336:                 my ($key,$value) = split(/=/,$line,2);
1.515     raeburn  4337:                 $$replyref{$key} = $value;
                   4338:             }
                   4339:         } else {
1.506     raeburn  4340:             my $pathname = $perlvar{'lonDaemons'}.'/tmp';
1.800     albertel 4341:             foreach my $line (@responses) {
                   4342:                 my ($key,$value) = split(/=/,$line);
1.506     raeburn  4343:                 $$replyref{$key} = $value;
                   4344:                 if ($value > 0) {
1.800     albertel 4345:                     foreach my $item (@{$$affiliatesref{$key}}) {
                   4346:                         my $filename = $dom.'_'.$key.'_'.$item.'_classlist.xml';
1.506     raeburn  4347:                         my $destname = $pathname.'/'.$filename;
                   4348:                         my $xml_classlist = &reply("autoretrieve:".$filename,$homeserver);
1.526     raeburn  4349:                         if ($xml_classlist =~ /^error/) {
                   4350:                             &logthis('fetch_enrollment_query - autoretrieve error: '.$xml_classlist.' for '.$filename.' from server: '.$homeserver.' '.$context.' '.$cnum);
                   4351:                         } else {
1.506     raeburn  4352:                             if ( open(FILE,">$destname") ) {
                   4353:                                 print FILE &unescape($xml_classlist);
                   4354:                                 close(FILE);
1.526     raeburn  4355:                             } else {
                   4356:                                 &logthis('fetch_enrollment_query - error opening classlist file '.$destname.' '.$context.' '.$cnum);
1.506     raeburn  4357:                             }
                   4358:                         }
                   4359:                     }
                   4360:                 }
                   4361:             }
                   4362:         }
                   4363:         return 'ok';
                   4364:     }
                   4365:     return 'error';
                   4366: }
                   4367: 
1.242     www      4368: sub get_query_reply {
                   4369:     my $queryid=shift;
1.240     www      4370:     my $replyfile=$perlvar{'lonDaemons'}.'/tmp/'.$queryid;
                   4371:     my $reply='';
                   4372:     for (1..100) {
                   4373: 	sleep 2;
                   4374:         if (-e $replyfile.'.end') {
1.448     albertel 4375: 	    if (open(my $fh,$replyfile)) {
1.240     www      4376:                $reply.=<$fh>;
1.448     albertel 4377:                close($fh);
1.240     www      4378: 	   } else { return 'error: reply_file_error'; }
1.242     www      4379:            return &unescape($reply);
                   4380: 	}
1.240     www      4381:     }
1.242     www      4382:     return 'timeout:'.$queryid;
1.240     www      4383: }
                   4384: 
                   4385: sub courselog_query {
1.241     www      4386: #
                   4387: # possible filters:
                   4388: # url: url or symb
                   4389: # username
                   4390: # domain
                   4391: # action: view, submit, grade
                   4392: # start: timestamp
                   4393: # end: timestamp
                   4394: #
1.240     www      4395:     my (%filters)=@_;
1.620     albertel 4396:     unless ($env{'request.course.id'}) { return 'no_course'; }
1.241     www      4397:     if ($filters{'url'}) {
                   4398: 	$filters{'url'}=&symbclean(&declutter($filters{'url'}));
                   4399:         $filters{'url'}=~s/\.(\w+)$/(\\.\\d+)*\\.$1/;
                   4400:         $filters{'url'}=~s/\.(\w+)\_\_\_/(\\.\\d+)*\\.$1/;
                   4401:     }
1.620     albertel 4402:     my $cname=$env{'course.'.$env{'request.course.id'}.'.num'};
                   4403:     my $cdom=$env{'course.'.$env{'request.course.id'}.'.domain'};
1.240     www      4404:     return &log_query($cname,$cdom,'courselog',%filters);
                   4405: }
                   4406: 
                   4407: sub userlog_query {
1.858     raeburn  4408: #
                   4409: # possible filters:
                   4410: # action: log check role
                   4411: # start: timestamp
                   4412: # end: timestamp
                   4413: #
1.240     www      4414:     my ($uname,$udom,%filters)=@_;
                   4415:     return &log_query($uname,$udom,'userlog',%filters);
1.12      www      4416: }
                   4417: 
1.506     raeburn  4418: #--------- Call auto-enrollment subs in localenroll.pm for homeserver for course 
                   4419: 
                   4420: sub auto_run {
1.508     raeburn  4421:     my ($cnum,$cdom) = @_;
                   4422:     my $homeserver = &homeserver($cnum,$cdom);
1.511     raeburn  4423:     my $response = &reply('autorun:'.$cdom,$homeserver);
1.506     raeburn  4424:     return $response;
                   4425: }
1.776     albertel 4426: 
1.506     raeburn  4427: sub auto_get_sections {
1.508     raeburn  4428:     my ($cnum,$cdom,$inst_coursecode) = @_;
                   4429:     my $homeserver = &homeserver($cnum,$cdom);
1.506     raeburn  4430:     my @secs = ();
1.511     raeburn  4431:     my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver));
1.506     raeburn  4432:     unless ($response eq 'refused') {
                   4433:         @secs = split/:/,$response;
                   4434:     }
                   4435:     return @secs;
                   4436: }
1.776     albertel 4437: 
1.506     raeburn  4438: sub auto_new_course {
1.508     raeburn  4439:     my ($cnum,$cdom,$inst_course_id,$owner) = @_;
                   4440:     my $homeserver = &homeserver($cnum,$cdom);
1.515     raeburn  4441:     my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.$owner.':'.$cdom,$homeserver));
1.506     raeburn  4442:     return $response;
                   4443: }
1.776     albertel 4444: 
1.506     raeburn  4445: sub auto_validate_courseID {
1.508     raeburn  4446:     my ($cnum,$cdom,$inst_course_id) = @_;
                   4447:     my $homeserver = &homeserver($cnum,$cdom);
1.511     raeburn  4448:     my $response=&unescape(&reply('autovalidatecourse:'.$inst_course_id.':'.$cdom,$homeserver));
1.506     raeburn  4449:     return $response;
                   4450: }
1.776     albertel 4451: 
1.506     raeburn  4452: sub auto_create_password {
1.508     raeburn  4453:     my ($cnum,$cdom,$authparam) = @_;
                   4454:     my $homeserver = &homeserver($cnum,$cdom); 
1.506     raeburn  4455:     my $create_passwd = 0;
                   4456:     my $authchk = '';
1.511     raeburn  4457:     my $response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver));
1.506     raeburn  4458:     if ($response eq 'refused') {
                   4459:         $authchk = 'refused';
                   4460:     } else {
                   4461:         ($authparam,$create_passwd,$authchk) = split/:/,$response;
                   4462:     }
                   4463:     return ($authparam,$create_passwd,$authchk);
                   4464: }
                   4465: 
1.706     raeburn  4466: sub auto_photo_permission {
                   4467:     my ($cnum,$cdom,$students) = @_;
                   4468:     my $homeserver = &homeserver($cnum,$cdom);
1.707     albertel 4469:     my ($outcome,$perm_reqd,$conditions) = 
                   4470: 	split(/:/,&unescape(&reply('autophotopermission:'.$cdom,$homeserver)),3);
1.709     albertel 4471:     if ($outcome =~ /^(con_lost|unknown_cmd|no_such_host)$/) {
                   4472: 	return (undef,undef);
                   4473:     }
1.706     raeburn  4474:     return ($outcome,$perm_reqd,$conditions);
                   4475: }
                   4476: 
                   4477: sub auto_checkphotos {
                   4478:     my ($uname,$udom,$pid) = @_;
                   4479:     my $homeserver = &homeserver($uname,$udom);
                   4480:     my ($result,$resulttype);
                   4481:     my $outcome = &unescape(&reply('autophotocheck:'.&escape($udom).':'.
1.707     albertel 4482: 				   &escape($uname).':'.&escape($pid),
                   4483: 				   $homeserver));
1.709     albertel 4484:     if ($outcome =~ /^(con_lost|unknown_cmd|no_such_host)$/) {
                   4485: 	return (undef,undef);
                   4486:     }
1.706     raeburn  4487:     if ($outcome) {
                   4488:         ($result,$resulttype) = split(/:/,$outcome);
                   4489:     } 
                   4490:     return ($result,$resulttype);
                   4491: }
                   4492: 
                   4493: sub auto_photochoice {
                   4494:     my ($cnum,$cdom) = @_;
                   4495:     my $homeserver = &homeserver($cnum,$cdom);
                   4496:     my ($update,$comment) = split(/:/,&unescape(&reply('autophotochoice:'.
1.707     albertel 4497: 						       &escape($cdom),
                   4498: 						       $homeserver)));
1.709     albertel 4499:     if ($update =~ /^(con_lost|unknown_cmd|no_such_host)$/) {
                   4500: 	return (undef,undef);
                   4501:     }
1.706     raeburn  4502:     return ($update,$comment);
                   4503: }
                   4504: 
                   4505: sub auto_photoupdate {
                   4506:     my ($affiliatesref,$dom,$cnum,$photo) = @_;
                   4507:     my $homeserver = &homeserver($cnum,$dom);
1.838     albertel 4508:     my $host=&hostname($homeserver);
1.706     raeburn  4509:     my $cmd = '';
                   4510:     my $maxtries = 1;
1.800     albertel 4511:     foreach my $affiliate (keys(%{$affiliatesref})) {
                   4512:         $cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';
1.706     raeburn  4513:     }
                   4514:     $cmd =~ s/%%$//;
                   4515:     $cmd = &escape($cmd);
                   4516:     my $query = 'institutionalphotos';
                   4517:     my $queryid=&reply("querysend:".$query.':'.$dom.':'.$cnum.':'.$cmd,$homeserver);
                   4518:     unless ($queryid=~/^\Q$host\E\_/) {
                   4519:         &logthis('institutionalphotos: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' and course: '.$cnum);
                   4520:         return 'error: '.$queryid;
                   4521:     }
                   4522:     my $reply = &get_query_reply($queryid);
                   4523:     my $tries = 1;
                   4524:     while (($reply=~/^timeout/) && ($tries < $maxtries)) {
                   4525:         $reply = &get_query_reply($queryid);
                   4526:         $tries ++;
                   4527:     }
                   4528:     if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
                   4529:         &logthis('institutionalphotos error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' course: '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);
                   4530:     } else {
                   4531:         my @responses = split(/:/,$reply);
                   4532:         my $outcome = shift(@responses); 
                   4533:         foreach my $item (@responses) {
                   4534:             my ($key,$value) = split(/=/,$item);
                   4535:             $$photo{$key} = $value;
                   4536:         }
                   4537:         return $outcome;
                   4538:     }
                   4539:     return 'error';
                   4540: }
                   4541: 
1.521     raeburn  4542: sub auto_instcode_format {
1.793     albertel 4543:     my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,
                   4544: 	$cat_order) = @_;
1.521     raeburn  4545:     my $courses = '';
1.772     raeburn  4546:     my @homeservers;
1.521     raeburn  4547:     if ($caller eq 'global') {
1.841     albertel 4548: 	my %servers = &get_servers($codedom,'library');
                   4549: 	foreach my $tryserver (keys(%servers)) {
                   4550: 	    if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
                   4551: 		push(@homeservers,$tryserver);
                   4552: 	    }
1.584     raeburn  4553:         }
1.521     raeburn  4554:     } else {
1.772     raeburn  4555:         push(@homeservers,&homeserver($caller,$codedom));
1.521     raeburn  4556:     }
1.793     albertel 4557:     foreach my $code (keys(%{$instcodes})) {
                   4558:         $courses .= &escape($code).'='.&escape($$instcodes{$code}).'&';
1.521     raeburn  4559:     }
                   4560:     chop($courses);
1.772     raeburn  4561:     my $ok_response = 0;
                   4562:     my $response;
                   4563:     while (@homeservers > 0 && $ok_response == 0) {
                   4564:         my $server = shift(@homeservers); 
                   4565:         $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$server);
                   4566:         if ($response !~ /(con_lost|error|no_such_host|refused)/) {
                   4567:             my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = 
1.793     albertel 4568: 		split/:/,$response;
1.772     raeburn  4569:             %{$codes} = (%{$codes},&str2hash($codes_str));
                   4570:             push(@{$codetitles},&str2array($codetitles_str));
                   4571:             %{$cat_titles} = (%{$cat_titles},&str2hash($cat_titles_str));
                   4572:             %{$cat_order} = (%{$cat_order},&str2hash($cat_order_str));
                   4573:             $ok_response = 1;
                   4574:         }
                   4575:     }
                   4576:     if ($ok_response) {
1.521     raeburn  4577:         return 'ok';
1.772     raeburn  4578:     } else {
                   4579:         return $response;
1.521     raeburn  4580:     }
                   4581: }
                   4582: 
1.792     raeburn  4583: sub auto_instcode_defaults {
                   4584:     my ($domain,$returnhash,$code_order) = @_;
                   4585:     my @homeservers;
1.841     albertel 4586: 
                   4587:     my %servers = &get_servers($domain,'library');
                   4588:     foreach my $tryserver (keys(%servers)) {
                   4589: 	if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
                   4590: 	    push(@homeservers,$tryserver);
                   4591: 	}
1.792     raeburn  4592:     }
1.841     albertel 4593: 
1.792     raeburn  4594:     my $response;
1.841     albertel 4595:     foreach my $server (@homeservers) {
1.792     raeburn  4596:         $response=&reply('autoinstcodedefaults:'.$domain,$server);
1.841     albertel 4597:         next if ($response =~ /(con_lost|error|no_such_host|refused)/);
                   4598: 	
                   4599: 	foreach my $pair (split(/\&/,$response)) {
                   4600: 	    my ($name,$value)=split(/\=/,$pair);
                   4601: 	    if ($name eq 'code_order') {
                   4602: 		@{$code_order} = split(/\&/,&unescape($value));
                   4603: 	    } else {
                   4604: 		$returnhash->{&unescape($name)}=&unescape($value);
                   4605: 	    }
                   4606: 	}
                   4607: 	return 'ok';
1.792     raeburn  4608:     }
1.841     albertel 4609: 
                   4610:     return $response;
1.792     raeburn  4611: } 
                   4612: 
1.777     albertel 4613: sub auto_validate_class_sec {
1.773     raeburn  4614:     my ($cdom,$cnum,$owner,$inst_class) = @_;
                   4615:     my $homeserver = &homeserver($cnum,$cdom);
                   4616:     my $response=&reply('autovalidateclass_sec:'.$inst_class.':'.
1.774     banghart 4617:                         &escape($owner).':'.$cdom,$homeserver);
1.773     raeburn  4618:     return $response;
                   4619: }
                   4620: 
1.679     raeburn  4621: # ------------------------------------------------------- Course Group routines
                   4622: 
                   4623: sub get_coursegroups {
1.809     raeburn  4624:     my ($cdom,$cnum,$group,$namespace) = @_;
                   4625:     return(&dump($namespace,$cdom,$cnum,$group));
1.805     raeburn  4626: }
                   4627: 
1.679     raeburn  4628: sub modify_coursegroup {
                   4629:     my ($cdom,$cnum,$groupsettings) = @_;
                   4630:     return(&put('coursegroups',$groupsettings,$cdom,$cnum));
                   4631: }
                   4632: 
1.809     raeburn  4633: sub toggle_coursegroup_status {
                   4634:     my ($cdom,$cnum,$group,$action) = @_;
                   4635:     my ($from_namespace,$to_namespace);
                   4636:     if ($action eq 'delete') {
                   4637:         $from_namespace = 'coursegroups';
                   4638:         $to_namespace = 'deleted_groups';
                   4639:     } else {
                   4640:         $from_namespace = 'deleted_groups';
                   4641:         $to_namespace = 'coursegroups';
                   4642:     }
                   4643:     my %curr_group = &get_coursegroups($cdom,$cnum,$group,$from_namespace);
1.805     raeburn  4644:     if (my $tmp = &error(%curr_group)) {
                   4645:         &Apache::lonnet::logthis('Error retrieving group: '.$tmp.' in '.$cnum.':'.$cdom);
                   4646:         return ('read error',$tmp);
                   4647:     } else {
                   4648:         my %savedsettings = %curr_group; 
1.809     raeburn  4649:         my $result = &put($to_namespace,\%savedsettings,$cdom,$cnum);
1.805     raeburn  4650:         my $deloutcome;
                   4651:         if ($result eq 'ok') {
1.809     raeburn  4652:             $deloutcome = &del($from_namespace,[$group],$cdom,$cnum);
1.805     raeburn  4653:         } else {
                   4654:             return ('write error',$result);
                   4655:         }
                   4656:         if ($deloutcome eq 'ok') {
                   4657:             return 'ok';
                   4658:         } else {
                   4659:             return ('delete error',$deloutcome);
                   4660:         }
                   4661:     }
                   4662: }
                   4663: 
1.679     raeburn  4664: sub modify_group_roles {
                   4665:     my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs) = @_;
                   4666:     my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id;
                   4667:     my $role = 'gr/'.&escape($userprivs);
                   4668:     my ($uname,$udom) = split(/:/,$user);
                   4669:     my $result = &assignrole($udom,$uname,$url,$role,$end,$start);
1.684     raeburn  4670:     if ($result eq 'ok') {
                   4671:         &devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);
                   4672:     }
1.679     raeburn  4673:     return $result;
                   4674: }
                   4675: 
                   4676: sub modify_coursegroup_membership {
                   4677:     my ($cdom,$cnum,$membership) = @_;
                   4678:     my $result = &put('groupmembership',$membership,$cdom,$cnum);
                   4679:     return $result;
                   4680: }
                   4681: 
1.682     raeburn  4682: sub get_active_groups {
                   4683:     my ($udom,$uname,$cdom,$cnum) = @_;
                   4684:     my $now = time;
                   4685:     my %groups = ();
                   4686:     foreach my $key (keys(%env)) {
1.811     albertel 4687:         if ($key =~ m-user\.role\.gr\./($match_domain)/($match_courseid)/(\w+)$-) {
1.682     raeburn  4688:             my ($start,$end) = split(/\./,$env{$key});
                   4689:             if (($end!=0) && ($end<$now)) { next; }
                   4690:             if (($start!=0) && ($start>$now)) { next; }
                   4691:             if ($1 eq $cdom && $2 eq $cnum) {
                   4692:                 $groups{$3} = $env{$key} ;
                   4693:             }
                   4694:         }
                   4695:     }
                   4696:     return %groups;
                   4697: }
                   4698: 
1.683     raeburn  4699: sub get_group_membership {
                   4700:     my ($cdom,$cnum,$group) = @_;
                   4701:     return(&dump('groupmembership',$cdom,$cnum,$group));
                   4702: }
                   4703: 
                   4704: sub get_users_groups {
                   4705:     my ($udom,$uname,$courseid) = @_;
1.733     raeburn  4706:     my @usersgroups;
1.683     raeburn  4707:     my $cachetime=1800;
                   4708: 
                   4709:     my $hashid="$udom:$uname:$courseid";
1.733     raeburn  4710:     my ($grouplist,$cached)=&is_cached_new('getgroups',$hashid);
                   4711:     if (defined($cached)) {
1.734     albertel 4712:         @usersgroups = split(/:/,$grouplist);
1.733     raeburn  4713:     } else {  
                   4714:         $grouplist = '';
1.816     raeburn  4715:         my $courseurl = &courseid_to_courseurl($courseid);
                   4716:         my %roleshash = &dump('roles',$udom,$uname,$courseurl);
1.817     raeburn  4717:         my $access_end = $env{'course.'.$courseid.
                   4718:                               '.default_enrollment_end_date'};
                   4719:         my $now = time;
                   4720:         foreach my $key (keys(%roleshash)) {
                   4721:             if ($key =~ /^\Q$courseurl\E\/(\w+)\_gr$/) {
                   4722:                 my $group = $1;
                   4723:                 if ($roleshash{$key} =~ /_(\d+)_(\d+)$/) {
                   4724:                     my $start = $2;
                   4725:                     my $end = $1;
                   4726:                     if ($start == -1) { next; } # deleted from group
                   4727:                     if (($start!=0) && ($start>$now)) { next; }
                   4728:                     if (($end!=0) && ($end<$now)) {
                   4729:                         if ($access_end && $access_end < $now) {
                   4730:                             if ($access_end - $end < 86400) {
                   4731:                                 push(@usersgroups,$group);
1.733     raeburn  4732:                             }
                   4733:                         }
1.817     raeburn  4734:                         next;
1.733     raeburn  4735:                     }
1.817     raeburn  4736:                     push(@usersgroups,$group);
1.683     raeburn  4737:                 }
                   4738:             }
                   4739:         }
1.817     raeburn  4740:         @usersgroups = &sort_course_groups($courseid,@usersgroups);
                   4741:         $grouplist = join(':',@usersgroups);
                   4742:         &do_cache_new('getgroups',$hashid,$grouplist,$cachetime);
1.683     raeburn  4743:     }
1.733     raeburn  4744:     return @usersgroups;
1.683     raeburn  4745: }
                   4746: 
                   4747: sub devalidate_getgroups_cache {
                   4748:     my ($udom,$uname,$cdom,$cnum)=@_;
                   4749:     my $courseid = $cdom.'_'.$cnum;
1.807     albertel 4750: 
1.683     raeburn  4751:     my $hashid="$udom:$uname:$courseid";
                   4752:     &devalidate_cache_new('getgroups',$hashid);
                   4753: }
                   4754: 
1.12      www      4755: # ------------------------------------------------------------------ Plain Text
                   4756: 
                   4757: sub plaintext {
1.742     raeburn  4758:     my ($short,$type,$cid) = @_;
1.758     albertel 4759:     if ($short =~ /^cr/) {
                   4760: 	return (split('/',$short))[-1];
                   4761:     }
1.742     raeburn  4762:     if (!defined($cid)) {
                   4763:         $cid = $env{'request.course.id'};
                   4764:     }
                   4765:     if (defined($cid) && defined($env{'course.'.$cid.'.'.$short.'.plaintext'})) {
                   4766:         return &Apache::lonlocal::mt($env{'course.'.$cid.'.'.$short.
                   4767:                                           '.plaintext'});
                   4768:     }
                   4769:     my %rolenames = (
                   4770:                       Course => 'std',
                   4771:                       Group => 'alt1',
                   4772:                     );
                   4773:     if (defined($type) && 
                   4774:          defined($rolenames{$type}) && 
                   4775:          defined($prp{$short}{$rolenames{$type}})) {
                   4776:         return &Apache::lonlocal::mt($prp{$short}{$rolenames{$type}});
                   4777:     } else {
                   4778:         return &Apache::lonlocal::mt($prp{$short}{'std'});
                   4779:     }
1.12      www      4780: }
                   4781: 
                   4782: # ----------------------------------------------------------------- Assign Role
                   4783: 
                   4784: sub assignrole {
1.357     www      4785:     my ($udom,$uname,$url,$role,$end,$start,$deleteflag)=@_;
1.21      www      4786:     my $mrole;
                   4787:     if ($role =~ /^cr\//) {
1.393     www      4788:         my $cwosec=$url;
1.811     albertel 4789:         $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
1.393     www      4790: 	unless (&allowed('ccr',$cwosec)) {
1.104     www      4791:            &logthis('Refused custom assignrole: '.
                   4792:              $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
1.620     albertel 4793: 		    $env{'user.name'}.' at '.$env{'user.domain'});
1.104     www      4794:            return 'refused'; 
                   4795:         }
1.21      www      4796:         $mrole='cr';
1.678     raeburn  4797:     } elsif ($role =~ /^gr\//) {
                   4798:         my $cwogrp=$url;
1.811     albertel 4799:         $cwogrp=~s{^/($match_domain)/($match_courseid)/.*}{$1/$2};
1.678     raeburn  4800:         unless (&allowed('mdg',$cwogrp)) {
                   4801:             &logthis('Refused group assignrole: '.
                   4802:               $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
                   4803:                     $env{'user.name'}.' at '.$env{'user.domain'});
                   4804:             return 'refused';
                   4805:         }
                   4806:         $mrole='gr';
1.21      www      4807:     } else {
1.82      www      4808:         my $cwosec=$url;
1.811     albertel 4809:         $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
1.373     www      4810:         unless ((&allowed('c'.$role,$cwosec)) || &allowed('c'.$role,$udom)) { 
1.104     www      4811:            &logthis('Refused assignrole: '.
                   4812:              $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
1.620     albertel 4813: 		    $env{'user.name'}.' at '.$env{'user.domain'});
1.104     www      4814:            return 'refused'; 
                   4815:         }
1.21      www      4816:         $mrole=$role;
                   4817:     }
1.620     albertel 4818:     my $command="encrypt:rolesput:$env{'user.domain'}:$env{'user.name'}:".
1.21      www      4819:                 "$udom:$uname:$url".'_'."$mrole=$role";
1.81      www      4820:     if ($end) { $command.='_'.$end; }
1.21      www      4821:     if ($start) {
                   4822: 	if ($end) { 
1.81      www      4823:            $command.='_'.$start; 
1.21      www      4824:         } else {
1.81      www      4825:            $command.='_0_'.$start;
1.21      www      4826:         }
                   4827:     }
1.739     raeburn  4828:     my $origstart = $start;
                   4829:     my $origend = $end;
1.357     www      4830: # actually delete
                   4831:     if ($deleteflag) {
1.373     www      4832: 	if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) {
1.357     www      4833: # modify command to delete the role
1.620     albertel 4834:            $command="encrypt:rolesdel:$env{'user.domain'}:$env{'user.name'}:".
1.357     www      4835:                 "$udom:$uname:$url".'_'."$mrole";
1.620     albertel 4836: 	   &logthis("$env{'user.name'} at $env{'user.domain'} deletes $mrole in $url for $uname at $udom"); 
1.357     www      4837: # set start and finish to negative values for userrolelog
                   4838:            $start=-1;
                   4839:            $end=-1;
                   4840:         }
                   4841:     }
                   4842: # send command
1.349     www      4843:     my $answer=&reply($command,&homeserver($uname,$udom));
1.357     www      4844: # log new user role if status is ok
1.349     www      4845:     if ($answer eq 'ok') {
1.663     raeburn  4846: 	&userrolelog($role,$uname,$udom,$url,$start,$end);
1.739     raeburn  4847: # for course roles, perform group memberships changes triggered by role change.
                   4848:         unless ($role =~ /^gr/) {
                   4849:             &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend,
                   4850:                                              $origstart);
                   4851:         }
1.349     www      4852:     }
                   4853:     return $answer;
1.169     harris41 4854: }
                   4855: 
                   4856: # -------------------------------------------------- Modify user authentication
1.197     www      4857: # Overrides without validation
                   4858: 
1.169     harris41 4859: sub modifyuserauth {
                   4860:     my ($udom,$uname,$umode,$upass)=@_;
                   4861:     my $uhome=&homeserver($uname,$udom);
1.197     www      4862:     unless (&allowed('mau',$udom)) { return 'refused'; }
                   4863:     &logthis('Call to modify user authentication '.$udom.', '.$uname.', '.
1.620     albertel 4864:              $umode.' by '.$env{'user.name'}.' at '.$env{'user.domain'}.
                   4865:              ' in domain '.$env{'request.role.domain'});  
1.169     harris41 4866:     my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'.
                   4867: 		     &escape($upass),$uhome);
1.620     albertel 4868:     &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},
1.197     www      4869:         'Authentication changed for '.$udom.', '.$uname.', '.$umode.
                   4870:          '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply);
                   4871:     &log($udom,,$uname,$uhome,
1.620     albertel 4872:         'Authentication changed by '.$env{'user.domain'}.', '.
                   4873:                                      $env{'user.name'}.', '.$umode.
1.197     www      4874:          '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply);
1.169     harris41 4875:     unless ($reply eq 'ok') {
1.197     www      4876:         &logthis('Authentication mode error: '.$reply);
1.169     harris41 4877: 	return 'error: '.$reply;
                   4878:     }   
1.170     harris41 4879:     return 'ok';
1.80      www      4880: }
                   4881: 
1.81      www      4882: # --------------------------------------------------------------- Modify a user
1.80      www      4883: 
1.81      www      4884: sub modifyuser {
1.206     matthew  4885:     my ($udom,    $uname, $uid,
                   4886:         $umode,   $upass, $first,
                   4887:         $middle,  $last,  $gene,
1.387     www      4888:         $forceid, $desiredhome, $email)=@_;
1.807     albertel 4889:     $udom= &LONCAPA::clean_domain($udom);
                   4890:     $uname=&LONCAPA::clean_username($uname);
1.81      www      4891:     &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
1.80      www      4892:              $umode.', '.$first.', '.$middle.', '.
1.206     matthew  4893: 	     $last.', '.$gene.'(forceid: '.$forceid.')'.
                   4894:              (defined($desiredhome) ? ' desiredhome = '.$desiredhome :
                   4895:                                      ' desiredhome not specified'). 
1.620     albertel 4896:              ' by '.$env{'user.name'}.' at '.$env{'user.domain'}.
                   4897:              ' in domain '.$env{'request.role.domain'});
1.230     stredwic 4898:     my $uhome=&homeserver($uname,$udom,'true');
1.80      www      4899: # ----------------------------------------------------------------- Create User
1.406     albertel 4900:     if (($uhome eq 'no_host') && 
                   4901: 	(($umode && $upass) || ($umode eq 'localauth'))) {
1.80      www      4902:         my $unhome='';
1.844     albertel 4903:         if (defined($desiredhome) && &host_domain($desiredhome) eq $udom) { 
1.209     matthew  4904:             $unhome = $desiredhome;
1.620     albertel 4905: 	} elsif($env{'course.'.$env{'request.course.id'}.'.domain'} eq $udom) {
                   4906: 	    $unhome=$env{'course.'.$env{'request.course.id'}.'.home'};
1.209     matthew  4907:         } else { # load balancing routine for determining $unhome
1.81      www      4908:             my $loadm=10000000;
1.841     albertel 4909: 	    my %servers = &get_servers($udom,'library');
                   4910: 	    foreach my $tryserver (keys(%servers)) {
                   4911: 		my $answer=reply('load',$tryserver);
                   4912: 		if (($answer=~/\d+/) && ($answer<$loadm)) {
                   4913: 		    $loadm=$answer;
                   4914: 		    $unhome=$tryserver;
                   4915: 		}
1.80      www      4916: 	    }
                   4917:         }
                   4918:         if (($unhome eq '') || ($unhome eq 'no_host')) {
1.206     matthew  4919: 	    return 'error: unable to find a home server for '.$uname.
                   4920:                    ' in domain '.$udom;
1.80      www      4921:         }
                   4922:         my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':'.$umode.':'.
                   4923:                          &escape($upass),$unhome);
                   4924: 	unless ($reply eq 'ok') {
                   4925:             return 'error: '.$reply;
                   4926:         }   
1.230     stredwic 4927:         $uhome=&homeserver($uname,$udom,'true');
1.80      www      4928:         if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) {
1.386     matthew  4929: 	    return 'error: unable verify users home machine.';
1.80      www      4930:         }
1.209     matthew  4931:     }   # End of creation of new user
1.80      www      4932: # ---------------------------------------------------------------------- Add ID
                   4933:     if ($uid) {
                   4934:        $uid=~tr/A-Z/a-z/;
                   4935:        my %uidhash=&idrget($udom,$uname);
1.196     www      4936:        if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/) 
                   4937:          && (!$forceid)) {
1.80      www      4938: 	  unless ($uid eq $uidhash{$uname}) {
1.386     matthew  4939: 	      return 'error: user id "'.$uid.'" does not match '.
                   4940:                   'current user id "'.$uidhash{$uname}.'".';
1.80      www      4941:           }
                   4942:        } else {
                   4943: 	  &idput($udom,($uname => $uid));
                   4944:        }
                   4945:     }
                   4946: # -------------------------------------------------------------- Add names, etc
1.313     matthew  4947:     my @tmp=&get('environment',
1.134     albertel 4948: 		   ['firstname','middlename','lastname','generation'],
                   4949: 		   $udom,$uname);
1.313     matthew  4950:     my %names;
                   4951:     if ($tmp[0] =~ m/^error:.*/) { 
                   4952:         %names=(); 
                   4953:     } else {
                   4954:         %names = @tmp;
                   4955:     }
1.388     www      4956: #
                   4957: # Make sure to not trash student environment if instructor does not bother
                   4958: # to supply name and email information
                   4959: #
                   4960:     if ($first)  { $names{'firstname'}  = $first; }
1.385     matthew  4961:     if (defined($middle)) { $names{'middlename'} = $middle; }
1.388     www      4962:     if ($last)   { $names{'lastname'}   = $last; }
1.385     matthew  4963:     if (defined($gene))   { $names{'generation'} = $gene; }
1.592     www      4964:     if ($email) {
                   4965:        $email=~s/[^\w\@\.\-\,]//gs;
                   4966:        if ($email=~/\@/) { $names{'notification'} = $email;
                   4967: 			   $names{'critnotification'} = $email;
                   4968: 			   $names{'permanentemail'} = $email; }
                   4969:     }
1.134     albertel 4970:     my $reply = &put('environment', \%names, $udom,$uname);
                   4971:     if ($reply ne 'ok') { return 'error: '.$reply; }
1.680     www      4972:     &devalidate_cache_new('namescache',$uname.':'.$udom);
1.81      www      4973:     &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
1.80      www      4974:              $umode.', '.$first.', '.$middle.', '.
                   4975: 	     $last.', '.$gene.' by '.
1.620     albertel 4976:              $env{'user.name'}.' at '.$env{'user.domain'});
1.134     albertel 4977:     return 'ok';
1.80      www      4978: }
                   4979: 
1.81      www      4980: # -------------------------------------------------------------- Modify student
1.80      www      4981: 
1.81      www      4982: sub modifystudent {
                   4983:     my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
1.515     raeburn  4984:         $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid)=@_;
1.455     albertel 4985:     if (!$cid) {
1.620     albertel 4986: 	unless ($cid=$env{'request.course.id'}) {
1.455     albertel 4987: 	    return 'not_in_class';
                   4988: 	}
1.80      www      4989:     }
                   4990: # --------------------------------------------------------------- Make the user
1.81      www      4991:     my $reply=&modifyuser
1.209     matthew  4992: 	($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid,
1.387     www      4993:          $desiredhome,$email);
1.80      www      4994:     unless ($reply eq 'ok') { return $reply; }
1.297     matthew  4995:     # This will cause &modify_student_enrollment to get the uid from the
                   4996:     # students environment
                   4997:     $uid = undef if (!$forceid);
1.455     albertel 4998:     $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,
1.515     raeburn  4999: 					$gene,$usec,$end,$start,$type,$locktype,$cid);
1.297     matthew  5000:     return $reply;
                   5001: }
                   5002: 
                   5003: sub modify_student_enrollment {
1.515     raeburn  5004:     my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid) = @_;
1.455     albertel 5005:     my ($cdom,$cnum,$chome);
                   5006:     if (!$cid) {
1.620     albertel 5007: 	unless ($cid=$env{'request.course.id'}) {
1.455     albertel 5008: 	    return 'not_in_class';
                   5009: 	}
1.620     albertel 5010: 	$cdom=$env{'course.'.$cid.'.domain'};
                   5011: 	$cnum=$env{'course.'.$cid.'.num'};
1.455     albertel 5012:     } else {
                   5013: 	($cdom,$cnum)=split(/_/,$cid);
                   5014:     }
1.620     albertel 5015:     $chome=$env{'course.'.$cid.'.home'};
1.455     albertel 5016:     if (!$chome) {
1.457     raeburn  5017: 	$chome=&homeserver($cnum,$cdom);
1.297     matthew  5018:     }
1.455     albertel 5019:     if (!$chome) { return 'unknown_course'; }
1.297     matthew  5020:     # Make sure the user exists
1.81      www      5021:     my $uhome=&homeserver($uname,$udom);
                   5022:     if (($uhome eq '') || ($uhome eq 'no_host')) { 
                   5023: 	return 'error: no such user';
                   5024:     }
1.297     matthew  5025:     # Get student data if we were not given enough information
                   5026:     if (!defined($first)  || $first  eq '' || 
                   5027:         !defined($last)   || $last   eq '' || 
                   5028:         !defined($uid)    || $uid    eq '' || 
                   5029:         !defined($middle) || $middle eq '' || 
                   5030:         !defined($gene)   || $gene   eq '') {
1.294     matthew  5031:         # They did not supply us with enough data to enroll the student, so
                   5032:         # we need to pick up more information.
1.297     matthew  5033:         my %tmp = &get('environment',
1.294     matthew  5034:                        ['firstname','middlename','lastname', 'generation','id']
1.297     matthew  5035:                        ,$udom,$uname);
                   5036: 
1.800     albertel 5037:         #foreach my $key (keys(%tmp)) {
                   5038:         #    &logthis("key $key = ".$tmp{$key});
1.455     albertel 5039:         #}
1.294     matthew  5040:         $first  = $tmp{'firstname'}  if (!defined($first)  || $first  eq '');
                   5041:         $middle = $tmp{'middlename'} if (!defined($middle) || $middle eq '');
                   5042:         $last   = $tmp{'lastname'}   if (!defined($last)   || $last eq '');
1.297     matthew  5043:         $gene   = $tmp{'generation'} if (!defined($gene)   || $gene eq '');
1.294     matthew  5044:         $uid    = $tmp{'id'}         if (!defined($uid)    || $uid  eq '');
                   5045:     }
1.556     albertel 5046:     my $fullname = &format_name($first,$middle,$last,$gene,'lastname');
1.487     albertel 5047:     my $reply=cput('classlist',
                   5048: 		   {"$uname:$udom" => 
1.515     raeburn  5049: 			join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) },
1.487     albertel 5050: 		   $cdom,$cnum);
1.81      www      5051:     unless (($reply eq 'ok') || ($reply eq 'delayed')) {
                   5052: 	return 'error: '.$reply;
1.652     albertel 5053:     } else {
                   5054: 	&devalidate_getsection_cache($udom,$uname,$cid);
1.81      www      5055:     }
1.297     matthew  5056:     # Add student role to user
1.83      www      5057:     my $uurl='/'.$cid;
1.81      www      5058:     $uurl=~s/\_/\//g;
                   5059:     if ($usec) {
                   5060: 	$uurl.='/'.$usec;
                   5061:     }
                   5062:     return &assignrole($udom,$uname,$uurl,'st',$end,$start);
1.21      www      5063: }
                   5064: 
1.556     albertel 5065: sub format_name {
                   5066:     my ($firstname,$middlename,$lastname,$generation,$first)=@_;
                   5067:     my $name;
                   5068:     if ($first ne 'lastname') {
                   5069: 	$name=$firstname.' '.$middlename.' '.$lastname.' '.$generation;
                   5070:     } else {
                   5071: 	if ($lastname=~/\S/) {
                   5072: 	    $name.= $lastname.' '.$generation.', '.$firstname.' '.$middlename;
                   5073: 	    $name=~s/\s+,/,/;
                   5074: 	} else {
                   5075: 	    $name.= $firstname.' '.$middlename.' '.$generation;
                   5076: 	}
                   5077:     }
                   5078:     $name=~s/^\s+//;
                   5079:     $name=~s/\s+$//;
                   5080:     $name=~s/\s+/ /g;
                   5081:     return $name;
                   5082: }
                   5083: 
1.84      www      5084: # ------------------------------------------------- Write to course preferences
                   5085: 
                   5086: sub writecoursepref {
                   5087:     my ($courseid,%prefs)=@_;
                   5088:     $courseid=~s/^\///;
                   5089:     $courseid=~s/\_/\//g;
                   5090:     my ($cdomain,$cnum)=split(/\//,$courseid);
                   5091:     my $chome=homeserver($cnum,$cdomain);
                   5092:     if (($chome eq '') || ($chome eq 'no_host')) { 
                   5093: 	return 'error: no such course';
                   5094:     }
                   5095:     my $cstring='';
1.800     albertel 5096:     foreach my $pref (keys(%prefs)) {
                   5097: 	$cstring.=&escape($pref).'='.&escape($prefs{$pref}).'&';
1.191     harris41 5098:     }
1.84      www      5099:     $cstring=~s/\&$//;
                   5100:     return reply('put:'.$cdomain.':'.$cnum.':environment:'.$cstring,$chome);
                   5101: }
                   5102: 
                   5103: # ---------------------------------------------------------- Make/modify course
                   5104: 
                   5105: sub createcourse {
1.741     raeburn  5106:     my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,
                   5107:         $course_owner,$crstype)=@_;
1.84      www      5108:     $url=&declutter($url);
                   5109:     my $cid='';
1.264     matthew  5110:     unless (&allowed('ccc',$udom)) {
1.84      www      5111:         return 'refused';
                   5112:     }
                   5113: # ------------------------------------------------------------------- Create ID
1.674     www      5114:    my $uname=int(1+rand(9)).
                   5115:        ('a'..'z','A'..'Z','0'..'9')[int(rand(62))].
                   5116:        substr($$.time,0,5).unpack("H8",pack("I32",time)).
1.84      www      5117:        unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
                   5118: # ----------------------------------------------- Make sure that does not exist
1.230     stredwic 5119:    my $uhome=&homeserver($uname,$udom,'true');
1.84      www      5120:    unless (($uhome eq '') || ($uhome eq 'no_host')) {
                   5121:        $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).
                   5122:         unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
1.230     stredwic 5123:        $uhome=&homeserver($uname,$udom,'true');       
1.84      www      5124:        unless (($uhome eq '') || ($uhome eq 'no_host')) {
                   5125:            return 'error: unable to generate unique course-ID';
                   5126:        } 
                   5127:    }
1.264     matthew  5128: # ------------------------------------------------ Check supplied server name
1.620     albertel 5129:     $course_server = $env{'user.homeserver'} if (! defined($course_server));
1.845     albertel 5130:     if (! &is_library($course_server)) {
1.264     matthew  5131:         return 'error:bad server name '.$course_server;
                   5132:     }
1.84      www      5133: # ------------------------------------------------------------- Make the course
                   5134:     my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',
1.264     matthew  5135:                       $course_server);
1.84      www      5136:     unless ($reply eq 'ok') { return 'error: '.$reply; }
1.230     stredwic 5137:     $uhome=&homeserver($uname,$udom,'true');
1.84      www      5138:     if (($uhome eq '') || ($uhome eq 'no_host')) { 
                   5139: 	return 'error: no such course';
                   5140:     }
1.271     www      5141: # ----------------------------------------------------------------- Course made
1.516     raeburn  5142: # log existence
                   5143:     &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description).
1.741     raeburn  5144:                  ':'.&escape($inst_code).':'.&escape($course_owner).':'.
                   5145:                   &escape($crstype),$uhome);
1.358     www      5146:     &flushcourselogs();
                   5147: # set toplevel url
1.271     www      5148:     my $topurl=$url;
                   5149:     unless ($nonstandard) {
                   5150: # ------------------------------------------ For standard courses, make top url
                   5151:         my $mapurl=&clutter($url);
1.278     www      5152:         if ($mapurl eq '/res/') { $mapurl=''; }
1.620     albertel 5153:         $env{'form.initmap'}=(<<ENDINITMAP);
1.271     www      5154: <map>
                   5155: <resource id="1" type="start"></resource>
                   5156: <resource id="2" src="$mapurl"></resource>
                   5157: <resource id="3" type="finish"></resource>
                   5158: <link index="1" from="1" to="2"></link>
                   5159: <link index="2" from="2" to="3"></link>
                   5160: </map>
                   5161: ENDINITMAP
                   5162:         $topurl=&declutter(
1.638     albertel 5163:         &finishuserfileupload($uname,$udom,'initmap','default.sequence')
1.271     www      5164:                           );
                   5165:     }
                   5166: # ----------------------------------------------------------- Write preferences
1.84      www      5167:     &writecoursepref($udom.'_'.$uname,
                   5168:                      ('description' => $description,
1.271     www      5169:                       'url'         => $topurl));
1.84      www      5170:     return '/'.$udom.'/'.$uname;
                   5171: }
                   5172: 
1.813     albertel 5173: sub is_course {
                   5174:     my ($cdom,$cnum) = @_;
                   5175:     my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,
                   5176: 				undef,'.');
                   5177:     if (exists($courses{$cdom.'_'.$cnum})) {
                   5178:         return 1;
                   5179:     }
                   5180:     return 0;
                   5181: }
                   5182: 
1.21      www      5183: # ---------------------------------------------------------- Assign Custom Role
                   5184: 
                   5185: sub assigncustomrole {
1.357     www      5186:     my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag)=@_;
1.21      www      5187:     return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename,
1.357     www      5188:                        $end,$start,$deleteflag);
1.21      www      5189: }
                   5190: 
                   5191: # ----------------------------------------------------------------- Revoke Role
                   5192: 
                   5193: sub revokerole {
1.357     www      5194:     my ($udom,$uname,$url,$role,$deleteflag)=@_;
1.21      www      5195:     my $now=time;
1.357     www      5196:     return &assignrole($udom,$uname,$url,$role,$now,$deleteflag);
1.21      www      5197: }
                   5198: 
                   5199: # ---------------------------------------------------------- Revoke Custom Role
                   5200: 
                   5201: sub revokecustomrole {
1.357     www      5202:     my ($udom,$uname,$url,$rdom,$rnam,$rolename,$deleteflag)=@_;
1.21      www      5203:     my $now=time;
1.357     www      5204:     return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now,
                   5205:            $deleteflag);
1.17      www      5206: }
                   5207: 
1.533     banghart 5208: # ------------------------------------------------------------ Disk usage
1.535     albertel 5209: sub diskusage {
1.533     banghart 5210:     my ($udom,$uname,$directoryRoot)=@_;
                   5211:     $directoryRoot =~ s/\/$//;
1.535     albertel 5212:     my $listing=&reply('du:'.$directoryRoot,homeserver($uname,$udom));
1.514     albertel 5213:     return $listing;
1.512     banghart 5214: }
                   5215: 
1.566     banghart 5216: sub is_locked {
                   5217:     my ($file_name, $domain, $user) = @_;
                   5218:     my @check;
                   5219:     my $is_locked;
                   5220:     push @check, $file_name;
1.613     albertel 5221:     my %locked = &get('file_permissions',\@check,
1.620     albertel 5222: 		      $env{'user.domain'},$env{'user.name'});
1.615     albertel 5223:     my ($tmp)=keys(%locked);
                   5224:     if ($tmp=~/^error:/) { undef(%locked); }
1.745     raeburn  5225:     
1.566     banghart 5226:     if (ref($locked{$file_name}) eq 'ARRAY') {
1.745     raeburn  5227:         $is_locked = 'false';
                   5228:         foreach my $entry (@{$locked{$file_name}}) {
                   5229:            if (ref($entry) eq 'ARRAY') { 
1.746     raeburn  5230:                $is_locked = 'true';
                   5231:                last;
1.745     raeburn  5232:            }
                   5233:        }
1.566     banghart 5234:     } else {
                   5235:         $is_locked = 'false';
                   5236:     }
                   5237: }
                   5238: 
1.759     albertel 5239: sub declutter_portfile {
                   5240:     my ($file) = @_;
1.833     albertel 5241:     $file =~ s{^(/portfolio/|portfolio/)}{/};
1.759     albertel 5242:     return $file;
                   5243: }
                   5244: 
1.559     banghart 5245: # ------------------------------------------------------------- Mark as Read Only
                   5246: 
                   5247: sub mark_as_readonly {
                   5248:     my ($domain,$user,$files,$what) = @_;
1.613     albertel 5249:     my %current_permissions = &dump('file_permissions',$domain,$user);
1.615     albertel 5250:     my ($tmp)=keys(%current_permissions);
                   5251:     if ($tmp=~/^error:/) { undef(%current_permissions); }
1.560     banghart 5252:     foreach my $file (@{$files}) {
1.759     albertel 5253: 	$file = &declutter_portfile($file);
1.561     banghart 5254:         push(@{$current_permissions{$file}},$what);
1.559     banghart 5255:     }
1.613     albertel 5256:     &put('file_permissions',\%current_permissions,$domain,$user);
1.559     banghart 5257:     return;
                   5258: }
                   5259: 
1.572     banghart 5260: # ------------------------------------------------------------Save Selected Files
                   5261: 
                   5262: sub save_selected_files {
                   5263:     my ($user, $path, @files) = @_;
                   5264:     my $filename = $user."savedfiles";
1.573     banghart 5265:     my @other_files = &files_not_in_path($user, $path);
1.574     banghart 5266:     open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
1.573     banghart 5267:     foreach my $file (@files) {
1.620     albertel 5268:         print (OUT $env{'form.currentpath'}.$file."\n");
1.573     banghart 5269:     }
                   5270:     foreach my $file (@other_files) {
1.574     banghart 5271:         print (OUT $file."\n");
1.572     banghart 5272:     }
1.574     banghart 5273:     close (OUT);
1.572     banghart 5274:     return 'ok';
                   5275: }
                   5276: 
1.574     banghart 5277: sub clear_selected_files {
                   5278:     my ($user) = @_;
                   5279:     my $filename = $user."savedfiles";
                   5280:     open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
                   5281:     print (OUT undef);
                   5282:     close (OUT);
                   5283:     return ("ok");    
                   5284: }
                   5285: 
1.572     banghart 5286: sub files_in_path {
                   5287:     my ($user, $path) = @_;
                   5288:     my $filename = $user."savedfiles";
                   5289:     my %return_files;
1.574     banghart 5290:     open (IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
1.573     banghart 5291:     while (my $line_in = <IN>) {
1.574     banghart 5292:         chomp ($line_in);
                   5293:         my @paths_and_file = split (m!/!, $line_in);
                   5294:         my $file_part = pop (@paths_and_file);
                   5295:         my $path_part = join ('/', @paths_and_file);
1.573     banghart 5296:         $path_part.='/';
                   5297:         my $path_and_file = $path_part.$file_part;
                   5298:         if ($path_part eq $path) {
                   5299:             $return_files{$file_part}= 'selected';
                   5300:         }
                   5301:     }
1.574     banghart 5302:     close (IN);
                   5303:     return (\%return_files);
1.572     banghart 5304: }
                   5305: 
                   5306: # called in portfolio select mode, to show files selected NOT in current directory
                   5307: sub files_not_in_path {
                   5308:     my ($user, $path) = @_;
                   5309:     my $filename = $user."savedfiles";
                   5310:     my @return_files;
                   5311:     my $path_part;
1.800     albertel 5312:     open(IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
                   5313:     while (my $line = <IN>) {
1.572     banghart 5314:         #ok, I know it's clunky, but I want it to work
1.800     albertel 5315:         my @paths_and_file = split(m|/|, $line);
                   5316:         my $file_part = pop(@paths_and_file);
                   5317:         chomp($file_part);
                   5318:         my $path_part = join('/', @paths_and_file);
1.572     banghart 5319:         $path_part .= '/';
                   5320:         my $path_and_file = $path_part.$file_part;
                   5321:         if ($path_part ne $path) {
1.800     albertel 5322:             push(@return_files, ($path_and_file));
1.572     banghart 5323:         }
                   5324:     }
1.800     albertel 5325:     close(OUT);
1.574     banghart 5326:     return (@return_files);
1.572     banghart 5327: }
                   5328: 
1.745     raeburn  5329: #----------------------------------------------Get portfolio file permissions
1.629     banghart 5330: 
1.745     raeburn  5331: sub get_portfile_permissions {
                   5332:     my ($domain,$user) = @_;
1.613     albertel 5333:     my %current_permissions = &dump('file_permissions',$domain,$user);
1.615     albertel 5334:     my ($tmp)=keys(%current_permissions);
                   5335:     if ($tmp=~/^error:/) { undef(%current_permissions); }
1.745     raeburn  5336:     return \%current_permissions;
                   5337: }
                   5338: 
                   5339: #---------------------------------------------Get portfolio file access controls
                   5340: 
1.749     raeburn  5341: sub get_access_controls {
1.745     raeburn  5342:     my ($current_permissions,$group,$file) = @_;
1.769     albertel 5343:     my %access;
                   5344:     my $real_file = $file;
                   5345:     $file =~ s/\.meta$//;
1.745     raeburn  5346:     if (defined($file)) {
1.749     raeburn  5347:         if (ref($$current_permissions{$file."\0".'accesscontrol'}) eq 'HASH') {
                   5348:             foreach my $control (keys(%{$$current_permissions{$file."\0".'accesscontrol'}})) {
1.769     albertel 5349:                 $access{$real_file}{$control} = $$current_permissions{$file."\0".$control};
1.749     raeburn  5350:             }
                   5351:         }
1.745     raeburn  5352:     } else {
1.749     raeburn  5353:         foreach my $key (keys(%{$current_permissions})) {
                   5354:             if ($key =~ /\0accesscontrol$/) {
                   5355:                 if (defined($group)) {
                   5356:                     if ($key !~ m-^\Q$group\E/-) {
                   5357:                         next;
                   5358:                     }
                   5359:                 }
                   5360:                 my ($fullpath) = split(/\0/,$key);
                   5361:                 if (ref($$current_permissions{$key}) eq 'HASH') {
                   5362:                     foreach my $control (keys(%{$$current_permissions{$key}})) {
                   5363:                         $access{$fullpath}{$control}=$$current_permissions{$fullpath."\0".$control};
                   5364:                     }
                   5365:                 }
                   5366:             }
                   5367:         }
                   5368:     }
                   5369:     return %access;
                   5370: }
                   5371: 
                   5372: sub modify_access_controls {
                   5373:     my ($file_name,$changes,$domain,$user)=@_;
                   5374:     my ($outcome,$deloutcome);
                   5375:     my %store_permissions;
                   5376:     my %new_values;
                   5377:     my %new_control;
                   5378:     my %translation;
                   5379:     my @deletions = ();
                   5380:     my $now = time;
                   5381:     if (exists($$changes{'activate'})) {
                   5382:         if (ref($$changes{'activate'}) eq 'HASH') {
                   5383:             my @newitems = sort(keys(%{$$changes{'activate'}}));
                   5384:             my $numnew = scalar(@newitems);
                   5385:             for (my $i=0; $i<$numnew; $i++) {
                   5386:                 my $newkey = $newitems[$i];
                   5387:                 my $newid = &Apache::loncommon::get_cgi_id();
1.797     raeburn  5388:                 if ($newkey =~ /^\d+:/) { 
                   5389:                     $newkey =~ s/^(\d+)/$newid/;
                   5390:                     $translation{$1} = $newid;
                   5391:                 } elsif ($newkey =~ /^\d+_\d+_\d+:/) {
                   5392:                     $newkey =~ s/^(\d+_\d+_\d+)/$newid/;
                   5393:                     $translation{$1} = $newid;
                   5394:                 }
1.749     raeburn  5395:                 $new_values{$file_name."\0".$newkey} = 
                   5396:                                           $$changes{'activate'}{$newitems[$i]};
                   5397:                 $new_control{$newkey} = $now;
                   5398:             }
                   5399:         }
                   5400:     }
                   5401:     my %todelete;
                   5402:     my %changed_items;
                   5403:     foreach my $action ('delete','update') {
                   5404:         if (exists($$changes{$action})) {
                   5405:             if (ref($$changes{$action}) eq 'HASH') {
                   5406:                 foreach my $key (keys(%{$$changes{$action}})) {
                   5407:                     my ($itemnum) = ($key =~ /^([^:]+):/);
                   5408:                     if ($action eq 'delete') { 
                   5409:                         $todelete{$itemnum} = 1;
                   5410:                     } else {
                   5411:                         $changed_items{$itemnum} = $key;
                   5412:                     }
                   5413:                 }
1.745     raeburn  5414:             }
                   5415:         }
1.749     raeburn  5416:     }
                   5417:     # get lock on access controls for file.
                   5418:     my $lockhash = {
                   5419:                   $file_name."\0".'locked_access_records' => $env{'user.name'}.
                   5420:                                                        ':'.$env{'user.domain'},
                   5421:                    }; 
                   5422:     my $tries = 0;
                   5423:     my $gotlock = &newput('file_permissions',$lockhash,$domain,$user);
                   5424:    
                   5425:     while (($gotlock ne 'ok') && $tries <3) {
                   5426:         $tries ++;
                   5427:         sleep 1;
                   5428:         $gotlock = &newput('file_permissions',$lockhash,$domain,$user);
                   5429:     }
                   5430:     if ($gotlock eq 'ok') {
                   5431:         my %curr_permissions = &dump('file_permissions',$domain,$user,$file_name);
                   5432:         my ($tmp)=keys(%curr_permissions);
                   5433:         if ($tmp=~/^error:/) { undef(%curr_permissions); }
                   5434:         if (exists($curr_permissions{$file_name."\0".'accesscontrol'})) {
                   5435:             my $curr_controls = $curr_permissions{$file_name."\0".'accesscontrol'};
                   5436:             if (ref($curr_controls) eq 'HASH') {
                   5437:                 foreach my $control_item (keys(%{$curr_controls})) {
                   5438:                     my ($itemnum) = ($control_item =~ /^([^:]+):/);
                   5439:                     if (defined($todelete{$itemnum})) {
                   5440:                         push(@deletions,$file_name."\0".$control_item);
                   5441:                     } else {
                   5442:                         if (defined($changed_items{$itemnum})) {
                   5443:                             $new_control{$changed_items{$itemnum}} = $now;
                   5444:                             push(@deletions,$file_name."\0".$control_item);
                   5445:                             $new_values{$file_name."\0".$changed_items{$itemnum}} = $$changes{'update'}{$changed_items{$itemnum}};
                   5446:                         } else {
                   5447:                             $new_control{$control_item} = $$curr_controls{$control_item};
                   5448:                         }
                   5449:                     }
1.745     raeburn  5450:                 }
                   5451:             }
                   5452:         }
1.749     raeburn  5453:         $deloutcome = &del('file_permissions',\@deletions,$domain,$user);
                   5454:         $new_values{$file_name."\0".'accesscontrol'} = \%new_control;
                   5455:         $outcome = &put('file_permissions',\%new_values,$domain,$user);
                   5456:         #  remove lock
                   5457:         my @del_lock = ($file_name."\0".'locked_access_records');
                   5458:         my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user);
1.818     raeburn  5459:         my ($file,$group);
                   5460:         if (&is_course($domain,$user)) {
                   5461:             ($group,$file) = split(/\//,$file_name,2);
                   5462:         } else {
                   5463:             $file = $file_name;
                   5464:         }
                   5465:         my $sqlresult =
                   5466:             &update_portfolio_table($user,$domain,$file,'portfolio_access',
                   5467:                                     $group);
1.749     raeburn  5468:     } else {
                   5469:         $outcome = "error: could not obtain lockfile\n";  
1.745     raeburn  5470:     }
1.749     raeburn  5471:     return ($outcome,$deloutcome,\%new_values,\%translation);
1.745     raeburn  5472: }
                   5473: 
1.827     raeburn  5474: sub make_public_indefinitely {
                   5475:     my ($requrl) = @_;
                   5476:     my $now = time;
                   5477:     my $action = 'activate';
                   5478:     my $aclnum = 0;
                   5479:     if (&is_portfolio_url($requrl)) {
                   5480:         my (undef,$udom,$unum,$file_name,$group) =
                   5481:             &parse_portfolio_url($requrl);
                   5482:         my $current_perms = &get_portfile_permissions($udom,$unum);
                   5483:         my %access_controls = &get_access_controls($current_perms,
                   5484:                                                    $group,$file_name);
                   5485:         foreach my $key (keys(%{$access_controls{$file_name}})) {
                   5486:             my ($num,$scope,$end,$start) = 
                   5487:                 ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/);
                   5488:             if ($scope eq 'public') {
                   5489:                 if ($start <= $now && $end == 0) {
                   5490:                     $action = 'none';
                   5491:                 } else {
                   5492:                     $action = 'update';
                   5493:                     $aclnum = $num;
                   5494:                 }
                   5495:                 last;
                   5496:             }
                   5497:         }
                   5498:         if ($action eq 'none') {
                   5499:              return 'ok';
                   5500:         } else {
                   5501:             my %changes;
                   5502:             my $newend = 0;
                   5503:             my $newstart = $now;
                   5504:             my $newkey = $aclnum.':public_'.$newend.'_'.$newstart;
                   5505:             $changes{$action}{$newkey} = {
                   5506:                 type => 'public',
                   5507:                 time => {
                   5508:                     start => $newstart,
                   5509:                     end   => $newend,
                   5510:                 },
                   5511:             };
                   5512:             my ($outcome,$deloutcome,$new_values,$translation) =
                   5513:                 &modify_access_controls($file_name,\%changes,$udom,$unum);
                   5514:             return $outcome;
                   5515:         }
                   5516:     } else {
                   5517:         return 'invalid';
                   5518:     }
                   5519: }
                   5520: 
1.745     raeburn  5521: #------------------------------------------------------Get Marked as Read Only
                   5522: 
                   5523: sub get_marked_as_readonly {
                   5524:     my ($domain,$user,$what,$group) = @_;
                   5525:     my $current_permissions = &get_portfile_permissions($domain,$user);
1.563     banghart 5526:     my @readonly_files;
1.629     banghart 5527:     my $cmp1=$what;
                   5528:     if (ref($what)) { $cmp1=join('',@{$what}) };
1.745     raeburn  5529:     while (my ($file_name,$value) = each(%{$current_permissions})) {
                   5530:         if (defined($group)) {
                   5531:             if ($file_name !~ m-^\Q$group\E/-) {
                   5532:                 next;
                   5533:             }
                   5534:         }
1.561     banghart 5535:         if (ref($value) eq "ARRAY"){
                   5536:             foreach my $stored_what (@{$value}) {
1.629     banghart 5537:                 my $cmp2=$stored_what;
1.759     albertel 5538:                 if (ref($stored_what) eq 'ARRAY') {
1.746     raeburn  5539:                     $cmp2=join('',@{$stored_what});
1.745     raeburn  5540:                 }
1.629     banghart 5541:                 if ($cmp1 eq $cmp2) {
1.561     banghart 5542:                     push(@readonly_files, $file_name);
1.745     raeburn  5543:                     last;
1.563     banghart 5544:                 } elsif (!defined($what)) {
                   5545:                     push(@readonly_files, $file_name);
1.745     raeburn  5546:                     last;
1.561     banghart 5547:                 }
                   5548:             }
1.745     raeburn  5549:         }
1.561     banghart 5550:     }
                   5551:     return @readonly_files;
                   5552: }
1.577     banghart 5553: #-----------------------------------------------------------Get Marked as Read Only Hash
1.561     banghart 5554: 
1.577     banghart 5555: sub get_marked_as_readonly_hash {
1.745     raeburn  5556:     my ($current_permissions,$group,$what) = @_;
1.577     banghart 5557:     my %readonly_files;
1.745     raeburn  5558:     while (my ($file_name,$value) = each(%{$current_permissions})) {
                   5559:         if (defined($group)) {
                   5560:             if ($file_name !~ m-^\Q$group\E/-) {
                   5561:                 next;
                   5562:             }
                   5563:         }
1.577     banghart 5564:         if (ref($value) eq "ARRAY"){
                   5565:             foreach my $stored_what (@{$value}) {
1.745     raeburn  5566:                 if (ref($stored_what) eq 'ARRAY') {
1.750     banghart 5567:                     foreach my $lock_descriptor(@{$stored_what}) {
                   5568:                         if ($lock_descriptor eq 'graded') {
                   5569:                             $readonly_files{$file_name} = 'graded';
                   5570:                         } elsif ($lock_descriptor eq 'handback') {
                   5571:                             $readonly_files{$file_name} = 'handback';
                   5572:                         } else {
                   5573:                             if (!exists($readonly_files{$file_name})) {
                   5574:                                 $readonly_files{$file_name} = 'locked';
                   5575:                             }
                   5576:                         }
1.745     raeburn  5577:                     }
1.750     banghart 5578:                 } 
1.577     banghart 5579:             }
                   5580:         } 
                   5581:     }
                   5582:     return %readonly_files;
                   5583: }
1.559     banghart 5584: # ------------------------------------------------------------ Unmark as Read Only
                   5585: 
                   5586: sub unmark_as_readonly {
1.629     banghart 5587:     # unmarks $file_name (if $file_name is defined), or all files locked by $what 
                   5588:     # for portfolio submissions, $what contains [$symb,$crsid] 
1.745     raeburn  5589:     my ($domain,$user,$what,$file_name,$group) = @_;
1.759     albertel 5590:     $file_name = &declutter_portfile($file_name);
1.634     albertel 5591:     my $symb_crs = $what;
                   5592:     if (ref($what)) { $symb_crs=join('',@$what); }
1.745     raeburn  5593:     my %current_permissions = &dump('file_permissions',$domain,$user,$group);
1.615     albertel 5594:     my ($tmp)=keys(%current_permissions);
                   5595:     if ($tmp=~/^error:/) { undef(%current_permissions); }
1.745     raeburn  5596:     my @readonly_files = &get_marked_as_readonly($domain,$user,$what,$group);
1.650     albertel 5597:     foreach my $file (@readonly_files) {
1.759     albertel 5598: 	my $clean_file = &declutter_portfile($file);
                   5599: 	if (defined($file_name) && ($file_name ne $clean_file)) { next; }
1.650     albertel 5600: 	my $current_locks = $current_permissions{$file};
1.563     banghart 5601:         my @new_locks;
                   5602:         my @del_keys;
                   5603:         if (ref($current_locks) eq "ARRAY"){
                   5604:             foreach my $locker (@{$current_locks}) {
1.632     albertel 5605:                 my $compare=$locker;
1.749     raeburn  5606:                 if (ref($locker) eq 'ARRAY') {
1.745     raeburn  5607:                     $compare=join('',@{$locker});
1.746     raeburn  5608:                     if ($compare ne $symb_crs) {
                   5609:                         push(@new_locks, $locker);
                   5610:                     }
1.563     banghart 5611:                 }
                   5612:             }
1.650     albertel 5613:             if (scalar(@new_locks) > 0) {
1.563     banghart 5614:                 $current_permissions{$file} = \@new_locks;
                   5615:             } else {
                   5616:                 push(@del_keys, $file);
1.613     albertel 5617:                 &del('file_permissions',\@del_keys, $domain, $user);
1.650     albertel 5618:                 delete($current_permissions{$file});
1.563     banghart 5619:             }
                   5620:         }
1.561     banghart 5621:     }
1.613     albertel 5622:     &put('file_permissions',\%current_permissions,$domain,$user);
1.559     banghart 5623:     return;
                   5624: }
1.512     banghart 5625: 
1.17      www      5626: # ------------------------------------------------------------ Directory lister
                   5627: 
                   5628: sub dirlist {
1.253     stredwic 5629:     my ($uri,$userdomain,$username,$alternateDirectoryRoot)=@_;
                   5630: 
1.18      www      5631:     $uri=~s/^\///;
                   5632:     $uri=~s/\/$//;
1.253     stredwic 5633:     my ($udom, $uname);
                   5634:     (undef,$udom,$uname)=split(/\//,$uri);
                   5635:     if(defined($userdomain)) {
                   5636:         $udom = $userdomain;
                   5637:     }
                   5638:     if(defined($username)) {
                   5639:         $uname = $username;
                   5640:     }
                   5641: 
                   5642:     my $dirRoot = $perlvar{'lonDocRoot'};
                   5643:     if(defined($alternateDirectoryRoot)) {
                   5644:         $dirRoot = $alternateDirectoryRoot;
                   5645:         $dirRoot =~ s/\/$//;
1.751     banghart 5646:     }
1.253     stredwic 5647: 
                   5648:     if($udom) {
                   5649:         if($uname) {
1.800     albertel 5650:             my $listing = &reply('ls2:'.$dirRoot.'/'.$uri,
                   5651: 				 &homeserver($uname,$udom));
1.605     matthew  5652:             my @listing_results;
                   5653:             if ($listing eq 'unknown_cmd') {
1.800     albertel 5654:                 $listing = &reply('ls:'.$dirRoot.'/'.$uri,
                   5655: 				  &homeserver($uname,$udom));
1.605     matthew  5656:                 @listing_results = split(/:/,$listing);
                   5657:             } else {
                   5658:                 @listing_results = map { &unescape($_); } split(/:/,$listing);
                   5659:             }
                   5660:             return @listing_results;
1.253     stredwic 5661:         } elsif(!defined($alternateDirectoryRoot)) {
1.800     albertel 5662:             my %allusers;
1.841     albertel 5663: 	    my %servers = &get_servers($udom,'library');
                   5664: 	    foreach my $tryserver (keys(%servers)) {
                   5665: 		my $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'.
                   5666: 				     $udom, $tryserver);
                   5667: 		my @listing_results;
                   5668: 		if ($listing eq 'unknown_cmd') {
                   5669: 		    $listing = &reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.
                   5670: 				      $udom, $tryserver);
                   5671: 		    @listing_results = split(/:/,$listing);
                   5672: 		} else {
                   5673: 		    @listing_results =
                   5674: 			map { &unescape($_); } split(/:/,$listing);
                   5675: 		}
                   5676: 		if ($listing_results[0] ne 'no_such_dir' && 
                   5677: 		    $listing_results[0] ne 'empty'       &&
                   5678: 		    $listing_results[0] ne 'con_lost') {
                   5679: 		    foreach my $line (@listing_results) {
                   5680: 			my ($entry) = split(/&/,$line,2);
                   5681: 			$allusers{$entry} = 1;
                   5682: 		    }
                   5683: 		}
1.253     stredwic 5684:             }
                   5685:             my $alluserstr='';
1.800     albertel 5686:             foreach my $user (sort(keys(%allusers))) {
                   5687:                 $alluserstr.=$user.'&user:';
1.253     stredwic 5688:             }
                   5689:             $alluserstr=~s/:$//;
                   5690:             return split(/:/,$alluserstr);
                   5691:         } else {
1.800     albertel 5692:             return ('missing user name');
1.253     stredwic 5693:         }
                   5694:     } elsif(!defined($alternateDirectoryRoot)) {
1.841     albertel 5695:         my @all_domains = sort(&all_domains());
                   5696:          foreach my $domain (@all_domains) {
                   5697:              $domain = $perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain';
                   5698:          }
                   5699:          return @all_domains;
                   5700:      } else {
1.800     albertel 5701:         return ('missing domain');
1.275     stredwic 5702:     }
                   5703: }
                   5704: 
                   5705: # --------------------------------------------- GetFileTimestamp
                   5706: # This function utilizes dirlist and returns the date stamp for
                   5707: # when it was last modified.  It will also return an error of -1
                   5708: # if an error occurs
                   5709: 
1.410     matthew  5710: ##
                   5711: ## FIXME: This subroutine assumes its caller knows something about the
                   5712: ## directory structure of the home server for the student ($root).
                   5713: ## Not a good assumption to make.  Since this is for looking up files
                   5714: ## in user directories, the full path should be constructed by lond, not
                   5715: ## whatever machine we request data from.
                   5716: ##
1.275     stredwic 5717: sub GetFileTimestamp {
                   5718:     my ($studentDomain,$studentName,$filename,$root)=@_;
1.807     albertel 5719:     $studentDomain = &LONCAPA::clean_domain($studentDomain);
                   5720:     $studentName   = &LONCAPA::clean_username($studentName);
1.275     stredwic 5721:     my $subdir=$studentName.'__';
                   5722:     $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
                   5723:     my $proname="$studentDomain/$subdir/$studentName";
                   5724:     $proname .= '/'.$filename;
1.375     matthew  5725:     my ($fileStat) = &Apache::lonnet::dirlist($proname, $studentDomain, 
                   5726:                                               $studentName, $root);
1.275     stredwic 5727:     my @stats = split('&', $fileStat);
                   5728:     if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {
1.375     matthew  5729:         # @stats contains first the filename, then the stat output
                   5730:         return $stats[10]; # so this is 10 instead of 9.
1.275     stredwic 5731:     } else {
                   5732:         return -1;
1.253     stredwic 5733:     }
1.26      www      5734: }
                   5735: 
1.712     albertel 5736: sub stat_file {
                   5737:     my ($uri) = @_;
1.787     albertel 5738:     $uri = &clutter_with_no_wrapper($uri);
1.722     albertel 5739: 
1.712     albertel 5740:     my ($udom,$uname,$file,$dir);
                   5741:     if ($uri =~ m-^/(uploaded|editupload)/-) {
                   5742: 	($udom,$uname,$file) =
1.811     albertel 5743: 	    ($uri =~ m-/(?:uploaded|editupload)/?($match_domain)/?($match_name)/?(.*)-);
1.712     albertel 5744: 	$file = 'userfiles/'.$file;
1.740     www      5745: 	$dir = &propath($udom,$uname);
1.712     albertel 5746:     }
                   5747:     if ($uri =~ m-^/res/-) {
                   5748: 	($udom,$uname) = 
1.807     albertel 5749: 	    ($uri =~ m-/(?:res)/?($match_domain)/?($match_username)/-);
1.712     albertel 5750: 	$file = $uri;
                   5751:     }
                   5752: 
                   5753:     if (!$udom || !$uname || !$file) {
                   5754: 	# unable to handle the uri
                   5755: 	return ();
                   5756:     }
                   5757: 
                   5758:     my ($result) = &dirlist($file,$udom,$uname,$dir);
                   5759:     my @stats = split('&', $result);
1.721     banghart 5760:     
1.712     albertel 5761:     if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {
                   5762: 	shift(@stats); #filename is first
                   5763: 	return @stats;
                   5764:     }
                   5765:     return ();
                   5766: }
                   5767: 
1.26      www      5768: # -------------------------------------------------------- Value of a Condition
                   5769: 
1.713     albertel 5770: # gets the value of a specific preevaluated condition
                   5771: #    stored in the string  $env{user.state.<cid>}
                   5772: # or looks up a condition reference in the bighash and if if hasn't
                   5773: # already been evaluated recurses into docondval to get the value of
                   5774: # the condition, then memoizing it to 
                   5775: #   $env{user.state.<cid>.<condition>}
1.40      www      5776: sub directcondval {
                   5777:     my $number=shift;
1.620     albertel 5778:     if (!defined($env{'user.state.'.$env{'request.course.id'}})) {
1.555     albertel 5779: 	&Apache::lonuserstate::evalstate();
                   5780:     }
1.713     albertel 5781:     if (exists($env{'user.state.'.$env{'request.course.id'}.".$number"})) {
                   5782: 	return $env{'user.state.'.$env{'request.course.id'}.".$number"};
                   5783:     } elsif ($number =~ /^_/) {
                   5784: 	my $sub_condition;
                   5785: 	if (tie(my %bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
                   5786: 		&GDBM_READER(),0640)) {
                   5787: 	    $sub_condition=$bighash{'conditions'.$number};
                   5788: 	    untie(%bighash);
                   5789: 	}
                   5790: 	my $value = &docondval($sub_condition);
                   5791: 	&appenv('user.state.'.$env{'request.course.id'}.".$number" => $value);
                   5792: 	return $value;
                   5793:     }
1.620     albertel 5794:     if ($env{'user.state.'.$env{'request.course.id'}}) {
                   5795:        return substr($env{'user.state.'.$env{'request.course.id'}},$number,1);
1.40      www      5796:     } else {
                   5797:        return 2;
                   5798:     }
                   5799: }
                   5800: 
1.713     albertel 5801: # get the collection of conditions for this resource
1.26      www      5802: sub condval {
                   5803:     my $condidx=shift;
1.54      www      5804:     my $allpathcond='';
1.713     albertel 5805:     foreach my $cond (split(/\|/,$condidx)) {
                   5806: 	if (defined($env{'acc.cond.'.$env{'request.course.id'}.'.'.$cond})) {
                   5807: 	    $allpathcond.=
                   5808: 		'('.$env{'acc.cond.'.$env{'request.course.id'}.'.'.$cond}.')|';
                   5809: 	}
1.191     harris41 5810:     }
1.54      www      5811:     $allpathcond=~s/\|$//;
1.713     albertel 5812:     return &docondval($allpathcond);
                   5813: }
                   5814: 
                   5815: #evaluates an expression of conditions
                   5816: sub docondval {
                   5817:     my ($allpathcond) = @_;
                   5818:     my $result=0;
                   5819:     if ($env{'request.course.id'}
                   5820: 	&& defined($allpathcond)) {
                   5821: 	my $operand='|';
                   5822: 	my @stack;
                   5823: 	foreach my $chunk ($allpathcond=~/(\d+|_\d+\.\d+|\(|\)|\&|\|)/g) {
                   5824: 	    if ($chunk eq '(') {
                   5825: 		push @stack,($operand,$result);
                   5826: 	    } elsif ($chunk eq ')') {
                   5827: 		my $before=pop @stack;
                   5828: 		if (pop @stack eq '&') {
                   5829: 		    $result=$result>$before?$before:$result;
                   5830: 		} else {
                   5831: 		    $result=$result>$before?$result:$before;
                   5832: 		}
                   5833: 	    } elsif (($chunk eq '&') || ($chunk eq '|')) {
                   5834: 		$operand=$chunk;
                   5835: 	    } else {
                   5836: 		my $new=directcondval($chunk);
                   5837: 		if ($operand eq '&') {
                   5838: 		    $result=$result>$new?$new:$result;
                   5839: 		} else {
                   5840: 		    $result=$result>$new?$result:$new;
                   5841: 		}
                   5842: 	    }
                   5843: 	}
1.26      www      5844:     }
                   5845:     return $result;
1.421     albertel 5846: }
                   5847: 
                   5848: # ---------------------------------------------------- Devalidate courseresdata
                   5849: 
                   5850: sub devalidatecourseresdata {
                   5851:     my ($coursenum,$coursedomain)=@_;
                   5852:     my $hashid=$coursenum.':'.$coursedomain;
1.599     albertel 5853:     &devalidate_cache_new('courseres',$hashid);
1.28      www      5854: }
                   5855: 
1.763     www      5856: 
1.200     www      5857: # --------------------------------------------------- Course Resourcedata Query
                   5858: 
1.624     albertel 5859: sub get_courseresdata {
                   5860:     my ($coursenum,$coursedomain)=@_;
1.200     www      5861:     my $coursehom=&homeserver($coursenum,$coursedomain);
                   5862:     my $hashid=$coursenum.':'.$coursedomain;
1.599     albertel 5863:     my ($result,$cached)=&is_cached_new('courseres',$hashid);
1.624     albertel 5864:     my %dumpreply;
1.417     albertel 5865:     unless (defined($cached)) {
1.624     albertel 5866: 	%dumpreply=&dump('resourcedata',$coursedomain,$coursenum);
1.417     albertel 5867: 	$result=\%dumpreply;
1.251     albertel 5868: 	my ($tmp) = keys(%dumpreply);
                   5869: 	if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
1.599     albertel 5870: 	    &do_cache_new('courseres',$hashid,$result,600);
1.306     albertel 5871: 	} elsif ($tmp =~ /^(con_lost|no_such_host)/) {
                   5872: 	    return $tmp;
1.416     albertel 5873: 	} elsif ($tmp =~ /^(error)/) {
1.417     albertel 5874: 	    $result=undef;
1.599     albertel 5875: 	    &do_cache_new('courseres',$hashid,$result,600);
1.250     albertel 5876: 	}
                   5877:     }
1.624     albertel 5878:     return $result;
                   5879: }
                   5880: 
1.633     albertel 5881: sub devalidateuserresdata {
                   5882:     my ($uname,$udom)=@_;
                   5883:     my $hashid="$udom:$uname";
                   5884:     &devalidate_cache_new('userres',$hashid);
                   5885: }
                   5886: 
1.624     albertel 5887: sub get_userresdata {
                   5888:     my ($uname,$udom)=@_;
                   5889:     #most student don\'t have any data set, check if there is some data
                   5890:     if (&EXT_cache_status($udom,$uname)) { return undef; }
                   5891: 
                   5892:     my $hashid="$udom:$uname";
                   5893:     my ($result,$cached)=&is_cached_new('userres',$hashid);
                   5894:     if (!defined($cached)) {
                   5895: 	my %resourcedata=&dump('resourcedata',$udom,$uname);
                   5896: 	$result=\%resourcedata;
                   5897: 	&do_cache_new('userres',$hashid,$result,600);
                   5898:     }
                   5899:     my ($tmp)=keys(%$result);
                   5900:     if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) {
                   5901: 	return $result;
                   5902:     }
                   5903:     #error 2 occurs when the .db doesn't exist
                   5904:     if ($tmp!~/error: 2 /) {
1.672     albertel 5905: 	&logthis("<font color=\"blue\">WARNING:".
1.624     albertel 5906: 		 " Trying to get resource data for ".
                   5907: 		 $uname." at ".$udom.": ".
                   5908: 		 $tmp."</font>");
                   5909:     } elsif ($tmp=~/error: 2 /) {
1.633     albertel 5910: 	#&EXT_cache_set($udom,$uname);
                   5911: 	&do_cache_new('userres',$hashid,undef,600);
1.636     albertel 5912: 	undef($tmp); # not really an error so don't send it back
1.624     albertel 5913:     }
                   5914:     return $tmp;
                   5915: }
                   5916: 
                   5917: sub resdata {
                   5918:     my ($name,$domain,$type,@which)=@_;
                   5919:     my $result;
                   5920:     if ($type eq 'course') {
                   5921: 	$result=&get_courseresdata($name,$domain);
                   5922:     } elsif ($type eq 'user') {
                   5923: 	$result=&get_userresdata($name,$domain);
                   5924:     }
                   5925:     if (!ref($result)) { return $result; }    
1.251     albertel 5926:     foreach my $item (@which) {
1.417     albertel 5927: 	if (defined($result->{$item})) {
                   5928: 	    return $result->{$item};
1.251     albertel 5929: 	}
1.250     albertel 5930:     }
1.291     albertel 5931:     return undef;
1.200     www      5932: }
                   5933: 
1.379     matthew  5934: #
                   5935: # EXT resource caching routines
                   5936: #
                   5937: 
                   5938: sub clear_EXT_cache_status {
1.383     albertel 5939:     &delenv('cache.EXT.');
1.379     matthew  5940: }
                   5941: 
                   5942: sub EXT_cache_status {
                   5943:     my ($target_domain,$target_user) = @_;
1.383     albertel 5944:     my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain;
1.620     albertel 5945:     if (exists($env{$cachename}) && ($env{$cachename}+600) > time) {
1.379     matthew  5946:         # We know already the user has no data
                   5947:         return 1;
                   5948:     } else {
                   5949:         return 0;
                   5950:     }
                   5951: }
                   5952: 
                   5953: sub EXT_cache_set {
                   5954:     my ($target_domain,$target_user) = @_;
1.383     albertel 5955:     my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain;
1.633     albertel 5956:     #&appenv($cachename => time);
1.379     matthew  5957: }
                   5958: 
1.28      www      5959: # --------------------------------------------------------- Value of a Variable
1.58      www      5960: sub EXT {
1.715     albertel 5961: 
1.395     albertel 5962:     my ($varname,$symbparm,$udom,$uname,$usection,$recurse)=@_;
1.68      www      5963:     unless ($varname) { return ''; }
1.218     albertel 5964:     #get real user name/domain, courseid and symb
                   5965:     my $courseid;
1.359     albertel 5966:     my $publicuser;
1.427     www      5967:     if ($symbparm) {
                   5968: 	$symbparm=&get_symb_from_alias($symbparm);
                   5969:     }
1.218     albertel 5970:     if (!($uname && $udom)) {
1.790     albertel 5971:       (my $cursymb,$courseid,$udom,$uname,$publicuser)= &whichuser($symbparm);
1.218     albertel 5972:       if (!$symbparm) {	$symbparm=$cursymb; }
                   5973:     } else {
1.620     albertel 5974: 	$courseid=$env{'request.course.id'};
1.218     albertel 5975:     }
1.48      www      5976:     my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);
                   5977:     my $rest;
1.320     albertel 5978:     if (defined($therest[0])) {
1.48      www      5979:        $rest=join('.',@therest);
                   5980:     } else {
                   5981:        $rest='';
                   5982:     }
1.320     albertel 5983: 
1.57      www      5984:     my $qualifierrest=$qualifier;
                   5985:     if ($rest) { $qualifierrest.='.'.$rest; }
                   5986:     my $spacequalifierrest=$space;
                   5987:     if ($qualifierrest) { $spacequalifierrest.='.'.$qualifierrest; }
1.28      www      5988:     if ($realm eq 'user') {
1.48      www      5989: # --------------------------------------------------------------- user.resource
                   5990: 	if ($space eq 'resource') {
1.651     albertel 5991: 	    if ( (defined($Apache::lonhomework::parsing_a_problem)
                   5992: 		  || defined($Apache::lonhomework::parsing_a_task))
                   5993: 		 &&
1.744     albertel 5994: 		 ($symbparm eq &symbread()) ) {	
                   5995: 		# if we are in the middle of processing the resource the
                   5996: 		# get the value we are planning on committing
                   5997:                 if (defined($Apache::lonhomework::results{$qualifierrest})) {
                   5998:                     return $Apache::lonhomework::results{$qualifierrest};
                   5999:                 } else {
                   6000:                     return $Apache::lonhomework::history{$qualifierrest};
                   6001:                 }
1.335     albertel 6002: 	    } else {
1.359     albertel 6003: 		my %restored;
1.620     albertel 6004: 		if ($publicuser || $env{'request.state'} eq 'construct') {
1.359     albertel 6005: 		    %restored=&tmprestore($symbparm,$courseid,$udom,$uname);
                   6006: 		} else {
                   6007: 		    %restored=&restore($symbparm,$courseid,$udom,$uname);
                   6008: 		}
1.335     albertel 6009: 		return $restored{$qualifierrest};
                   6010: 	    }
1.48      www      6011: # ----------------------------------------------------------------- user.access
                   6012:         } elsif ($space eq 'access') {
1.218     albertel 6013: 	    # FIXME - not supporting calls for a specific user
1.48      www      6014:             return &allowed($qualifier,$rest);
                   6015: # ------------------------------------------ user.preferences, user.environment
                   6016:         } elsif (($space eq 'preferences') || ($space eq 'environment')) {
1.620     albertel 6017: 	    if (($uname eq $env{'user.name'}) &&
                   6018: 		($udom eq $env{'user.domain'})) {
                   6019: 		return $env{join('.',('environment',$qualifierrest))};
1.218     albertel 6020: 	    } else {
1.359     albertel 6021: 		my %returnhash;
                   6022: 		if (!$publicuser) {
                   6023: 		    %returnhash=&userenvironment($udom,$uname,
                   6024: 						 $qualifierrest);
                   6025: 		}
1.218     albertel 6026: 		return $returnhash{$qualifierrest};
                   6027: 	    }
1.48      www      6028: # ----------------------------------------------------------------- user.course
                   6029:         } elsif ($space eq 'course') {
1.218     albertel 6030: 	    # FIXME - not supporting calls for a specific user
1.620     albertel 6031:             return $env{join('.',('request.course',$qualifier))};
1.48      www      6032: # ------------------------------------------------------------------- user.role
                   6033:         } elsif ($space eq 'role') {
1.218     albertel 6034: 	    # FIXME - not supporting calls for a specific user
1.620     albertel 6035:             my ($role,$where)=split(/\./,$env{'request.role'});
1.48      www      6036:             if ($qualifier eq 'value') {
                   6037: 		return $role;
                   6038:             } elsif ($qualifier eq 'extent') {
                   6039:                 return $where;
                   6040:             }
                   6041: # ----------------------------------------------------------------- user.domain
                   6042:         } elsif ($space eq 'domain') {
1.218     albertel 6043:             return $udom;
1.48      www      6044: # ------------------------------------------------------------------- user.name
                   6045:         } elsif ($space eq 'name') {
1.218     albertel 6046:             return $uname;
1.48      www      6047: # ---------------------------------------------------- Any other user namespace
1.29      www      6048:         } else {
1.359     albertel 6049: 	    my %reply;
                   6050: 	    if (!$publicuser) {
                   6051: 		%reply=&get($space,[$qualifierrest],$udom,$uname);
                   6052: 	    }
                   6053: 	    return $reply{$qualifierrest};
1.48      www      6054:         }
1.236     www      6055:     } elsif ($realm eq 'query') {
                   6056: # ---------------------------------------------- pull stuff out of query string
1.384     albertel 6057:         &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'},
                   6058: 						[$spacequalifierrest]);
1.620     albertel 6059: 	return $env{'form.'.$spacequalifierrest}; 
1.236     www      6060:    } elsif ($realm eq 'request') {
1.48      www      6061: # ------------------------------------------------------------- request.browser
                   6062:         if ($space eq 'browser') {
1.430     www      6063: 	    if ($qualifier eq 'textremote') {
1.676     albertel 6064: 		if (&Apache::lonlocal::mt('textual_remote_display') eq 'on') {
1.430     www      6065: 		    return 1;
                   6066: 		} else {
                   6067: 		    return 0;
                   6068: 		}
                   6069: 	    } else {
1.620     albertel 6070: 		return $env{'browser.'.$qualifier};
1.430     www      6071: 	    }
1.57      www      6072: # ------------------------------------------------------------ request.filename
                   6073:         } else {
1.620     albertel 6074:             return $env{'request.'.$spacequalifierrest};
1.29      www      6075:         }
1.28      www      6076:     } elsif ($realm eq 'course') {
1.48      www      6077: # ---------------------------------------------------------- course.description
1.620     albertel 6078:         return $env{'course.'.$courseid.'.'.$spacequalifierrest};
1.57      www      6079:     } elsif ($realm eq 'resource') {
1.165     www      6080: 
1.620     albertel 6081: 	if (defined($courseid) && $courseid eq $env{'request.course.id'}) {
1.539     albertel 6082: 	    if (!$symbparm) { $symbparm=&symbread(); }
                   6083: 	}
1.693     albertel 6084: 
                   6085: 	if ($space eq 'title') {
                   6086: 	    if (!$symbparm) { $symbparm = $env{'request.filename'}; }
                   6087: 	    return &gettitle($symbparm);
                   6088: 	}
                   6089: 	
                   6090: 	if ($space eq 'map') {
                   6091: 	    my ($map) = &decode_symb($symbparm);
                   6092: 	    return &symbread($map);
                   6093: 	}
                   6094: 
                   6095: 	my ($section, $group, @groups);
1.593     albertel 6096: 	my ($courselevelm,$courselevel);
1.539     albertel 6097: 	if ($symbparm && defined($courseid) && 
1.620     albertel 6098: 	    $courseid eq $env{'request.course.id'}) {
1.165     www      6099: 
1.218     albertel 6100: 	    #print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;
1.165     www      6101: 
1.60      www      6102: # ----------------------------------------------------- Cascading lookup scheme
1.218     albertel 6103: 	    my $symbp=$symbparm;
1.735     albertel 6104: 	    my $mapp=&deversion((&decode_symb($symbp))[0]);
1.218     albertel 6105: 
                   6106: 	    my $symbparm=$symbp.'.'.$spacequalifierrest;
                   6107: 	    my $mapparm=$mapp.'___(all).'.$spacequalifierrest;
                   6108: 
1.620     albertel 6109: 	    if (($env{'user.name'} eq $uname) &&
                   6110: 		($env{'user.domain'} eq $udom)) {
                   6111: 		$section=$env{'request.course.sec'};
1.733     raeburn  6112:                 @groups = split(/:/,$env{'request.course.groups'});  
                   6113:                 @groups=&sort_course_groups($courseid,@groups); 
1.218     albertel 6114: 	    } else {
1.539     albertel 6115: 		if (! defined($usection)) {
1.551     albertel 6116: 		    $section=&getsection($udom,$uname,$courseid);
1.539     albertel 6117: 		} else {
                   6118: 		    $section = $usection;
                   6119: 		}
1.733     raeburn  6120:                 @groups = &get_users_groups($udom,$uname,$courseid);
1.218     albertel 6121: 	    }
                   6122: 
                   6123: 	    my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
                   6124: 	    my $seclevelr=$courseid.'.['.$section.'].'.$symbparm;
                   6125: 	    my $seclevelm=$courseid.'.['.$section.'].'.$mapparm;
                   6126: 
1.593     albertel 6127: 	    $courselevel=$courseid.'.'.$spacequalifierrest;
1.218     albertel 6128: 	    my $courselevelr=$courseid.'.'.$symbparm;
1.593     albertel 6129: 	    $courselevelm=$courseid.'.'.$mapparm;
1.69      www      6130: 
1.60      www      6131: # ----------------------------------------------------------- first, check user
1.624     albertel 6132: 
                   6133: 	    my $userreply=&resdata($uname,$udom,'user',
                   6134: 				       ($courselevelr,$courselevelm,
                   6135: 					$courselevel));
                   6136: 	    if (defined($userreply)) { return $userreply; }
1.95      www      6137: 
1.594     albertel 6138: # ------------------------------------------------ second, check some of course
1.684     raeburn  6139:             my $coursereply;
1.691     raeburn  6140:             if (@groups > 0) {
                   6141:                 $coursereply = &check_group_parms($courseid,\@groups,$symbparm,
                   6142:                                        $mapparm,$spacequalifierrest);
1.684     raeburn  6143:                 if (defined($coursereply)) { return $coursereply; }
                   6144:             }
1.96      www      6145: 
1.684     raeburn  6146: 	    $coursereply=&resdata($env{'course.'.$courseid.'.num'},
1.624     albertel 6147: 				     $env{'course.'.$courseid.'.domain'},
                   6148: 				     'course',
                   6149: 				     ($seclevelr,$seclevelm,$seclevel,
                   6150: 				      $courselevelr));
1.287     albertel 6151: 	    if (defined($coursereply)) { return $coursereply; }
1.200     www      6152: 
1.60      www      6153: # ------------------------------------------------------ third, check map parms
1.218     albertel 6154: 	    my %parmhash=();
                   6155: 	    my $thisparm='';
                   6156: 	    if (tie(%parmhash,'GDBM_File',
1.620     albertel 6157: 		    $env{'request.course.fn'}.'_parms.db',
1.256     albertel 6158: 		    &GDBM_READER(),0640)) {
1.218     albertel 6159: 		$thisparm=$parmhash{$symbparm};
                   6160: 		untie(%parmhash);
                   6161: 	    }
                   6162: 	    if ($thisparm) { return $thisparm; }
                   6163: 	}
1.594     albertel 6164: # ------------------------------------------ fourth, look in resource metadata
1.71      www      6165: 
1.218     albertel 6166: 	$spacequalifierrest=~s/\./\_/;
1.282     albertel 6167: 	my $filename;
                   6168: 	if (!$symbparm) { $symbparm=&symbread(); }
                   6169: 	if ($symbparm) {
1.409     www      6170: 	    $filename=(&decode_symb($symbparm))[2];
1.282     albertel 6171: 	} else {
1.620     albertel 6172: 	    $filename=$env{'request.filename'};
1.282     albertel 6173: 	}
                   6174: 	my $metadata=&metadata($filename,$spacequalifierrest);
1.288     albertel 6175: 	if (defined($metadata)) { return $metadata; }
1.282     albertel 6176: 	$metadata=&metadata($filename,'parameter_'.$spacequalifierrest);
1.288     albertel 6177: 	if (defined($metadata)) { return $metadata; }
1.142     www      6178: 
1.594     albertel 6179: # ---------------------------------------------- fourth, look in rest pf course
1.593     albertel 6180: 	if ($symbparm && defined($courseid) && 
1.620     albertel 6181: 	    $courseid eq $env{'request.course.id'}) {
1.624     albertel 6182: 	    my $coursereply=&resdata($env{'course.'.$courseid.'.num'},
                   6183: 				     $env{'course.'.$courseid.'.domain'},
                   6184: 				     'course',
                   6185: 				     ($courselevelm,$courselevel));
1.593     albertel 6186: 	    if (defined($coursereply)) { return $coursereply; }
                   6187: 	}
1.145     www      6188: # ------------------------------------------------------------------ Cascade up
1.218     albertel 6189: 	unless ($space eq '0') {
1.336     albertel 6190: 	    my @parts=split(/_/,$space);
                   6191: 	    my $id=pop(@parts);
                   6192: 	    my $part=join('_',@parts);
                   6193: 	    if ($part eq '') { $part='0'; }
                   6194: 	    my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,
1.395     albertel 6195: 				 $symbparm,$udom,$uname,$section,1);
1.337     albertel 6196: 	    if (defined($partgeneral)) { return $partgeneral; }
1.218     albertel 6197: 	}
1.395     albertel 6198: 	if ($recurse) { return undef; }
                   6199: 	my $pack_def=&packages_tab_default($filename,$varname);
                   6200: 	if (defined($pack_def)) { return $pack_def; }
1.71      www      6201: 
1.48      www      6202: # ---------------------------------------------------- Any other user namespace
                   6203:     } elsif ($realm eq 'environment') {
                   6204: # ----------------------------------------------------------------- environment
1.620     albertel 6205: 	if (($uname eq $env{'user.name'})&&($udom eq $env{'user.domain'})) {
                   6206: 	    return $env{'environment.'.$spacequalifierrest};
1.219     albertel 6207: 	} else {
1.770     albertel 6208: 	    if ($uname eq 'anonymous' && $udom eq '') {
                   6209: 		return '';
                   6210: 	    }
1.219     albertel 6211: 	    my %returnhash=&userenvironment($udom,$uname,
                   6212: 					    $spacequalifierrest);
                   6213: 	    return $returnhash{$spacequalifierrest};
                   6214: 	}
1.28      www      6215:     } elsif ($realm eq 'system') {
1.48      www      6216: # ----------------------------------------------------------------- system.time
                   6217: 	if ($space eq 'time') {
                   6218: 	    return time;
                   6219:         }
1.696     albertel 6220:     } elsif ($realm eq 'server') {
                   6221: # ----------------------------------------------------------------- system.time
                   6222: 	if ($space eq 'name') {
                   6223: 	    return $ENV{'SERVER_NAME'};
                   6224:         }
1.28      www      6225:     }
1.48      www      6226:     return '';
1.61      www      6227: }
                   6228: 
1.691     raeburn  6229: sub check_group_parms {
                   6230:     my ($courseid,$groups,$symbparm,$mapparm,$what) = @_;
                   6231:     my @groupitems = ();
                   6232:     my $resultitem;
                   6233:     my @levels = ($symbparm,$mapparm,$what);
                   6234:     foreach my $group (@{$groups}) {
                   6235:         foreach my $level (@levels) {
                   6236:              my $item = $courseid.'.['.$group.'].'.$level;
                   6237:              push(@groupitems,$item);
                   6238:         }
                   6239:     }
                   6240:     my $coursereply = &resdata($env{'course.'.$courseid.'.num'},
                   6241:                             $env{'course.'.$courseid.'.domain'},
                   6242:                                      'course',@groupitems);
                   6243:     return $coursereply;
                   6244: }
                   6245: 
                   6246: sub sort_course_groups { # Sort groups based on defined rankings. Default is sort().
1.733     raeburn  6247:     my ($courseid,@groups) = @_;
                   6248:     @groups = sort(@groups);
1.691     raeburn  6249:     return @groups;
                   6250: }
                   6251: 
1.395     albertel 6252: sub packages_tab_default {
                   6253:     my ($uri,$varname)=@_;
                   6254:     my (undef,$part,$name)=split(/\./,$varname);
1.738     albertel 6255: 
                   6256:     my (@extension,@specifics,$do_default);
                   6257:     foreach my $package (split(/,/,&metadata($uri,'packages'))) {
1.395     albertel 6258: 	my ($pack_type,$pack_part)=split(/_/,$package,2);
1.738     albertel 6259: 	if ($pack_type eq 'default') {
                   6260: 	    $do_default=1;
                   6261: 	} elsif ($pack_type eq 'extension') {
                   6262: 	    push(@extension,[$package,$pack_type,$pack_part]);
1.848     albertel 6263: 	} elsif ($pack_part eq $part) {
                   6264: 	    # only look at packages defaults for packages that this id is
1.738     albertel 6265: 	    push(@specifics,[$package,$pack_type,$pack_part]);
                   6266: 	}
                   6267:     }
                   6268:     # first look for a package that matches the requested part id
                   6269:     foreach my $package (@specifics) {
                   6270: 	my (undef,$pack_type,$pack_part)=@{$package};
                   6271: 	next if ($pack_part ne $part);
                   6272: 	if (defined($packagetab{"$pack_type&$name&default"})) {
                   6273: 	    return $packagetab{"$pack_type&$name&default"};
                   6274: 	}
                   6275:     }
                   6276:     # look for any possible matching non extension_ package
                   6277:     foreach my $package (@specifics) {
                   6278: 	my (undef,$pack_type,$pack_part)=@{$package};
1.468     albertel 6279: 	if (defined($packagetab{"$pack_type&$name&default"})) {
                   6280: 	    return $packagetab{"$pack_type&$name&default"};
                   6281: 	}
1.585     albertel 6282: 	if ($pack_type eq 'part') { $pack_part='0'; }
1.468     albertel 6283: 	if (defined($packagetab{$pack_type."_".$pack_part."&$name&default"})) {
                   6284: 	    return $packagetab{$pack_type."_".$pack_part."&$name&default"};
1.395     albertel 6285: 	}
                   6286:     }
1.738     albertel 6287:     # look for any posible extension_ match
                   6288:     foreach my $package (@extension) {
                   6289: 	my ($package,$pack_type)=@{$package};
                   6290: 	if (defined($packagetab{"$pack_type&$name&default"})) {
                   6291: 	    return $packagetab{"$pack_type&$name&default"};
                   6292: 	}
                   6293: 	if (defined($packagetab{$package."&$name&default"})) {
                   6294: 	    return $packagetab{$package."&$name&default"};
                   6295: 	}
                   6296:     }
                   6297:     # look for a global default setting
                   6298:     if ($do_default && defined($packagetab{"default&$name&default"})) {
                   6299: 	return $packagetab{"default&$name&default"};
                   6300:     }
1.395     albertel 6301:     return undef;
                   6302: }
                   6303: 
1.334     albertel 6304: sub add_prefix_and_part {
                   6305:     my ($prefix,$part)=@_;
                   6306:     my $keyroot;
                   6307:     if (defined($prefix) && $prefix !~ /^__/) {
                   6308: 	# prefix that has a part already
                   6309: 	$keyroot=$prefix;
                   6310:     } elsif (defined($prefix)) {
                   6311: 	# prefix that is missing a part
                   6312: 	if (defined($part)) { $keyroot='_'.$part.substr($prefix,1); }
                   6313:     } else {
                   6314: 	# no prefix at all
                   6315: 	if (defined($part)) { $keyroot='_'.$part; }
                   6316:     }
                   6317:     return $keyroot;
                   6318: }
                   6319: 
1.71      www      6320: # ---------------------------------------------------------------- Get metadata
                   6321: 
1.599     albertel 6322: my %metaentry;
1.71      www      6323: sub metadata {
1.176     www      6324:     my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
1.71      www      6325:     $uri=&declutter($uri);
1.288     albertel 6326:     # if it is a non metadata possible uri return quickly
1.529     albertel 6327:     if (($uri eq '') || 
                   6328: 	(($uri =~ m|^/*adm/|) && 
1.698     albertel 6329: 	     ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) ||
1.423     albertel 6330:         ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) ||
1.807     albertel 6331: 	($uri =~ m|home/$match_username/public_html/|)) {
1.468     albertel 6332: 	return undef;
1.288     albertel 6333:     }
1.73      www      6334:     my $filename=$uri;
                   6335:     $uri=~s/\.meta$//;
1.172     www      6336: #
                   6337: # Is the metadata already cached?
1.177     www      6338: # Look at timestamp of caching
1.172     www      6339: # Everything is cached by the main uri, libraries are never directly cached
                   6340: #
1.428     albertel 6341:     if (!defined($liburi)) {
1.599     albertel 6342: 	my ($result,$cached)=&is_cached_new('meta',$uri);
1.428     albertel 6343: 	if (defined($cached)) { return $result->{':'.$what}; }
                   6344:     }
                   6345:     {
1.172     www      6346: #
                   6347: # Is this a recursive call for a library?
                   6348: #
1.599     albertel 6349: #	if (! exists($metacache{$uri})) {
                   6350: #	    $metacache{$uri}={};
                   6351: #	}
1.171     www      6352:         if ($liburi) {
                   6353: 	    $liburi=&declutter($liburi);
                   6354:             $filename=$liburi;
1.401     bowersj2 6355:         } else {
1.599     albertel 6356: 	    &devalidate_cache_new('meta',$uri);
                   6357: 	    undef(%metaentry);
1.401     bowersj2 6358: 	}
1.140     www      6359:         my %metathesekeys=();
1.73      www      6360:         unless ($filename=~/\.meta$/) { $filename.='.meta'; }
1.489     albertel 6361: 	my $metastring;
1.768     albertel 6362: 	if ($uri !~ m -^(editupload)/-) {
1.543     albertel 6363: 	    my $file=&filelocation('',&clutter($filename));
1.599     albertel 6364: 	    #push(@{$metaentry{$uri.'.file'}},$file);
1.543     albertel 6365: 	    $metastring=&getfile($file);
1.489     albertel 6366: 	}
1.208     albertel 6367:         my $parser=HTML::LCParser->new(\$metastring);
1.71      www      6368:         my $token;
1.140     www      6369:         undef %metathesekeys;
1.71      www      6370:         while ($token=$parser->get_token) {
1.339     albertel 6371: 	    if ($token->[0] eq 'S') {
                   6372: 		if (defined($token->[2]->{'package'})) {
1.172     www      6373: #
                   6374: # This is a package - get package info
                   6375: #
1.339     albertel 6376: 		    my $package=$token->[2]->{'package'};
                   6377: 		    my $keyroot=&add_prefix_and_part($prefix,$token->[2]->{'part'});
                   6378: 		    if (defined($token->[2]->{'id'})) { 
                   6379: 			$keyroot.='_'.$token->[2]->{'id'}; 
                   6380: 		    }
1.599     albertel 6381: 		    if ($metaentry{':packages'}) {
                   6382: 			$metaentry{':packages'}.=','.$package.$keyroot;
1.339     albertel 6383: 		    } else {
1.599     albertel 6384: 			$metaentry{':packages'}=$package.$keyroot;
1.339     albertel 6385: 		    }
1.736     albertel 6386: 		    foreach my $pack_entry (keys(%packagetab)) {
1.432     albertel 6387: 			my $part=$keyroot;
                   6388: 			$part=~s/^\_//;
1.736     albertel 6389: 			if ($pack_entry=~/^\Q$package\E\&/ || 
                   6390: 			    $pack_entry=~/^\Q$package\E_0\&/) {
                   6391: 			    my ($pack,$name,$subp)=split(/\&/,$pack_entry);
1.395     albertel 6392: 			    # ignore package.tab specified default values
                   6393:                             # here &package_tab_default() will fetch those
                   6394: 			    if ($subp eq 'default') { next; }
1.736     albertel 6395: 			    my $value=$packagetab{$pack_entry};
1.432     albertel 6396: 			    my $unikey;
                   6397: 			    if ($pack =~ /_0$/) {
                   6398: 				$unikey='parameter_0_'.$name;
                   6399: 				$part=0;
                   6400: 			    } else {
                   6401: 				$unikey='parameter'.$keyroot.'_'.$name;
                   6402: 			    }
1.339     albertel 6403: 			    if ($subp eq 'display') {
                   6404: 				$value.=' [Part: '.$part.']';
                   6405: 			    }
1.599     albertel 6406: 			    $metaentry{':'.$unikey.'.part'}=$part;
1.395     albertel 6407: 			    $metathesekeys{$unikey}=1;
1.599     albertel 6408: 			    unless (defined($metaentry{':'.$unikey.'.'.$subp})) {
                   6409: 				$metaentry{':'.$unikey.'.'.$subp}=$value;
1.339     albertel 6410: 			    }
1.599     albertel 6411: 			    if (defined($metaentry{':'.$unikey.'.default'})) {
                   6412: 				$metaentry{':'.$unikey}=
                   6413: 				    $metaentry{':'.$unikey.'.default'};
1.356     albertel 6414: 			    }
1.339     albertel 6415: 			}
                   6416: 		    }
                   6417: 		} else {
1.172     www      6418: #
                   6419: # This is not a package - some other kind of start tag
1.339     albertel 6420: #
                   6421: 		    my $entry=$token->[1];
                   6422: 		    my $unikey;
                   6423: 		    if ($entry eq 'import') {
                   6424: 			$unikey='';
                   6425: 		    } else {
                   6426: 			$unikey=$entry;
                   6427: 		    }
                   6428: 		    $unikey.=&add_prefix_and_part($prefix,$token->[2]->{'part'});
                   6429: 
                   6430: 		    if (defined($token->[2]->{'id'})) { 
                   6431: 			$unikey.='_'.$token->[2]->{'id'}; 
                   6432: 		    }
1.175     www      6433: 
1.339     albertel 6434: 		    if ($entry eq 'import') {
1.175     www      6435: #
                   6436: # Importing a library here
1.339     albertel 6437: #
                   6438: 			if ($depthcount<20) {
                   6439: 			    my $location=$parser->get_text('/import');
                   6440: 			    my $dir=$filename;
                   6441: 			    $dir=~s|[^/]*$||;
                   6442: 			    $location=&filelocation($dir,$location);
1.736     albertel 6443: 			    my $metadata = 
                   6444: 				&metadata($uri,'keys', $location,$unikey,
                   6445: 					  $depthcount+1);
                   6446: 			    foreach my $meta (split(',',$metadata)) {
                   6447: 				$metaentry{':'.$meta}=$metaentry{':'.$meta};
                   6448: 				$metathesekeys{$meta}=1;
1.339     albertel 6449: 			    }
                   6450: 			}
                   6451: 		    } else { 
                   6452: 			
                   6453: 			if (defined($token->[2]->{'name'})) { 
                   6454: 			    $unikey.='_'.$token->[2]->{'name'}; 
                   6455: 			}
                   6456: 			$metathesekeys{$unikey}=1;
1.736     albertel 6457: 			foreach my $param (@{$token->[3]}) {
                   6458: 			    $metaentry{':'.$unikey.'.'.$param} =
                   6459: 				$token->[2]->{$param};
1.339     albertel 6460: 			}
                   6461: 			my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));
1.599     albertel 6462: 			my $default=$metaentry{':'.$unikey.'.default'};
1.339     albertel 6463: 			if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) {
                   6464: 		 # only ws inside the tag, and not in default, so use default
                   6465: 		 # as value
1.599     albertel 6466: 			    $metaentry{':'.$unikey}=$default;
1.339     albertel 6467: 			} else {
1.321     albertel 6468: 		  # either something interesting inside the tag or default
                   6469:                   # uninteresting
1.599     albertel 6470: 			    $metaentry{':'.$unikey}=$internaltext;
1.339     albertel 6471: 			}
1.172     www      6472: # end of not-a-package not-a-library import
1.339     albertel 6473: 		    }
1.172     www      6474: # end of not-a-package start tag
1.339     albertel 6475: 		}
1.172     www      6476: # the next is the end of "start tag"
1.339     albertel 6477: 	    }
                   6478: 	}
1.483     albertel 6479: 	my ($extension) = ($uri =~ /\.(\w+)$/);
1.737     albertel 6480: 	foreach my $key (keys(%packagetab)) {
1.483     albertel 6481: 	    #no specific packages #how's our extension
                   6482: 	    if ($key!~/^extension_\Q$extension\E&/) { next; }
1.488     albertel 6483: 	    &metadata_create_package_def($uri,$key,'extension_'.$extension,
1.483     albertel 6484: 					 \%metathesekeys);
                   6485: 	}
1.599     albertel 6486: 	if (!exists($metaentry{':packages'})) {
1.737     albertel 6487: 	    foreach my $key (keys(%packagetab)) {
1.483     albertel 6488: 		#no specific packages well let's get default then
                   6489: 		if ($key!~/^default&/) { next; }
1.488     albertel 6490: 		&metadata_create_package_def($uri,$key,'default',
1.483     albertel 6491: 					     \%metathesekeys);
                   6492: 	    }
                   6493: 	}
1.338     www      6494: # are there custom rights to evaluate
1.599     albertel 6495: 	if ($metaentry{':copyright'} eq 'custom') {
1.339     albertel 6496: 
1.338     www      6497:     #
                   6498:     # Importing a rights file here
1.339     albertel 6499:     #
                   6500: 	    unless ($depthcount) {
1.599     albertel 6501: 		my $location=$metaentry{':customdistributionfile'};
1.339     albertel 6502: 		my $dir=$filename;
                   6503: 		$dir=~s|[^/]*$||;
                   6504: 		$location=&filelocation($dir,$location);
1.736     albertel 6505: 		my $rights_metadata =
                   6506: 		    &metadata($uri,'keys',$location,'_rights',
                   6507: 			      $depthcount+1);
                   6508: 		foreach my $rights (split(',',$rights_metadata)) {
                   6509: 		    #$metaentry{':'.$rights}=$metacache{$uri}->{':'.$rights};
                   6510: 		    $metathesekeys{$rights}=1;
1.339     albertel 6511: 		}
                   6512: 	    }
                   6513: 	}
1.737     albertel 6514: 	# uniqifiy package listing
                   6515: 	my %seen;
                   6516: 	my @uniq_packages =
                   6517: 	    grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'}));
                   6518: 	$metaentry{':packages'} = join(',',@uniq_packages);
                   6519: 
                   6520: 	$metaentry{':keys'} = join(',',keys(%metathesekeys));
1.599     albertel 6521: 	&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
                   6522: 	$metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);
1.699     albertel 6523: 	&do_cache_new('meta',$uri,\%metaentry,60*60);
1.177     www      6524: # this is the end of "was not already recently cached
1.71      www      6525:     }
1.599     albertel 6526:     return $metaentry{':'.$what};
1.261     albertel 6527: }
                   6528: 
1.488     albertel 6529: sub metadata_create_package_def {
1.483     albertel 6530:     my ($uri,$key,$package,$metathesekeys)=@_;
                   6531:     my ($pack,$name,$subp)=split(/\&/,$key);
                   6532:     if ($subp eq 'default') { next; }
                   6533:     
1.599     albertel 6534:     if (defined($metaentry{':packages'})) {
                   6535: 	$metaentry{':packages'}.=','.$package;
1.483     albertel 6536:     } else {
1.599     albertel 6537: 	$metaentry{':packages'}=$package;
1.483     albertel 6538:     }
                   6539:     my $value=$packagetab{$key};
                   6540:     my $unikey;
                   6541:     $unikey='parameter_0_'.$name;
1.599     albertel 6542:     $metaentry{':'.$unikey.'.part'}=0;
1.483     albertel 6543:     $$metathesekeys{$unikey}=1;
1.599     albertel 6544:     unless (defined($metaentry{':'.$unikey.'.'.$subp})) {
                   6545: 	$metaentry{':'.$unikey.'.'.$subp}=$value;
1.483     albertel 6546:     }
1.599     albertel 6547:     if (defined($metaentry{':'.$unikey.'.default'})) {
                   6548: 	$metaentry{':'.$unikey}=
                   6549: 	    $metaentry{':'.$unikey.'.default'};
1.483     albertel 6550:     }
                   6551: }
                   6552: 
1.261     albertel 6553: sub metadata_generate_part0 {
                   6554:     my ($metadata,$metacache,$uri) = @_;
                   6555:     my %allnames;
1.737     albertel 6556:     foreach my $metakey (keys(%$metadata)) {
1.261     albertel 6557: 	if ($metakey=~/^parameter\_(.*)/) {
1.428     albertel 6558: 	  my $part=$$metacache{':'.$metakey.'.part'};
                   6559: 	  my $name=$$metacache{':'.$metakey.'.name'};
1.356     albertel 6560: 	  if (! exists($$metadata{'parameter_0_'.$name.'.name'})) {
1.261     albertel 6561: 	    $allnames{$name}=$part;
                   6562: 	  }
                   6563: 	}
                   6564:     }
                   6565:     foreach my $name (keys(%allnames)) {
                   6566:       $$metadata{"parameter_0_$name"}=1;
1.428     albertel 6567:       my $key=":parameter_0_$name";
1.261     albertel 6568:       $$metacache{"$key.part"}='0';
                   6569:       $$metacache{"$key.name"}=$name;
1.428     albertel 6570:       $$metacache{"$key.type"}=$$metacache{':parameter_'.
1.261     albertel 6571: 					   $allnames{$name}.'_'.$name.
                   6572: 					   '.type'};
1.428     albertel 6573:       my $olddis=$$metacache{':parameter_'.$allnames{$name}.'_'.$name.
1.261     albertel 6574: 			     '.display'};
1.644     www      6575:       my $expr='[Part: '.$allnames{$name}.']';
1.479     albertel 6576:       $olddis=~s/\Q$expr\E/\[Part: 0\]/;
1.261     albertel 6577:       $$metacache{"$key.display"}=$olddis;
                   6578:     }
1.71      www      6579: }
                   6580: 
1.764     albertel 6581: # ------------------------------------------------------ Devalidate title cache
                   6582: 
                   6583: sub devalidate_title_cache {
                   6584:     my ($url)=@_;
                   6585:     if (!$env{'request.course.id'}) { return; }
                   6586:     my $symb=&symbread($url);
                   6587:     if (!$symb) { return; }
                   6588:     my $key=$env{'request.course.id'}."\0".$symb;
                   6589:     &devalidate_cache_new('title',$key);
                   6590: }
                   6591: 
1.301     www      6592: # ------------------------------------------------- Get the title of a resource
                   6593: 
                   6594: sub gettitle {
                   6595:     my $urlsymb=shift;
                   6596:     my $symb=&symbread($urlsymb);
1.534     albertel 6597:     if ($symb) {
1.620     albertel 6598: 	my $key=$env{'request.course.id'}."\0".$symb;
1.599     albertel 6599: 	my ($result,$cached)=&is_cached_new('title',$key);
1.575     albertel 6600: 	if (defined($cached)) { 
                   6601: 	    return $result;
                   6602: 	}
1.534     albertel 6603: 	my ($map,$resid,$url)=&decode_symb($symb);
                   6604: 	my $title='';
                   6605: 	my %bighash;
1.620     albertel 6606: 	if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
1.534     albertel 6607: 		&GDBM_READER(),0640)) {
                   6608: 	    my $mapid=$bighash{'map_pc_'.&clutter($map)};
                   6609: 	    $title=$bighash{'title_'.$mapid.'.'.$resid};
                   6610: 	    untie %bighash;
                   6611: 	}
                   6612: 	$title=~s/\&colon\;/\:/gs;
                   6613: 	if ($title) {
1.599     albertel 6614: 	    return &do_cache_new('title',$key,$title,600);
1.534     albertel 6615: 	}
                   6616: 	$urlsymb=$url;
                   6617:     }
                   6618:     my $title=&metadata($urlsymb,'title');
                   6619:     if (!$title) { $title=(split('/',$urlsymb))[-1]; }    
                   6620:     return $title;
1.301     www      6621: }
1.613     albertel 6622: 
1.614     albertel 6623: sub get_slot {
                   6624:     my ($which,$cnum,$cdom)=@_;
                   6625:     if (!$cnum || !$cdom) {
1.790     albertel 6626: 	(undef,my $courseid)=&whichuser();
1.620     albertel 6627: 	$cdom=$env{'course.'.$courseid.'.domain'};
                   6628: 	$cnum=$env{'course.'.$courseid.'.num'};
1.614     albertel 6629:     }
1.703     albertel 6630:     my $key=join("\0",'slots',$cdom,$cnum,$which);
                   6631:     my %slotinfo;
                   6632:     if (exists($remembered{$key})) {
                   6633: 	$slotinfo{$which} = $remembered{$key};
                   6634:     } else {
                   6635: 	%slotinfo=&get('slots',[$which],$cdom,$cnum);
                   6636: 	&Apache::lonhomework::showhash(%slotinfo);
                   6637: 	my ($tmp)=keys(%slotinfo);
                   6638: 	if ($tmp=~/^error:/) { return (); }
                   6639: 	$remembered{$key} = $slotinfo{$which};
                   6640:     }
1.616     albertel 6641:     if (ref($slotinfo{$which}) eq 'HASH') {
                   6642: 	return %{$slotinfo{$which}};
                   6643:     }
                   6644:     return $slotinfo{$which};
1.614     albertel 6645: }
1.31      www      6646: # ------------------------------------------------- Update symbolic store links
                   6647: 
                   6648: sub symblist {
                   6649:     my ($mapname,%newhash)=@_;
1.438     www      6650:     $mapname=&deversion(&declutter($mapname));
1.31      www      6651:     my %hash;
1.620     albertel 6652:     if (($env{'request.course.fn'}) && (%newhash)) {
                   6653:         if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
1.256     albertel 6654:                       &GDBM_WRCREAT(),0640)) {
1.711     albertel 6655: 	    foreach my $url (keys %newhash) {
                   6656: 		next if ($url eq 'last_known'
                   6657: 			 && $env{'form.no_update_last_known'});
                   6658: 		$hash{declutter($url)}=&encode_symb($mapname,
                   6659: 						    $newhash{$url}->[1],
                   6660: 						    $newhash{$url}->[0]);
1.191     harris41 6661:             }
1.31      www      6662:             if (untie(%hash)) {
                   6663: 		return 'ok';
                   6664:             }
                   6665:         }
                   6666:     }
                   6667:     return 'error';
1.212     www      6668: }
                   6669: 
                   6670: # --------------------------------------------------------------- Verify a symb
                   6671: 
                   6672: sub symbverify {
1.510     www      6673:     my ($symb,$thisurl)=@_;
                   6674:     my $thisfn=$thisurl;
1.439     www      6675:     $thisfn=&declutter($thisfn);
1.215     www      6676: # direct jump to resource in page or to a sequence - will construct own symbs
                   6677:     if ($thisfn=~/\.(page|sequence)$/) { return 1; }
                   6678: # check URL part
1.409     www      6679:     my ($map,$resid,$url)=&decode_symb($symb);
1.439     www      6680: 
1.431     www      6681:     unless ($url eq $thisfn) { return 0; }
1.213     www      6682: 
1.216     www      6683:     $symb=&symbclean($symb);
1.510     www      6684:     $thisurl=&deversion($thisurl);
1.439     www      6685:     $thisfn=&deversion($thisfn);
1.213     www      6686: 
                   6687:     my %bighash;
                   6688:     my $okay=0;
1.431     www      6689: 
1.620     albertel 6690:     if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
1.256     albertel 6691:                             &GDBM_READER(),0640)) {
1.510     www      6692:         my $ids=$bighash{'ids_'.&clutter($thisurl)};
1.216     www      6693:         unless ($ids) { 
1.510     www      6694:            $ids=$bighash{'ids_/'.$thisurl};
1.216     www      6695:         }
                   6696:         if ($ids) {
                   6697: # ------------------------------------------------------------------- Has ID(s)
1.800     albertel 6698: 	    foreach my $id (split(/\,/,$ids)) {
                   6699: 	       my ($mapid,$resid)=split(/\./,$id);
1.216     www      6700:                if (
                   6701:   &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)
                   6702:    eq $symb) { 
1.620     albertel 6703: 		   if (($env{'request.role.adv'}) ||
1.800     albertel 6704: 		       $bighash{'encrypted_'.$id} eq $env{'request.enc'}) {
1.582     albertel 6705: 		       $okay=1; 
                   6706: 		   }
                   6707: 	       }
1.216     www      6708: 	   }
                   6709:         }
1.213     www      6710: 	untie(%bighash);
                   6711:     }
                   6712:     return $okay;
1.31      www      6713: }
                   6714: 
1.210     www      6715: # --------------------------------------------------------------- Clean-up symb
                   6716: 
                   6717: sub symbclean {
                   6718:     my $symb=shift;
1.568     albertel 6719:     if ($symb=~m|^/enc/|) { $symb=&Apache::lonenc::unencrypted($symb); }
1.210     www      6720: # remove version from map
                   6721:     $symb=~s/\.(\d+)\.(\w+)\_\_\_/\.$2\_\_\_/;
1.215     www      6722: 
1.210     www      6723: # remove version from URL
                   6724:     $symb=~s/\.(\d+)\.(\w+)$/\.$2/;
1.213     www      6725: 
1.507     www      6726: # remove wrapper
                   6727: 
1.510     www      6728:     $symb=~s/(\_\_\_\d+\_\_\_)adm\/wrapper\/(res\/)*/$1/;
1.694     albertel 6729:     $symb=~s/(\_\_\_\d+\_\_\_)adm\/coursedocs\/showdoc\/(res\/)*/$1/;
1.210     www      6730:     return $symb;
1.409     www      6731: }
                   6732: 
                   6733: # ---------------------------------------------- Split symb to find map and url
1.429     albertel 6734: 
                   6735: sub encode_symb {
                   6736:     my ($map,$resid,$url)=@_;
                   6737:     return &symbclean(&declutter($map).'___'.$resid.'___'.&declutter($url));
                   6738: }
1.409     www      6739: 
                   6740: sub decode_symb {
1.568     albertel 6741:     my $symb=shift;
                   6742:     if ($symb=~m|^/enc/|) { $symb=&Apache::lonenc::unencrypted($symb); }
                   6743:     my ($map,$resid,$url)=split(/___/,$symb);
1.413     www      6744:     return (&fixversion($map),$resid,&fixversion($url));
                   6745: }
                   6746: 
                   6747: sub fixversion {
                   6748:     my $fn=shift;
1.609     banghart 6749:     if ($fn=~/^(adm|uploaded|editupload|public)/) { return $fn; }
1.435     www      6750:     my %bighash;
                   6751:     my $uri=&clutter($fn);
1.620     albertel 6752:     my $key=$env{'request.course.id'}.'_'.$uri;
1.440     www      6753: # is this cached?
1.599     albertel 6754:     my ($result,$cached)=&is_cached_new('courseresversion',$key);
1.440     www      6755:     if (defined($cached)) { return $result; }
                   6756: # unfortunately not cached, or expired
1.620     albertel 6757:     if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
1.440     www      6758: 	    &GDBM_READER(),0640)) {
                   6759:  	if ($bighash{'version_'.$uri}) {
                   6760:  	    my $version=$bighash{'version_'.$uri};
1.444     www      6761:  	    unless (($version eq 'mostrecent') || 
                   6762: 		    ($version==&getversion($uri))) {
1.440     www      6763:  		$uri=~s/\.(\w+)$/\.$version\.$1/;
                   6764:  	    }
                   6765:  	}
                   6766:  	untie %bighash;
1.413     www      6767:     }
1.599     albertel 6768:     return &do_cache_new('courseresversion',$key,&declutter($uri),600);
1.438     www      6769: }
                   6770: 
                   6771: sub deversion {
                   6772:     my $url=shift;
                   6773:     $url=~s/\.\d+\.(\w+)$/\.$1/;
                   6774:     return $url;
1.210     www      6775: }
                   6776: 
1.31      www      6777: # ------------------------------------------------------ Return symb list entry
                   6778: 
                   6779: sub symbread {
1.249     www      6780:     my ($thisfn,$donotrecurse)=@_;
1.542     albertel 6781:     my $cache_str='request.symbread.cached.'.$thisfn;
1.620     albertel 6782:     if (defined($env{$cache_str})) { return $env{$cache_str}; }
1.242     www      6783: # no filename provided? try from environment
1.44      www      6784:     unless ($thisfn) {
1.620     albertel 6785:         if ($env{'request.symb'}) {
                   6786: 	    return $env{$cache_str}=&symbclean($env{'request.symb'});
1.539     albertel 6787: 	}
1.620     albertel 6788: 	$thisfn=$env{'request.filename'};
1.44      www      6789:     }
1.569     albertel 6790:     if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }
1.242     www      6791: # is that filename actually a symb? Verify, clean, and return
                   6792:     if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) {
1.539     albertel 6793: 	if (&symbverify($thisfn,$1)) {
1.620     albertel 6794: 	    return $env{$cache_str}=&symbclean($thisfn);
1.539     albertel 6795: 	}
1.242     www      6796:     }
1.44      www      6797:     $thisfn=declutter($thisfn);
1.31      www      6798:     my %hash;
1.37      www      6799:     my %bighash;
                   6800:     my $syval='';
1.620     albertel 6801:     if (($env{'request.course.fn'}) && ($thisfn)) {
1.481     raeburn  6802:         my $targetfn = $thisfn;
1.609     banghart 6803:         if ( ($thisfn =~ m/^(uploaded|editupload)\//) && ($thisfn !~ m/\.(page|sequence)$/) ) {
1.481     raeburn  6804:             $targetfn = 'adm/wrapper/'.$thisfn;
                   6805:         }
1.687     albertel 6806: 	if ($targetfn =~ m|^adm/wrapper/(ext/.*)|) {
                   6807: 	    $targetfn=$1;
                   6808: 	}
1.620     albertel 6809:         if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
1.256     albertel 6810:                       &GDBM_READER(),0640)) {
1.481     raeburn  6811: 	    $syval=$hash{$targetfn};
1.37      www      6812:             untie(%hash);
                   6813:         }
                   6814: # ---------------------------------------------------------- There was an entry
                   6815:         if ($syval) {
1.601     albertel 6816: 	    #unless ($syval=~/\_\d+$/) {
1.620     albertel 6817: 		#unless ($env{'form.request.prefix'}=~/\.(\d+)\_$/) {
1.601     albertel 6818: 		    #&appenv('request.ambiguous' => $thisfn);
1.620     albertel 6819: 		    #return $env{$cache_str}='';
1.601     albertel 6820: 		#}    
                   6821: 		#$syval.=$1;
                   6822: 	    #}
1.37      www      6823:         } else {
                   6824: # ------------------------------------------------------- Was not in symb table
1.620     albertel 6825:            if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
1.256     albertel 6826:                             &GDBM_READER(),0640)) {
1.37      www      6827: # ---------------------------------------------- Get ID(s) for current resource
1.280     www      6828:               my $ids=$bighash{'ids_'.&clutter($thisfn)};
1.65      www      6829:               unless ($ids) { 
                   6830:                  $ids=$bighash{'ids_/'.$thisfn};
1.242     www      6831:               }
                   6832:               unless ($ids) {
                   6833: # alias?
                   6834: 		  $ids=$bighash{'mapalias_'.$thisfn};
1.65      www      6835:               }
1.37      www      6836:               if ($ids) {
                   6837: # ------------------------------------------------------------------- Has ID(s)
                   6838:                  my @possibilities=split(/\,/,$ids);
1.39      www      6839:                  if ($#possibilities==0) {
                   6840: # ----------------------------------------------- There is only one possibility
1.37      www      6841: 		     my ($mapid,$resid)=split(/\./,$ids);
1.626     albertel 6842: 		     $syval=&encode_symb($bighash{'map_id_'.$mapid},
                   6843: 						    $resid,$thisfn);
1.249     www      6844:                  } elsif (!$donotrecurse) {
1.39      www      6845: # ------------------------------------------ There is more than one possibility
                   6846:                      my $realpossible=0;
1.800     albertel 6847:                      foreach my $id (@possibilities) {
                   6848: 			 my $file=$bighash{'src_'.$id};
1.39      www      6849:                          if (&allowed('bre',$file)) {
1.800     albertel 6850:          		    my ($mapid,$resid)=split(/\./,$id);
1.39      www      6851:                             if ($bighash{'map_type_'.$mapid} ne 'page') {
                   6852: 				$realpossible++;
1.626     albertel 6853:                                 $syval=&encode_symb($bighash{'map_id_'.$mapid},
                   6854: 						    $resid,$thisfn);
1.39      www      6855:                             }
                   6856: 			 }
1.191     harris41 6857:                      }
1.39      www      6858: 		     if ($realpossible!=1) { $syval=''; }
1.249     www      6859:                  } else {
                   6860:                      $syval='';
1.37      www      6861:                  }
                   6862: 	      }
                   6863:               untie(%bighash)
1.481     raeburn  6864:            }
1.31      www      6865:         }
1.62      www      6866:         if ($syval) {
1.620     albertel 6867: 	    return $env{$cache_str}=$syval;
1.62      www      6868:         }
1.31      www      6869:     }
1.44      www      6870:     &appenv('request.ambiguous' => $thisfn);
1.620     albertel 6871:     return $env{$cache_str}='';
1.31      www      6872: }
                   6873: 
                   6874: # ---------------------------------------------------------- Return random seed
                   6875: 
1.32      www      6876: sub numval {
                   6877:     my $txt=shift;
                   6878:     $txt=~tr/A-J/0-9/;
                   6879:     $txt=~tr/a-j/0-9/;
                   6880:     $txt=~tr/K-T/0-9/;
                   6881:     $txt=~tr/k-t/0-9/;
                   6882:     $txt=~tr/U-Z/0-5/;
                   6883:     $txt=~tr/u-z/0-5/;
                   6884:     $txt=~s/\D//g;
1.564     albertel 6885:     if ($_64bit) { if ($txt > 2**32) { return -1; } }
1.32      www      6886:     return int($txt);
1.368     albertel 6887: }
                   6888: 
1.484     albertel 6889: sub numval2 {
                   6890:     my $txt=shift;
                   6891:     $txt=~tr/A-J/0-9/;
                   6892:     $txt=~tr/a-j/0-9/;
                   6893:     $txt=~tr/K-T/0-9/;
                   6894:     $txt=~tr/k-t/0-9/;
                   6895:     $txt=~tr/U-Z/0-5/;
                   6896:     $txt=~tr/u-z/0-5/;
                   6897:     $txt=~s/\D//g;
                   6898:     my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt);
                   6899:     my $total;
                   6900:     foreach my $val (@txts) { $total+=$val; }
1.564     albertel 6901:     if ($_64bit) { if ($total > 2**32) { return -1; } }
1.484     albertel 6902:     return int($total);
                   6903: }
                   6904: 
1.575     albertel 6905: sub numval3 {
                   6906:     use integer;
                   6907:     my $txt=shift;
                   6908:     $txt=~tr/A-J/0-9/;
                   6909:     $txt=~tr/a-j/0-9/;
                   6910:     $txt=~tr/K-T/0-9/;
                   6911:     $txt=~tr/k-t/0-9/;
                   6912:     $txt=~tr/U-Z/0-5/;
                   6913:     $txt=~tr/u-z/0-5/;
                   6914:     $txt=~s/\D//g;
                   6915:     my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt);
                   6916:     my $total;
                   6917:     foreach my $val (@txts) { $total+=$val; }
                   6918:     if ($_64bit) { $total=(($total<<32)>>32); }
                   6919:     return $total;
                   6920: }
                   6921: 
1.675     albertel 6922: sub digest {
                   6923:     my ($data)=@_;
                   6924:     my $digest=&Digest::MD5::md5($data);
                   6925:     my ($a,$b,$c,$d)=unpack("iiii",$digest);
                   6926:     my ($e,$f);
                   6927:     {
                   6928:         use integer;
                   6929:         $e=($a+$b);
                   6930:         $f=($c+$d);
                   6931:         if ($_64bit) {
                   6932:             $e=(($e<<32)>>32);
                   6933:             $f=(($f<<32)>>32);
                   6934:         }
                   6935:     }
                   6936:     if (wantarray) {
                   6937: 	return ($e,$f);
                   6938:     } else {
                   6939: 	my $g;
                   6940: 	{
                   6941: 	    use integer;
                   6942: 	    $g=($e+$f);
                   6943: 	    if ($_64bit) {
                   6944: 		$g=(($g<<32)>>32);
                   6945: 	    }
                   6946: 	}
                   6947: 	return $g;
                   6948:     }
                   6949: }
                   6950: 
1.368     albertel 6951: sub latest_rnd_algorithm_id {
1.675     albertel 6952:     return '64bit5';
1.366     albertel 6953: }
1.32      www      6954: 
1.503     albertel 6955: sub get_rand_alg {
                   6956:     my ($courseid)=@_;
1.790     albertel 6957:     if (!$courseid) { $courseid=(&whichuser())[1]; }
1.503     albertel 6958:     if ($courseid) {
1.620     albertel 6959: 	return $env{"course.$courseid.rndseed"};
1.503     albertel 6960:     }
                   6961:     return &latest_rnd_algorithm_id();
                   6962: }
                   6963: 
1.562     albertel 6964: sub validCODE {
                   6965:     my ($CODE)=@_;
                   6966:     if (defined($CODE) && $CODE ne '' && $CODE =~ /^\w+$/) { return 1; }
                   6967:     return 0;
                   6968: }
                   6969: 
1.491     albertel 6970: sub getCODE {
1.620     albertel 6971:     if (&validCODE($env{'form.CODE'})) { return $env{'form.CODE'}; }
1.618     albertel 6972:     if ( (defined($Apache::lonhomework::parsing_a_problem) ||
                   6973: 	  defined($Apache::lonhomework::parsing_a_task) ) &&
                   6974: 	 &validCODE($Apache::lonhomework::history{'resource.CODE'})) {
1.491     albertel 6975: 	return $Apache::lonhomework::history{'resource.CODE'};
                   6976:     }
                   6977:     return undef;
                   6978: }
                   6979: 
1.31      www      6980: sub rndseed {
1.155     albertel 6981:     my ($symb,$courseid,$domain,$username)=@_;
1.790     albertel 6982:     my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser();
1.155     albertel 6983:     if (!$symb) {
1.366     albertel 6984: 	unless ($symb=$wsymb) { return time; }
                   6985:     }
                   6986:     if (!$courseid) { $courseid=$wcourseid; }
                   6987:     if (!$domain) { $domain=$wdomain; }
                   6988:     if (!$username) { $username=$wusername }
1.503     albertel 6989:     my $which=&get_rand_alg();
1.803     albertel 6990: 
1.491     albertel 6991:     if (defined(&getCODE())) {
1.675     albertel 6992: 	if ($which eq '64bit5') {
                   6993: 	    return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username);
                   6994: 	} elsif ($which eq '64bit4') {
1.575     albertel 6995: 	    return &rndseed_CODE_64bit4($symb,$courseid,$domain,$username);
                   6996: 	} else {
                   6997: 	    return &rndseed_CODE_64bit($symb,$courseid,$domain,$username);
                   6998: 	}
1.675     albertel 6999:     } elsif ($which eq '64bit5') {
                   7000: 	return &rndseed_64bit5($symb,$courseid,$domain,$username);
1.575     albertel 7001:     } elsif ($which eq '64bit4') {
                   7002: 	return &rndseed_64bit4($symb,$courseid,$domain,$username);
1.501     albertel 7003:     } elsif ($which eq '64bit3') {
                   7004: 	return &rndseed_64bit3($symb,$courseid,$domain,$username);
1.443     albertel 7005:     } elsif ($which eq '64bit2') {
                   7006: 	return &rndseed_64bit2($symb,$courseid,$domain,$username);
1.366     albertel 7007:     } elsif ($which eq '64bit') {
                   7008: 	return &rndseed_64bit($symb,$courseid,$domain,$username);
                   7009:     }
                   7010:     return &rndseed_32bit($symb,$courseid,$domain,$username);
                   7011: }
                   7012: 
                   7013: sub rndseed_32bit {
                   7014:     my ($symb,$courseid,$domain,$username)=@_;
                   7015:     {
                   7016: 	use integer;
                   7017: 	my $symbchck=unpack("%32C*",$symb) << 27;
                   7018: 	my $symbseed=numval($symb) << 22;
                   7019: 	my $namechck=unpack("%32C*",$username) << 17;
                   7020: 	my $nameseed=numval($username) << 12;
                   7021: 	my $domainseed=unpack("%32C*",$domain) << 7;
                   7022: 	my $courseseed=unpack("%32C*",$courseid);
                   7023: 	my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;
1.790     albertel 7024: 	#&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
                   7025: 	#&logthis("rndseed :$num:$symb");
1.564     albertel 7026: 	if ($_64bit) { $num=(($num<<32)>>32); }
1.366     albertel 7027: 	return $num;
                   7028:     }
                   7029: }
                   7030: 
                   7031: sub rndseed_64bit {
                   7032:     my ($symb,$courseid,$domain,$username)=@_;
                   7033:     {
                   7034: 	use integer;
                   7035: 	my $symbchck=unpack("%32S*",$symb) << 21;
                   7036: 	my $symbseed=numval($symb) << 10;
                   7037: 	my $namechck=unpack("%32S*",$username);
                   7038: 	
                   7039: 	my $nameseed=numval($username) << 21;
                   7040: 	my $domainseed=unpack("%32S*",$domain) << 10;
                   7041: 	my $courseseed=unpack("%32S*",$courseid);
                   7042: 	
                   7043: 	my $num1=$symbchck+$symbseed+$namechck;
                   7044: 	my $num2=$nameseed+$domainseed+$courseseed;
1.790     albertel 7045: 	#&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
                   7046: 	#&logthis("rndseed :$num:$symb");
1.564     albertel 7047: 	if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
1.366     albertel 7048: 	return "$num1,$num2";
1.155     albertel 7049:     }
1.366     albertel 7050: }
                   7051: 
1.443     albertel 7052: sub rndseed_64bit2 {
                   7053:     my ($symb,$courseid,$domain,$username)=@_;
                   7054:     {
                   7055: 	use integer;
                   7056: 	# strings need to be an even # of cahracters long, it it is odd the
                   7057:         # last characters gets thrown away
                   7058: 	my $symbchck=unpack("%32S*",$symb.' ') << 21;
                   7059: 	my $symbseed=numval($symb) << 10;
                   7060: 	my $namechck=unpack("%32S*",$username.' ');
                   7061: 	
                   7062: 	my $nameseed=numval($username) << 21;
1.501     albertel 7063: 	my $domainseed=unpack("%32S*",$domain.' ') << 10;
                   7064: 	my $courseseed=unpack("%32S*",$courseid.' ');
                   7065: 	
                   7066: 	my $num1=$symbchck+$symbseed+$namechck;
                   7067: 	my $num2=$nameseed+$domainseed+$courseseed;
1.790     albertel 7068: 	#&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
                   7069: 	#&logthis("rndseed :$num:$symb");
1.803     albertel 7070: 	if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
1.501     albertel 7071: 	return "$num1,$num2";
                   7072:     }
                   7073: }
                   7074: 
                   7075: sub rndseed_64bit3 {
                   7076:     my ($symb,$courseid,$domain,$username)=@_;
                   7077:     {
                   7078: 	use integer;
                   7079: 	# strings need to be an even # of cahracters long, it it is odd the
                   7080:         # last characters gets thrown away
                   7081: 	my $symbchck=unpack("%32S*",$symb.' ') << 21;
                   7082: 	my $symbseed=numval2($symb) << 10;
                   7083: 	my $namechck=unpack("%32S*",$username.' ');
                   7084: 	
                   7085: 	my $nameseed=numval2($username) << 21;
1.443     albertel 7086: 	my $domainseed=unpack("%32S*",$domain.' ') << 10;
                   7087: 	my $courseseed=unpack("%32S*",$courseid.' ');
                   7088: 	
                   7089: 	my $num1=$symbchck+$symbseed+$namechck;
                   7090: 	my $num2=$nameseed+$domainseed+$courseseed;
1.790     albertel 7091: 	#&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
                   7092: 	#&logthis("rndseed :$num1:$num2:$_64bit");
1.564     albertel 7093: 	if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
                   7094: 	
1.503     albertel 7095: 	return "$num1:$num2";
1.443     albertel 7096:     }
                   7097: }
                   7098: 
1.575     albertel 7099: sub rndseed_64bit4 {
                   7100:     my ($symb,$courseid,$domain,$username)=@_;
                   7101:     {
                   7102: 	use integer;
                   7103: 	# strings need to be an even # of cahracters long, it it is odd the
                   7104:         # last characters gets thrown away
                   7105: 	my $symbchck=unpack("%32S*",$symb.' ') << 21;
                   7106: 	my $symbseed=numval3($symb) << 10;
                   7107: 	my $namechck=unpack("%32S*",$username.' ');
                   7108: 	
                   7109: 	my $nameseed=numval3($username) << 21;
                   7110: 	my $domainseed=unpack("%32S*",$domain.' ') << 10;
                   7111: 	my $courseseed=unpack("%32S*",$courseid.' ');
                   7112: 	
                   7113: 	my $num1=$symbchck+$symbseed+$namechck;
                   7114: 	my $num2=$nameseed+$domainseed+$courseseed;
1.790     albertel 7115: 	#&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
                   7116: 	#&logthis("rndseed :$num1:$num2:$_64bit");
1.575     albertel 7117: 	if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
                   7118: 	
                   7119: 	return "$num1:$num2";
                   7120:     }
                   7121: }
                   7122: 
1.675     albertel 7123: sub rndseed_64bit5 {
                   7124:     my ($symb,$courseid,$domain,$username)=@_;
                   7125:     my ($num1,$num2)=&digest("$symb,$courseid,$domain,$username");
                   7126:     return "$num1:$num2";
                   7127: }
                   7128: 
1.366     albertel 7129: sub rndseed_CODE_64bit {
                   7130:     my ($symb,$courseid,$domain,$username)=@_;
1.155     albertel 7131:     {
1.366     albertel 7132: 	use integer;
1.443     albertel 7133: 	my $symbchck=unpack("%32S*",$symb.' ') << 16;
1.484     albertel 7134: 	my $symbseed=numval2($symb);
1.491     albertel 7135: 	my $CODEchck=unpack("%32S*",&getCODE().' ') << 16;
                   7136: 	my $CODEseed=numval(&getCODE());
1.443     albertel 7137: 	my $courseseed=unpack("%32S*",$courseid.' ');
1.484     albertel 7138: 	my $num1=$symbseed+$CODEchck;
                   7139: 	my $num2=$CODEseed+$courseseed+$symbchck;
1.790     albertel 7140: 	#&logthis("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck");
                   7141: 	#&logthis("rndseed :$num1:$num2:$symb");
1.564     albertel 7142: 	if ($_64bit) { $num1=(($num1<<32)>>32); }
                   7143: 	if ($_64bit) { $num2=(($num2<<32)>>32); }
1.503     albertel 7144: 	return "$num1:$num2";
1.366     albertel 7145:     }
                   7146: }
                   7147: 
1.575     albertel 7148: sub rndseed_CODE_64bit4 {
                   7149:     my ($symb,$courseid,$domain,$username)=@_;
                   7150:     {
                   7151: 	use integer;
                   7152: 	my $symbchck=unpack("%32S*",$symb.' ') << 16;
                   7153: 	my $symbseed=numval3($symb);
                   7154: 	my $CODEchck=unpack("%32S*",&getCODE().' ') << 16;
                   7155: 	my $CODEseed=numval3(&getCODE());
                   7156: 	my $courseseed=unpack("%32S*",$courseid.' ');
                   7157: 	my $num1=$symbseed+$CODEchck;
                   7158: 	my $num2=$CODEseed+$courseseed+$symbchck;
1.790     albertel 7159: 	#&logthis("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck");
                   7160: 	#&logthis("rndseed :$num1:$num2:$symb");
1.575     albertel 7161: 	if ($_64bit) { $num1=(($num1<<32)>>32); }
                   7162: 	if ($_64bit) { $num2=(($num2<<32)>>32); }
                   7163: 	return "$num1:$num2";
                   7164:     }
                   7165: }
                   7166: 
1.675     albertel 7167: sub rndseed_CODE_64bit5 {
                   7168:     my ($symb,$courseid,$domain,$username)=@_;
                   7169:     my $code = &getCODE();
                   7170:     my ($num1,$num2)=&digest("$symb,$courseid,$code");
                   7171:     return "$num1:$num2";
                   7172: }
                   7173: 
1.366     albertel 7174: sub setup_random_from_rndseed {
                   7175:     my ($rndseed)=@_;
1.503     albertel 7176:     if ($rndseed =~/([,:])/) {
                   7177: 	my ($num1,$num2)=split(/[,:]/,$rndseed);
1.366     albertel 7178: 	&Math::Random::random_set_seed(abs($num1),abs($num2));
                   7179:     } else {
                   7180: 	&Math::Random::random_set_seed_from_phrase($rndseed);
1.98      albertel 7181:     }
1.36      albertel 7182: }
                   7183: 
1.474     albertel 7184: sub latest_receipt_algorithm_id {
1.835     albertel 7185:     return 'receipt3';
1.474     albertel 7186: }
                   7187: 
1.480     www      7188: sub recunique {
                   7189:     my $fucourseid=shift;
                   7190:     my $unique;
1.835     albertel 7191:     if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' ||
                   7192: 	$env{"course.$fucourseid.receiptalg"} eq 'receipt3' ) {
1.620     albertel 7193: 	$unique=$env{"course.$fucourseid.internal.encseed"};
1.480     www      7194:     } else {
                   7195: 	$unique=$perlvar{'lonReceipt'};
                   7196:     }
                   7197:     return unpack("%32C*",$unique);
                   7198: }
                   7199: 
                   7200: sub recprefix {
                   7201:     my $fucourseid=shift;
                   7202:     my $prefix;
1.835     albertel 7203:     if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2'||
                   7204: 	$env{"course.$fucourseid.receiptalg"} eq 'receipt3' ) {
1.620     albertel 7205: 	$prefix=$env{"course.$fucourseid.internal.encpref"};
1.480     www      7206:     } else {
                   7207: 	$prefix=$perlvar{'lonHostID'};
                   7208:     }
                   7209:     return unpack("%32C*",$prefix);
                   7210: }
                   7211: 
1.76      www      7212: sub ireceipt {
1.474     albertel 7213:     my ($funame,$fudom,$fucourseid,$fusymb,$part)=@_;
1.835     albertel 7214: 
                   7215:     my $return =&recprefix($fucourseid).'-';
                   7216: 
                   7217:     if ($env{"course.$fucourseid.receiptalg"} eq 'receipt3' ||
                   7218: 	$env{'request.state'} eq 'construct') {
                   7219: 	$return .= (&digest("$funame,$fudom,$fucourseid,$fusymb,$part")%10000);
                   7220: 	return $return;
                   7221:     }
                   7222: 
1.76      www      7223:     my $cuname=unpack("%32C*",$funame);
                   7224:     my $cudom=unpack("%32C*",$fudom);
                   7225:     my $cucourseid=unpack("%32C*",$fucourseid);
                   7226:     my $cusymb=unpack("%32C*",$fusymb);
1.480     www      7227:     my $cunique=&recunique($fucourseid);
1.474     albertel 7228:     my $cpart=unpack("%32S*",$part);
1.835     albertel 7229:     if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') {
                   7230: 
1.790     albertel 7231: 	#&logthis("doing receipt2  using parts $cpart, uname $cuname and udom $cudom gets  ".($cpart%$cuname)." and ".($cpart%$cudom));
1.474     albertel 7232: 			       
                   7233: 	$return.= ($cunique%$cuname+
                   7234: 		   $cunique%$cudom+
                   7235: 		   $cusymb%$cuname+
                   7236: 		   $cusymb%$cudom+
                   7237: 		   $cucourseid%$cuname+
                   7238: 		   $cucourseid%$cudom+
                   7239: 		   $cpart%$cuname+
                   7240: 		   $cpart%$cudom);
                   7241:     } else {
                   7242: 	$return.= ($cunique%$cuname+
                   7243: 		   $cunique%$cudom+
                   7244: 		   $cusymb%$cuname+
                   7245: 		   $cusymb%$cudom+
                   7246: 		   $cucourseid%$cuname+
                   7247: 		   $cucourseid%$cudom);
                   7248:     }
                   7249:     return $return;
1.76      www      7250: }
                   7251: 
                   7252: sub receipt {
1.474     albertel 7253:     my ($part)=@_;
1.790     albertel 7254:     my ($symb,$courseid,$domain,$name) = &whichuser();
1.474     albertel 7255:     return &ireceipt($name,$domain,$courseid,$symb,$part);
1.76      www      7256: }
1.260     ng       7257: 
1.790     albertel 7258: sub whichuser {
                   7259:     my ($passedsymb)=@_;
                   7260:     my ($symb,$courseid,$domain,$name,$publicuser);
                   7261:     if (defined($env{'form.grade_symb'})) {
                   7262: 	my ($tmp_courseid)=&get_env_multiple('form.grade_courseid');
                   7263: 	my $allowed=&allowed('vgr',$tmp_courseid);
                   7264: 	if (!$allowed &&
                   7265: 	    exists($env{'request.course.sec'}) &&
                   7266: 	    $env{'request.course.sec'} !~ /^\s*$/) {
                   7267: 	    $allowed=&allowed('vgr',$tmp_courseid.
                   7268: 			      '/'.$env{'request.course.sec'});
                   7269: 	}
                   7270: 	if ($allowed) {
                   7271: 	    ($symb)=&get_env_multiple('form.grade_symb');
                   7272: 	    $courseid=$tmp_courseid;
                   7273: 	    ($domain)=&get_env_multiple('form.grade_domain');
                   7274: 	    ($name)=&get_env_multiple('form.grade_username');
                   7275: 	    return ($symb,$courseid,$domain,$name,$publicuser);
                   7276: 	}
                   7277:     }
                   7278:     if (!$passedsymb) {
                   7279: 	$symb=&symbread();
                   7280:     } else {
                   7281: 	$symb=$passedsymb;
                   7282:     }
                   7283:     $courseid=$env{'request.course.id'};
                   7284:     $domain=$env{'user.domain'};
                   7285:     $name=$env{'user.name'};
                   7286:     if ($name eq 'public' && $domain eq 'public') {
                   7287: 	if (!defined($env{'form.username'})) {
                   7288: 	    $env{'form.username'}.=time.rand(10000000);
                   7289: 	}
                   7290: 	$name.=$env{'form.username'};
                   7291:     }
                   7292:     return ($symb,$courseid,$domain,$name,$publicuser);
                   7293: 
                   7294: }
                   7295: 
1.36      albertel 7296: # ------------------------------------------------------------ Serves up a file
1.472     albertel 7297: # returns either the contents of the file or 
                   7298: # -1 if the file doesn't exist
1.481     raeburn  7299: #
                   7300: # if the target is a file that was uploaded via DOCS, 
                   7301: # a check will be made to see if a current copy exists on the local server,
                   7302: # if it does this will be served, otherwise a copy will be retrieved from
                   7303: # the home server for the course and stored in /home/httpd/html/userfiles on
                   7304: # the local server.   
1.472     albertel 7305: 
1.36      albertel 7306: sub getfile {
1.538     albertel 7307:     my ($file) = @_;
1.609     banghart 7308:     if ($file =~ m -^/*(uploaded|editupload)/-) { $file=&filelocation("",$file); }
1.538     albertel 7309:     &repcopy($file);
                   7310:     return &readfile($file);
                   7311: }
                   7312: 
                   7313: sub repcopy_userfile {
                   7314:     my ($file)=@_;
1.609     banghart 7315:     if ($file =~ m -^/*(uploaded|editupload)/-) { $file=&filelocation("",$file); }
1.610     albertel 7316:     if ($file =~ m|^/home/httpd/html/lonUsers/|) { return 'ok'; }
1.538     albertel 7317:     my ($cdom,$cnum,$filename) = 
1.811     albertel 7318: 	($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_name)/+(.*)|);
1.538     albertel 7319:     my $uri="/uploaded/$cdom/$cnum/$filename";
                   7320:     if (-e "$file") {
1.828     www      7321: # we already have a local copy, check it out
1.538     albertel 7322: 	my @fileinfo = stat($file);
1.828     www      7323: 	my $rtncode;
                   7324: 	my $info;
1.538     albertel 7325: 	my $lwpresp = &getuploaded('HEAD',$uri,$cdom,$cnum,\$info,\$rtncode);
1.482     albertel 7326: 	if ($lwpresp ne 'ok') {
1.828     www      7327: # there is no such file anymore, even though we had a local copy
1.482     albertel 7328: 	    if ($rtncode eq '404') {
1.538     albertel 7329: 		unlink($file);
1.482     albertel 7330: 	    }
                   7331: 	    return -1;
                   7332: 	}
                   7333: 	if ($info < $fileinfo[9]) {
1.828     www      7334: # nice, the file we have is up-to-date, just say okay
1.607     raeburn  7335: 	    return 'ok';
1.828     www      7336: 	} else {
                   7337: # the file is outdated, get rid of it
                   7338: 	    unlink($file);
1.482     albertel 7339: 	}
1.828     www      7340:     }
                   7341: # one way or the other, at this point, we don't have the file
                   7342: # construct the correct path for the file
                   7343:     my @parts = ($cdom,$cnum); 
                   7344:     if ($filename =~ m|^(.+)/[^/]+$|) {
                   7345: 	push @parts, split(/\//,$1);
                   7346:     }
                   7347:     my $path = $perlvar{'lonDocRoot'}.'/userfiles';
                   7348:     foreach my $part (@parts) {
                   7349: 	$path .= '/'.$part;
                   7350: 	if (!-e $path) {
                   7351: 	    mkdir($path,0770);
1.482     albertel 7352: 	}
                   7353:     }
1.828     www      7354: # now the path exists for sure
                   7355: # get a user agent
                   7356:     my $ua=new LWP::UserAgent;
                   7357:     my $transferfile=$file.'.in.transfer';
                   7358: # FIXME: this should flock
                   7359:     if (-e $transferfile) { return 'ok'; }
                   7360:     my $request;
                   7361:     $uri=~s/^\///;
1.838     albertel 7362:     $request=new HTTP::Request('GET','http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri);
1.828     www      7363:     my $response=$ua->request($request,$transferfile);
                   7364: # did it work?
                   7365:     if ($response->is_error()) {
                   7366: 	unlink($transferfile);
                   7367: 	&logthis("Userfile repcopy failed for $uri");
                   7368: 	return -1;
                   7369:     }
                   7370: # worked, rename the transfer file
                   7371:     rename($transferfile,$file);
1.607     raeburn  7372:     return 'ok';
1.481     raeburn  7373: }
                   7374: 
1.517     albertel 7375: sub tokenwrapper {
                   7376:     my $uri=shift;
1.552     albertel 7377:     $uri=~s|^http\://([^/]+)||;
                   7378:     $uri=~s|^/||;
1.620     albertel 7379:     $env{'user.environment'}=~/\/([^\/]+)\.id/;
1.517     albertel 7380:     my $token=$1;
1.552     albertel 7381:     my (undef,$udom,$uname,$file)=split('/',$uri,4);
                   7382:     if ($udom && $uname && $file) {
                   7383: 	$file=~s|(\?\.*)*$||;
1.620     albertel 7384:         &appenv("userfile.$udom/$uname/$file" => $env{'request.course.id'});
1.838     albertel 7385:         return 'http://'.&hostname(&homeserver($uname,$udom)).'/'.$uri.
1.517     albertel 7386:                (($uri=~/\?/)?'&':'?').'token='.$token.
                   7387:                                '&tokenissued='.$perlvar{'lonHostID'};
                   7388:     } else {
                   7389:         return '/adm/notfound.html';
                   7390:     }
                   7391: }
                   7392: 
1.828     www      7393: # call with reqtype HEAD: get last modification time
                   7394: # call with reqtype GET: get the file contents
                   7395: # Do not call this with reqtype GET for large files! It loads everything into memory
                   7396: #
1.481     raeburn  7397: sub getuploaded {
                   7398:     my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
                   7399:     $uri=~s/^\///;
1.838     albertel 7400:     $uri = 'http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri;
1.481     raeburn  7401:     my $ua=new LWP::UserAgent;
                   7402:     my $request=new HTTP::Request($reqtype,$uri);
                   7403:     my $response=$ua->request($request);
                   7404:     $$rtncode = $response->code;
1.482     albertel 7405:     if (! $response->is_success()) {
                   7406: 	return 'failed';
                   7407:     }      
                   7408:     if ($reqtype eq 'HEAD') {
1.486     www      7409: 	$$info = &HTTP::Date::str2time( $response->header('Last-modified') );
1.482     albertel 7410:     } elsif ($reqtype eq 'GET') {
                   7411: 	$$info = $response->content;
1.472     albertel 7412:     }
1.482     albertel 7413:     return 'ok';
1.36      albertel 7414: }
                   7415: 
1.481     raeburn  7416: sub readfile {
                   7417:     my $file = shift;
                   7418:     if ( (! -e $file ) || ($file eq '') ) { return -1; };
                   7419:     my $fh;
                   7420:     open($fh,"<$file");
                   7421:     my $a='';
1.800     albertel 7422:     while (my $line = <$fh>) { $a .= $line; }
1.481     raeburn  7423:     return $a;
                   7424: }
                   7425: 
1.36      albertel 7426: sub filelocation {
1.590     banghart 7427:     my ($dir,$file) = @_;
                   7428:     my $location;
                   7429:     $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces
1.700     albertel 7430: 
                   7431:     if ($file =~ m-^/adm/-) {
                   7432: 	$file=~s-^/adm/wrapper/-/-;
                   7433: 	$file=~s-^/adm/coursedocs/showdoc/-/-;
                   7434:     }
1.590     banghart 7435:     if ($file=~m:^/~:) { # is a contruction space reference
                   7436:         $location = $file;
                   7437:         $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;
1.807     albertel 7438:     } elsif ($file=~m{^/home/$match_username/public_html/}) {
1.649     albertel 7439: 	# is a correct contruction space reference
                   7440:         $location = $file;
1.609     banghart 7441:     } elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file
1.590     banghart 7442:         my ($udom,$uname,$filename)=
1.811     albertel 7443:   	    ($file=~m -^/+(?:uploaded|editupload)/+($match_domain)/+($match_name)/+(.*)$-);
1.590     banghart 7444:         my $home=&homeserver($uname,$udom);
                   7445:         my $is_me=0;
                   7446:         my @ids=&current_machine_ids();
                   7447:         foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }
                   7448:         if ($is_me) {
1.740     www      7449:   	    $location=&propath($udom,$uname).
1.590     banghart 7450:   	      '/userfiles/'.$filename;
                   7451:         } else {
                   7452:   	  $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.
                   7453:   	      $udom.'/'.$uname.'/'.$filename;
                   7454:         }
                   7455:     } else {
                   7456:         $file=~s/^\Q$perlvar{'lonDocRoot'}\E//;
                   7457:         $file=~s:^/res/:/:;
                   7458:         if ( !( $file =~ m:^/:) ) {
                   7459:             $location = $dir. '/'.$file;
                   7460:         } else {
                   7461:             $location = '/home/httpd/html/res'.$file;
                   7462:         }
1.59      albertel 7463:     }
1.590     banghart 7464:     $location=~s://+:/:g; # remove duplicate /
                   7465:     while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..
                   7466:     while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./
                   7467:     return $location;
1.46      www      7468: }
1.36      albertel 7469: 
1.46      www      7470: sub hreflocation {
                   7471:     my ($dir,$file)=@_;
1.460     albertel 7472:     unless (($file=~m-^http://-i) || ($file=~m-^/-)) {
1.666     albertel 7473: 	$file=filelocation($dir,$file);
1.700     albertel 7474:     } elsif ($file=~m-^/adm/-) {
                   7475: 	$file=~s-^/adm/wrapper/-/-;
                   7476: 	$file=~s-^/adm/coursedocs/showdoc/-/-;
1.666     albertel 7477:     }
                   7478:     if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) {
                   7479: 	$file=~s-^\Q$perlvar{'lonDocRoot'}\E--;
1.807     albertel 7480:     } elsif ($file=~m-/home/($match_username)/public_html/-) {
                   7481: 	$file=~s-^/home/($match_username)/public_html/-/~$1/-;
1.666     albertel 7482:     } elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) {
1.811     albertel 7483: 	$file=~s-^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/
1.666     albertel 7484: 	    -/uploaded/$1/$2/-x;
1.46      www      7485:     }
1.462     albertel 7486:     return $file;
1.465     albertel 7487: }
                   7488: 
                   7489: sub current_machine_domains {
1.853     albertel 7490:     return &machine_domains(&hostname($perlvar{'lonHostID'}));
                   7491: }
                   7492: 
                   7493: sub machine_domains {
                   7494:     my ($hostname) = @_;
1.465     albertel 7495:     my @domains;
1.838     albertel 7496:     my %hostname = &all_hostnames();
1.465     albertel 7497:     while( my($id, $name) = each(%hostname)) {
1.467     matthew  7498: #	&logthis("-$id-$name-$hostname-");
1.465     albertel 7499: 	if ($hostname eq $name) {
1.844     albertel 7500: 	    push(@domains,&host_domain($id));
1.465     albertel 7501: 	}
                   7502:     }
                   7503:     return @domains;
                   7504: }
                   7505: 
                   7506: sub current_machine_ids {
1.853     albertel 7507:     return &machine_ids(&hostname($perlvar{'lonHostID'}));
                   7508: }
                   7509: 
                   7510: sub machine_ids {
                   7511:     my ($hostname) = @_;
                   7512:     $hostname ||= &hostname($perlvar{'lonHostID'});
1.465     albertel 7513:     my @ids;
1.838     albertel 7514:     my %hostname = &all_hostnames();
1.465     albertel 7515:     while( my($id, $name) = each(%hostname)) {
1.467     matthew  7516: #	&logthis("-$id-$name-$hostname-");
1.465     albertel 7517: 	if ($hostname eq $name) {
                   7518: 	    push(@ids,$id);
                   7519: 	}
                   7520:     }
                   7521:     return @ids;
1.31      www      7522: }
                   7523: 
1.824     raeburn  7524: sub additional_machine_domains {
                   7525:     my @domains;
                   7526:     open(my $fh,"<$perlvar{'lonTabDir'}/expected_domains.tab");
                   7527:     while( my $line = <$fh>) {
                   7528:         $line =~ s/\s//g;
                   7529:         push(@domains,$line);
                   7530:     }
                   7531:     return @domains;
                   7532: }
                   7533: 
                   7534: sub default_login_domain {
                   7535:     my $domain = $perlvar{'lonDefDomain'};
                   7536:     my $testdomain=(split(/\./,$ENV{'HTTP_HOST'}))[0];
                   7537:     foreach my $posdom (&current_machine_domains(),
                   7538:                         &additional_machine_domains()) {
                   7539:         if (lc($posdom) eq lc($testdomain)) {
                   7540:             $domain=$posdom;
                   7541:             last;
                   7542:         }
                   7543:     }
                   7544:     return $domain;
                   7545: }
                   7546: 
1.31      www      7547: # ------------------------------------------------------------- Declutters URLs
                   7548: 
                   7549: sub declutter {
                   7550:     my $thisfn=shift;
1.569     albertel 7551:     if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }
1.479     albertel 7552:     $thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//;
1.31      www      7553:     $thisfn=~s/^\///;
1.697     albertel 7554:     $thisfn=~s|^adm/wrapper/||;
                   7555:     $thisfn=~s|^adm/coursedocs/showdoc/||;
1.31      www      7556:     $thisfn=~s/^res\///;
1.235     www      7557:     $thisfn=~s/\?.+$//;
1.268     www      7558:     return $thisfn;
                   7559: }
                   7560: 
                   7561: # ------------------------------------------------------------- Clutter up URLs
                   7562: 
                   7563: sub clutter {
                   7564:     my $thisfn='/'.&declutter(shift);
1.609     banghart 7565:     unless ($thisfn=~/^\/(uploaded|editupload|adm|userfiles|ext|raw|priv|public)\//) { 
1.270     www      7566:        $thisfn='/res'.$thisfn; 
                   7567:     }
1.694     albertel 7568:     if ($thisfn !~m|/adm|) {
1.695     albertel 7569: 	if ($thisfn =~ m|/ext/|) {
1.694     albertel 7570: 	    $thisfn='/adm/wrapper'.$thisfn;
1.695     albertel 7571: 	} else {
                   7572: 	    my ($ext) = ($thisfn =~ /\.(\w+)$/);
                   7573: 	    my $embstyle=&Apache::loncommon::fileembstyle($ext);
1.698     albertel 7574: 	    if ($embstyle eq 'ssi'
                   7575: 		|| ($embstyle eq 'hdn')
                   7576: 		|| ($embstyle eq 'rat')
                   7577: 		|| ($embstyle eq 'prv')
                   7578: 		|| ($embstyle eq 'ign')) {
                   7579: 		#do nothing with these
                   7580: 	    } elsif (($embstyle eq 'img') 
1.695     albertel 7581: 		|| ($embstyle eq 'emb')
                   7582: 		|| ($embstyle eq 'wrp')) {
                   7583: 		$thisfn='/adm/wrapper'.$thisfn;
1.698     albertel 7584: 	    } elsif ($embstyle eq 'unk'
                   7585: 		     && $thisfn!~/\.(sequence|page)$/) {
1.695     albertel 7586: 		$thisfn='/adm/coursedocs/showdoc'.$thisfn;
1.698     albertel 7587: 	    } else {
1.718     www      7588: #		&logthis("Got a blank emb style");
1.695     albertel 7589: 	    }
1.694     albertel 7590: 	}
                   7591:     }
1.31      www      7592:     return $thisfn;
1.12      www      7593: }
                   7594: 
1.787     albertel 7595: sub clutter_with_no_wrapper {
                   7596:     my $uri = &clutter(shift);
                   7597:     if ($uri =~ m-^/adm/-) {
                   7598: 	$uri =~ s-^/adm/wrapper/-/-;
                   7599: 	$uri =~ s-^/adm/coursedocs/showdoc/-/-;
                   7600:     }
                   7601:     return $uri;
                   7602: }
                   7603: 
1.557     albertel 7604: sub freeze_escape {
                   7605:     my ($value)=@_;
                   7606:     if (ref($value)) {
                   7607: 	$value=&nfreeze($value);
                   7608: 	return '__FROZEN__'.&escape($value);
                   7609:     }
                   7610:     return &escape($value);
                   7611: }
                   7612: 
1.11      www      7613: 
1.557     albertel 7614: sub thaw_unescape {
                   7615:     my ($value)=@_;
                   7616:     if ($value =~ /^__FROZEN__/) {
                   7617: 	substr($value,0,10,undef);
                   7618: 	$value=&unescape($value);
                   7619: 	return &thaw($value);
                   7620:     }
                   7621:     return &unescape($value);
                   7622: }
                   7623: 
1.436     albertel 7624: sub correct_line_ends {
                   7625:     my ($result)=@_;
                   7626:     $$result =~s/\r\n/\n/mg;
                   7627:     $$result =~s/\r/\n/mg;
1.415     albertel 7628: }
1.1       albertel 7629: # ================================================================ Main Program
                   7630: 
1.184     www      7631: sub goodbye {
1.204     albertel 7632:    &logthis("Starting Shut down");
1.443     albertel 7633: #not converted to using infrastruture and probably shouldn't be
1.599     albertel 7634:    &logthis(sprintf("%-20s is %s",'%badServerCache',length(&freeze(\%badServerCache))));
1.443     albertel 7635: #converted
1.599     albertel 7636: #   &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));
                   7637:    &logthis(sprintf("%-20s is %s",'%homecache',length(&freeze(\%homecache))));
                   7638: #   &logthis(sprintf("%-20s is %s",'%titlecache',length(&freeze(\%titlecache))));
                   7639: #   &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&freeze(\%courseresdatacache))));
1.425     albertel 7640: #1.1 only
1.599     albertel 7641: #   &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&freeze(\%userresdatacache))));
                   7642: #   &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&freeze(\%getsectioncache))));
                   7643: #   &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&freeze(\%courseresversioncache))));
                   7644: #   &logthis(sprintf("%-20s is %s",'%resversioncache',length(&freeze(\%resversioncache))));
                   7645:    &logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered))));
                   7646:    &logthis(sprintf("%-20s is %s",'kicks',$kicks));
                   7647:    &logthis(sprintf("%-20s is %s",'hits',$hits));
1.184     www      7648:    &flushcourselogs();
                   7649:    &logthis("Shutting down");
                   7650: }
                   7651: 
1.852     albertel 7652: sub get_dns {
                   7653:     my ($url,$func) = @_;
                   7654:     open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
                   7655:     foreach my $dns (<$config>) {
                   7656: 	next if ($dns !~ /^\^(\S*)/x);
                   7657: 	$dns = $1;
                   7658: 	my $ua=new LWP::UserAgent;
                   7659: 	my $request=new HTTP::Request('GET',"http://$dns$url");
                   7660: 	my $response=$ua->request($request);
                   7661: 	next if ($response->is_error());
                   7662: 	my @content = split("\n",$response->content);
                   7663: 	&$func(\@content);
                   7664:     }
                   7665:     close($config);
                   7666: }
1.327     albertel 7667: # ------------------------------------------------------------ Read domain file
                   7668: {
1.852     albertel 7669:     my $loaded;
1.846     albertel 7670:     my %domain;
                   7671: 
1.852     albertel 7672:     sub parse_domain_tab {
                   7673: 	my ($lines) = @_;
                   7674: 	foreach my $line (@$lines) {
                   7675: 	    next if ($line =~ /^(\#|\s*$ )/x);
1.403     www      7676: 
1.846     albertel 7677: 	    chomp($line);
1.852     albertel 7678: 	    my ($name,@elements) = split(/:/,$line,9);
1.846     albertel 7679: 	    my %this_domain;
                   7680: 	    foreach my $field ('description', 'auth_def', 'auth_arg_def',
                   7681: 			       'lang_def', 'city', 'longi', 'lati',
                   7682: 			       'primary') {
                   7683: 		$this_domain{$field} = shift(@elements);
                   7684: 	    }
                   7685: 	    $domain{$name} = \%this_domain;
1.852     albertel 7686: 	}
                   7687:     }
1.864   ! albertel 7688: 
        !          7689:     sub reset_domain_info {
        !          7690: 	undef($loaded);
        !          7691: 	undef(%domain);
        !          7692:     }
        !          7693: 
1.852     albertel 7694:     sub load_domain_tab {
                   7695: 	&get_dns('/adm/dns/domain',\&parse_domain_tab);
                   7696: 	my $fh;
                   7697: 	if (open($fh,"<".$perlvar{'lonTabDir'}.'/domain.tab')) {
                   7698: 	    my @lines = <$fh>;
                   7699: 	    &parse_domain_tab(\@lines);
1.448     albertel 7700: 	}
1.852     albertel 7701: 	close($fh);
                   7702: 	$loaded = 1;
1.327     albertel 7703:     }
1.846     albertel 7704: 
                   7705:     sub domain {
1.852     albertel 7706: 	&load_domain_tab() if (!$loaded);
                   7707: 
1.846     albertel 7708: 	my ($name,$what) = @_;
                   7709: 	return if ( !exists($domain{$name}) );
                   7710: 
                   7711: 	if (!$what) {
                   7712: 	    return $domain{$name}{'description'};
                   7713: 	}
                   7714: 	return $domain{$name}{$what};
                   7715:     }
1.327     albertel 7716: }
                   7717: 
                   7718: 
1.1       albertel 7719: # ------------------------------------------------------------- Read hosts file
                   7720: {
1.838     albertel 7721:     my %hostname;
1.844     albertel 7722:     my %hostdom;
1.845     albertel 7723:     my %libserv;
1.852     albertel 7724:     my $loaded;
                   7725: 
                   7726:     sub parse_hosts_tab {
                   7727: 	my ($file) = @_;
                   7728: 	foreach my $configline (@$file) {
                   7729: 	    next if ($configline =~ /^(\#|\s*$ )/x);
                   7730: 	    next if ($configline =~ /^\^/);
                   7731: 	    chomp($configline);
                   7732: 	    my ($id,$domain,$role,$name)=split(/:/,$configline);
                   7733: 	    $name=~s/\s//g;
                   7734: 	    if ($id && $domain && $role && $name) {
                   7735: 		$hostname{$id}=$name;
                   7736: 		$hostdom{$id}=$domain;
                   7737: 		if ($role eq 'library') { $libserv{$id}=$name; }
                   7738: 	    }
                   7739: 	}
                   7740:     }
1.864   ! albertel 7741:     
        !          7742:     sub reset_hosts_info {
        !          7743: 	&reset_domain_info();
        !          7744: 	&reset_hosts_ip_info();
        !          7745: 	undef(%hostname);
        !          7746: 	undef(%hostdom);
        !          7747: 	undef(%libserv);
        !          7748: 	undef($loaded);
        !          7749:     }
1.1       albertel 7750: 
1.852     albertel 7751:     sub load_hosts_tab {
                   7752: 	&get_dns('/adm/dns/hosts',\&parse_hosts_tab);
                   7753: 	open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
                   7754: 	my @config = <$config>;
                   7755: 	&parse_hosts_tab(\@config);
                   7756: 	close($config);
                   7757: 	$loaded=1;
1.1       albertel 7758:     }
1.852     albertel 7759: 
1.838     albertel 7760:     sub hostname {
1.852     albertel 7761: 	&load_hosts_tab() if (!$loaded);
                   7762: 
1.838     albertel 7763: 	my ($lonid) = @_;
                   7764: 	return $hostname{$lonid};
                   7765:     }
1.845     albertel 7766: 
1.838     albertel 7767:     sub all_hostnames {
1.852     albertel 7768: 	&load_hosts_tab() if (!$loaded);
                   7769: 
1.838     albertel 7770: 	return %hostname;
                   7771:     }
1.845     albertel 7772: 
                   7773:     sub is_library {
1.852     albertel 7774: 	&load_hosts_tab() if (!$loaded);
                   7775: 
1.845     albertel 7776: 	return exists($libserv{$_[0]});
                   7777:     }
                   7778: 
                   7779:     sub all_library {
1.852     albertel 7780: 	&load_hosts_tab() if (!$loaded);
                   7781: 
1.845     albertel 7782: 	return %libserv;
                   7783:     }
                   7784: 
1.841     albertel 7785:     sub get_servers {
1.852     albertel 7786: 	&load_hosts_tab() if (!$loaded);
                   7787: 
1.841     albertel 7788: 	my ($domain,$type) = @_;
                   7789: 	my %possible_hosts = ($type eq 'library') ? %libserv
                   7790: 	                                          : %hostname;
                   7791: 	my %result;
1.842     albertel 7792: 	if (ref($domain) eq 'ARRAY') {
                   7793: 	    while ( my ($host,$hostname) = each(%possible_hosts)) {
1.843     albertel 7794: 		if (grep(/^\Q$hostdom{$host}\E$/,@$domain)) {
1.842     albertel 7795: 		    $result{$host} = $hostname;
                   7796: 		}
                   7797: 	    }
                   7798: 	} else {
                   7799: 	    while ( my ($host,$hostname) = each(%possible_hosts)) {
                   7800: 		if ($hostdom{$host} eq $domain) {
                   7801: 		    $result{$host} = $hostname;
                   7802: 		}
1.841     albertel 7803: 	    }
                   7804: 	}
                   7805: 	return %result;
                   7806:     }
1.845     albertel 7807: 
1.844     albertel 7808:     sub host_domain {
1.852     albertel 7809: 	&load_hosts_tab() if (!$loaded);
                   7810: 
1.844     albertel 7811: 	my ($lonid) = @_;
                   7812: 	return $hostdom{$lonid};
                   7813:     }
                   7814: 
1.841     albertel 7815:     sub all_domains {
1.852     albertel 7816: 	&load_hosts_tab() if (!$loaded);
                   7817: 
1.841     albertel 7818: 	my %seen;
                   7819: 	my @uniq = grep(!$seen{$_}++, values(%hostdom));
                   7820: 	return @uniq;
                   7821:     }
1.1       albertel 7822: }
                   7823: 
1.847     albertel 7824: { 
                   7825:     my %iphost;
1.856     albertel 7826:     my %name_to_ip;
                   7827:     my %lonid_to_ip;
1.847     albertel 7828:     sub get_hosts_from_ip {
                   7829: 	my ($ip) = @_;
                   7830: 	my %iphosts = &get_iphost();
                   7831: 	if (ref($iphosts{$ip})) {
                   7832: 	    return @{$iphosts{$ip}};
                   7833: 	}
                   7834: 	return;
1.839     albertel 7835:     }
1.864   ! albertel 7836:     
        !          7837:     sub reset_hosts_ip_info {
        !          7838: 	undef(%iphost);
        !          7839: 	undef(%name_to_ip);
        !          7840: 	undef(%lonid_to_ip);
        !          7841:     }
1.856     albertel 7842: 
                   7843:     sub get_host_ip {
                   7844: 	my ($lonid) = @_;
                   7845: 	if (exists($lonid_to_ip{$lonid})) {
                   7846: 	    return $lonid_to_ip{$lonid};
                   7847: 	}
                   7848: 	my $name=&hostname($lonid);
                   7849:    	my $ip = gethostbyname($name);
                   7850: 	return if (!$ip || length($ip) ne 4);
                   7851: 	$ip=inet_ntoa($ip);
                   7852: 	$name_to_ip{$name}   = $ip;
                   7853: 	$lonid_to_ip{$lonid} = $ip;
                   7854: 	return $ip;
                   7855:     }
1.847     albertel 7856:     
                   7857:     sub get_iphost {
                   7858: 	if (%iphost) { return %iphost; }
                   7859: 	my %hostname = &all_hostnames();
                   7860: 	foreach my $id (keys(%hostname)) {
1.864   ! albertel 7861: 	    my $name=&hostname($id);
1.847     albertel 7862: 	    my $ip;
                   7863: 	    if (!exists($name_to_ip{$name})) {
                   7864: 		$ip = gethostbyname($name);
                   7865: 		if (!$ip || length($ip) ne 4) {
                   7866: 		    &logthis("Skipping host $id name $name no IP found");
                   7867: 		    next;
                   7868: 		}
                   7869: 		$ip=inet_ntoa($ip);
                   7870: 		$name_to_ip{$name} = $ip;
                   7871: 	    } else {
                   7872: 		$ip = $name_to_ip{$name};
1.653     albertel 7873: 	    }
1.856     albertel 7874: 	    $lonid_to_ip{$id} = $ip;
1.847     albertel 7875: 	    push(@{$iphost{$ip}},$id);
1.598     albertel 7876: 	}
1.847     albertel 7877: 	return %iphost;
1.598     albertel 7878:     }
                   7879: }
                   7880: 
1.862     albertel 7881: BEGIN {
                   7882: 
                   7883: # ----------------------------------- Read loncapa.conf and loncapa_apache.conf
                   7884:     unless ($readit) {
                   7885: {
                   7886:     my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf');
                   7887:     %perlvar = (%perlvar,%{$configvars});
                   7888: }
                   7889: 
                   7890: 
1.1       albertel 7891: # ------------------------------------------------------ Read spare server file
                   7892: {
1.448     albertel 7893:     open(my $config,"<$perlvar{'lonTabDir'}/spare.tab");
1.1       albertel 7894: 
                   7895:     while (my $configline=<$config>) {
                   7896:        chomp($configline);
1.284     matthew  7897:        if ($configline) {
1.784     albertel 7898: 	   my ($host,$type) = split(':',$configline,2);
1.785     albertel 7899: 	   if (!defined($type) || $type eq '') { $type = 'default' };
1.784     albertel 7900: 	   push(@{ $spareid{$type} }, $host);
1.1       albertel 7901:        }
                   7902:     }
1.448     albertel 7903:     close($config);
1.1       albertel 7904: }
1.11      www      7905: # ------------------------------------------------------------ Read permissions
                   7906: {
1.448     albertel 7907:     open(my $config,"<$perlvar{'lonTabDir'}/roles.tab");
1.11      www      7908: 
                   7909:     while (my $configline=<$config>) {
1.448     albertel 7910: 	chomp($configline);
                   7911: 	if ($configline) {
                   7912: 	    my ($role,$perm)=split(/ /,$configline);
                   7913: 	    if ($perm ne '') { $pr{$role}=$perm; }
                   7914: 	}
1.11      www      7915:     }
1.448     albertel 7916:     close($config);
1.11      www      7917: }
                   7918: 
                   7919: # -------------------------------------------- Read plain texts for permissions
                   7920: {
1.448     albertel 7921:     open(my $config,"<$perlvar{'lonTabDir'}/rolesplain.tab");
1.11      www      7922: 
                   7923:     while (my $configline=<$config>) {
1.448     albertel 7924: 	chomp($configline);
                   7925: 	if ($configline) {
1.742     raeburn  7926: 	    my ($short,@plain)=split(/:/,$configline);
                   7927:             %{$prp{$short}} = ();
                   7928: 	    if (@plain > 0) {
                   7929:                 $prp{$short}{'std'} = $plain[0];
                   7930:                 for (my $i=1; $i<@plain; $i++) {
                   7931:                     $prp{$short}{'alt'.$i} = $plain[$i];  
                   7932:                 }
                   7933:             }
1.448     albertel 7934: 	}
1.135     www      7935:     }
1.448     albertel 7936:     close($config);
1.135     www      7937: }
                   7938: 
                   7939: # ---------------------------------------------------------- Read package table
                   7940: {
1.448     albertel 7941:     open(my $config,"<$perlvar{'lonTabDir'}/packages.tab");
1.135     www      7942: 
                   7943:     while (my $configline=<$config>) {
1.483     albertel 7944: 	if ($configline !~ /\S/ || $configline=~/^#/) { next; }
1.448     albertel 7945: 	chomp($configline);
                   7946: 	my ($short,$plain)=split(/:/,$configline);
                   7947: 	my ($pack,$name)=split(/\&/,$short);
                   7948: 	if ($plain ne '') {
                   7949: 	    $packagetab{$pack.'&'.$name.'&name'}=$name; 
                   7950: 	    $packagetab{$short}=$plain; 
                   7951: 	}
1.11      www      7952:     }
1.448     albertel 7953:     close($config);
1.329     matthew  7954: }
                   7955: 
                   7956: # ------------- set up temporary directory
                   7957: {
                   7958:     $tmpdir = $perlvar{'lonDaemons'}.'/tmp/';
                   7959: 
1.11      www      7960: }
                   7961: 
1.794     albertel 7962: $memcache=new Cache::Memcached({'servers'           => ['127.0.0.1:11211'],
                   7963: 				'compress_threshold'=> 20_000,
                   7964:  			        });
1.185     www      7965: 
1.281     www      7966: $processmarker='_'.time.'_'.$perlvar{'lonHostID'};
1.186     www      7967: $dumpcount=0;
1.22      www      7968: 
1.163     harris41 7969: &logtouch();
1.672     albertel 7970: &logthis('<font color="yellow">INFO: Read configuration</font>');
1.195     www      7971: $readit=1;
1.564     albertel 7972:     {
                   7973: 	use integer;
                   7974: 	my $test=(2**32)+1;
1.568     albertel 7975: 	if ($test != 0) { $_64bit=1; } else { $_64bit=0; }
1.564     albertel 7976: 	&logthis(" Detected 64bit platform ($_64bit)");
                   7977:     }
1.195     www      7978: }
1.1       albertel 7979: }
1.179     www      7980: 
1.1       albertel 7981: 1;
1.191     harris41 7982: __END__
                   7983: 
1.243     albertel 7984: =pod
                   7985: 
1.191     harris41 7986: =head1 NAME
                   7987: 
1.243     albertel 7988: Apache::lonnet - Subroutines to ask questions about things in the network.
1.191     harris41 7989: 
                   7990: =head1 SYNOPSIS
                   7991: 
1.243     albertel 7992: Invoked by other LON-CAPA modules, when they need to talk to or about objects in the network.
1.191     harris41 7993: 
                   7994:  &Apache::lonnet::SUBROUTINENAME(ARGUMENTS);
                   7995: 
1.243     albertel 7996: Common parameters:
                   7997: 
                   7998: =over 4
                   7999: 
                   8000: =item *
                   8001: 
                   8002: $uname : an internal username (if $cname expecting a course Id specifically)
                   8003: 
                   8004: =item *
                   8005: 
                   8006: $udom : a domain (if $cdom expecting a course's domain specifically)
                   8007: 
                   8008: =item *
                   8009: 
                   8010: $symb : a resource instance identifier
                   8011: 
                   8012: =item *
                   8013: 
                   8014: $namespace : the name of a .db file that contains the data needed or
                   8015: being set.
                   8016: 
                   8017: =back
                   8018: 
1.394     bowersj2 8019: =head1 OVERVIEW
1.191     harris41 8020: 
1.394     bowersj2 8021: lonnet provides subroutines which interact with the
                   8022: lonc/lond (TCP) network layer of LON-CAPA. They can be used to ask
                   8023: about classes, users, and resources.
1.243     albertel 8024: 
                   8025: For many of these objects you can also use this to store data about
                   8026: them or modify them in various ways.
1.191     harris41 8027: 
1.394     bowersj2 8028: =head2 Symbs
1.191     harris41 8029: 
1.394     bowersj2 8030: To identify a specific instance of a resource, LON-CAPA uses symbols
                   8031: or "symbs"X<symb>. These identifiers are built from the URL of the
                   8032: map, the resource number of the resource in the map, and the URL of
                   8033: the resource itself. The latter is somewhat redundant, but might help
                   8034: if maps change.
                   8035: 
                   8036: An example is
                   8037: 
                   8038:  msu/korte/parts/part1.sequence___19___msu/korte/tests/part12.problem
                   8039: 
                   8040: The respective map entry is
                   8041: 
                   8042:  <resource id="19" src="/res/msu/korte/tests/part12.problem"
                   8043:   title="Problem 2">
                   8044:  </resource>
                   8045: 
                   8046: Symbs are used by the random number generator, as well as to store and
                   8047: restore data specific to a certain instance of for example a problem.
                   8048: 
                   8049: =head2 Storing And Retrieving Data
                   8050: 
                   8051: X<store()>X<cstore()>X<restore()>Three of the most important functions
                   8052: in C<lonnet.pm> are C<&Apache::lonnet::cstore()>,
                   8053: C<&Apache::lonnet:restore()>, and C<&Apache::lonnet::store()>, which
                   8054: is is the non-critical message twin of cstore. These functions are for
                   8055: handlers to store a perl hash to a user's permanent data space in an
                   8056: easy manner, and to retrieve it again on another call. It is expected
                   8057: that a handler would use this once at the beginning to retrieve data,
                   8058: and then again once at the end to send only the new data back.
                   8059: 
                   8060: The data is stored in the user's data directory on the user's
                   8061: homeserver under the ID of the course.
                   8062: 
                   8063: The hash that is returned by restore will have all of the previous
                   8064: value for all of the elements of the hash.
                   8065: 
                   8066: Example:
                   8067: 
                   8068:  #creating a hash
                   8069:  my %hash;
                   8070:  $hash{'foo'}='bar';
                   8071: 
                   8072:  #storing it
                   8073:  &Apache::lonnet::cstore(\%hash);
                   8074: 
                   8075:  #changing a value
                   8076:  $hash{'foo'}='notbar';
                   8077: 
                   8078:  #adding a new value
                   8079:  $hash{'bar'}='foo';
                   8080:  &Apache::lonnet::cstore(\%hash);
                   8081: 
                   8082:  #retrieving the hash
                   8083:  my %history=&Apache::lonnet::restore();
                   8084: 
                   8085:  #print the hash
                   8086:  foreach my $key (sort(keys(%history))) {
                   8087:    print("\%history{$key} = $history{$key}");
                   8088:  }
                   8089: 
                   8090: Will print out:
1.191     harris41 8091: 
1.394     bowersj2 8092:  %history{1:foo} = bar
                   8093:  %history{1:keys} = foo:timestamp
                   8094:  %history{1:timestamp} = 990455579
                   8095:  %history{2:bar} = foo
                   8096:  %history{2:foo} = notbar
                   8097:  %history{2:keys} = foo:bar:timestamp
                   8098:  %history{2:timestamp} = 990455580
                   8099:  %history{bar} = foo
                   8100:  %history{foo} = notbar
                   8101:  %history{timestamp} = 990455580
                   8102:  %history{version} = 2
                   8103: 
                   8104: Note that the special hash entries C<keys>, C<version> and
                   8105: C<timestamp> were added to the hash. C<version> will be equal to the
                   8106: total number of versions of the data that have been stored. The
                   8107: C<timestamp> attribute will be the UNIX time the hash was
                   8108: stored. C<keys> is available in every historical section to list which
                   8109: keys were added or changed at a specific historical revision of a
                   8110: hash.
                   8111: 
                   8112: B<Warning>: do not store the hash that restore returns directly. This
                   8113: will cause a mess since it will restore the historical keys as if the
                   8114: were new keys. I.E. 1:foo will become 1:1:foo etc.
1.191     harris41 8115: 
1.394     bowersj2 8116: Calling convention:
1.191     harris41 8117: 
1.394     bowersj2 8118:  my %record=&Apache::lonnet::restore($symb,$courseid,$domain,$uname,$home);
                   8119:  &Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname,$home);
1.191     harris41 8120: 
1.394     bowersj2 8121: For more detailed information, see lonnet specific documentation.
1.191     harris41 8122: 
1.394     bowersj2 8123: =head1 RETURN MESSAGES
1.191     harris41 8124: 
1.394     bowersj2 8125: =over 4
1.191     harris41 8126: 
1.394     bowersj2 8127: =item * B<con_lost>: unable to contact remote host
1.191     harris41 8128: 
1.394     bowersj2 8129: =item * B<con_delayed>: unable to contact remote host, message will be delivered
                   8130: when the connection is brought back up
1.191     harris41 8131: 
1.394     bowersj2 8132: =item * B<con_failed>: unable to contact remote host and unable to save message
                   8133: for later delivery
1.191     harris41 8134: 
1.394     bowersj2 8135: =item * B<error:>: an error a occured, a description of the error follows the :
1.191     harris41 8136: 
1.394     bowersj2 8137: =item * B<no_such_host>: unable to fund a host associated with the user/domain
1.243     albertel 8138: that was requested
1.191     harris41 8139: 
1.243     albertel 8140: =back
1.191     harris41 8141: 
1.243     albertel 8142: =head1 PUBLIC SUBROUTINES
1.191     harris41 8143: 
1.243     albertel 8144: =head2 Session Environment Functions
1.191     harris41 8145: 
1.243     albertel 8146: =over 4
1.191     harris41 8147: 
1.394     bowersj2 8148: =item * 
                   8149: X<appenv()>
                   8150: B<appenv(%hash)>: the value of %hash is written to
                   8151: the user envirnoment file, and will be restored for each access this
1.620     albertel 8152: user makes during this session, also modifies the %env for the current
1.394     bowersj2 8153: process
1.191     harris41 8154: 
                   8155: =item *
1.394     bowersj2 8156: X<delenv()>
                   8157: B<delenv($regexp)>: removes all items from the session
                   8158: environment file that matches the regular expression in $regexp. The
1.620     albertel 8159: values are also delted from the current processes %env.
1.191     harris41 8160: 
1.795     albertel 8161: =item * get_env_multiple($name) 
                   8162: 
                   8163: gets $name from the %env hash, it seemlessly handles the cases where multiple
                   8164: values may be defined and end up as an array ref.
                   8165: 
                   8166: returns an array of values
                   8167: 
1.243     albertel 8168: =back
                   8169: 
                   8170: =head2 User Information
1.191     harris41 8171: 
1.243     albertel 8172: =over 4
1.191     harris41 8173: 
                   8174: =item *
1.394     bowersj2 8175: X<queryauthenticate()>
                   8176: B<queryauthenticate($uname,$udom)>: try to determine user's current 
1.191     harris41 8177: authentication scheme
                   8178: 
                   8179: =item *
1.394     bowersj2 8180: X<authenticate()>
                   8181: B<authenticate($uname,$upass,$udom)>: try to
                   8182: authenticate user from domain's lib servers (first use the current
                   8183: one). C<$upass> should be the users password.
1.191     harris41 8184: 
                   8185: =item *
1.394     bowersj2 8186: X<homeserver()>
                   8187: B<homeserver($uname,$udom)>: find the server which has
                   8188: the user's directory and files (there must be only one), this caches
                   8189: the answer, and also caches if there is a borken connection.
1.191     harris41 8190: 
                   8191: =item *
1.394     bowersj2 8192: X<idget()>
                   8193: B<idget($udom,@ids)>: find the usernames behind a list of IDs
                   8194: (IDs are a unique resource in a domain, there must be only 1 ID per
                   8195: username, and only 1 username per ID in a specific domain) (returns
                   8196: hash: id=>name,id=>name)
1.191     harris41 8197: 
                   8198: =item *
1.394     bowersj2 8199: X<idrget()>
                   8200: B<idrget($udom,@unames)>: find the IDs behind a list of
                   8201: usernames (returns hash: name=>id,name=>id)
1.191     harris41 8202: 
                   8203: =item *
1.394     bowersj2 8204: X<idput()>
                   8205: B<idput($udom,%ids)>: store away a list of names and associated IDs
1.191     harris41 8206: 
                   8207: =item *
1.394     bowersj2 8208: X<rolesinit()>
                   8209: B<rolesinit($udom,$username,$authhost)>: get user privileges
1.243     albertel 8210: 
                   8211: =item *
1.551     albertel 8212: X<getsection()>
                   8213: B<getsection($udom,$uname,$cname)>: finds the section of student in the
1.243     albertel 8214: course $cname, return section name/number or '' for "not in course"
                   8215: and '-1' for "no section"
                   8216: 
                   8217: =item *
1.394     bowersj2 8218: X<userenvironment()>
                   8219: B<userenvironment($udom,$uname,@what)>: gets the values of the keys
1.243     albertel 8220: passed in @what from the requested user's environment, returns a hash
                   8221: 
1.858     raeburn  8222: =item * 
                   8223: X<userlog_query()>
1.859     albertel 8224: B<userlog_query($uname,$udom,%filters)>: retrieves data from a user's
                   8225: activity.log file. %filters defines filters applied when parsing the
                   8226: log file. These can be start or end timestamps, or the type of action
                   8227: - log to look for Login or Logout events, check for Checkin or
                   8228: Checkout, role for role selection. The response is in the form
                   8229: timestamp1:hostid1:event1&timestamp2:hostid2:event2 where events are
                   8230: escaped strings of the action recorded in the activity.log file.
1.858     raeburn  8231: 
1.243     albertel 8232: =back
                   8233: 
                   8234: =head2 User Roles
                   8235: 
                   8236: =over 4
                   8237: 
                   8238: =item *
                   8239: 
1.810     raeburn  8240: allowed($priv,$uri,$symb,$role) : check for a user privilege; returns codes for allowed actions
1.243     albertel 8241:  F: full access
                   8242:  U,I,K: authentication modes (cxx only)
                   8243:  '': forbidden
                   8244:  1: user needs to choose course
                   8245:  2: browse allowed
1.766     albertel 8246:  A: passphrase authentication needed
1.243     albertel 8247: 
                   8248: =item *
                   8249: 
                   8250: definerole($rolename,$sysrole,$domrole,$courole) : define role; define a custom
                   8251: role rolename set privileges in format of lonTabs/roles.tab for system, domain,
                   8252: and course level
                   8253: 
                   8254: =item *
                   8255: 
                   8256: plaintext($short) : return value in %prp hash (rolesplain.tab); plain text
                   8257: explanation of a user role term
                   8258: 
1.832     raeburn  8259: =item *
                   8260: 
1.858     raeburn  8261: get_my_roles($uname,$udom,$context,$types,$roles,$roledoms) :
                   8262: All arguments are optional. Returns a hash of a roles, either for
                   8263: co-author/assistant author roles for a user's Construction Space
                   8264: (default), or if $context is 'user', roles for the user himself,
                   8265: In the hash, keys are set to colon-sparated $uname,$udom,and $role,
                   8266: and value is set to colon-separated start and end times for the role.
                   8267: If no username and domain are specified, will default to current
                   8268: user/domain. Types, roles, and roledoms are references to arrays,
                   8269: of role statuses (active, future or previous), roles 
                   8270: (e.g., cc,in, st etc.) and domains of the roles which can be used
                   8271: to restrict the list of roles reported. If no array ref is 
                   8272: provided for types, will default to return only active roles.
1.834     albertel 8273: 
1.243     albertel 8274: =back
                   8275: 
                   8276: =head2 User Modification
                   8277: 
                   8278: =over 4
                   8279: 
                   8280: =item *
                   8281: 
                   8282: assignrole($udom,$uname,$url,$role,$end,$start) : assign role; give a role to a
                   8283: user for the level given by URL.  Optional start and end dates (leave empty
                   8284: string or zero for "no date")
1.191     harris41 8285: 
                   8286: =item *
                   8287: 
1.243     albertel 8288: changepass($uname,$udom,$currentpass,$newpass,$server) : attempts to
                   8289: change a users, password, possible return values are: ok,
                   8290: pwchange_failure, non_authorized, auth_mode_error, unknown_user,
                   8291: refused
1.191     harris41 8292: 
                   8293: =item *
                   8294: 
1.243     albertel 8295: modifyuserauth($udom,$uname,$umode,$upass) : modify user authentication
1.191     harris41 8296: 
                   8297: =item *
                   8298: 
1.243     albertel 8299: modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene) : 
                   8300: modify user
1.191     harris41 8301: 
                   8302: =item *
                   8303: 
1.286     matthew  8304: modifystudent
                   8305: 
                   8306: modify a students enrollment and identification information.
                   8307: The course id is resolved based on the current users environment.  
                   8308: This means the envoking user must be a course coordinator or otherwise
                   8309: associated with a course.
                   8310: 
1.297     matthew  8311: This call is essentially a wrapper for lonnet::modifyuser and
                   8312: lonnet::modify_student_enrollment
1.286     matthew  8313: 
                   8314: Inputs: 
                   8315: 
                   8316: =over 4
                   8317: 
                   8318: =item B<$udom> Students loncapa domain
                   8319: 
                   8320: =item B<$uname> Students loncapa login name
                   8321: 
                   8322: =item B<$uid> Students id/student number
                   8323: 
                   8324: =item B<$umode> Students authentication mode
                   8325: 
                   8326: =item B<$upass> Students password
                   8327: 
                   8328: =item B<$first> Students first name
                   8329: 
                   8330: =item B<$middle> Students middle name
                   8331: 
                   8332: =item B<$last> Students last name
                   8333: 
                   8334: =item B<$gene> Students generation
                   8335: 
                   8336: =item B<$usec> Students section in course
                   8337: 
                   8338: =item B<$end> Unix time of the roles expiration
                   8339: 
                   8340: =item B<$start> Unix time of the roles start date
                   8341: 
                   8342: =item B<$forceid> If defined, allow $uid to be changed
                   8343: 
                   8344: =item B<$desiredhome> server to use as home server for student
                   8345: 
                   8346: =back
1.297     matthew  8347: 
                   8348: =item *
                   8349: 
                   8350: modify_student_enrollment
                   8351: 
                   8352: Change a students enrollment status in a class.  The environment variable
                   8353: 'role.request.course' must be defined for this function to proceed.
                   8354: 
                   8355: Inputs:
                   8356: 
                   8357: =over 4
                   8358: 
                   8359: =item $udom, students domain
                   8360: 
                   8361: =item $uname, students name
                   8362: 
                   8363: =item $uid, students user id
                   8364: 
                   8365: =item $first, students first name
                   8366: 
                   8367: =item $middle
                   8368: 
                   8369: =item $last
                   8370: 
                   8371: =item $gene
                   8372: 
                   8373: =item $usec
                   8374: 
                   8375: =item $end
                   8376: 
                   8377: =item $start
                   8378: 
                   8379: =back
                   8380: 
1.191     harris41 8381: 
                   8382: =item *
                   8383: 
1.243     albertel 8384: assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start) : assign
                   8385: custom role; give a custom role to a user for the level given by URL.  Specify
                   8386: name and domain of role author, and role name
1.191     harris41 8387: 
                   8388: =item *
                   8389: 
1.243     albertel 8390: revokerole($udom,$uname,$url,$role) : revoke a role for url
1.191     harris41 8391: 
                   8392: =item *
                   8393: 
1.243     albertel 8394: revokecustomrole($udom,$uname,$url,$role) : revoke a custom role
                   8395: 
                   8396: =back
                   8397: 
                   8398: =head2 Course Infomation
                   8399: 
                   8400: =over 4
1.191     harris41 8401: 
                   8402: =item *
                   8403: 
1.631     albertel 8404: coursedescription($courseid) : returns a hash of information about the
                   8405: specified course id, including all environment settings for the
                   8406: course, the description of the course will be in the hash under the
                   8407: key 'description'
1.191     harris41 8408: 
                   8409: =item *
                   8410: 
1.624     albertel 8411: resdata($name,$domain,$type,@which) : request for current parameter
                   8412: setting for a specific $type, where $type is either 'course' or 'user',
                   8413: @what should be a list of parameters to ask about. This routine caches
                   8414: answers for 5 minutes.
1.243     albertel 8415: 
                   8416: =back
                   8417: 
                   8418: =head2 Course Modification
                   8419: 
                   8420: =over 4
1.191     harris41 8421: 
                   8422: =item *
                   8423: 
1.243     albertel 8424: writecoursepref($courseid,%prefs) : write preferences (environment
                   8425: database) for a course
1.191     harris41 8426: 
                   8427: =item *
                   8428: 
1.243     albertel 8429: createcourse($udom,$description,$url) : make/modify course
                   8430: 
                   8431: =back
                   8432: 
                   8433: =head2 Resource Subroutines
                   8434: 
                   8435: =over 4
1.191     harris41 8436: 
                   8437: =item *
                   8438: 
1.243     albertel 8439: subscribe($fname) : subscribe to a resource, returns URL if possible (probably should use repcopy instead)
1.191     harris41 8440: 
                   8441: =item *
                   8442: 
1.243     albertel 8443: repcopy($filename) : subscribes to the requested file, and attempts to
                   8444: replicate from the owning library server, Might return
1.607     raeburn  8445: 'unavailable', 'not_found', 'forbidden', 'ok', or
                   8446: 'bad_request', also attempts to grab the metadata for the
1.243     albertel 8447: resource. Expects the local filesystem pathname
                   8448: (/home/httpd/html/res/....)
                   8449: 
                   8450: =back
                   8451: 
                   8452: =head2 Resource Information
                   8453: 
                   8454: =over 4
1.191     harris41 8455: 
                   8456: =item *
                   8457: 
1.243     albertel 8458: EXT($varname,$symb,$udom,$uname) : evaluates and returns the value of
                   8459: a vairety of different possible values, $varname should be a request
                   8460: string, and the other parameters can be used to specify who and what
                   8461: one is asking about.
                   8462: 
                   8463: Possible values for $varname are environment.lastname (or other item
                   8464: from the envirnment hash), user.name (or someother aspect about the
                   8465: user), resource.0.maxtries (or some other part and parameter of a
                   8466: resource)
1.204     albertel 8467: 
                   8468: =item *
                   8469: 
1.243     albertel 8470: directcondval($number) : get current value of a condition; reads from a state
                   8471: string
1.204     albertel 8472: 
                   8473: =item *
                   8474: 
1.243     albertel 8475: condval($condidx) : value of condition index based on state
1.204     albertel 8476: 
                   8477: =item *
                   8478: 
1.243     albertel 8479: metadata($uri,$what,$liburi,$prefix,$depthcount) : request a
                   8480: resource's metadata, $what should be either a specific key, or either
                   8481: 'keys' (to get a list of possible keys) or 'packages' to get a list of
                   8482: packages that this resource currently uses, the last 3 arguments are only used internally for recursive metadata.
                   8483: 
                   8484: this function automatically caches all requests
1.191     harris41 8485: 
                   8486: =item *
                   8487: 
1.243     albertel 8488: metadata_query($query,$custom,$customshow) : make a metadata query against the
                   8489: network of library servers; returns file handle of where SQL and regex results
                   8490: will be stored for query
1.191     harris41 8491: 
                   8492: =item *
                   8493: 
1.243     albertel 8494: symbread($filename) : return symbolic list entry (filename argument optional);
                   8495: returns the data handle
1.191     harris41 8496: 
                   8497: =item *
                   8498: 
1.243     albertel 8499: symbverify($symb,$thisfn) : verifies that $symb actually exists and is
1.582     albertel 8500: a possible symb for the URL in $thisfn, and if is an encryypted
                   8501: resource that the user accessed using /enc/ returns a 1 on success, 0
                   8502: on failure, user must be in a course, as it assumes the existance of
1.620     albertel 8503: the course initial hash, and uses $env('request.course.id'}
1.243     albertel 8504: 
1.191     harris41 8505: 
                   8506: =item *
                   8507: 
1.243     albertel 8508: symbclean($symb) : removes versions numbers from a symb, returns the
                   8509: cleaned symb
1.191     harris41 8510: 
                   8511: =item *
                   8512: 
1.243     albertel 8513: is_on_map($uri) : checks if the $uri is somewhere on the current
                   8514: course map, user must be in a course for it to work.
1.191     harris41 8515: 
                   8516: =item *
                   8517: 
1.243     albertel 8518: numval($salt) : return random seed value (addend for rndseed)
1.191     harris41 8519: 
                   8520: =item *
                   8521: 
1.243     albertel 8522: rndseed($symb,$courseid,$udom,$uname) : create a random sum; returns
                   8523: a random seed, all arguments are optional, if they aren't sent it uses the
                   8524: environment to derive them. Note: if symb isn't sent and it can't get one
                   8525: from &symbread it will use the current time as its return value
1.191     harris41 8526: 
                   8527: =item *
                   8528: 
1.243     albertel 8529: ireceipt($funame,$fudom,$fucourseid,$fusymb) : return unique,
                   8530: unfakeable, receipt
1.191     harris41 8531: 
                   8532: =item *
                   8533: 
1.620     albertel 8534: receipt() : API to ireceipt working off of env values; given out to users
1.191     harris41 8535: 
                   8536: =item *
                   8537: 
1.243     albertel 8538: countacc($url) : count the number of accesses to a given URL
1.191     harris41 8539: 
                   8540: =item *
                   8541: 
1.243     albertel 8542: 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 8543: 
                   8544: =item *
                   8545: 
1.243     albertel 8546: 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 8547: 
                   8548: =item *
                   8549: 
1.243     albertel 8550: expirespread($uname,$udom,$stype,$usymb) : set expire date for spreadsheet
1.191     harris41 8551: 
                   8552: =item *
                   8553: 
1.243     albertel 8554: devalidate($symb) : devalidate temporary spreadsheet calculations,
                   8555: forcing spreadsheet to reevaluate the resource scores next time.
                   8556: 
                   8557: =back
                   8558: 
                   8559: =head2 Storing/Retreiving Data
                   8560: 
                   8561: =over 4
1.191     harris41 8562: 
                   8563: =item *
                   8564: 
1.243     albertel 8565: store($storehash,$symb,$namespace,$udom,$uname) : stores hash permanently
                   8566: for this url; hashref needs to be given and should be a \%hashname; the
                   8567: remaining args aren't required and if they aren't passed or are '' they will
1.620     albertel 8568: be derived from the env
1.191     harris41 8569: 
                   8570: =item *
                   8571: 
1.243     albertel 8572: cstore($storehash,$symb,$namespace,$udom,$uname) : same as store but
                   8573: uses critical subroutine
1.191     harris41 8574: 
                   8575: =item *
                   8576: 
1.243     albertel 8577: restore($symb,$namespace,$udom,$uname) : returns hash for this symb;
                   8578: all args are optional
1.191     harris41 8579: 
                   8580: =item *
                   8581: 
1.717     albertel 8582: dumpstore($namespace,$udom,$uname,$regexp,$range) : 
                   8583: dumps the complete (or key matching regexp) namespace into a hash
                   8584: ($udom, $uname, $regexp, $range are optional) for a namespace that is
                   8585: normally &store()ed into
                   8586: 
                   8587: $range should be either an integer '100' (give me the first 100
                   8588:                                            matching records)
                   8589:               or be  two integers sperated by a - with no spaces
                   8590:                  '30-50' (give me the 30th through the 50th matching
                   8591:                           records)
                   8592: 
                   8593: 
                   8594: =item *
                   8595: 
                   8596: putstore($namespace,$symb,$version,$storehash,$udomain,$uname) :
                   8597: replaces a &store() version of data with a replacement set of data
                   8598: for a particular resource in a namespace passed in the $storehash hash 
                   8599: reference
                   8600: 
                   8601: =item *
                   8602: 
1.243     albertel 8603: tmpstore($storehash,$symb,$namespace,$udom,$uname) : storage that
                   8604: works very similar to store/cstore, but all data is stored in a
                   8605: temporary location and can be reset using tmpreset, $storehash should
                   8606: be a hash reference, returns nothing on success
1.191     harris41 8607: 
                   8608: =item *
                   8609: 
1.243     albertel 8610: tmprestore($symb,$namespace,$udom,$uname) : storage that works very
                   8611: similar to restore, but all data is stored in a temporary location and
                   8612: can be reset using tmpreset. Returns a hash of values on success,
                   8613: error string otherwise.
1.191     harris41 8614: 
                   8615: =item *
                   8616: 
1.243     albertel 8617: tmpreset($symb,$namespace,$udom,$uname) : temporary storage reset,
                   8618: deltes all keys for $symb form the temporary storage hash.
1.191     harris41 8619: 
                   8620: =item *
                   8621: 
1.243     albertel 8622: get($namespace,$storearr,$udom,$uname) : returns hash with keys from array
                   8623: reference filled in from namesp ($udom and $uname are optional)
1.191     harris41 8624: 
                   8625: =item *
                   8626: 
1.243     albertel 8627: del($namespace,$storearr,$udom,$uname) : deletes keys out of array from
                   8628: namesp ($udom and $uname are optional)
1.191     harris41 8629: 
                   8630: =item *
                   8631: 
1.702     albertel 8632: dump($namespace,$udom,$uname,$regexp,$range) : 
1.243     albertel 8633: dumps the complete (or key matching regexp) namespace into a hash
1.702     albertel 8634: ($udom, $uname, $regexp, $range are optional)
1.449     matthew  8635: 
1.702     albertel 8636: $range should be either an integer '100' (give me the first 100
                   8637:                                            matching records)
                   8638:               or be  two integers sperated by a - with no spaces
                   8639:                  '30-50' (give me the 30th through the 50th matching
                   8640:                           records)
1.449     matthew  8641: =item *
                   8642: 
                   8643: inc($namespace,$store,$udom,$uname) : increments $store in $namespace.
                   8644: $store can be a scalar, an array reference, or if the amount to be 
                   8645: incremented is > 1, a hash reference.
                   8646: 
                   8647: ($udom and $uname are optional)
1.191     harris41 8648: 
                   8649: =item *
                   8650: 
1.243     albertel 8651: put($namespace,$storehash,$udom,$uname) : stores hash in namesp
                   8652: ($udom and $uname are optional)
1.191     harris41 8653: 
                   8654: =item *
                   8655: 
1.243     albertel 8656: cput($namespace,$storehash,$udom,$uname) : critical put
                   8657: ($udom and $uname are optional)
1.191     harris41 8658: 
                   8659: =item *
                   8660: 
1.748     albertel 8661: newput($namespace,$storehash,$udom,$uname) :
                   8662: 
                   8663: Attempts to store the items in the $storehash, but only if they don't
                   8664: currently exist, if this succeeds you can be certain that you have 
                   8665: successfully created a new key value pair in the $namespace db.
                   8666: 
                   8667: 
                   8668: Args:
                   8669:  $namespace: name of database to store values to
                   8670:  $storehash: hashref to store to the db
                   8671:  $udom: (optional) domain of user containing the db
                   8672:  $uname: (optional) name of user caontaining the db
                   8673: 
                   8674: Returns:
                   8675:  'ok' -> succeeded in storing all keys of $storehash
                   8676:  'key_exists: <key>' -> failed to anything out of $storehash, as at
                   8677:                         least <key> already existed in the db (other
                   8678:                         requested keys may also already exist)
                   8679:  'error: <msg>' -> unable to tie the DB or other erorr occured
                   8680:  'con_lost' -> unable to contact request server
                   8681:  'refused' -> action was not allowed by remote machine
                   8682: 
                   8683: 
                   8684: =item *
                   8685: 
1.243     albertel 8686: eget($namespace,$storearr,$udom,$uname) : returns hash with keys from array
                   8687: reference filled in from namesp (encrypts the return communication)
                   8688: ($udom and $uname are optional)
1.191     harris41 8689: 
                   8690: =item *
                   8691: 
1.243     albertel 8692: log($udom,$name,$home,$message) : write to permanent log for user; use
                   8693: critical subroutine
                   8694: 
1.806     raeburn  8695: =item *
                   8696: 
1.860     raeburn  8697: get_dom($namespace,$storearr,$udom,$uhome) : returns hash with keys from
                   8698: array reference filled in from namespace found in domain level on either
                   8699: specified domain server ($uhome) or primary domain server ($udom and $uhome are optional).
1.806     raeburn  8700: 
                   8701: =item *
                   8702: 
1.860     raeburn  8703: put_dom($namespace,$storehash,$udom,$uhome) :  stores hash in namespace at 
                   8704: domain level either on specified domain server ($uhome) or primary domain 
                   8705: server ($udom and $uhome are optional)
1.806     raeburn  8706: 
1.243     albertel 8707: =back
                   8708: 
                   8709: =head2 Network Status Functions
                   8710: 
                   8711: =over 4
1.191     harris41 8712: 
                   8713: =item *
                   8714: 
                   8715: dirlist($uri) : return directory list based on URI
                   8716: 
                   8717: =item *
                   8718: 
1.243     albertel 8719: spareserver() : find server with least workload from spare.tab
                   8720: 
                   8721: =back
                   8722: 
                   8723: =head2 Apache Request
                   8724: 
                   8725: =over 4
1.191     harris41 8726: 
                   8727: =item *
                   8728: 
1.243     albertel 8729: ssi($url,%hash) : server side include, does a complete request cycle on url to
                   8730: localhost, posts hash
                   8731: 
                   8732: =back
                   8733: 
                   8734: =head2 Data to String to Data
                   8735: 
                   8736: =over 4
1.191     harris41 8737: 
                   8738: =item *
                   8739: 
1.243     albertel 8740: hash2str(%hash) : convert a hash into a string complete with escaping and '='
                   8741: and '&' separators, supports elements that are arrayrefs and hashrefs
1.191     harris41 8742: 
                   8743: =item *
                   8744: 
1.243     albertel 8745: hashref2str($hashref) : convert a hashref into a string complete with
                   8746: escaping and '=' and '&' separators, supports elements that are
                   8747: arrayrefs and hashrefs
1.191     harris41 8748: 
                   8749: =item *
                   8750: 
1.243     albertel 8751: arrayref2str($arrayref) : convert an arrayref into a string complete
                   8752: with escaping and '&' separators, supports elements that are arrayrefs
                   8753: and hashrefs
1.191     harris41 8754: 
                   8755: =item *
                   8756: 
1.243     albertel 8757: str2hash($string) : convert string to hash using unescaping and
                   8758: splitting on '=' and '&', supports elements that are arrayrefs and
                   8759: hashrefs
1.191     harris41 8760: 
                   8761: =item *
                   8762: 
1.243     albertel 8763: str2array($string) : convert string to hash using unescaping and
                   8764: splitting on '&', supports elements that are arrayrefs and hashrefs
                   8765: 
                   8766: =back
                   8767: 
                   8768: =head2 Logging Routines
                   8769: 
                   8770: =over 4
                   8771: 
                   8772: These routines allow one to make log messages in the lonnet.log and
                   8773: lonnet.perm logfiles.
1.191     harris41 8774: 
                   8775: =item *
                   8776: 
1.243     albertel 8777: logtouch() : make sure the logfile, lonnet.log, exists
1.191     harris41 8778: 
                   8779: =item *
                   8780: 
1.243     albertel 8781: logthis() : append message to the normal lonnet.log file, it gets
                   8782: preiodically rolled over and deleted.
1.191     harris41 8783: 
                   8784: =item *
                   8785: 
1.243     albertel 8786: logperm() : append a permanent message to lonnet.perm.log, this log
                   8787: file never gets deleted by any automated portion of the system, only
                   8788: messages of critical importance should go in here.
                   8789: 
                   8790: =back
                   8791: 
                   8792: =head2 General File Helper Routines
                   8793: 
                   8794: =over 4
1.191     harris41 8795: 
                   8796: =item *
                   8797: 
1.481     raeburn  8798: getfile($file,$caller) : two cases - requests for files in /res or in /uploaded.
                   8799: (a) files in /uploaded
                   8800:   (i) If a local copy of the file exists - 
                   8801:       compares modification date of local copy with last-modified date for 
                   8802:       definitive version stored on home server for course. If local copy is 
                   8803:       stale, requests a new version from the home server and stores it. 
                   8804:       If the original has been removed from the home server, then local copy 
                   8805:       is unlinked.
                   8806:   (ii) If local copy does not exist -
                   8807:       requests the file from the home server and stores it. 
                   8808:   
                   8809:   If $caller is 'uploadrep':  
                   8810:     This indicates a call from lonuploadrep.pm (PerlHeaderParserHandler phase)
                   8811:     for request for files originally uploaded via DOCS. 
                   8812:      - returns 'ok' if fresh local copy now available, -1 otherwise.
                   8813:   
                   8814:   Otherwise:
                   8815:      This indicates a call from the content generation phase of the request.
                   8816:      -  returns the entire contents of the file or -1.
                   8817:      
                   8818: (b) files in /res
                   8819:    - returns the entire contents of a file or -1; 
                   8820:    it properly subscribes to and replicates the file if neccessary.
1.191     harris41 8821: 
1.712     albertel 8822: 
                   8823: =item *
                   8824: 
                   8825: stat_file($url) : $url is expected to be a /res/ or /uploaded/ style file
                   8826:                   reference
                   8827: 
                   8828: returns either a stat() list of data about the file or an empty list
                   8829: if the file doesn't exist or couldn't find out about it (connection
                   8830: problems or user unknown)
                   8831: 
1.191     harris41 8832: =item *
                   8833: 
1.243     albertel 8834: filelocation($dir,$file) : returns file system location of a file
                   8835: based on URI; meant to be "fairly clean" absolute reference, $dir is a
                   8836: directory that relative $file lookups are to looked in ($dir of /a/dir
                   8837: and a file of ../bob will become /a/bob)
1.191     harris41 8838: 
                   8839: =item *
                   8840: 
                   8841: hreflocation($dir,$file) : returns file system location or a URL; same as
                   8842: filelocation except for hrefs
                   8843: 
                   8844: =item *
                   8845: 
                   8846: declutter() : declutters URLs (remove docroot, beginning slashes, 'res' etc)
                   8847: 
1.243     albertel 8848: =back
                   8849: 
1.608     albertel 8850: =head2 Usererfile file routines (/uploaded*)
                   8851: 
                   8852: =over 4
                   8853: 
                   8854: =item *
                   8855: 
                   8856: userfileupload(): main rotine for putting a file in a user or course's
                   8857:                   filespace, arguments are,
                   8858: 
1.620     albertel 8859:  formname - required - this is the name of the element in $env where the
1.608     albertel 8860:            filename, and the contents of the file to create/modifed exist
1.620     albertel 8861:            the filename is in $env{'form.'.$formname.'.filename'} and the
                   8862:            contents of the file is located in $env{'form.'.$formname}
1.608     albertel 8863:  coursedoc - if true, store the file in the course of the active role
                   8864:              of the current user
                   8865:  subdir - required - subdirectory to put the file in under ../userfiles/
                   8866:          if undefined, it will be placed in "unknown"
                   8867: 
                   8868:  (This routine calls clean_filename() to remove any dangerous
                   8869:  characters from the filename, and then calls finuserfileupload() to
                   8870:  complete the transaction)
                   8871: 
                   8872:  returns either the url of the uploaded file (/uploaded/....) if successful
                   8873:  and /adm/notfound.html if unsuccessful
                   8874: 
                   8875: =item *
                   8876: 
                   8877: clean_filename(): routine for cleaing a filename up for storage in
                   8878:                  userfile space, argument is:
                   8879: 
                   8880:  filename - proposed filename
                   8881: 
                   8882: returns: the new clean filename
                   8883: 
                   8884: =item *
                   8885: 
                   8886: finishuserfileupload(): routine that creaes and sends the file to
                   8887: userspace, probably shouldn't be called directly
                   8888: 
                   8889:   docuname: username or courseid of destination for the file
                   8890:   docudom: domain of user/course of destination for the file
                   8891:   formname: same as for userfileupload()
                   8892:   fname: filename (inculding subdirectories) for the file
                   8893: 
                   8894:  returns either the url of the uploaded file (/uploaded/....) if successful
                   8895:  and /adm/notfound.html if unsuccessful
                   8896: 
                   8897: =item *
                   8898: 
                   8899: renameuserfile(): renames an existing userfile to a new name
                   8900: 
                   8901:   Args:
                   8902:    docuname: username or courseid of destination for the file
                   8903:    docudom: domain of user/course of destination for the file
                   8904:    old: current file name (including any subdirs under userfiles)
                   8905:    new: desired file name (including any subdirs under userfiles)
                   8906: 
                   8907: =item *
                   8908: 
                   8909: mkdiruserfile(): creates a directory is a userfiles dir
                   8910: 
                   8911:   Args:
                   8912:    docuname: username or courseid of destination for the file
                   8913:    docudom: domain of user/course of destination for the file
                   8914:    dir: dir to create (including any subdirs under userfiles)
                   8915: 
                   8916: =item *
                   8917: 
                   8918: removeuserfile(): removes a file that exists in userfiles
                   8919: 
                   8920:   Args:
                   8921:    docuname: username or courseid of destination for the file
                   8922:    docudom: domain of user/course of destination for the file
                   8923:    fname: filname to delete (including any subdirs under userfiles)
                   8924: 
                   8925: =item *
                   8926: 
                   8927: removeuploadedurl(): convience function for removeuserfile()
                   8928: 
                   8929:   Args:
                   8930:    url:  a full /uploaded/... url to delete
                   8931: 
1.747     albertel 8932: =item * 
                   8933: 
                   8934: get_portfile_permissions():
                   8935:   Args:
                   8936:     domain: domain of user or course contain the portfolio files
                   8937:     user: name of user or num of course contain the portfolio files
                   8938:   Returns:
                   8939:     hashref of a dump of the proper file_permissions.db
                   8940:    
                   8941: 
                   8942: =item * 
                   8943: 
                   8944: get_access_controls():
                   8945: 
                   8946: Args:
                   8947:   current_permissions: the hash ref returned from get_portfile_permissions()
                   8948:   group: (optional) the group you want the files associated with
                   8949:   file: (optional) the file you want access info on
                   8950: 
                   8951: Returns:
1.749     raeburn  8952:     a hash (keys are file names) of hashes containing
                   8953:         keys are: path to file/file_name\0uniqueID:scope_end_start (see below)
                   8954:         values are XML containing access control settings (see below) 
1.747     albertel 8955: 
                   8956: Internal notes:
                   8957: 
1.749     raeburn  8958:  access controls are stored in file_permissions.db as key=value pairs.
                   8959:     key -> path to file/file_name\0uniqueID:scope_end_start
                   8960:         where scope -> public,guest,course,group,domains or users.
                   8961:               end -> UNIX time for end of access (0 -> no end date)
                   8962:               start -> UNIX time for start of access
                   8963: 
                   8964:     value -> XML description of access control
                   8965:            <scope type=""> (type =1 of: public,guest,course,group,domains,users">
                   8966:             <start></start>
                   8967:             <end></end>
                   8968: 
                   8969:             <password></password>  for scope type = guest
                   8970: 
                   8971:             <domain></domain>     for scope type = course or group
                   8972:             <number></number>
                   8973:             <roles id="">
                   8974:              <role></role>
                   8975:              <access></access>
                   8976:              <section></section>
                   8977:              <group></group>
                   8978:             </roles>
                   8979: 
                   8980:             <dom></dom>         for scope type = domains
                   8981: 
                   8982:             <users>             for scope type = users
                   8983:              <user>
                   8984:               <uname></uname>
                   8985:               <udom></udom>
                   8986:              </user>
                   8987:             </users>
                   8988:            </scope> 
                   8989:               
                   8990:  Access data is also aggregated for each file in an additional key=value pair:
                   8991:  key -> path to file/file_name\0accesscontrol 
                   8992:  value -> reference to hash
                   8993:           hash contains key = value pairs
                   8994:           where key = uniqueID:scope_end_start
                   8995:                 value = UNIX time record was last updated
                   8996: 
                   8997:           Used to improve speed of look-ups of access controls for each file.  
                   8998:  
                   8999:  Locks on files (resulting from submission of portfolio file to a homework problem stored in array of arrays.
                   9000: 
                   9001: modify_access_controls():
                   9002: 
                   9003: Modifies access controls for a portfolio file
                   9004: Args
                   9005: 1. file name
                   9006: 2. reference to hash of required changes,
                   9007: 3. domain
                   9008: 4. username
                   9009:   where domain,username are the domain of the portfolio owner 
                   9010:   (either a user or a course) 
                   9011: 
                   9012: Returns:
                   9013: 1. result of additions or updates ('ok' or 'error', with error message). 
                   9014: 2. result of deletions ('ok' or 'error', with error message).
                   9015: 3. reference to hash of any new or updated access controls.
                   9016: 4. reference to hash used to map incoming IDs to uniqueIDs assigned to control.
                   9017:    key = integer (inbound ID)
                   9018:    value = uniqueID  
1.747     albertel 9019: 
1.608     albertel 9020: =back
                   9021: 
1.243     albertel 9022: =head2 HTTP Helper Routines
                   9023: 
                   9024: =over 4
                   9025: 
1.191     harris41 9026: =item *
                   9027: 
                   9028: escape() : unpack non-word characters into CGI-compatible hex codes
                   9029: 
                   9030: =item *
                   9031: 
                   9032: unescape() : pack CGI-compatible hex codes into actual non-word ASCII character
                   9033: 
1.243     albertel 9034: =back
                   9035: 
                   9036: =head1 PRIVATE SUBROUTINES
                   9037: 
                   9038: =head2 Underlying communication routines (Shouldn't call)
                   9039: 
                   9040: =over 4
                   9041: 
                   9042: =item *
                   9043: 
                   9044: subreply() : tries to pass a message to lonc, returns con_lost if incapable
                   9045: 
                   9046: =item *
                   9047: 
                   9048: reply() : uses subreply to send a message to remote machine, logs all failures
                   9049: 
                   9050: =item *
                   9051: 
                   9052: critical() : passes a critical message to another server; if cannot
                   9053: get through then place message in connection buffer directory and
                   9054: returns con_delayed, if incapable of saving message, returns
                   9055: con_failed
                   9056: 
                   9057: =item *
                   9058: 
                   9059: reconlonc() : tries to reconnect lonc client processes.
                   9060: 
                   9061: =back
                   9062: 
                   9063: =head2 Resource Access Logging
                   9064: 
                   9065: =over 4
                   9066: 
                   9067: =item *
                   9068: 
                   9069: flushcourselogs() : flush (save) buffer logs and access logs
                   9070: 
                   9071: =item *
                   9072: 
                   9073: courselog($what) : save message for course in hash
                   9074: 
                   9075: =item *
                   9076: 
                   9077: courseacclog($what) : save message for course using &courselog().  Perform
                   9078: special processing for specific resource types (problems, exams, quizzes, etc).
                   9079: 
1.191     harris41 9080: =item *
                   9081: 
                   9082: goodbye() : flush course logs and log shutting down; it is called in srm.conf
                   9083: as a PerlChildExitHandler
1.243     albertel 9084: 
                   9085: =back
                   9086: 
                   9087: =head2 Other
                   9088: 
                   9089: =over 4
                   9090: 
                   9091: =item *
                   9092: 
                   9093: symblist($mapname,%newhash) : update symbolic storage links
1.191     harris41 9094: 
                   9095: =back
                   9096: 
                   9097: =cut

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