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

1.1       albertel    1: # The LearningOnline Network
                      2: # TCP networking package
1.12      www         3: #
1.333   ! albertel    4: # $Id: lonnet.pm,v 1.332 2003/03/01 15:13:58 www 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: # 6/1/99,6/2,6/10,6/11,6/12,6/14,6/26,6/28,6/29,6/30,
                     29: # 7/1,7/2,7/9,7/10,7/12,7/14,7/15,7/19,
                     30: # 11/8,11/16,11/18,11/22,11/23,12/22,
                     31: # 01/06,01/13,02/24,02/28,02/29,
                     32: # 03/01,03/02,03/06,03/07,03/13,
                     33: # 04/05,05/29,05/31,06/01,
                     34: # 06/05,06/26 Gerd Kortemeyer
                     35: # 06/26 Ben Tyszka
                     36: # 06/30,07/15,07/17,07/18,07/20,07/21,07/22,07/25 Gerd Kortemeyer
                     37: # 08/14 Ben Tyszka
                     38: # 08/22,08/28,08/31,09/01,09/02,09/04,09/05,09/25,09/28,09/30 Gerd Kortemeyer
                     39: # 10/04 Gerd Kortemeyer
                     40: # 10/04 Guy Albertelli
                     41: # 10/06,10/09,10/10,10/11,10/14,10/20,10/23,10/25,10/26,10/27,10/28,10/29, 
                     42: # 10/30,10/31,
                     43: # 11/2,11/14,11/15,11/16,11/20,11/21,11/22,11/25,11/27,
                     44: # 12/02,12/12,12/13,12/14,12/28,12/29 Gerd Kortemeyer
                     45: # 05/01/01 Guy Albertelli
                     46: # 05/01,06/01,09/01 Gerd Kortemeyer
                     47: # 09/01 Guy Albertelli
                     48: # 09/01,10/01,11/01 Gerd Kortemeyer
                     49: # YEAR=2001
                     50: # 3/2 Gerd Kortemeyer
                     51: # 3/19,3/20 Gerd Kortemeyer
                     52: # 5/26,5/28 Gerd Kortemeyer
                     53: # 5/30 H. K. Ng
                     54: # 6/1 Gerd Kortemeyer
                     55: # July Guy Albertelli
                     56: # 8/4,8/7,8/8,8/9,8/11,8/16,8/17,8/18,8/20,8/23,9/20,9/21,9/26,
                     57: # 10/2 Gerd Kortemeyer
1.179     www        58: # 11/17,11/20,11/22,11/29 Gerd Kortemeyer
1.182     matthew    59: # 12/5 Matthew Hall
1.184     www        60: # 12/5 Guy Albertelli
1.190     www        61: # 12/6,12/7,12/12 Gerd Kortemeyer
1.195     www        62: # 12/21,12/22,12/27,12/28 Gerd Kortemeyer
1.196     www        63: # YEAR=2002
1.200     www        64: # 1/4,2/4,2/7 Gerd Kortemeyer
1.171     www        65: #
1.169     harris41   66: ###
                     67: 
1.1       albertel   68: package Apache::lonnet;
                     69: 
                     70: use strict;
                     71: use Apache::File;
1.8       www        72: use LWP::UserAgent();
1.15      www        73: use HTTP::Headers;
1.11      www        74: use vars 
1.300     albertel   75: qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom 
1.301     www        76:    %libserv %pr %prp %metacache %packagetab %titlecache 
1.188     www        77:    %courselogs %accesshash $processmarker $dumpcount 
1.308     albertel   78:    %coursedombuf %coursehombuf %courseresdatacache 
1.329     matthew    79:    %domaindescription %domain_auth_def %domain_auth_arg_def $tmpdir);
1.1       albertel   80: use IO::Socket;
1.31      www        81: use GDBM_File;
1.8       www        82: use Apache::Constants qw(:common :http);
1.208     albertel   83: use HTML::LCParser;
1.88      www        84: use Fcntl qw(:flock);
1.294     matthew    85: use Apache::loncoursedata;
                     86: 
1.195     www        87: my $readit;
1.1       albertel   88: 
                     89: # --------------------------------------------------------------------- Logging
                     90: 
1.163     harris41   91: sub logtouch {
                     92:     my $execdir=$perlvar{'lonDaemons'};
                     93:     unless (-e "$execdir/logs/lonnet.log") {
                     94: 	my $fh=Apache::File->new(">>$execdir/logs/lonnet.log");
                     95: 	close $fh;
                     96:     }
                     97:     my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3];
                     98:     chown($wwwuid,$wwwgid,$execdir.'/logs/lonnet.log');
                     99: }
                    100: 
1.1       albertel  101: sub logthis {
                    102:     my $message=shift;
                    103:     my $execdir=$perlvar{'lonDaemons'};
                    104:     my $now=time;
                    105:     my $local=localtime($now);
1.162     harris41  106:     my $fh=Apache::File->new(">>$execdir/logs/lonnet.log");
                    107:     print $fh "$local ($$): $message\n";
1.1       albertel  108:     return 1;
                    109: }
                    110: 
                    111: sub logperm {
                    112:     my $message=shift;
                    113:     my $execdir=$perlvar{'lonDaemons'};
                    114:     my $now=time;
                    115:     my $local=localtime($now);
1.162     harris41  116:     my $fh=Apache::File->new(">>$execdir/logs/lonnet.perm.log");
                    117:     print $fh "$now:$message:$local\n";
1.1       albertel  118:     return 1;
                    119: }
                    120: 
                    121: # -------------------------------------------------- Non-critical communication
                    122: sub subreply {
                    123:     my ($cmd,$server)=@_;
                    124:     my $peerfile="$perlvar{'lonSockDir'}/$server";
                    125:     my $client=IO::Socket::UNIX->new(Peer    =>"$peerfile",
                    126:                                      Type    => SOCK_STREAM,
                    127:                                      Timeout => 10)
                    128:        or return "con_lost";
                    129:     print $client "$cmd\n";
                    130:     my $answer=<$client>;
1.9       www       131:     if (!$answer) { $answer="con_lost"; }
1.1       albertel  132:     chomp($answer);
                    133:     return $answer;
                    134: }
                    135: 
                    136: sub reply {
                    137:     my ($cmd,$server)=@_;
1.205     www       138:     unless (defined($hostname{$server})) { return 'no_such_host'; }
1.1       albertel  139:     my $answer=subreply($cmd,$server);
1.203     www       140:     if ($answer eq 'con_lost') {
1.311     matthew   141:         #sleep 5; 
                    142:         #$answer=subreply($cmd,$server);
                    143:         #if ($answer eq 'con_lost') {
1.233     albertel  144: 	#   &logthis("Second attempt con_lost on $server");
                    145:         #   my $peerfile="$perlvar{'lonSockDir'}/$server";
                    146:         #   my $client=IO::Socket::UNIX->new(Peer    =>"$peerfile",
                    147:         #                                    Type    => SOCK_STREAM,
                    148:         #                                    Timeout => 10)
                    149:         #              or return "con_lost";
                    150:         #   &logthis("Killing socket");
                    151:         #   print $client "close_connection_exit\n";
                    152:            #sleep 5;
                    153:         #   $answer=subreply($cmd,$server);       
                    154:        #}   
1.203     www       155:     }
1.65      www       156:     if (($answer=~/^refused/) || ($answer=~/^rejected/)) {
1.12      www       157:        &logthis("<font color=blue>WARNING:".
                    158:                 " $cmd to $server returned $answer</font>");
                    159:     }
1.1       albertel  160:     return $answer;
                    161: }
                    162: 
                    163: # ----------------------------------------------------------- Send USR1 to lonc
                    164: 
                    165: sub reconlonc {
                    166:     my $peerfile=shift;
                    167:     &logthis("Trying to reconnect for $peerfile");
                    168:     my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
                    169:     if (my $fh=Apache::File->new("$loncfile")) {
                    170: 	my $loncpid=<$fh>;
                    171:         chomp($loncpid);
                    172:         if (kill 0 => $loncpid) {
                    173: 	    &logthis("lonc at pid $loncpid responding, sending USR1");
                    174:             kill USR1 => $loncpid;
                    175:             sleep 1;
                    176:             if (-e "$peerfile") { return; }
                    177:             &logthis("$peerfile still not there, give it another try");
                    178:             sleep 5;
                    179:             if (-e "$peerfile") { return; }
1.12      www       180:             &logthis(
                    181:   "<font color=blue>WARNING: $peerfile still not there, giving up</font>");
1.1       albertel  182:         } else {
1.12      www       183: 	    &logthis(
                    184:                "<font color=blue>WARNING:".
                    185:                " lonc at pid $loncpid not responding, giving up</font>");
1.1       albertel  186:         }
                    187:     } else {
1.12      www       188:      &logthis('<font color=blue>WARNING: lonc not running, giving up</font>');
1.1       albertel  189:     }
                    190: }
                    191: 
                    192: # ------------------------------------------------------ Critical communication
1.12      www       193: 
1.1       albertel  194: sub critical {
                    195:     my ($cmd,$server)=@_;
1.89      www       196:     unless ($hostname{$server}) {
                    197:         &logthis("<font color=blue>WARNING:".
                    198:                " Critical message to unknown server ($server)</font>");
                    199:         return 'no_such_host';
                    200:     }
1.1       albertel  201:     my $answer=reply($cmd,$server);
                    202:     if ($answer eq 'con_lost') {
                    203:         my $pingreply=reply('ping',$server);
                    204: 	&reconlonc("$perlvar{'lonSockDir'}/$server");
                    205:         my $pongreply=reply('pong',$server);
                    206:         &logthis("Ping/Pong for $server: $pingreply/$pongreply");
                    207:         $answer=reply($cmd,$server);
                    208:         if ($answer eq 'con_lost') {
                    209:             my $now=time;
                    210:             my $middlename=$cmd;
1.5       www       211:             $middlename=substr($middlename,0,16);
1.1       albertel  212:             $middlename=~s/\W//g;
                    213:             my $dfilename=
1.305     www       214:       "$perlvar{'lonSockDir'}/delayed/$now.$dumpcount.$$.$middlename.$server";
                    215:             $dumpcount++;
1.1       albertel  216:             {
                    217:              my $dfh;
                    218:              if ($dfh=Apache::File->new(">$dfilename")) {
1.7       www       219:                 print $dfh "$cmd\n";
1.1       albertel  220: 	     }
                    221:             }
                    222:             sleep 2;
                    223:             my $wcmd='';
                    224:             {
                    225: 	     my $dfh;
                    226:              if ($dfh=Apache::File->new("$dfilename")) {
                    227:                 $wcmd=<$dfh>;
                    228: 	     }
                    229:             }
                    230:             chomp($wcmd);
1.7       www       231:             if ($wcmd eq $cmd) {
1.12      www       232: 		&logthis("<font color=blue>WARNING: ".
                    233:                          "Connection buffer $dfilename: $cmd</font>");
1.1       albertel  234:                 &logperm("D:$server:$cmd");
                    235: 	        return 'con_delayed';
                    236:             } else {
1.12      www       237:                 &logthis("<font color=red>CRITICAL:"
                    238:                         ." Critical connection failed: $server $cmd</font>");
1.1       albertel  239:                 &logperm("F:$server:$cmd");
                    240:                 return 'con_failed';
                    241:             }
                    242:         }
                    243:     }
                    244:     return $answer;
                    245: }
                    246: 
1.5       www       247: # ---------------------------------------------------------- Append Environment
                    248: 
                    249: sub appenv {
1.6       www       250:     my %newenv=@_;
1.191     harris41  251:     foreach (keys %newenv) {
1.35      www       252: 	if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) {
                    253:             &logthis("<font color=blue>WARNING: ".
1.151     www       254:                 "Attempt to modify environment ".$_." to ".$newenv{$_}
                    255:                 .'</font>');
1.35      www       256: 	    delete($newenv{$_});
                    257:         } else {
                    258:             $ENV{$_}=$newenv{$_};
                    259:         }
1.191     harris41  260:     }
1.95      www       261: 
                    262:     my $lockfh;
                    263:     unless ($lockfh=Apache::File->new("$ENV{'user.environment'}")) {
1.97      www       264:        return 'error: '.$!;
1.95      www       265:     }
                    266:     unless (flock($lockfh,LOCK_EX)) {
                    267:          &logthis("<font color=blue>WARNING: ".
                    268:                   'Could not obtain exclusive lock in appenv: '.$!);
                    269:          $lockfh->close();
                    270:          return 'error: '.$!;
                    271:     }
                    272: 
1.6       www       273:     my @oldenv;
                    274:     {
                    275:      my $fh;
                    276:      unless ($fh=Apache::File->new("$ENV{'user.environment'}")) {
1.97      www       277: 	return 'error: '.$!;
1.6       www       278:      }
                    279:      @oldenv=<$fh>;
1.89      www       280:      $fh->close();
1.6       www       281:     }
                    282:     for (my $i=0; $i<=$#oldenv; $i++) {
                    283:         chomp($oldenv[$i]);
1.9       www       284:         if ($oldenv[$i] ne '') {
                    285:            my ($name,$value)=split(/=/,$oldenv[$i]);
1.24      www       286:            unless (defined($newenv{$name})) {
                    287: 	      $newenv{$name}=$value;
                    288: 	   }
1.9       www       289:         }
1.6       www       290:     }
                    291:     {
                    292:      my $fh;
                    293:      unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) {
                    294: 	return 'error';
                    295:      }
                    296:      my $newname;
1.93      www       297:      foreach $newname (keys %newenv) {
1.6       www       298: 	 print $fh "$newname=$newenv{$newname}\n";
                    299:      }
1.86      albertel  300:      $fh->close();
1.56      www       301:     }
1.95      www       302: 
                    303:     $lockfh->close();
1.56      www       304:     return 'ok';
                    305: }
                    306: # ----------------------------------------------------- Delete from Environment
                    307: 
                    308: sub delenv {
                    309:     my $delthis=shift;
                    310:     my %newenv=();
                    311:     if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {
                    312:         &logthis("<font color=blue>WARNING: ".
                    313:                 "Attempt to delete from environment ".$delthis);
                    314:         return 'error';
                    315:     }
                    316:     my @oldenv;
                    317:     {
                    318:      my $fh;
                    319:      unless ($fh=Apache::File->new("$ENV{'user.environment'}")) {
                    320: 	return 'error';
                    321:      }
1.89      www       322:      unless (flock($fh,LOCK_SH)) {
                    323:          &logthis("<font color=blue>WARNING: ".
                    324:                   'Could not obtain shared lock in delenv: '.$!);
                    325:          $fh->close();
                    326:          return 'error: '.$!;
                    327:      }
1.56      www       328:      @oldenv=<$fh>;
1.89      www       329:      $fh->close();
1.56      www       330:     }
                    331:     {
                    332:      my $fh;
                    333:      unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) {
                    334: 	return 'error';
                    335:      }
1.89      www       336:      unless (flock($fh,LOCK_EX)) {
                    337:          &logthis("<font color=blue>WARNING: ".
                    338:                   'Could not obtain exclusive lock in delenv: '.$!);
                    339:          $fh->close();
                    340:          return 'error: '.$!;
                    341:      }
1.191     harris41  342:      foreach (@oldenv) {
1.56      www       343: 	 unless ($_=~/^$delthis/) { print $fh $_; }
1.191     harris41  344:      }
1.87      www       345:      $fh->close();
1.5       www       346:     }
                    347:     return 'ok';
1.283     www       348: }
                    349: 
                    350: # ------------------------------------------ Fight off request when overloaded
                    351: 
                    352: sub overloaderror {
                    353:     my ($r,$checkserver)=@_;
                    354:     unless ($checkserver) { $checkserver=$perlvar{'lonHostID'}; }
                    355:     my $loadavg;
                    356:     if ($checkserver eq $perlvar{'lonHostID'}) {
                    357:        my $loadfile=Apache::File->new('/proc/loadavg');
                    358:        $loadavg=<$loadfile>;
                    359:        $loadavg =~ s/\s.*//g;
1.285     matthew   360:        $loadavg = 100*$loadavg/$perlvar{'lonLoadLim'};
1.283     www       361:     } else {
                    362:        $loadavg=&reply('load',$checkserver);
                    363:     }
1.285     matthew   364:     my $overload=$loadavg-100;
1.283     www       365:     if ($overload>0) {
1.285     matthew   366: 	$r->err_headers_out->{'Retry-After'}=$overload;
1.283     www       367:         $r->log_error('Overload of '.$overload.' on '.$checkserver);
                    368:         return 413;
                    369:     }    
                    370:     return '';
1.5       www       371: }
1.1       albertel  372: 
                    373: # ------------------------------ Find server with least workload from spare.tab
1.11      www       374: 
1.1       albertel  375: sub spareserver {
1.284     matthew   376:     my $loadpercent = shift;
1.1       albertel  377:     my $tryserver;
                    378:     my $spareserver='';
1.284     matthew   379:     my $lowestserver=$loadpercent; 
1.1       albertel  380:     foreach $tryserver (keys %spareid) {
                    381:        my $answer=reply('load',$tryserver);
                    382:        if (($answer =~ /\d/) && ($answer<$lowestserver)) {
                    383: 	   $spareserver="http://$hostname{$tryserver}";
                    384:            $lowestserver=$answer;
                    385:        }
                    386:     }    
                    387:     return $spareserver;
1.202     matthew   388: }
                    389: 
                    390: # --------------------------------------------- Try to change a user's password
                    391: 
                    392: sub changepass {
                    393:     my ($uname,$udom,$currentpass,$newpass,$server)=@_;
                    394:     $currentpass = &escape($currentpass);
                    395:     $newpass     = &escape($newpass);
                    396:     my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass",
                    397: 		       $server);
                    398:     if (! $answer) {
                    399: 	&logthis("No reply on password change request to $server ".
                    400: 		 "by $uname in domain $udom.");
                    401:     } elsif ($answer =~ "^ok") {
                    402:         &logthis("$uname in $udom successfully changed their password ".
                    403: 		 "on $server.");
                    404:     } elsif ($answer =~ "^pwchange_failure") {
                    405: 	&logthis("$uname in $udom was unable to change their password ".
                    406: 		 "on $server.  The action was blocked by either lcpasswd ".
                    407: 		 "or pwchange");
                    408:     } elsif ($answer =~ "^non_authorized") {
                    409:         &logthis("$uname in $udom did not get their password correct when ".
                    410: 		 "attempting to change it on $server.");
                    411:     } elsif ($answer =~ "^auth_mode_error") {
                    412:         &logthis("$uname in $udom attempted to change their password despite ".
                    413: 		 "not being locally or internally authenticated on $server.");
                    414:     } elsif ($answer =~ "^unknown_user") {
                    415:         &logthis("$uname in $udom attempted to change their password ".
                    416: 		 "on $server but were unable to because $server is not ".
                    417: 		 "their home server.");
                    418:     } elsif ($answer =~ "^refused") {
                    419: 	&logthis("$server refused to change $uname in $udom password because ".
                    420: 		 "it was sent an unencrypted request to change the password.");
                    421:     }
                    422:     return $answer;
1.1       albertel  423: }
                    424: 
1.169     harris41  425: # ----------------------- Try to determine user's current authentication scheme
                    426: 
                    427: sub queryauthenticate {
                    428:     my ($uname,$udom)=@_;
                    429:     if (($perlvar{'lonRole'} eq 'library') && 
                    430:         ($udom eq $perlvar{'lonDefDomain'})) {
                    431: 	my $answer=reply("encrypt:currentauth:$udom:$uname",
                    432: 			 $perlvar{'lonHostID'});
                    433: 	unless ($answer eq 'unknown_user' or $answer eq 'refused') {
                    434: 	    if (length($answer)) {
                    435: 		return $answer;
                    436: 	    }
                    437: 	    else {
                    438: 	&logthis("User $uname at $udom lacks an authentication mechanism");
                    439: 		return 'no_host';
                    440: 	    }
                    441: 	}
                    442:     }
                    443: 
                    444:     my $tryserver;
                    445:     foreach $tryserver (keys %libserv) {
                    446: 	if ($hostdom{$tryserver} eq $udom) {
                    447:            my $answer=reply("encrypt:currentauth:$udom:$uname",$tryserver);
                    448: 	   unless ($answer eq 'unknown_user' or $answer eq 'refused') {
                    449: 	       if (length($answer)) {
                    450: 		   return $answer;
                    451: 	       }
                    452: 	       else {
                    453: 	   &logthis("User $uname at $udom lacks an authentication mechanism");
                    454: 		   return 'no_host';
                    455: 	       }
                    456: 	   }
                    457:        }
                    458:     }
                    459:     &logthis("User $uname at $udom lacks an authentication mechanism");    
                    460:     return 'no_host';
                    461: }
                    462: 
1.1       albertel  463: # --------- Try to authenticate user from domain's lib servers (first this one)
1.11      www       464: 
1.1       albertel  465: sub authenticate {
                    466:     my ($uname,$upass,$udom)=@_;
1.12      www       467:     $upass=escape($upass);
1.199     www       468:     $uname=~s/\W//g;
1.1       albertel  469:     if (($perlvar{'lonRole'} eq 'library') && 
                    470:         ($udom eq $perlvar{'lonDefDomain'})) {
1.3       www       471:     my $answer=reply("encrypt:auth:$udom:$uname:$upass",$perlvar{'lonHostID'});
1.2       www       472:         if ($answer =~ /authorized/) {
1.9       www       473:               if ($answer eq 'authorized') {
                    474:                  &logthis("User $uname at $udom authorized by local server"); 
                    475:                  return $perlvar{'lonHostID'}; 
                    476:               }
                    477:               if ($answer eq 'non_authorized') {
                    478:                  &logthis("User $uname at $udom rejected by local server"); 
                    479:                  return 'no_host'; 
                    480:               }
1.2       www       481: 	}
1.1       albertel  482:     }
                    483: 
                    484:     my $tryserver;
                    485:     foreach $tryserver (keys %libserv) {
                    486: 	if ($hostdom{$tryserver} eq $udom) {
1.10      www       487:            my $answer=reply("encrypt:auth:$udom:$uname:$upass",$tryserver);
1.1       albertel  488:            if ($answer =~ /authorized/) {
1.9       www       489:               if ($answer eq 'authorized') {
                    490:                  &logthis("User $uname at $udom authorized by $tryserver"); 
                    491:                  return $tryserver; 
                    492:               }
                    493:               if ($answer eq 'non_authorized') {
                    494:                  &logthis("User $uname at $udom rejected by $tryserver");
                    495:                  return 'no_host';
                    496:               } 
1.1       albertel  497: 	   }
                    498:        }
1.9       www       499:     }
                    500:     &logthis("User $uname at $udom could not be authenticated");    
1.1       albertel  501:     return 'no_host';
                    502: }
                    503: 
                    504: # ---------------------- Find the homebase for a user from domain's lib servers
1.11      www       505: 
1.1       albertel  506: sub homeserver {
1.230     stredwic  507:     my ($uname,$udom,$ignoreBadCache)=@_;
1.1       albertel  508:     my $index="$uname:$udom";
1.221     matthew   509:     if ($homecache{$index}) { 
                    510:         return "$homecache{$index}"; 
                    511:     }
1.1       albertel  512:     my $tryserver;
                    513:     foreach $tryserver (keys %libserv) {
1.230     stredwic  514:         next if ($ignoreBadCache ne 'true' && 
1.231     stredwic  515: 		 exists($badServerCache{$tryserver}));
1.1       albertel  516: 	if ($hostdom{$tryserver} eq $udom) {
                    517:            my $answer=reply("home:$udom:$uname",$tryserver);
                    518:            if ($answer eq 'found') { 
1.221     matthew   519:               $homecache{$index}=$tryserver;
1.1       albertel  520:               return $tryserver; 
1.231     stredwic  521:            } elsif ($answer eq 'no_host') {
                    522: 	       $badServerCache{$tryserver}=1;
1.221     matthew   523:            }
1.1       albertel  524:        }
                    525:     }    
                    526:     return 'no_host';
1.70      www       527: }
                    528: 
                    529: # ------------------------------------- Find the usernames behind a list of IDs
                    530: 
                    531: sub idget {
                    532:     my ($udom,@ids)=@_;
                    533:     my %returnhash=();
                    534:     
                    535:     my $tryserver;
                    536:     foreach $tryserver (keys %libserv) {
                    537:        if ($hostdom{$tryserver} eq $udom) {
                    538: 	  my $idlist=join('&',@ids);
                    539:           $idlist=~tr/A-Z/a-z/; 
                    540: 	  my $reply=&reply("idget:$udom:".$idlist,$tryserver);
                    541:           my @answer=();
1.76      www       542:           if (($reply ne 'con_lost') && ($reply!~/^error\:/)) {
1.70      www       543: 	      @answer=split(/\&/,$reply);
                    544:           }                    ;
                    545:           my $i;
                    546:           for ($i=0;$i<=$#ids;$i++) {
                    547:               if ($answer[$i]) {
                    548: 		  $returnhash{$ids[$i]}=$answer[$i];
                    549:               } 
                    550:           }
                    551:        }
                    552:     }    
                    553:     return %returnhash;
                    554: }
                    555: 
                    556: # ------------------------------------- Find the IDs behind a list of usernames
                    557: 
                    558: sub idrget {
                    559:     my ($udom,@unames)=@_;
                    560:     my %returnhash=();
1.191     harris41  561:     foreach (@unames) {
1.70      www       562:         $returnhash{$_}=(&userenvironment($udom,$_,'id'))[1];
1.191     harris41  563:     }
1.70      www       564:     return %returnhash;
                    565: }
                    566: 
                    567: # ------------------------------- Store away a list of names and associated IDs
                    568: 
                    569: sub idput {
                    570:     my ($udom,%ids)=@_;
                    571:     my %servers=();
1.191     harris41  572:     foreach (keys %ids) {
1.70      www       573:         my $uhom=&homeserver($_,$udom);
                    574:         if ($uhom ne 'no_host') {
                    575:             my $id=&escape($ids{$_});
                    576:             $id=~tr/A-Z/a-z/;
                    577:             my $unam=&escape($_);
                    578: 	    if ($servers{$uhom}) {
                    579: 		$servers{$uhom}.='&'.$id.'='.$unam;
                    580:             } else {
                    581:                 $servers{$uhom}=$id.'='.$unam;
                    582:             }
                    583:             &critical('put:'.$udom.':'.$unam.':environment:id='.$id,$uhom);
                    584:         }
1.191     harris41  585:     }
                    586:     foreach (keys %servers) {
1.70      www       587:         &critical('idput:'.$udom.':'.$servers{$_},$_);
1.191     harris41  588:     }
1.70      www       589: }
                    590: 
                    591: # ------------------------------------- Find the section of student in a course
1.298     matthew   592: 
                    593: sub getsection {
                    594:     my ($udom,$unam,$courseid)=@_;
                    595:     $courseid=~s/\_/\//g;
                    596:     $courseid=~s/^(\w)/\/$1/;
                    597:     my %Pending; 
                    598:     my %Expired;
                    599:     #
                    600:     # Each role can either have not started yet (pending), be active, 
                    601:     #    or have expired.
                    602:     #
                    603:     # If there is an active role, we are done.
                    604:     #
                    605:     # If there is more than one role which has not started yet, 
                    606:     #     choose the one which will start sooner
                    607:     # If there is one role which has not started yet, return it.
                    608:     #
                    609:     # If there is more than one expired role, choose the one which ended last.
                    610:     # If there is a role which has expired, return it.
                    611:     #
                    612:     foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',
                    613:                         &homeserver($unam,$udom)))) {
                    614:         my ($key,$value)=split(/\=/,$_);
                    615:         $key=&unescape($key);
                    616:         next if ($key !~/^$courseid(?:\/)*(\w+)*\_st$/);
                    617:         my $section=$1;
                    618:         if ($key eq $courseid.'_st') { $section=''; }
                    619:         my ($dummy,$end,$start)=split(/\_/,&unescape($value));
                    620:         my $now=time;
                    621:         if (defined($end) && ($now > $end)) {
                    622:             $Expired{$end}=$section;
                    623:             next;
                    624:         }
                    625:         if (defined($start) && ($now < $start)) {
                    626:             $Pending{$start}=$section;
                    627:             next;
                    628:         }
                    629:         return $section;
                    630:     }
                    631:     #
                    632:     # Presumedly there will be few matching roles from the above
                    633:     # loop and the sorting time will be negligible.
                    634:     if (scalar(keys(%Pending))) {
                    635:         my ($time) = sort {$a <=> $b} keys(%Pending);
                    636:         return $Pending{$time};
                    637:     } 
                    638:     if (scalar(keys(%Expired))) {
                    639:         my @sorted = sort {$a <=> $b} keys(%Expired);
                    640:         my $time = pop(@sorted);
                    641:         return $Expired{$time};
                    642:     }
                    643:     return '-1';
                    644: }
1.70      www       645: 
                    646: sub usection {
                    647:     my ($udom,$unam,$courseid)=@_;
                    648:     $courseid=~s/\_/\//g;
                    649:     $courseid=~s/^(\w)/\/$1/;
1.191     harris41  650:     foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',
                    651:                         &homeserver($unam,$udom)))) {
1.70      www       652:         my ($key,$value)=split(/\=/,$_);
                    653:         $key=&unescape($key);
                    654:         if ($key=~/^$courseid(?:\/)*(\w+)*\_st$/) {
                    655:             my $section=$1;
                    656:             if ($key eq $courseid.'_st') { $section=''; }
                    657: 	    my ($dummy,$end,$start)=split(/\_/,&unescape($value));
                    658:             my $now=time;
                    659:             my $notactive=0;
                    660:             if ($start) {
                    661: 		if ($now<$start) { $notactive=1; }
                    662:             }
                    663:             if ($end) {
                    664:                 if ($now>$end) { $notactive=1; }
                    665:             } 
                    666:             unless ($notactive) { return $section; }
                    667:         }
1.191     harris41  668:     }
1.70      www       669:     return '-1';
                    670: }
                    671: 
                    672: # ------------------------------------- Read an entry from a user's environment
                    673: 
                    674: sub userenvironment {
                    675:     my ($udom,$unam,@what)=@_;
                    676:     my %returnhash=();
                    677:     my @answer=split(/\&/,
                    678:                 &reply('get:'.$udom.':'.$unam.':environment:'.join('&',@what),
                    679:                       &homeserver($unam,$udom)));
                    680:     my $i;
                    681:     for ($i=0;$i<=$#what;$i++) {
                    682: 	$returnhash{$what[$i]}=&unescape($answer[$i]);
                    683:     }
                    684:     return %returnhash;
1.1       albertel  685: }
                    686: 
1.263     www       687: # -------------------------------------------------------------------- New chat
                    688: 
                    689: sub chatsend {
                    690:     my ($newentry,$anon)=@_;
                    691:     my $cnum=$ENV{'course.'.$ENV{'request.course.id'}.'.num'};
                    692:     my $cdom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'};
                    693:     my $chome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'};
                    694:     &reply('chatsend:'.$cdom.':'.$cnum.':'.
                    695: 	   &escape($ENV{'user.domain'}.':'.$ENV{'user.name'}.':'.$anon.':'.
                    696: 		   &escape($newentry)),$chome);
1.292     www       697: }
                    698: 
                    699: # ------------------------------------------ Find current version of a resource
                    700: 
                    701: sub getversion {
                    702:     my $fname=&clutter(shift);
                    703:     unless ($fname=~/^\/res\//) { return -1; }
                    704:     return &currentversion(&filelocation('',$fname));
                    705: }
                    706: 
                    707: sub currentversion {
                    708:     my $fname=shift;
                    709:     my $author=$fname;
                    710:     $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
                    711:     my ($udom,$uname)=split(/\//,$author);
                    712:     my $home=homeserver($uname,$udom);
                    713:     if ($home eq 'no_host') { 
                    714:         return -1; 
                    715:     }
                    716:     my $answer=reply("currentversion:$fname",$home);
                    717:     if (($answer eq 'con_lost') || ($answer eq 'rejected')) {
                    718: 	return -1;
                    719:     }
                    720:     return $answer;
1.263     www       721: }
                    722: 
1.1       albertel  723: # ----------------------------- Subscribe to a resource, return URL if possible
1.11      www       724: 
1.1       albertel  725: sub subscribe {
                    726:     my $fname=shift;
1.312     www       727:     if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return ''; }
1.1       albertel  728:     my $author=$fname;
                    729:     $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
                    730:     my ($udom,$uname)=split(/\//,$author);
                    731:     my $home=homeserver($uname,$udom);
1.290     www       732:     if ($home eq 'no_host') { 
1.1       albertel  733:         return 'not_found'; 
                    734:     }
                    735:     my $answer=reply("sub:$fname",$home);
1.64      www       736:     if (($answer eq 'con_lost') || ($answer eq 'rejected')) {
                    737: 	$answer.=' by '.$home;
                    738:     }
1.1       albertel  739:     return $answer;
                    740: }
                    741:     
1.8       www       742: # -------------------------------------------------------------- Replicate file
                    743: 
                    744: sub repcopy {
                    745:     my $filename=shift;
1.23      www       746:     $filename=~s/\/+/\//g;
1.214     www       747:     if ($filename=~/^\/home\/httpd\/html\/adm\//) { return OK; }
1.8       www       748:     my $transname="$filename.in.transfer";
1.17      www       749:     if ((-e $filename) || (-e $transname)) { return OK; }
1.8       www       750:     my $remoteurl=subscribe($filename);
1.64      www       751:     if ($remoteurl =~ /^con_lost by/) {
                    752: 	   &logthis("Subscribe returned $remoteurl: $filename");
1.8       www       753:            return HTTP_SERVICE_UNAVAILABLE;
                    754:     } elsif ($remoteurl eq 'not_found') {
                    755: 	   &logthis("Subscribe returned not_found: $filename");
                    756: 	   return HTTP_NOT_FOUND;
1.64      www       757:     } elsif ($remoteurl =~ /^rejected by/) {
                    758: 	   &logthis("Subscribe returned $remoteurl: $filename");
1.8       www       759:            return FORBIDDEN;
1.20      www       760:     } elsif ($remoteurl eq 'directory') {
                    761:            return OK;
1.8       www       762:     } else {
1.290     www       763:         my $author=$filename;
                    764:         $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
                    765:         my ($udom,$uname)=split(/\//,$author);
                    766:         my $home=homeserver($uname,$udom);
                    767:         unless ($home eq $perlvar{'lonHostID'}) {
1.8       www       768:            my @parts=split(/\//,$filename);
                    769:            my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";
                    770:            if ($path ne "$perlvar{'lonDocRoot'}/res") {
                    771:                &logthis("Malconfiguration for replication: $filename");
                    772: 	       return HTTP_BAD_REQUEST;
                    773:            }
                    774:            my $count;
                    775:            for ($count=5;$count<$#parts;$count++) {
                    776:                $path.="/$parts[$count]";
                    777:                if ((-e $path)!=1) {
                    778: 		   mkdir($path,0777);
                    779:                }
                    780:            }
                    781:            my $ua=new LWP::UserAgent;
                    782:            my $request=new HTTP::Request('GET',"$remoteurl");
                    783:            my $response=$ua->request($request,$transname);
                    784:            if ($response->is_error()) {
                    785: 	       unlink($transname);
                    786:                my $message=$response->status_line;
1.12      www       787:                &logthis("<font color=blue>WARNING:"
                    788:                        ." LWP get: $message: $filename</font>");
1.8       www       789:                return HTTP_SERVICE_UNAVAILABLE;
                    790:            } else {
1.16      www       791: 	       if ($remoteurl!~/\.meta$/) {
                    792:                   my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');
                    793:                   my $mresponse=$ua->request($mrequest,$filename.'.meta');
                    794:                   if ($mresponse->is_error()) {
                    795: 		      unlink($filename.'.meta');
                    796:                       &logthis(
                    797:                      "<font color=yellow>INFO: No metadata: $filename</font>");
                    798:                   }
                    799: 	       }
1.8       www       800:                rename($transname,$filename);
                    801:                return OK;
                    802:            }
1.290     www       803:        }
1.8       www       804:     }
1.330     www       805: }
                    806: 
                    807: # ------------------------------------------------ Get server side include body
                    808: sub ssi_body {
                    809:     my $filelink=shift;
                    810:     my $output=($filelink=~/^http\:/?&externalssi($filelink):
                    811:                                      &ssi($filelink));
                    812:     $output=~s/^.*\<body[^\>]*\>//si;
                    813:     $output=~s/\<\/body\s*\>.*$//si;
1.331     www       814:     $output=~
                    815:             s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs;
1.330     www       816:     return $output;
1.8       www       817: }
                    818: 
1.15      www       819: # --------------------------------------------------------- Server Side Include
                    820: 
                    821: sub ssi {
                    822: 
1.23      www       823:     my ($fn,%form)=@_;
1.15      www       824: 
                    825:     my $ua=new LWP::UserAgent;
1.23      www       826:     
                    827:     my $request;
                    828:     
                    829:     if (%form) {
                    830:       $request=new HTTP::Request('POST',"http://".$ENV{'HTTP_HOST'}.$fn);
1.201     albertel  831:       $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form));
1.23      www       832:     } else {
                    833:       $request=new HTTP::Request('GET',"http://".$ENV{'HTTP_HOST'}.$fn);
                    834:     }
                    835: 
1.15      www       836:     $request->header(Cookie => $ENV{'HTTP_COOKIE'});
                    837:     my $response=$ua->request($request);
                    838: 
1.324     www       839:     return $response->content;
                    840: }
                    841: 
                    842: sub externalssi {
                    843:     my ($url)=@_;
                    844:     my $ua=new LWP::UserAgent;
                    845:     my $request=new HTTP::Request('GET',$url);
                    846:     my $response=$ua->request($request);
1.15      www       847:     return $response->content;
                    848: }
1.254     www       849: 
                    850: # ------- Add a token to a remote URI's query string to vouch for access rights
                    851: 
                    852: sub tokenwrapper {
                    853:     my $uri=shift;
1.259     www       854:     $uri=~s/^http\:\/\/([^\/]+)//;
                    855:     $uri=~s/^\///;
                    856:     $ENV{'user.environment'}=~/\/([^\/]+)\.id/;
                    857:     my $token=$1;
                    858:     if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.*)*$/) {
                    859: 	&appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'});
                    860:         return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri.
1.304     www       861:                (($uri=~/\?/)?'&':'?').'token='.$token.
                    862:                                '&tokenissued='.$perlvar{'lonHostID'};
1.259     www       863:     } else {
                    864: 	return '/adm/notfound.html';
                    865:     }
1.254     www       866: }
                    867:     
1.257     www       868: # --------------- Take an uploaded file and put it into the userfiles directory
1.259     www       869: # input: name of form element, coursedoc=1 means this is for the course
1.257     www       870: # output: url of file in userspace
                    871: 
                    872: sub userfileupload {
1.259     www       873:     my ($formname,$coursedoc)=@_;
1.257     www       874:     my $fname=$ENV{'form.'.$formname.'.filename'};
1.315     www       875: # Replace Windows backslashes by forward slashes
1.257     www       876:     $fname=~s/\\/\//g;
1.315     www       877: # Get rid of everything but the actual filename
1.257     www       878:     $fname=~s/^.*\/([^\/]+)$/$1/;
1.315     www       879: # Replace spaces by underscores
                    880:     $fname=~s/\s+/\_/g;
                    881: # Replace all other weird characters by nothing
1.317     www       882:     $fname=~s/[^\w\.\-]//g;
1.315     www       883: # See if there is anything left
1.257     www       884:     unless ($fname) { return 'error: no uploaded file'; }
                    885:     chop($ENV{'form.'.$formname});
1.258     www       886: # Create the directory if not present
1.259     www       887:     my $docuname='';
                    888:     my $docudom='';
                    889:     my $docuhome='';
                    890:     if ($coursedoc) {
                    891: 	$docuname=$ENV{'course.'.$ENV{'request.course.id'}.'.num'};
                    892: 	$docudom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'};
                    893: 	$docuhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'};
                    894:     } else {
                    895:         $docuname=$ENV{'user.name'};
                    896:         $docudom=$ENV{'user.domain'};
                    897:         $docuhome=$ENV{'user.home'};
                    898:     }
1.271     www       899:     return 
                    900:         &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname);
                    901: }
                    902: 
                    903: sub finishuserfileupload {
                    904:     my ($docuname,$docudom,$docuhome,$formname,$fname)=@_;
1.259     www       905:     my $path=$docudom.'/'.$docuname.'/';
1.258     www       906:     my $filepath=$perlvar{'lonDocRoot'};
1.259     www       907:     my @parts=split(/\//,$filepath.'/userfiles/'.$path);
1.258     www       908:     my $count;
                    909:     for ($count=4;$count<=$#parts;$count++) {
                    910:         $filepath.="/$parts[$count]";
                    911:         if ((-e $filepath)!=1) {
                    912: 	    mkdir($filepath,0777);
                    913:         }
                    914:     }
                    915: # Save the file
                    916:     {
                    917:        my $fh=Apache::File->new('>'.$filepath.'/'.$fname);
                    918:        print $fh $ENV{'form.'.$formname};
                    919:     }
1.259     www       920: # Notify homeserver to grep it
                    921: #
1.295     www       922:     
                    923:     my $fetchresult= 
                    924:  &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,$docuhome);
                    925:     if ($fetchresult eq 'ok') {
1.259     www       926: #
1.258     www       927: # Return the URL to it
1.263     www       928:         return '/uploaded/'.$path.$fname;
                    929:     } else {
1.295     www       930:         &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$fname.
                    931:          ' to host '.$docuhome.': '.$fetchresult);
1.263     www       932:         return '/adm/notfound.html';
                    933:     }    
1.257     www       934: }
1.15      www       935: 
1.14      www       936: # ------------------------------------------------------------------------- Log
                    937: 
                    938: sub log {
                    939:     my ($dom,$nam,$hom,$what)=@_;
1.47      www       940:     return critical("log:$dom:$nam:$what",$hom);
1.157     www       941: }
                    942: 
                    943: # ------------------------------------------------------------------ Course Log
                    944: 
                    945: sub flushcourselogs {
                    946:     &logthis('Flushing course log buffers');
1.191     harris41  947:     foreach (keys %courselogs) {
1.157     www       948:         my $crsid=$_;
1.188     www       949:         if (&reply('log:'.$coursedombuf{$crsid}.':'.
                    950: 		          &escape($courselogs{$crsid}),
                    951: 		          $coursehombuf{$crsid}) eq 'ok') {
1.157     www       952: 	    delete $courselogs{$crsid};
                    953:         } else {
                    954:             &logthis('Failed to flush log buffer for '.$crsid);
                    955:             if (length($courselogs{$crsid})>40000) {
                    956:                &logthis("<font color=blue>WARNING: Buffer for ".$crsid.
                    957:                         " exceeded maximum size, deleting.</font>");
                    958:                delete $courselogs{$crsid};
                    959:             }
                    960:         }        
1.191     harris41  961:     }
1.185     www       962:     &logthis('Flushing access logs');
1.191     harris41  963:     foreach (keys %accesshash) {
1.185     www       964:         my $entry=$_;
                    965:         $entry=~/\_\_\_(\w+)\/(\w+)\/(.*)\_\_\_(\w+)$/;
                    966:         my %temphash=($entry => $accesshash{$entry});
1.266     albertel  967:         if (&Apache::lonnet::put('nohist_resevaldata',\%temphash,$1,$2) eq 'ok') {
1.185     www       968: 	    delete $accesshash{$entry};
                    969:         }
1.191     harris41  970:     }
1.186     www       971:     $dumpcount++;
1.157     www       972: }
                    973: 
                    974: sub courselog {
                    975:     my $what=shift;
1.158     www       976:     $what=time.':'.$what;
1.157     www       977:     unless ($ENV{'request.course.id'}) { return ''; }
1.188     www       978:     $coursedombuf{$ENV{'request.course.id'}}=
                    979:        $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.':'.
                    980:        $ENV{'course.'.$ENV{'request.course.id'}.'.num'};
                    981:     $coursehombuf{$ENV{'request.course.id'}}=
                    982:        $ENV{'course.'.$ENV{'request.course.id'}.'.home'};
1.157     www       983:     if (defined $courselogs{$ENV{'request.course.id'}}) {
                    984: 	$courselogs{$ENV{'request.course.id'}}.='&'.$what;
                    985:     } else {
                    986: 	$courselogs{$ENV{'request.course.id'}}.=$what;
                    987:     }
                    988:     if (length($courselogs{$ENV{'request.course.id'}})>4048) {
                    989: 	&flushcourselogs();
                    990:     }
1.158     www       991: }
                    992: 
                    993: sub courseacclog {
                    994:     my $fnsymb=shift;
                    995:     unless ($ENV{'request.course.id'}) { return ''; }
                    996:     my $what=$fnsymb.':'.$ENV{'user.name'}.':'.$ENV{'user.domain'};
1.192     www       997:     if ($fnsymb=~/(problem|exam|quiz|assess|survey|form)$/) {
1.187     www       998:         $what.=':POST';
1.191     harris41  999: 	foreach (keys %ENV) {
1.158     www      1000:             if ($_=~/^form\.(.*)/) {
                   1001: 		$what.=':'.$1.'='.$ENV{$_};
                   1002:             }
1.191     harris41 1003:         }
1.158     www      1004:     }
                   1005:     &courselog($what);
1.149     www      1006: }
                   1007: 
1.185     www      1008: sub countacc {
                   1009:     my $url=&declutter(shift);
                   1010:     unless ($ENV{'request.course.id'}) { return ''; }
                   1011:     $accesshash{$ENV{'request.course.id'}.'___'.$url.'___course'}=1;
1.281     www      1012:     my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count';
1.185     www      1013:     if (defined($accesshash{$key})) {
                   1014: 	$accesshash{$key}++;
                   1015:     } else {
                   1016:         $accesshash{$key}=1;
                   1017:     }
                   1018: }
                   1019:     
1.149     www      1020: # ----------------------------------------------------------- Check out an item
                   1021: 
                   1022: sub checkout {
                   1023:     my ($symb,$tuname,$tudom,$tcrsid)=@_;
                   1024:     my $now=time;
                   1025:     my $lonhost=$perlvar{'lonHostID'};
                   1026:     my $infostr=&escape(
1.234     www      1027:                  'CHECKOUTTOKEN&'.
1.149     www      1028:                  $tuname.'&'.
                   1029:                  $tudom.'&'.
                   1030:                  $tcrsid.'&'.
                   1031:                  $symb.'&'.
                   1032: 		 $now.'&'.$ENV{'REMOTE_ADDR'});
                   1033:     my $token=&reply('tmpput:'.$infostr,$lonhost);
1.151     www      1034:     if ($token=~/^error\:/) { 
                   1035:         &logthis("<font color=blue>WARNING: ".
                   1036:                 "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.
                   1037:                  "</font>");
                   1038:         return ''; 
                   1039:     }
                   1040: 
1.149     www      1041:     $token=~s/^(\d+)\_.*\_(\d+)$/$1\*$2\*$lonhost/;
                   1042:     $token=~tr/a-z/A-Z/;
                   1043: 
1.153     www      1044:     my %infohash=('resource.0.outtoken' => $token,
                   1045:                   'resource.0.checkouttime' => $now,
                   1046:                   'resource.0.outremote' => $ENV{'REMOTE_ADDR'});
1.149     www      1047: 
                   1048:     unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
                   1049:        return '';
1.151     www      1050:     } else {
                   1051:         &logthis("<font color=blue>WARNING: ".
                   1052:                 "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.
                   1053:                  "</font>");
1.149     www      1054:     }    
                   1055: 
                   1056:     if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
                   1057:                          &escape('Checkout '.$infostr.' - '.
                   1058:                                                  $token)) ne 'ok') {
                   1059: 	return '';
1.151     www      1060:     } else {
                   1061:         &logthis("<font color=blue>WARNING: ".
                   1062:                 "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.
                   1063:                  "</font>");
1.149     www      1064:     }
1.151     www      1065:     return $token;
1.149     www      1066: }
                   1067: 
                   1068: # ------------------------------------------------------------ Check in an item
                   1069: 
                   1070: sub checkin {
                   1071:     my $token=shift;
1.150     www      1072:     my $now=time;
                   1073:     my ($ta,$tb,$lonhost)=split(/\*/,$token);
                   1074:     $lonhost=~tr/A-Z/a-z/;
                   1075:     my $dtoken=$ta.'_'.$hostip{$lonhost}.'_'.$tb;
                   1076:     $dtoken=~s/\W/\_/g;
1.234     www      1077:     my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
1.150     www      1078:                  split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));
                   1079: 
1.154     www      1080:     unless (($tuname) && ($tudom)) {
                   1081:         &logthis('Check in '.$token.' ('.$dtoken.') failed');
                   1082:         return '';
                   1083:     }
                   1084:     
                   1085:     unless (&allowed('mgr',$tcrsid)) {
                   1086:         &logthis('Check in '.$token.' ('.$dtoken.') unauthorized: '.
                   1087:                  $ENV{'user.name'}.' - '.$ENV{'user.domain'});
                   1088:         return '';
                   1089:     }
                   1090: 
1.153     www      1091:     my %infohash=('resource.0.intoken' => $token,
                   1092:                   'resource.0.checkintime' => $now,
                   1093:                   'resource.0.inremote' => $ENV{'REMOTE_ADDR'});
1.150     www      1094: 
                   1095:     unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
                   1096:        return '';
                   1097:     }    
                   1098: 
                   1099:     if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
                   1100:                          &escape('Checkin - '.$token)) ne 'ok') {
                   1101: 	return '';
                   1102:     }
                   1103: 
                   1104:     return ($symb,$tuname,$tudom,$tcrsid);    
1.110     www      1105: }
                   1106: 
                   1107: # --------------------------------------------- Set Expire Date for Spreadsheet
                   1108: 
                   1109: sub expirespread {
                   1110:     my ($uname,$udom,$stype,$usymb)=@_;
                   1111:     my $cid=$ENV{'request.course.id'}; 
                   1112:     if ($cid) {
                   1113:        my $now=time;
                   1114:        my $key=$uname.':'.$udom.':'.$stype.':'.$usymb;
                   1115:        return &reply('put:'.$ENV{'course.'.$cid.'.domain'}.':'.
                   1116:                             $ENV{'course.'.$cid.'.num'}.
                   1117: 	        	    ':nohist_expirationdates:'.
                   1118:                             &escape($key).'='.$now,
                   1119:                             $ENV{'course.'.$cid.'.home'})
                   1120:     }
                   1121:     return 'ok';
1.14      www      1122: }
                   1123: 
1.109     www      1124: # ----------------------------------------------------- Devalidate Spreadsheets
                   1125: 
                   1126: sub devalidate {
1.325     www      1127:     my ($symb,$uname,$udom)=@_;
1.109     www      1128:     my $cid=$ENV{'request.course.id'}; 
                   1129:     if ($cid) {
1.325     www      1130: # delete the stored spreadsheets for
                   1131: # - the student level sheet of this user in course's homespace
                   1132: # - the assessment level sheet for this resource 
                   1133: #   for this user in user's homespace
                   1134: 	my $key=$uname.':'.$udom.':';
1.109     www      1135:         my $status=
1.299     matthew  1136: 	    &del('nohist_calculatedsheets',
1.133     albertel 1137: 		 [$key.'studentcalc'],
                   1138: 		 $ENV{'course.'.$cid.'.domain'},
                   1139: 		 $ENV{'course.'.$cid.'.num'})
                   1140: 		.' '.
                   1141: 	    &del('nohist_calculatedsheets_'.$cid,
                   1142: 		 [$key.'assesscalc:'.$symb]);
1.109     www      1143:         unless ($status eq 'ok ok') {
                   1144:            &logthis('Could not devalidate spreadsheet '.
1.325     www      1145:                     $uname.' at '.$udom.' for '.
1.109     www      1146: 		    $symb.': '.$status);
1.133     albertel 1147:         }
1.109     www      1148:     }
                   1149: }
                   1150: 
1.265     albertel 1151: sub get_scalar {
                   1152:     my ($string,$end) = @_;
                   1153:     my $value;
                   1154:     if ($$string =~ s/^([^&]*?)($end)/$2/) {
                   1155: 	$value = $1;
                   1156:     } elsif ($$string =~ s/^([^&]*?)&//) {
                   1157: 	$value = $1;
                   1158:     }
                   1159:     return &unescape($value);
                   1160: }
                   1161: 
                   1162: sub array2str {
                   1163:   my (@array) = @_;
                   1164:   my $result=&arrayref2str(\@array);
                   1165:   $result=~s/^__ARRAY_REF__//;
                   1166:   $result=~s/__END_ARRAY_REF__$//;
                   1167:   return $result;
                   1168: }
                   1169: 
1.204     albertel 1170: sub arrayref2str {
                   1171:   my ($arrayref) = @_;
1.265     albertel 1172:   my $result='__ARRAY_REF__';
1.204     albertel 1173:   foreach my $elem (@$arrayref) {
1.265     albertel 1174:     if(ref($elem) eq 'ARRAY') {
                   1175:       $result.=&arrayref2str($elem).'&';
                   1176:     } elsif(ref($elem) eq 'HASH') {
                   1177:       $result.=&hashref2str($elem).'&';
                   1178:     } elsif(ref($elem)) {
                   1179:       #print("Got a ref of ".(ref($elem))." skipping.");
1.204     albertel 1180:     } else {
                   1181:       $result.=&escape($elem).'&';
                   1182:     }
                   1183:   }
                   1184:   $result=~s/\&$//;
1.265     albertel 1185:   $result .= '__END_ARRAY_REF__';
1.204     albertel 1186:   return $result;
                   1187: }
                   1188: 
1.168     albertel 1189: sub hash2str {
1.204     albertel 1190:   my (%hash) = @_;
                   1191:   my $result=&hashref2str(\%hash);
1.265     albertel 1192:   $result=~s/^__HASH_REF__//;
                   1193:   $result=~s/__END_HASH_REF__$//;
1.204     albertel 1194:   return $result;
                   1195: }
                   1196: 
                   1197: sub hashref2str {
                   1198:   my ($hashref)=@_;
1.265     albertel 1199:   my $result='__HASH_REF__';
1.204     albertel 1200:   foreach (keys(%$hashref)) {
                   1201:     if (ref($_) eq 'ARRAY') {
1.265     albertel 1202:       $result.=&arrayref2str($_).'=';
1.204     albertel 1203:     } elsif (ref($_) eq 'HASH') {
1.265     albertel 1204:       $result.=&hashref2str($_).'=';
1.204     albertel 1205:     } elsif (ref($_)) {
1.265     albertel 1206:       $result.='=';
                   1207:       #print("Got a ref of ".(ref($_))." skipping.");
1.204     albertel 1208:     } else {
1.265     albertel 1209: 	if ($_) {$result.=&escape($_).'=';} else { last; }
1.204     albertel 1210:     }
                   1211: 
1.265     albertel 1212:     if(ref($hashref->{$_}) eq 'ARRAY') {
                   1213:       $result.=&arrayref2str($hashref->{$_}).'&';
                   1214:     } elsif(ref($hashref->{$_}) eq 'HASH') {
                   1215:       $result.=&hashref2str($hashref->{$_}).'&';
                   1216:     } elsif(ref($hashref->{$_})) {
                   1217:        $result.='&';
                   1218:       #print("Got a ref of ".(ref($hashref->{$_}))." skipping.");
1.204     albertel 1219:     } else {
1.265     albertel 1220:       $result.=&escape($hashref->{$_}).'&';
1.204     albertel 1221:     }
                   1222:   }
1.168     albertel 1223:   $result=~s/\&$//;
1.265     albertel 1224:   $result .= '__END_HASH_REF__';
1.168     albertel 1225:   return $result;
                   1226: }
                   1227: 
                   1228: sub str2hash {
1.265     albertel 1229:     my ($string)=@_;
                   1230:     my ($hash)=&str2hashref('__HASH_REF__'.$string.'__END_HASH_REF__');
                   1231:     return %$hash;
                   1232: }
                   1233: 
                   1234: sub str2hashref {
1.168     albertel 1235:   my ($string) = @_;
1.265     albertel 1236: 
                   1237:   my %hash;
                   1238: 
                   1239:   if($string !~ /^__HASH_REF__/) {
                   1240:       if (! ($string eq '' || !defined($string))) {
                   1241: 	  $hash{'error'}='Not hash reference';
                   1242:       }
                   1243:       return (\%hash, $string);
                   1244:   }
                   1245: 
                   1246:   $string =~ s/^__HASH_REF__//;
                   1247: 
                   1248:   while($string !~ /^__END_HASH_REF__/) {
                   1249:       #key
                   1250:       my $key='';
                   1251:       if($string =~ /^__HASH_REF__/) {
                   1252:           ($key, $string)=&str2hashref($string);
                   1253:           if(defined($key->{'error'})) {
                   1254:               $hash{'error'}='Bad data';
                   1255:               return (\%hash, $string);
                   1256:           }
                   1257:       } elsif($string =~ /^__ARRAY_REF__/) {
                   1258:           ($key, $string)=&str2arrayref($string);
                   1259:           if($key->[0] eq 'Array reference error') {
                   1260:               $hash{'error'}='Bad data';
                   1261:               return (\%hash, $string);
                   1262:           }
                   1263:       } else {
                   1264:           $string =~ s/^(.*?)=//;
1.267     albertel 1265: 	  $key=&unescape($1);
1.265     albertel 1266:       }
                   1267:       $string =~ s/^=//;
                   1268: 
                   1269:       #value
                   1270:       my $value='';
                   1271:       if($string =~ /^__HASH_REF__/) {
                   1272:           ($value, $string)=&str2hashref($string);
                   1273:           if(defined($value->{'error'})) {
                   1274:               $hash{'error'}='Bad data';
                   1275:               return (\%hash, $string);
                   1276:           }
                   1277:       } elsif($string =~ /^__ARRAY_REF__/) {
                   1278:           ($value, $string)=&str2arrayref($string);
                   1279:           if($value->[0] eq 'Array reference error') {
                   1280:               $hash{'error'}='Bad data';
                   1281:               return (\%hash, $string);
                   1282:           }
                   1283:       } else {
                   1284: 	  $value=&get_scalar(\$string,'__END_HASH_REF__');
                   1285:       }
                   1286:       $string =~ s/^&//;
                   1287: 
                   1288:       $hash{$key}=$value;
1.204     albertel 1289:   }
1.265     albertel 1290: 
                   1291:   $string =~ s/^__END_HASH_REF__//;
                   1292: 
                   1293:   return (\%hash, $string);
1.204     albertel 1294: }
                   1295: 
                   1296: sub str2array {
1.265     albertel 1297:     my ($string)=@_;
                   1298:     my ($array)=&str2arrayref('__ARRAY_REF__'.$string.'__END_ARRAY_REF__');
                   1299:     return @$array;
                   1300: }
                   1301: 
                   1302: sub str2arrayref {
1.204     albertel 1303:   my ($string) = @_;
1.265     albertel 1304:   my @array;
                   1305: 
                   1306:   if($string !~ /^__ARRAY_REF__/) {
                   1307:       if (! ($string eq '' || !defined($string))) {
                   1308: 	  $array[0]='Array reference error';
                   1309:       }
                   1310:       return (\@array, $string);
                   1311:   }
                   1312: 
                   1313:   $string =~ s/^__ARRAY_REF__//;
                   1314: 
                   1315:   while($string !~ /^__END_ARRAY_REF__/) {
                   1316:       my $value='';
                   1317:       if($string =~ /^__HASH_REF__/) {
                   1318:           ($value, $string)=&str2hashref($string);
                   1319:           if(defined($value->{'error'})) {
                   1320:               $array[0] ='Array reference error';
                   1321:               return (\@array, $string);
                   1322:           }
                   1323:       } elsif($string =~ /^__ARRAY_REF__/) {
                   1324:           ($value, $string)=&str2arrayref($string);
                   1325:           if($value->[0] eq 'Array reference error') {
                   1326:               $array[0] ='Array reference error';
                   1327:               return (\@array, $string);
                   1328:           }
                   1329:       } else {
                   1330: 	  $value=&get_scalar(\$string,'__END_ARRAY_REF__');
                   1331:       }
                   1332:       $string =~ s/^&//;
                   1333: 
                   1334:       push(@array, $value);
1.191     harris41 1335:   }
1.265     albertel 1336: 
                   1337:   $string =~ s/^__END_ARRAY_REF__//;
                   1338: 
                   1339:   return (\@array, $string);
1.168     albertel 1340: }
                   1341: 
1.167     albertel 1342: # -------------------------------------------------------------------Temp Store
                   1343: 
1.168     albertel 1344: sub tmpreset {
                   1345:   my ($symb,$namespace,$domain,$stuname) = @_;
                   1346:   if (!$symb) {
                   1347:     $symb=&symbread();
                   1348:     if (!$symb) { $symb= $ENV{'REQUEST_URI'}; }
                   1349:   }
                   1350:   $symb=escape($symb);
                   1351: 
                   1352:   if (!$namespace) { $namespace=$ENV{'request.state'}; }
                   1353:   $namespace=~s/\//\_/g;
                   1354:   $namespace=~s/\W//g;
                   1355: 
                   1356:   #FIXME needs to do something for /pub resources
                   1357:   if (!$domain) { $domain=$ENV{'user.domain'}; }
                   1358:   if (!$stuname) { $stuname=$ENV{'user.name'}; }
                   1359:   my $path=$perlvar{'lonDaemons'}.'/tmp';
                   1360:   my %hash;
                   1361:   if (tie(%hash,'GDBM_File',
                   1362: 	  $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
1.256     albertel 1363: 	  &GDBM_WRCREAT(),0640)) {
1.168     albertel 1364:     foreach my $key (keys %hash) {
1.180     albertel 1365:       if ($key=~ /:$symb/) {
1.168     albertel 1366: 	delete($hash{$key});
                   1367:       }
                   1368:     }
                   1369:   }
                   1370: }
                   1371: 
1.167     albertel 1372: sub tmpstore {
1.168     albertel 1373:   my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
                   1374: 
                   1375:   if (!$symb) {
                   1376:     $symb=&symbread();
                   1377:     if (!$symb) { $symb= $ENV{'request.url'}; }
                   1378:   }
                   1379:   $symb=escape($symb);
                   1380: 
                   1381:   if (!$namespace) {
                   1382:     # I don't think we would ever want to store this for a course.
                   1383:     # it seems this will only be used if we don't have a course.
                   1384:     #$namespace=$ENV{'request.course.id'};
                   1385:     #if (!$namespace) {
                   1386:       $namespace=$ENV{'request.state'};
                   1387:     #}
                   1388:   }
                   1389:   $namespace=~s/\//\_/g;
                   1390:   $namespace=~s/\W//g;
                   1391: #FIXME needs to do something for /pub resources
                   1392:   if (!$domain) { $domain=$ENV{'user.domain'}; }
                   1393:   if (!$stuname) { $stuname=$ENV{'user.name'}; }
                   1394:   my $now=time;
                   1395:   my %hash;
                   1396:   my $path=$perlvar{'lonDaemons'}.'/tmp';
                   1397:   if (tie(%hash,'GDBM_File',
                   1398: 	  $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
1.256     albertel 1399: 	  &GDBM_WRCREAT(),0640)) {
1.168     albertel 1400:     $hash{"version:$symb"}++;
                   1401:     my $version=$hash{"version:$symb"};
                   1402:     my $allkeys=''; 
                   1403:     foreach my $key (keys(%$storehash)) {
                   1404:       $allkeys.=$key.':';
                   1405:       $hash{"$version:$symb:$key"}=$$storehash{$key};
                   1406:     }
                   1407:     $hash{"$version:$symb:timestamp"}=$now;
                   1408:     $allkeys.='timestamp';
                   1409:     $hash{"$version:keys:$symb"}=$allkeys;
                   1410:     if (untie(%hash)) {
                   1411:       return 'ok';
                   1412:     } else {
                   1413:       return "error:$!";
                   1414:     }
                   1415:   } else {
                   1416:     return "error:$!";
                   1417:   }
                   1418: }
1.167     albertel 1419: 
1.168     albertel 1420: # -----------------------------------------------------------------Temp Restore
1.167     albertel 1421: 
1.168     albertel 1422: sub tmprestore {
                   1423:   my ($symb,$namespace,$domain,$stuname) = @_;
1.167     albertel 1424: 
1.168     albertel 1425:   if (!$symb) {
                   1426:     $symb=&symbread();
                   1427:     if (!$symb) { $symb= $ENV{'request.url'}; }
                   1428:   }
                   1429:   $symb=escape($symb);
                   1430: 
                   1431:   if (!$namespace) { $namespace=$ENV{'request.state'}; }
                   1432:   #FIXME needs to do something for /pub resources
                   1433:   if (!$domain) { $domain=$ENV{'user.domain'}; }
                   1434:   if (!$stuname) { $stuname=$ENV{'user.name'}; }
                   1435: 
                   1436:   my %returnhash;
                   1437:   $namespace=~s/\//\_/g;
                   1438:   $namespace=~s/\W//g;
                   1439:   my %hash;
                   1440:   my $path=$perlvar{'lonDaemons'}.'/tmp';
                   1441:   if (tie(%hash,'GDBM_File',
                   1442: 	  $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
1.256     albertel 1443: 	  &GDBM_READER(),0640)) {
1.168     albertel 1444:     my $version=$hash{"version:$symb"};
                   1445:     $returnhash{'version'}=$version;
                   1446:     my $scope;
                   1447:     for ($scope=1;$scope<=$version;$scope++) {
                   1448:       my $vkeys=$hash{"$scope:keys:$symb"};
                   1449:       my @keys=split(/:/,$vkeys);
                   1450:       my $key;
                   1451:       $returnhash{"$scope:keys"}=$vkeys;
                   1452:       foreach $key (@keys) {
                   1453: 	$returnhash{"$scope:$key"}=$hash{"$scope:$symb:$key"};
                   1454: 	$returnhash{"$key"}=$hash{"$scope:$symb:$key"};
1.167     albertel 1455:       }
                   1456:     }
1.168     albertel 1457:     if (!(untie(%hash))) {
                   1458:       return "error:$!";
                   1459:     }
                   1460:   } else {
                   1461:     return "error:$!";
                   1462:   }
                   1463:   return %returnhash;
1.167     albertel 1464: }
                   1465: 
1.9       www      1466: # ----------------------------------------------------------------------- Store
                   1467: 
                   1468: sub store {
1.124     www      1469:     my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
                   1470:     my $home='';
                   1471: 
1.168     albertel 1472:     if ($stuname) { $home=&homeserver($stuname,$domain); }
1.124     www      1473: 
1.213     www      1474:     $symb=&symbclean($symb);
1.122     albertel 1475:     if (!$symb) { unless ($symb=&symbread()) { return ''; } }
1.109     www      1476: 
1.325     www      1477:     if (!$domain) { $domain=$ENV{'user.domain'}; }
                   1478:     if (!$stuname) { $stuname=$ENV{'user.name'}; }
                   1479: 
                   1480:     &devalidate($symb,$stuname,$domain);
1.109     www      1481: 
                   1482:     $symb=escape($symb);
1.187     www      1483:     if (!$namespace) { 
                   1484:        unless ($namespace=$ENV{'request.course.id'}) { 
                   1485:           return ''; 
                   1486:        } 
                   1487:     }
1.122     albertel 1488:     if (!$home) { $home=$ENV{'user.home'}; }
1.12      www      1489:     my $namevalue='';
1.191     harris41 1490:     foreach (keys %$storehash) {
1.122     albertel 1491:         $namevalue.=escape($_).'='.escape($$storehash{$_}).'&';
1.191     harris41 1492:     }
1.12      www      1493:     $namevalue=~s/\&$//;
1.187     www      1494:     &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue);
1.124     www      1495:     return reply("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");
1.9       www      1496: }
                   1497: 
1.47      www      1498: # -------------------------------------------------------------- Critical Store
                   1499: 
                   1500: sub cstore {
1.124     www      1501:     my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
                   1502:     my $home='';
                   1503: 
1.168     albertel 1504:     if ($stuname) { $home=&homeserver($stuname,$domain); }
1.124     www      1505: 
1.213     www      1506:     $symb=&symbclean($symb);
1.122     albertel 1507:     if (!$symb) { unless ($symb=&symbread()) { return ''; } }
1.109     www      1508: 
1.325     www      1509:     if (!$domain) { $domain=$ENV{'user.domain'}; }
                   1510:     if (!$stuname) { $stuname=$ENV{'user.name'}; }
                   1511: 
                   1512:     &devalidate($symb,$stuname,$domain);
1.109     www      1513: 
                   1514:     $symb=escape($symb);
1.187     www      1515:     if (!$namespace) { 
                   1516:        unless ($namespace=$ENV{'request.course.id'}) { 
                   1517:           return ''; 
                   1518:        } 
                   1519:     }
1.122     albertel 1520:     if (!$home) { $home=$ENV{'user.home'}; }
                   1521: 
1.47      www      1522:     my $namevalue='';
1.191     harris41 1523:     foreach (keys %$storehash) {
1.122     albertel 1524:         $namevalue.=escape($_).'='.escape($$storehash{$_}).'&';
1.191     harris41 1525:     }
1.47      www      1526:     $namevalue=~s/\&$//;
1.187     www      1527:     &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue);
1.188     www      1528:     return critical
                   1529:                 ("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");
1.47      www      1530: }
                   1531: 
1.9       www      1532: # --------------------------------------------------------------------- Restore
                   1533: 
                   1534: sub restore {
1.124     www      1535:     my ($symb,$namespace,$domain,$stuname) = @_;
                   1536:     my $home='';
                   1537: 
1.168     albertel 1538:     if ($stuname) { $home=&homeserver($stuname,$domain); }
1.124     www      1539: 
1.122     albertel 1540:     if (!$symb) {
                   1541:       unless ($symb=escape(&symbread())) { return ''; }
                   1542:     } else {
1.213     www      1543:       $symb=&escape(&symbclean($symb));
1.122     albertel 1544:     }
1.188     www      1545:     if (!$namespace) { 
                   1546:        unless ($namespace=$ENV{'request.course.id'}) { 
                   1547:           return ''; 
                   1548:        } 
                   1549:     }
1.122     albertel 1550:     if (!$domain) { $domain=$ENV{'user.domain'}; }
                   1551:     if (!$stuname) { $stuname=$ENV{'user.name'}; }
                   1552:     if (!$home) { $home=$ENV{'user.home'}; }
                   1553:     my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home");
                   1554: 
1.12      www      1555:     my %returnhash=();
1.191     harris41 1556:     foreach (split(/\&/,$answer)) {
1.12      www      1557: 	my ($name,$value)=split(/\=/,$_);
                   1558:         $returnhash{&unescape($name)}=&unescape($value);
1.191     harris41 1559:     }
1.75      www      1560:     my $version;
                   1561:     for ($version=1;$version<=$returnhash{'version'};$version++) {
1.191     harris41 1562:        foreach (split(/\:/,$returnhash{$version.':keys'})) {
1.75      www      1563:           $returnhash{$_}=$returnhash{$version.':'.$_};
1.191     harris41 1564:        }
1.75      www      1565:     }
1.13      www      1566:     return %returnhash;
1.34      www      1567: }
                   1568: 
                   1569: # ---------------------------------------------------------- Course Description
                   1570: 
                   1571: sub coursedescription {
                   1572:     my $courseid=shift;
                   1573:     $courseid=~s/^\///;
1.49      www      1574:     $courseid=~s/\_/\//g;
1.34      www      1575:     my ($cdomain,$cnum)=split(/\//,$courseid);
1.129     albertel 1576:     my $chome=&homeserver($cnum,$cdomain);
1.302     albertel 1577:     my $normalid=$cdomain.'_'.$cnum;
                   1578:     # need to always cache even if we get errors otherwise we keep 
                   1579:     # trying and trying and trying to get the course description.
                   1580:     my %envhash=();
                   1581:     my %returnhash=();
                   1582:     $envhash{'course.'.$normalid.'.last_cache'}=time;
1.34      www      1583:     if ($chome ne 'no_host') {
1.302     albertel 1584:        %returnhash=&dump('environment',$cdomain,$cnum);
1.129     albertel 1585:        if (!exists($returnhash{'con_lost'})) {
                   1586:            $returnhash{'home'}= $chome;
                   1587: 	   $returnhash{'domain'} = $cdomain;
                   1588: 	   $returnhash{'num'} = $cnum;
1.130     albertel 1589:            while (my ($name,$value) = each %returnhash) {
1.53      www      1590:                $envhash{'course.'.$normalid.'.'.$name}=$value;
1.129     albertel 1591:            }
1.270     www      1592:            $returnhash{'url'}=&clutter($returnhash{'url'});
1.34      www      1593:            $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'.
1.38      www      1594: 	       $ENV{'user.name'}.'_'.$cdomain.'_'.$cnum;
1.60      www      1595:            $envhash{'course.'.$normalid.'.home'}=$chome;
                   1596:            $envhash{'course.'.$normalid.'.domain'}=$cdomain;
                   1597:            $envhash{'course.'.$normalid.'.num'}=$cnum;
1.34      www      1598:        }
                   1599:     }
1.302     albertel 1600:     &appenv(%envhash);
                   1601:     return %returnhash;
1.9       www      1602: }
1.1       albertel 1603: 
1.103     harris41 1604: # -------------------------------------------------------- Get user privileges
1.11      www      1605: 
                   1606: sub rolesinit {
                   1607:     my ($domain,$username,$authhost)=@_;
                   1608:     my $rolesdump=reply("dump:$domain:$username:roles",$authhost);
1.12      www      1609:     if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; }
1.11      www      1610:     my %allroles=();
                   1611:     my %thesepriv=();
                   1612:     my $now=time;
1.21      www      1613:     my $userroles="user.login.time=$now\n";
1.11      www      1614:     my $thesestr;
                   1615: 
                   1616:     if ($rolesdump ne '') {
1.191     harris41 1617:         foreach (split(/&/,$rolesdump)) {
1.21      www      1618: 	  if ($_!~/^rolesdef\&/) {
1.11      www      1619:             my ($area,$role)=split(/=/,$_);
1.21      www      1620:             $area=~s/\_\w\w$//;
1.11      www      1621:             my ($trole,$tend,$tstart)=split(/_/,$role);
1.21      www      1622:             $userroles.='user.role.'.$trole.'.'.$area.'='.
                   1623:                         $tstart.'.'.$tend."\n";
1.11      www      1624:             if ($tend!=0) {
                   1625: 	        if ($tend<$now) {
                   1626: 	            $trole='';
                   1627:                 } 
                   1628:             }
                   1629:             if ($tstart!=0) {
                   1630:                 if ($tstart>$now) {
                   1631:                    $trole='';        
                   1632:                 }
                   1633:             }
                   1634:             if (($area ne '') && ($trole ne '')) {
1.50      www      1635: 	       my $spec=$trole.'.'.$area;
1.12      www      1636:                my ($tdummy,$tdomain,$trest)=split(/\//,$area);
                   1637:                if ($trole =~ /^cr\//) {
                   1638: 		   my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
                   1639:                    my $homsvr=homeserver($rauthor,$rdomain);
                   1640:                    if ($hostname{$homsvr} ne '') {
                   1641:                       my $roledef=
1.21      www      1642: 			  reply("get:$rdomain:$rauthor:roles:rolesdef_$rrole",
1.12      www      1643:                                 $homsvr);
                   1644:                       if (($roledef ne 'con_lost') && ($roledef ne '')) {
                   1645:                          my ($syspriv,$dompriv,$coursepriv)=
1.21      www      1646: 			     split(/\_/,unescape($roledef));
1.50      www      1647:  	                 $allroles{'cm./'}.=':'.$syspriv;
                   1648:                          $allroles{$spec.'./'}.=':'.$syspriv;
1.12      www      1649:                          if ($tdomain ne '') {
1.50      www      1650:                              $allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv;
                   1651:                              $allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv;
1.12      www      1652:                              if ($trest ne '') {
1.50      www      1653: 		                $allroles{'cm.'.$area}.=':'.$coursepriv;
                   1654: 		                $allroles{$spec.'.'.$area}.=':'.$coursepriv;
1.12      www      1655:                              }
                   1656: 	                 }
                   1657:                       }
1.11      www      1658:                    }
1.12      www      1659:                } else {
1.50      www      1660: 	           $allroles{'cm./'}.=':'.$pr{$trole.':s'};
                   1661: 	           $allroles{$spec.'./'}.=':'.$pr{$trole.':s'};
1.12      www      1662:                    if ($tdomain ne '') {
1.50      www      1663:                      $allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
                   1664:                      $allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
1.12      www      1665:                       if ($trest ne '') {
1.50      www      1666: 		          $allroles{'cm.'.$area}.=':'.$pr{$trole.':c'};
                   1667: 		          $allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'};
1.12      www      1668:                       }
                   1669: 	           }
1.11      www      1670: 	       }
1.12      www      1671:             }
                   1672:           } 
1.191     harris41 1673:         }
1.125     www      1674:         my $adv=0;
1.128     www      1675:         my $author=0;
1.191     harris41 1676:         foreach (keys %allroles) {
1.11      www      1677:             %thesepriv=();
1.146     www      1678:             if (($_!~/^st/) && ($_!~/^ta/) && ($_!~/^cm/)) { $adv=1; }
1.128     www      1679:             if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; }
1.191     harris41 1680:             foreach (split(/:/,$allroles{$_})) {
1.11      www      1681:                 if ($_ ne '') {
1.103     harris41 1682: 		    my ($privilege,$restrictions)=split(/&/,$_);
1.11      www      1683:                     if ($restrictions eq '') {
1.103     harris41 1684: 			$thesepriv{$privilege}='F';
1.11      www      1685:                     } else {
1.103     harris41 1686:                         if ($thesepriv{$privilege} ne 'F') {
                   1687: 			    $thesepriv{$privilege}.=$restrictions;
1.11      www      1688:                         }
                   1689:                     }
                   1690:                 }
1.191     harris41 1691:             }
1.11      www      1692:             $thesestr='';
1.191     harris41 1693:             foreach (keys %thesepriv) { $thesestr.=':'.$_.'&'.$thesepriv{$_}; }
1.11      www      1694:             $userroles.='user.priv.'.$_.'='.$thesestr."\n";
1.191     harris41 1695:         }
1.128     www      1696:         $userroles.='user.adv='.$adv."\n".
                   1697: 	            'user.author='.$author."\n";
1.126     www      1698:         $ENV{'user.adv'}=$adv;
1.11      www      1699:     }
                   1700:     return $userroles;  
                   1701: }
                   1702: 
1.12      www      1703: # --------------------------------------------------------------- get interface
                   1704: 
                   1705: sub get {
1.131     albertel 1706:    my ($namespace,$storearr,$udomain,$uname)=@_;
1.12      www      1707:    my $items='';
1.191     harris41 1708:    foreach (@$storearr) {
1.12      www      1709:        $items.=escape($_).'&';
1.191     harris41 1710:    }
1.12      www      1711:    $items=~s/\&$//;
1.131     albertel 1712:    if (!$udomain) { $udomain=$ENV{'user.domain'}; }
                   1713:    if (!$uname) { $uname=$ENV{'user.name'}; }
                   1714:    my $uhome=&homeserver($uname,$udomain);
                   1715: 
1.133     albertel 1716:    my $rep=&reply("get:$udomain:$uname:$namespace:$items",$uhome);
1.15      www      1717:    my @pairs=split(/\&/,$rep);
1.273     albertel 1718:    if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) {
                   1719:      return @pairs;
                   1720:    }
1.15      www      1721:    my %returnhash=();
1.42      www      1722:    my $i=0;
1.191     harris41 1723:    foreach (@$storearr) {
1.42      www      1724:       $returnhash{$_}=unescape($pairs[$i]);
                   1725:       $i++;
1.191     harris41 1726:    }
1.15      www      1727:    return %returnhash;
1.27      www      1728: }
                   1729: 
                   1730: # --------------------------------------------------------------- del interface
                   1731: 
                   1732: sub del {
1.133     albertel 1733:    my ($namespace,$storearr,$udomain,$uname)=@_;
1.27      www      1734:    my $items='';
1.191     harris41 1735:    foreach (@$storearr) {
1.27      www      1736:        $items.=escape($_).'&';
1.191     harris41 1737:    }
1.27      www      1738:    $items=~s/\&$//;
1.133     albertel 1739:    if (!$udomain) { $udomain=$ENV{'user.domain'}; }
                   1740:    if (!$uname) { $uname=$ENV{'user.name'}; }
                   1741:    my $uhome=&homeserver($uname,$udomain);
                   1742: 
                   1743:    return &reply("del:$udomain:$uname:$namespace:$items",$uhome);
1.15      www      1744: }
                   1745: 
                   1746: # -------------------------------------------------------------- dump interface
                   1747: 
                   1748: sub dump {
1.193     www      1749:    my ($namespace,$udomain,$uname,$regexp)=@_;
1.129     albertel 1750:    if (!$udomain) { $udomain=$ENV{'user.domain'}; }
                   1751:    if (!$uname) { $uname=$ENV{'user.name'}; }
                   1752:    my $uhome=&homeserver($uname,$udomain);
1.193     www      1753:    if ($regexp) {
                   1754:        $regexp=&escape($regexp);
                   1755:    } else {
                   1756:        $regexp='.';
                   1757:    }
                   1758:    my $rep=reply("dump:$udomain:$uname:$namespace:$regexp",$uhome);
1.12      www      1759:    my @pairs=split(/\&/,$rep);
                   1760:    my %returnhash=();
1.191     harris41 1761:    foreach (@pairs) {
1.12      www      1762:       my ($key,$value)=split(/=/,$_);
1.29      www      1763:       $returnhash{unescape($key)}=unescape($value);
1.318     matthew  1764:    }
                   1765:    return %returnhash;
                   1766: }
                   1767: 
1.319     matthew  1768: # --------------------------------------------------------------- currentdump
                   1769: sub currentdump {
1.328     matthew  1770:    my ($courseid,$sdom,$sname)=@_;
1.326     matthew  1771:    $courseid = $ENV{'request.course.id'} if (! defined($courseid));
                   1772:    $sdom     = $ENV{'user.domain'}       if (! defined($sdom));
                   1773:    $sname    = $ENV{'user.name'}         if (! defined($sname));
                   1774:    my $uhome = &homeserver($sname,$sdom);
                   1775:    my $rep=reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome);
1.318     matthew  1776:    return if ($rep =~ /^(error:|no_such_host)/);
1.319     matthew  1777:    #
1.318     matthew  1778:    my %returnhash=();
1.319     matthew  1779:    #
                   1780:    if ($rep eq "unknown_cmd") { 
                   1781:        # an old lond will not know currentdump
                   1782:        # Do a dump and make it look like a currentdump
1.326     matthew  1783:        my @tmp = &dump($courseid,$sdom,$sname,'.');
1.319     matthew  1784:        return if ($tmp[0] =~ /^(error:|no_such_host)/);
                   1785:        my %hash = @tmp;
                   1786:        @tmp=();
                   1787:        # Code ripped from lond, essentially.  The only difference
                   1788:        # here is the unescaping done by lonnet::dump().  Conceivably
                   1789:        # we might run in to problems with parameter names =~ /^v\./
                   1790:        while (my ($key,$value) = each(%hash)) {
                   1791:            my ($v,$symb,$param) = split(/:/,$key);
                   1792:            next if ($v eq 'version' || $symb eq 'keys');
                   1793:            next if (exists($returnhash{$symb}) &&
                   1794:                     exists($returnhash{$symb}->{$param}) &&
                   1795:                     $returnhash{$symb}->{'v.'.$param} > $v);
                   1796:            $returnhash{$symb}->{$param}=$value;
                   1797:            $returnhash{$symb}->{'v.'.$param}=$v;
                   1798:        }
                   1799:        #
                   1800:        # Remove all of the keys in the hashes which keep track of
                   1801:        # the version of the parameter.
                   1802:        while (my ($symb,$param_hash) = each(%returnhash)) {
                   1803:            # use a foreach because we are going to delete from the hash.
                   1804:            foreach my $key (keys(%$param_hash)) {
                   1805:                delete($param_hash->{$key}) if ($key =~ /^v\./);
                   1806:            }
                   1807:        }
                   1808:    } else {
                   1809:        my @pairs=split(/\&/,$rep);
                   1810:        foreach (@pairs) {
                   1811:            my ($key,$value)=split(/=/,$_);
                   1812:            my ($symb,$param) = split(/:/,$key);
                   1813:            $returnhash{&unescape($symb)}->{&unescape($param)} = 
                   1814:                                                           &unescape($value);
                   1815:        }
1.191     harris41 1816:    }
1.12      www      1817:    return %returnhash;
                   1818: }
                   1819: 
                   1820: # --------------------------------------------------------------- put interface
                   1821: 
                   1822: sub put {
1.134     albertel 1823:    my ($namespace,$storehash,$udomain,$uname)=@_;
                   1824:    if (!$udomain) { $udomain=$ENV{'user.domain'}; }
                   1825:    if (!$uname) { $uname=$ENV{'user.name'}; }
                   1826:    my $uhome=&homeserver($uname,$udomain);
1.12      www      1827:    my $items='';
1.191     harris41 1828:    foreach (keys %$storehash) {
1.134     albertel 1829:        $items.=&escape($_).'='.&escape($$storehash{$_}).'&';
1.191     harris41 1830:    }
1.12      www      1831:    $items=~s/\&$//;
1.134     albertel 1832:    return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
1.47      www      1833: }
                   1834: 
                   1835: # ------------------------------------------------------ critical put interface
                   1836: 
                   1837: sub cput {
1.134     albertel 1838:    my ($namespace,$storehash,$udomain,$uname)=@_;
                   1839:    if (!$udomain) { $udomain=$ENV{'user.domain'}; }
                   1840:    if (!$uname) { $uname=$ENV{'user.name'}; }
                   1841:    my $uhome=&homeserver($uname,$udomain);
1.47      www      1842:    my $items='';
1.191     harris41 1843:    foreach (keys %$storehash) {
1.134     albertel 1844:        $items.=escape($_).'='.escape($$storehash{$_}).'&';
1.191     harris41 1845:    }
1.47      www      1846:    $items=~s/\&$//;
1.134     albertel 1847:    return &critical("put:$udomain:$uname:$namespace:$items",$uhome);
1.12      www      1848: }
                   1849: 
                   1850: # -------------------------------------------------------------- eget interface
                   1851: 
                   1852: sub eget {
1.133     albertel 1853:    my ($namespace,$storearr,$udomain,$uname)=@_;
1.12      www      1854:    my $items='';
1.191     harris41 1855:    foreach (@$storearr) {
1.12      www      1856:        $items.=escape($_).'&';
1.191     harris41 1857:    }
1.12      www      1858:    $items=~s/\&$//;
1.133     albertel 1859:    if (!$udomain) { $udomain=$ENV{'user.domain'}; }
                   1860:    if (!$uname) { $uname=$ENV{'user.name'}; }
                   1861:    my $uhome=&homeserver($uname,$udomain);
                   1862:    my $rep=&reply("eget:$udomain:$uname:$namespace:$items",$uhome);
1.12      www      1863:    my @pairs=split(/\&/,$rep);
                   1864:    my %returnhash=();
1.42      www      1865:    my $i=0;
1.191     harris41 1866:    foreach (@$storearr) {
1.42      www      1867:       $returnhash{$_}=unescape($pairs[$i]);
                   1868:       $i++;
1.191     harris41 1869:    }
1.12      www      1870:    return %returnhash;
                   1871: }
                   1872: 
1.103     harris41 1873: # ------------------------------------------------- Check for a user privilege
1.12      www      1874: 
                   1875: sub allowed {
                   1876:     my ($priv,$uri)=@_;
1.152     www      1877: 
                   1878:     my $orguri=$uri;
1.52      www      1879:     $uri=&declutter($uri);
1.29      www      1880: 
1.54      www      1881: # Free bre access to adm and meta resources
1.29      www      1882: 
1.54      www      1883:     if ((($uri=~/^adm\//) || ($uri=~/\.meta$/)) && ($priv eq 'bre')) {
1.14      www      1884: 	return 'F';
1.159     www      1885:     }
                   1886: 
                   1887: # Free bre to public access
                   1888: 
                   1889:     if ($priv eq 'bre') {
1.238     www      1890:         my $copyright=&metadata($uri,'copyright');
1.301     www      1891: 	if (($copyright eq 'public') && (!$ENV{'request.course.id'})) { 
                   1892:            return 'F'; 
                   1893:         }
1.238     www      1894:         if ($copyright eq 'priv') {
                   1895:             $uri=~/([^\/]+)\/([^\/]+)\//;
                   1896: 	    unless (($ENV{'user.name'} eq $2) && ($ENV{'user.domain'} eq $1)) {
                   1897: 		return '';
                   1898:             }
                   1899:         }
                   1900:         if ($copyright eq 'domain') {
                   1901:             $uri=~/([^\/]+)\/([^\/]+)\//;
                   1902: 	    unless (($ENV{'user.domain'} eq $1) ||
                   1903:                  ($ENV{'course.'.$ENV{'request.course.id'}.'.domain'} eq $1)) {
                   1904: 		return '';
                   1905:             }
1.262     matthew  1906:         }
                   1907:         if ($ENV{'request.role'}=~ /li\.\//) {
                   1908:             # Library role, so allow browsing of resources in this domain.
                   1909:             return 'F';
1.238     www      1910:         }
1.14      www      1911:     }
1.264     matthew  1912:     # Domain coordinator is trying to create a course
                   1913:     if (($priv eq 'ccc') && ($ENV{'request.role'} =~ /^dc\./)) {
                   1914:         # uri is the requested domain in this case.
                   1915:         # comparison to 'request.role.domain' shows if the user has selected
                   1916:         # a role of dc for the domain in question. 
                   1917:         return 'F' if ($uri eq $ENV{'request.role.domain'});
                   1918:     }
1.29      www      1919: 
1.52      www      1920:     my $thisallowed='';
                   1921:     my $statecond=0;
                   1922:     my $courseprivid='';
                   1923: 
                   1924: # Course
                   1925: 
                   1926:     if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'}=~/$priv\&([^\:]*)/) {
                   1927:        $thisallowed.=$1;
                   1928:     }
1.29      www      1929: 
1.52      www      1930: # Domain
                   1931: 
                   1932:     if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.(split(/\//,$uri))[0].'/'}
                   1933:        =~/$priv\&([^\:]*)/) {
1.12      www      1934:        $thisallowed.=$1;
                   1935:     }
1.52      www      1936: 
                   1937: # Course: uri itself is a course
1.66      www      1938:     my $courseuri=$uri;
                   1939:     $courseuri=~s/\_(\d)/\/$1/;
1.83      www      1940:     $courseuri=~s/^([^\/])/\/$1/;
1.81      www      1941: 
1.83      www      1942:     if ($ENV{'user.priv.'.$ENV{'request.role'}.'.'.$courseuri}
1.52      www      1943:        =~/$priv\&([^\:]*)/) {
1.12      www      1944:        $thisallowed.=$1;
                   1945:     }
1.29      www      1946: 
1.314     www      1947: # URI is an uploaded document for this course
                   1948: 
                   1949:     if (($priv eq 'bre') && 
                   1950:         ($uri=~/^uploaded\/$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}\/$ENV{'course.'.$ENV{'request.course.id'}.'.num'}/)) {
                   1951:         return 'F';
                   1952:     }
1.52      www      1953: # Full access at system, domain or course-wide level? Exit.
1.29      www      1954: 
                   1955:     if ($thisallowed=~/F/) {
                   1956: 	return 'F';
                   1957:     }
                   1958: 
1.52      www      1959: # If this is generating or modifying users, exit with special codes
1.29      www      1960: 
1.166     www      1961:     if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:'=~/\:$priv\:/) {
1.52      www      1962: 	return $thisallowed;
                   1963:     }
                   1964: #
1.103     harris41 1965: # Gathered so far: system, domain and course wide privileges
1.52      www      1966: #
                   1967: # Course: See if uri or referer is an individual resource that is part of 
                   1968: # the course
                   1969: 
                   1970:     if ($ENV{'request.course.id'}) {
1.232     www      1971: 
1.52      www      1972:        $courseprivid=$ENV{'request.course.id'};
                   1973:        if ($ENV{'request.course.sec'}) {
                   1974:           $courseprivid.='/'.$ENV{'request.course.sec'};
                   1975:        }
                   1976:        $courseprivid=~s/\_/\//;
                   1977:        my $checkreferer=1;
1.232     www      1978:        my ($match,$cond)=&is_on_map($uri);
                   1979:        if ($match) {
                   1980:            $statecond=$cond;
1.52      www      1981:            if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid}
                   1982:                =~/$priv\&([^\:]*)/) {
                   1983:                $thisallowed.=$1;
                   1984:                $checkreferer=0;
                   1985:            }
1.29      www      1986:        }
1.83      www      1987:        
1.148     www      1988:        if ($checkreferer) {
1.152     www      1989: 	  my $refuri=$ENV{'httpref.'.$orguri};
1.148     www      1990:             unless ($refuri) {
1.191     harris41 1991:                 foreach (keys %ENV) {
1.148     www      1992: 		    if ($_=~/^httpref\..*\*/) {
                   1993: 			my $pattern=$_;
1.156     www      1994:                         $pattern=~s/^httpref\.\/res\///;
1.148     www      1995:                         $pattern=~s/\*/\[\^\/\]\+/g;
                   1996:                         $pattern=~s/\//\\\//g;
1.152     www      1997:                         if ($orguri=~/$pattern/) {
1.148     www      1998: 			    $refuri=$ENV{$_};
                   1999:                         }
                   2000:                     }
1.191     harris41 2001:                 }
1.148     www      2002:             }
1.232     www      2003: 
1.148     www      2004:          if ($refuri) { 
1.152     www      2005: 	  $refuri=&declutter($refuri);
1.232     www      2006:           my ($match,$cond)=&is_on_map($refuri);
                   2007:             if ($match) {
                   2008:               my $refstatecond=$cond;
1.52      www      2009:               if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid}
                   2010:                   =~/$priv\&([^\:]*)/) {
                   2011:                   $thisallowed.=$1;
1.53      www      2012:                   $uri=$refuri;
                   2013:                   $statecond=$refstatecond;
1.52      www      2014:               }
                   2015:           }
1.148     www      2016:         }
1.29      www      2017:        }
1.52      www      2018:    }
1.29      www      2019: 
1.52      www      2020: #
1.103     harris41 2021: # Gathered now: all privileges that could apply, and condition number
1.52      www      2022: # 
                   2023: #
                   2024: # Full or no access?
                   2025: #
1.29      www      2026: 
1.52      www      2027:     if ($thisallowed=~/F/) {
                   2028: 	return 'F';
                   2029:     }
1.29      www      2030: 
1.52      www      2031:     unless ($thisallowed) {
                   2032:         return '';
                   2033:     }
1.29      www      2034: 
1.52      www      2035: # Restrictions exist, deal with them
                   2036: #
                   2037: #   C:according to course preferences
                   2038: #   R:according to resource settings
                   2039: #   L:unless locked
                   2040: #   X:according to user session state
                   2041: #
                   2042: 
                   2043: # Possibly locked functionality, check all courses
1.54      www      2044: # Locks might take effect only after 10 minutes cache expiration for other
                   2045: # courses, and 2 minutes for current course
1.52      www      2046: 
                   2047:     my $envkey;
                   2048:     if ($thisallowed=~/L/) {
                   2049:         foreach $envkey (keys %ENV) {
1.54      www      2050:            if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) {
                   2051:                my $courseid=$2;
                   2052:                my $roleid=$1.'.'.$2;
1.92      www      2053:                $courseid=~s/^\///;
1.54      www      2054:                my $expiretime=600;
                   2055:                if ($ENV{'request.role'} eq $roleid) {
                   2056: 		  $expiretime=120;
                   2057:                }
                   2058: 	       my ($cdom,$cnum,$csec)=split(/\//,$courseid);
                   2059:                my $prefix='course.'.$cdom.'_'.$cnum.'.';
                   2060:                if ((time-$ENV{$prefix.'last_cache'})>$expiretime) {
                   2061: 		   &coursedescription($courseid);
                   2062:                }
                   2063:                if (($ENV{$prefix.'res.'.$uri.'.lock.sections'}=~/\,$csec\,/)
                   2064:                 || ($ENV{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) {
                   2065: 		   if ($ENV{$prefix.'res.'.$uri.'.lock.expire'}>time) {
1.57      www      2066:                        &log($ENV{'user.domain'},$ENV{'user.name'},
1.239     www      2067:                             $ENV{'user.home'},
1.57      www      2068:                             'Locked by res: '.$priv.' for '.$uri.' due to '.
1.52      www      2069:                             $cdom.'/'.$cnum.'/'.$csec.' expire '.
1.54      www      2070:                             $ENV{$prefix.'priv.'.$priv.'.lock.expire'});
1.52      www      2071: 		       return '';
                   2072:                    }
                   2073:                }
1.54      www      2074:                if (($ENV{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,$csec\,/)
                   2075:                 || ($ENV{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) {
                   2076: 		   if ($ENV{'priv.'.$priv.'.lock.expire'}>time) {
1.57      www      2077:                        &log($ENV{'user.domain'},$ENV{'user.name'},
1.239     www      2078:                             $ENV{'user.home'},
1.57      www      2079:                             'Locked by priv: '.$priv.' for '.$uri.' due to '.
1.52      www      2080:                             $cdom.'/'.$cnum.'/'.$csec.' expire '.
1.54      www      2081:                             $ENV{$prefix.'priv.'.$priv.'.lock.expire'});
1.52      www      2082: 		       return '';
                   2083:                    }
                   2084:                }
                   2085: 	   }
1.29      www      2086:        }
1.52      www      2087:     }
                   2088:    
                   2089: #
                   2090: # Rest of the restrictions depend on selected course
                   2091: #
                   2092: 
                   2093:     unless ($ENV{'request.course.id'}) {
                   2094:        return '1';
                   2095:     }
1.29      www      2096: 
1.52      www      2097: #
                   2098: # Now user is definitely in a course
                   2099: #
1.53      www      2100: 
                   2101: 
                   2102: # Course preferences
                   2103: 
                   2104:    if ($thisallowed=~/C/) {
1.54      www      2105:        my $rolecode=(split(/\./,$ENV{'request.role'}))[0];
1.237     www      2106:        my $unamedom=$ENV{'user.name'}.':'.$ENV{'user.domain'};
1.54      www      2107:        if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.roles.denied'}
1.194     www      2108: 	   =~/$rolecode/) {
1.57      www      2109:            &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},
                   2110:                 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
1.237     www      2111:                 $ENV{'request.course.id'});
                   2112:            return '';
                   2113:        }
                   2114: 
                   2115:        if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.users.denied'}
                   2116: 	   =~/$unamedom/) {
                   2117:            &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},
                   2118:                 'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.
1.54      www      2119:                 $ENV{'request.course.id'});
                   2120:            return '';
                   2121:        }
1.53      www      2122:    }
                   2123: 
                   2124: # Resource preferences
                   2125: 
                   2126:    if ($thisallowed=~/R/) {
1.54      www      2127:        my $rolecode=(split(/\./,$ENV{'request.role'}))[0];
                   2128:        my $filename=$perlvar{'lonDocRoot'}.'/res/'.$uri.'.meta';
                   2129:        if (-e $filename) {
                   2130:            my @content;
                   2131:            {
                   2132: 	     my $fh=Apache::File->new($filename);
                   2133:              @content=<$fh>;
                   2134: 	   }
                   2135:            if (join('',@content)=~
                   2136:                     /\<roledeny[^\>]*\>[^\<]*$rolecode[^\<]*\<\/roledeny\>/) {
1.57      www      2137: 	       &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},
                   2138:                     'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
1.54      www      2139:            return '';
                   2140: 
                   2141:            }
                   2142:        }
1.53      www      2143:    }
1.30      www      2144: 
1.246     www      2145: # Restricted by state or randomout?
1.30      www      2146: 
1.52      www      2147:    if ($thisallowed=~/X/) {
1.247     www      2148:       if ($ENV{'acc.randomout'}) {
1.249     www      2149:          my $symb=&symbread($uri,1);
1.248     www      2150:          if (($symb) && ($ENV{'acc.randomout'}=~/\&$symb\&/)) { 
                   2151:             return ''; 
                   2152:          }
1.247     www      2153:       }
                   2154:       if (&condval($statecond)) {
1.52      www      2155: 	 return '2';
                   2156:       } else {
                   2157:          return '';
                   2158:       }
                   2159:    }
1.30      www      2160: 
1.52      www      2161:    return 'F';
1.232     www      2162: }
                   2163: 
                   2164: # --------------------------------------------------- Is a resource on the map?
                   2165: 
                   2166: sub is_on_map {
                   2167:     my $uri=&declutter(shift);
                   2168:     my @uriparts=split(/\//,$uri);
                   2169:     my $filename=$uriparts[$#uriparts];
                   2170:     my $pathname=$uri;
1.289     bowersj2 2171:     $pathname=~s|/\Q$filename\E$||;
1.332     www      2172:     $pathname=~s/^adm\/wrapper\///;    
1.289     bowersj2 2173:     #Trying to find the conditional for the file
1.232     www      2174:     my $match=($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~
1.289     bowersj2 2175: 	       /\&\Q$filename\E\:([\d\|]+)\&/);
1.232     www      2176:     if ($match) {
1.289     bowersj2 2177: 	return (1,$1);
                   2178:     } else {
                   2179: 	return (0,0);
                   2180:     }
1.12      www      2181: }
                   2182: 
                   2183: # ----------------------------------------------------------------- Define Role
                   2184: 
                   2185: sub definerole {
                   2186:   if (allowed('mcr','/')) {
                   2187:     my ($rolename,$sysrole,$domrole,$courole)=@_;
1.191     harris41 2188:     foreach (split('/',$sysrole)) {
1.21      www      2189: 	my ($crole,$cqual)=split(/\&/,$_);
                   2190:         if ($pr{'cr:s'}!~/$crole/) { return "refused:s:$crole"; }
                   2191:         if ($pr{'cr:s'}=~/$crole\&/) {
                   2192: 	    if ($pr{'cr:s'}!~/$crole\&\w*$cqual/) { 
                   2193:                return "refused:s:$crole&$cqual"; 
                   2194:             }
                   2195:         }
1.191     harris41 2196:     }
                   2197:     foreach (split('/',$domrole)) {
1.21      www      2198: 	my ($crole,$cqual)=split(/\&/,$_);
                   2199:         if ($pr{'cr:d'}!~/$crole/) { return "refused:d:$crole"; }
                   2200:         if ($pr{'cr:d'}=~/$crole\&/) {
                   2201: 	    if ($pr{'cr:d'}!~/$crole\&\w*$cqual/) { 
                   2202:                return "refused:d:$crole&$cqual"; 
                   2203:             }
                   2204:         }
1.191     harris41 2205:     }
                   2206:     foreach (split('/',$courole)) {
1.21      www      2207: 	my ($crole,$cqual)=split(/\&/,$_);
                   2208:         if ($pr{'cr:c'}!~/$crole/) { return "refused:c:$crole"; }
                   2209:         if ($pr{'cr:c'}=~/$crole\&/) {
                   2210: 	    if ($pr{'cr:c'}!~/$crole\&\w*$cqual/) { 
                   2211:                return "refused:c:$crole&$cqual"; 
                   2212:             }
                   2213:         }
1.191     harris41 2214:     }
1.12      www      2215:     my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:".
                   2216:                 "$ENV{'user.domain'}:$ENV{'user.name'}:".
1.21      www      2217: 	        "rolesdef_$rolename=".
                   2218:                 escape($sysrole.'_'.$domrole.'_'.$courole);
1.12      www      2219:     return reply($command,$ENV{'user.home'});
                   2220:   } else {
                   2221:     return 'refused';
                   2222:   }
1.105     harris41 2223: }
                   2224: 
                   2225: # ---------------- Make a metadata query against the network of library servers
                   2226: 
                   2227: sub metadata_query {
1.244     matthew  2228:     my ($query,$custom,$customshow,$server_array)=@_;
1.120     harris41 2229:     my %rhash;
1.244     matthew  2230:     my @server_list = (defined($server_array) ? @$server_array
                   2231:                                               : keys(%libserv) );
                   2232:     for my $server (@server_list) {
1.118     harris41 2233: 	unless ($custom or $customshow) {
                   2234: 	    my $reply=&reply("querysend:".&escape($query),$server);
                   2235: 	    $rhash{$server}=$reply;
                   2236: 	}
                   2237: 	else {
                   2238: 	    my $reply=&reply("querysend:".&escape($query).':'.
                   2239: 			     &escape($custom).':'.&escape($customshow),
                   2240: 			     $server);
                   2241: 	    $rhash{$server}=$reply;
                   2242: 	}
1.112     harris41 2243:     }
1.118     harris41 2244:     return \%rhash;
1.240     www      2245: }
                   2246: 
                   2247: # ----------------------------------------- Send log queries and wait for reply
                   2248: 
                   2249: sub log_query {
                   2250:     my ($uname,$udom,$query,%filters)=@_;
                   2251:     my $uhome=&homeserver($uname,$udom);
                   2252:     if ($uhome eq 'no_host') { return 'error: no_host'; }
                   2253:     my $uhost=$hostname{$uhome};
1.241     www      2254:     my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys %filters));
1.240     www      2255:     my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command,
                   2256:                        $uhome);
                   2257:     unless ($queryid=~/^$uhost\_/) { return 'error: '.$queryid; }
1.242     www      2258:     return get_query_reply($queryid);
                   2259: }
                   2260: 
                   2261: sub get_query_reply {
                   2262:     my $queryid=shift;
1.240     www      2263:     my $replyfile=$perlvar{'lonDaemons'}.'/tmp/'.$queryid;
                   2264:     my $reply='';
                   2265:     for (1..100) {
                   2266: 	sleep 2;
                   2267:         if (-e $replyfile.'.end') {
                   2268: 	    if (my $fh=Apache::File->new($replyfile)) {
                   2269:                $reply.=<$fh>;
                   2270:                $fh->close;
                   2271: 	   } else { return 'error: reply_file_error'; }
1.242     www      2272:            return &unescape($reply);
                   2273: 	}
1.240     www      2274:     }
1.242     www      2275:     return 'timeout:'.$queryid;
1.240     www      2276: }
                   2277: 
                   2278: sub courselog_query {
1.241     www      2279: #
                   2280: # possible filters:
                   2281: # url: url or symb
                   2282: # username
                   2283: # domain
                   2284: # action: view, submit, grade
                   2285: # start: timestamp
                   2286: # end: timestamp
                   2287: #
1.240     www      2288:     my (%filters)=@_;
                   2289:     unless ($ENV{'request.course.id'}) { return 'no_course'; }
1.241     www      2290:     if ($filters{'url'}) {
                   2291: 	$filters{'url'}=&symbclean(&declutter($filters{'url'}));
                   2292:         $filters{'url'}=~s/\.(\w+)$/(\\.\\d+)*\\.$1/;
                   2293:         $filters{'url'}=~s/\.(\w+)\_\_\_/(\\.\\d+)*\\.$1/;
                   2294:     }
1.240     www      2295:     my $cname=$ENV{'course.'.$ENV{'request.course.id'}.'.num'};
                   2296:     my $cdom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'};
                   2297:     return &log_query($cname,$cdom,'courselog',%filters);
                   2298: }
                   2299: 
                   2300: sub userlog_query {
                   2301:     my ($uname,$udom,%filters)=@_;
                   2302:     return &log_query($uname,$udom,'userlog',%filters);
1.12      www      2303: }
                   2304: 
                   2305: # ------------------------------------------------------------------ Plain Text
                   2306: 
                   2307: sub plaintext {
1.22      www      2308:     my $short=shift;
                   2309:     return $prp{$short};
1.12      www      2310: }
                   2311: 
                   2312: # ----------------------------------------------------------------- Assign Role
                   2313: 
                   2314: sub assignrole {
1.21      www      2315:     my ($udom,$uname,$url,$role,$end,$start)=@_;
                   2316:     my $mrole;
                   2317:     if ($role =~ /^cr\//) {
1.104     www      2318: 	unless (&allowed('ccr',$url)) {
                   2319:            &logthis('Refused custom assignrole: '.
                   2320:              $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
                   2321: 		    $ENV{'user.name'}.' at '.$ENV{'user.domain'});
                   2322:            return 'refused'; 
                   2323:         }
1.21      www      2324:         $mrole='cr';
                   2325:     } else {
1.82      www      2326:         my $cwosec=$url;
1.83      www      2327:         $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;
1.104     www      2328:         unless (&allowed('c'.$role,$cwosec)) { 
                   2329:            &logthis('Refused assignrole: '.
                   2330:              $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
                   2331: 		    $ENV{'user.name'}.' at '.$ENV{'user.domain'});
                   2332:            return 'refused'; 
                   2333:         }
1.21      www      2334:         $mrole=$role;
                   2335:     }
                   2336:     my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:".
                   2337:                 "$udom:$uname:$url".'_'."$mrole=$role";
1.81      www      2338:     if ($end) { $command.='_'.$end; }
1.21      www      2339:     if ($start) {
                   2340: 	if ($end) { 
1.81      www      2341:            $command.='_'.$start; 
1.21      www      2342:         } else {
1.81      www      2343:            $command.='_0_'.$start;
1.21      www      2344:         }
                   2345:     }
                   2346:     return &reply($command,&homeserver($uname,$udom));
1.169     harris41 2347: }
                   2348: 
                   2349: # -------------------------------------------------- Modify user authentication
1.197     www      2350: # Overrides without validation
                   2351: 
1.169     harris41 2352: sub modifyuserauth {
                   2353:     my ($udom,$uname,$umode,$upass)=@_;
                   2354:     my $uhome=&homeserver($uname,$udom);
1.197     www      2355:     unless (&allowed('mau',$udom)) { return 'refused'; }
                   2356:     &logthis('Call to modify user authentication '.$udom.', '.$uname.', '.
1.272     matthew  2357:              $umode.' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}.
                   2358:              ' in domain '.$ENV{'request.role.domain'});  
1.169     harris41 2359:     my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'.
                   2360: 		     &escape($upass),$uhome);
1.197     www      2361:     &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.home'},
                   2362:         'Authentication changed for '.$udom.', '.$uname.', '.$umode.
                   2363:          '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply);
                   2364:     &log($udom,,$uname,$uhome,
                   2365:         'Authentication changed by '.$ENV{'user.domain'}.', '.
                   2366:                                      $ENV{'user.name'}.', '.$umode.
                   2367:          '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply);
1.169     harris41 2368:     unless ($reply eq 'ok') {
1.197     www      2369:         &logthis('Authentication mode error: '.$reply);
1.169     harris41 2370: 	return 'error: '.$reply;
                   2371:     }   
1.170     harris41 2372:     return 'ok';
1.80      www      2373: }
                   2374: 
1.81      www      2375: # --------------------------------------------------------------- Modify a user
1.80      www      2376: 
1.81      www      2377: sub modifyuser {
1.206     matthew  2378:     my ($udom,    $uname, $uid,
                   2379:         $umode,   $upass, $first,
                   2380:         $middle,  $last,  $gene,
                   2381:         $forceid, $desiredhome)=@_;
1.198     www      2382:     $udom=~s/\W//g;
                   2383:     $uname=~s/\W//g;
1.81      www      2384:     &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
1.80      www      2385:              $umode.', '.$first.', '.$middle.', '.
1.206     matthew  2386: 	     $last.', '.$gene.'(forceid: '.$forceid.')'.
                   2387:              (defined($desiredhome) ? ' desiredhome = '.$desiredhome :
                   2388:                                      ' desiredhome not specified'). 
1.272     matthew  2389:              ' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}.
                   2390:              ' in domain '.$ENV{'request.role.domain'});
1.230     stredwic 2391:     my $uhome=&homeserver($uname,$udom,'true');
1.80      www      2392: # ----------------------------------------------------------------- Create User
1.81      www      2393:     if (($uhome eq 'no_host') && ($umode) && ($upass)) {
1.80      www      2394:         my $unhome='';
1.209     matthew  2395:         if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) { 
                   2396:             $unhome = $desiredhome;
                   2397: 	} elsif($ENV{'course.'.$ENV{'request.course.id'}.'.domain'} eq $udom) {
1.80      www      2398: 	    $unhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'};
1.209     matthew  2399:         } else { # load balancing routine for determining $unhome
1.80      www      2400:             my $tryserver;
1.81      www      2401:             my $loadm=10000000;
1.80      www      2402:             foreach $tryserver (keys %libserv) {
                   2403: 	       if ($hostdom{$tryserver} eq $udom) {
                   2404:                   my $answer=reply('load',$tryserver);
                   2405:                   if (($answer=~/\d+/) && ($answer<$loadm)) {
                   2406: 		      $loadm=$answer;
                   2407:                       $unhome=$tryserver;
                   2408:                   }
                   2409: 	       }
                   2410: 	    }
                   2411:         }
                   2412:         if (($unhome eq '') || ($unhome eq 'no_host')) {
1.206     matthew  2413: 	    return 'error: unable to find a home server for '.$uname.
                   2414:                    ' in domain '.$udom;
1.80      www      2415:         }
                   2416:         my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':'.$umode.':'.
                   2417:                          &escape($upass),$unhome);
                   2418: 	unless ($reply eq 'ok') {
                   2419:             return 'error: '.$reply;
                   2420:         }   
1.230     stredwic 2421:         $uhome=&homeserver($uname,$udom,'true');
1.80      www      2422:         if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) {
                   2423: 	    return 'error: verify home';
                   2424:         }
1.209     matthew  2425:     }   # End of creation of new user
1.80      www      2426: # ---------------------------------------------------------------------- Add ID
                   2427:     if ($uid) {
                   2428:        $uid=~tr/A-Z/a-z/;
                   2429:        my %uidhash=&idrget($udom,$uname);
1.196     www      2430:        if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/) 
                   2431:          && (!$forceid)) {
1.80      www      2432: 	  unless ($uid eq $uidhash{$uname}) {
                   2433: 	      return 'error: mismatch '.$uidhash{$uname}.' versus '.$uid;
                   2434:           }
                   2435:        } else {
                   2436: 	  &idput($udom,($uname => $uid));
                   2437:        }
                   2438:     }
                   2439: # -------------------------------------------------------------- Add names, etc
1.313     matthew  2440:     my @tmp=&get('environment',
1.134     albertel 2441: 		   ['firstname','middlename','lastname','generation'],
                   2442: 		   $udom,$uname);
1.313     matthew  2443:     my %names;
                   2444:     if ($tmp[0] =~ m/^error:.*/) { 
                   2445:         %names=(); 
                   2446:     } else {
                   2447:         %names = @tmp;
                   2448:     }
1.134     albertel 2449:     if ($first)  { $names{'firstname'}  = $first; }
                   2450:     if ($middle) { $names{'middlename'} = $middle; }
                   2451:     if ($last)   { $names{'lastname'}   = $last; }
                   2452:     if ($gene)   { $names{'generation'} = $gene; }
                   2453:     my $reply = &put('environment', \%names, $udom,$uname);
                   2454:     if ($reply ne 'ok') { return 'error: '.$reply; }
1.81      www      2455:     &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
1.80      www      2456:              $umode.', '.$first.', '.$middle.', '.
                   2457: 	     $last.', '.$gene.' by '.
                   2458:              $ENV{'user.name'}.' at '.$ENV{'user.domain'});
1.134     albertel 2459:     return 'ok';
1.80      www      2460: }
                   2461: 
1.81      www      2462: # -------------------------------------------------------------- Modify student
1.80      www      2463: 
1.81      www      2464: sub modifystudent {
                   2465:     my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
1.209     matthew  2466:         $end,$start,$forceid,$desiredhome)=@_;
1.81      www      2467:     my $cid='';
                   2468:     unless ($cid=$ENV{'request.course.id'}) {
1.80      www      2469: 	return 'not_in_class';
                   2470:     }
                   2471: # --------------------------------------------------------------- Make the user
1.81      www      2472:     my $reply=&modifyuser
1.209     matthew  2473: 	($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid,
                   2474:          $desiredhome);
1.80      www      2475:     unless ($reply eq 'ok') { return $reply; }
1.297     matthew  2476:     # This will cause &modify_student_enrollment to get the uid from the
                   2477:     # students environment
                   2478:     $uid = undef if (!$forceid);
                   2479:     $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,
                   2480:                                         $last,$gene,$usec,$end,$start);
                   2481:     return $reply;
                   2482: }
                   2483: 
                   2484: sub modify_student_enrollment {
                   2485:     my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start) = @_;
                   2486:     # Get the course id from the environment
                   2487:     my $cid='';
                   2488:     unless ($cid=$ENV{'request.course.id'}) {
                   2489: 	return 'not_in_class';
                   2490:     }
                   2491:     # Make sure the user exists
1.81      www      2492:     my $uhome=&homeserver($uname,$udom);
                   2493:     if (($uhome eq '') || ($uhome eq 'no_host')) { 
                   2494: 	return 'error: no such user';
                   2495:     }
1.297     matthew  2496:     #
                   2497:     # Get student data if we were not given enough information
                   2498:     if (!defined($first)  || $first  eq '' || 
                   2499:         !defined($last)   || $last   eq '' || 
                   2500:         !defined($uid)    || $uid    eq '' || 
                   2501:         !defined($middle) || $middle eq '' || 
                   2502:         !defined($gene)   || $gene   eq '') {
1.294     matthew  2503:         # They did not supply us with enough data to enroll the student, so
                   2504:         # we need to pick up more information.
1.297     matthew  2505:         my %tmp = &get('environment',
1.294     matthew  2506:                        ['firstname','middlename','lastname', 'generation','id']
1.297     matthew  2507:                        ,$udom,$uname);
                   2508: 
                   2509:         foreach (keys(%tmp)) {
                   2510:             &logthis("key $_ = ".$tmp{$_});
                   2511:         }
1.294     matthew  2512:         $first  = $tmp{'firstname'}  if (!defined($first)  || $first  eq '');
                   2513:         $middle = $tmp{'middlename'} if (!defined($middle) || $middle eq '');
                   2514:         $last   = $tmp{'lastname'}   if (!defined($last)   || $last eq '');
1.297     matthew  2515:         $gene   = $tmp{'generation'} if (!defined($gene)   || $gene eq '');
1.294     matthew  2516:         $uid    = $tmp{'id'}         if (!defined($uid)    || $uid  eq '');
                   2517:     }
                   2518:     my $fullname = &Apache::loncoursedata::ProcessFullName($last,$gene,
                   2519:                                                            $first,$middle);
1.297     matthew  2520:     my $reply=critical('put:'.$ENV{'course.'.$cid.'.domain'}.':'.
1.81      www      2521: 	              $ENV{'course.'.$cid.'.num'}.':classlist:'.
                   2522:                       &escape($uname.':'.$udom).'='.
1.294     matthew  2523:                       &escape(join(':',$end,$start,$uid,$usec,$fullname)),
1.81      www      2524: 	              $ENV{'course.'.$cid.'.home'});
                   2525:     unless (($reply eq 'ok') || ($reply eq 'delayed')) {
                   2526: 	return 'error: '.$reply;
                   2527:     }
1.297     matthew  2528:     # Add student role to user
1.83      www      2529:     my $uurl='/'.$cid;
1.81      www      2530:     $uurl=~s/\_/\//g;
                   2531:     if ($usec) {
                   2532: 	$uurl.='/'.$usec;
                   2533:     }
                   2534:     return &assignrole($udom,$uname,$uurl,'st',$end,$start);
1.21      www      2535: }
                   2536: 
1.84      www      2537: # ------------------------------------------------- Write to course preferences
                   2538: 
                   2539: sub writecoursepref {
                   2540:     my ($courseid,%prefs)=@_;
                   2541:     $courseid=~s/^\///;
                   2542:     $courseid=~s/\_/\//g;
                   2543:     my ($cdomain,$cnum)=split(/\//,$courseid);
                   2544:     my $chome=homeserver($cnum,$cdomain);
                   2545:     if (($chome eq '') || ($chome eq 'no_host')) { 
                   2546: 	return 'error: no such course';
                   2547:     }
                   2548:     my $cstring='';
1.191     harris41 2549:     foreach (keys %prefs) {
1.84      www      2550: 	$cstring.=escape($_).'='.escape($prefs{$_}).'&';
1.191     harris41 2551:     }
1.84      www      2552:     $cstring=~s/\&$//;
                   2553:     return reply('put:'.$cdomain.':'.$cnum.':environment:'.$cstring,$chome);
                   2554: }
                   2555: 
                   2556: # ---------------------------------------------------------- Make/modify course
                   2557: 
                   2558: sub createcourse {
1.271     www      2559:     my ($udom,$description,$url,$course_server,$nonstandard)=@_;
1.84      www      2560:     $url=&declutter($url);
                   2561:     my $cid='';
1.264     matthew  2562:     unless (&allowed('ccc',$udom)) {
1.84      www      2563:         return 'refused';
                   2564:     }
                   2565: # ------------------------------------------------------------------- Create ID
                   2566:    my $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).
                   2567:        unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
                   2568: # ----------------------------------------------- Make sure that does not exist
1.230     stredwic 2569:    my $uhome=&homeserver($uname,$udom,'true');
1.84      www      2570:    unless (($uhome eq '') || ($uhome eq 'no_host')) {
                   2571:        $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).
                   2572:         unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
1.230     stredwic 2573:        $uhome=&homeserver($uname,$udom,'true');       
1.84      www      2574:        unless (($uhome eq '') || ($uhome eq 'no_host')) {
                   2575:            return 'error: unable to generate unique course-ID';
                   2576:        } 
                   2577:    }
1.264     matthew  2578: # ------------------------------------------------ Check supplied server name
                   2579:     $course_server = $ENV{'user.homeserver'} if (! defined($course_server));
                   2580:     if (! exists($libserv{$course_server})) {
                   2581:         return 'error:bad server name '.$course_server;
                   2582:     }
1.84      www      2583: # ------------------------------------------------------------- Make the course
                   2584:     my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',
1.264     matthew  2585:                       $course_server);
1.84      www      2586:     unless ($reply eq 'ok') { return 'error: '.$reply; }
1.230     stredwic 2587:     $uhome=&homeserver($uname,$udom,'true');
1.84      www      2588:     if (($uhome eq '') || ($uhome eq 'no_host')) { 
                   2589: 	return 'error: no such course';
                   2590:     }
1.271     www      2591: # ----------------------------------------------------------------- Course made
                   2592:     my $topurl=$url;
                   2593:     unless ($nonstandard) {
                   2594: # ------------------------------------------ For standard courses, make top url
                   2595:         my $mapurl=&clutter($url);
1.278     www      2596:         if ($mapurl eq '/res/') { $mapurl=''; }
1.271     www      2597:         $ENV{'form.initmap'}=(<<ENDINITMAP);
                   2598: <map>
                   2599: <resource id="1" type="start"></resource>
                   2600: <resource id="2" src="$mapurl"></resource>
                   2601: <resource id="3" type="finish"></resource>
                   2602: <link index="1" from="1" to="2"></link>
                   2603: <link index="2" from="2" to="3"></link>
                   2604: </map>
                   2605: ENDINITMAP
                   2606:         $topurl=&declutter(
                   2607:         &finishuserfileupload($uname,$udom,$uhome,'initmap','default.sequence')
                   2608:                           );
                   2609:     }
                   2610: # ----------------------------------------------------------- Write preferences
1.84      www      2611:     &writecoursepref($udom.'_'.$uname,
                   2612:                      ('description' => $description,
1.271     www      2613:                       'url'         => $topurl));
1.84      www      2614:     return '/'.$udom.'/'.$uname;
                   2615: }
                   2616: 
1.21      www      2617: # ---------------------------------------------------------- Assign Custom Role
                   2618: 
                   2619: sub assigncustomrole {
                   2620:     my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start)=@_;
                   2621:     return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename,
                   2622:                        $end,$start);
                   2623: }
                   2624: 
                   2625: # ----------------------------------------------------------------- Revoke Role
                   2626: 
                   2627: sub revokerole {
                   2628:     my ($udom,$uname,$url,$role)=@_;
                   2629:     my $now=time;
                   2630:     return &assignrole($udom,$uname,$url,$role,$now);
                   2631: }
                   2632: 
                   2633: # ---------------------------------------------------------- Revoke Custom Role
                   2634: 
                   2635: sub revokecustomrole {
                   2636:     my ($udom,$uname,$url,$rdom,$rnam,$rolename)=@_;
                   2637:     my $now=time;
                   2638:     return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now);
1.17      www      2639: }
                   2640: 
                   2641: # ------------------------------------------------------------ Directory lister
                   2642: 
                   2643: sub dirlist {
1.253     stredwic 2644:     my ($uri,$userdomain,$username,$alternateDirectoryRoot)=@_;
                   2645: 
1.18      www      2646:     $uri=~s/^\///;
                   2647:     $uri=~s/\/$//;
1.253     stredwic 2648:     my ($udom, $uname);
                   2649:     (undef,$udom,$uname)=split(/\//,$uri);
                   2650:     if(defined($userdomain)) {
                   2651:         $udom = $userdomain;
                   2652:     }
                   2653:     if(defined($username)) {
                   2654:         $uname = $username;
                   2655:     }
                   2656: 
                   2657:     my $dirRoot = $perlvar{'lonDocRoot'};
                   2658:     if(defined($alternateDirectoryRoot)) {
                   2659:         $dirRoot = $alternateDirectoryRoot;
                   2660:         $dirRoot =~ s/\/$//;
                   2661:     }
                   2662: 
                   2663:     if($udom) {
                   2664:         if($uname) {
                   2665:             my $listing=reply('ls:'.$dirRoot.'/'.$uri,
                   2666:                               homeserver($uname,$udom));
                   2667:             return split(/:/,$listing);
                   2668:         } elsif(!defined($alternateDirectoryRoot)) {
                   2669:             my $tryserver;
                   2670:             my %allusers=();
                   2671:             foreach $tryserver (keys %libserv) {
                   2672:                 if($hostdom{$tryserver} eq $udom) {
                   2673:                     my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.
                   2674:                                       $udom, $tryserver);
                   2675:                     if (($listing ne 'no_such_dir') && ($listing ne 'empty')
                   2676:                         && ($listing ne 'con_lost')) {
                   2677:                         foreach (split(/:/,$listing)) {
                   2678:                             my ($entry,@stat)=split(/&/,$_);
                   2679:                             $allusers{$entry}=1;
                   2680:                         }
                   2681:                     }
1.191     harris41 2682:                 }
1.253     stredwic 2683:             }
                   2684:             my $alluserstr='';
                   2685:             foreach (sort keys %allusers) {
                   2686:                 $alluserstr.=$_.'&user:';
                   2687:             }
                   2688:             $alluserstr=~s/:$//;
                   2689:             return split(/:/,$alluserstr);
                   2690:         } else {
                   2691:             my @emptyResults = ();
                   2692:             push(@emptyResults, 'missing user name');
                   2693:             return split(':',@emptyResults);
                   2694:         }
                   2695:     } elsif(!defined($alternateDirectoryRoot)) {
                   2696:         my $tryserver;
                   2697:         my %alldom=();
                   2698:         foreach $tryserver (keys %libserv) {
                   2699:             $alldom{$hostdom{$tryserver}}=1;
                   2700:         }
                   2701:         my $alldomstr='';
                   2702:         foreach (sort keys %alldom) {
                   2703:             $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'&domain:';
                   2704:         }
                   2705:         $alldomstr=~s/:$//;
                   2706:         return split(/:/,$alldomstr);       
                   2707:     } else {
                   2708:         my @emptyResults = ();
                   2709:         push(@emptyResults, 'missing domain');
                   2710:         return split(':',@emptyResults);
1.275     stredwic 2711:     }
                   2712: }
                   2713: 
                   2714: # --------------------------------------------- GetFileTimestamp
                   2715: # This function utilizes dirlist and returns the date stamp for
                   2716: # when it was last modified.  It will also return an error of -1
                   2717: # if an error occurs
                   2718: 
                   2719: sub GetFileTimestamp {
                   2720:     my ($studentDomain,$studentName,$filename,$root)=@_;
                   2721:     $studentDomain=~s/\W//g;
                   2722:     $studentName=~s/\W//g;
                   2723:     my $subdir=$studentName.'__';
                   2724:     $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
                   2725:     my $proname="$studentDomain/$subdir/$studentName";
                   2726:     $proname .= '/'.$filename;
                   2727:     my @dir = &Apache::lonnet::dirlist($proname, $studentDomain, $studentName,
                   2728:                                        $root);
                   2729:     my $fileStat = $dir[0];
                   2730:     my @stats = split('&', $fileStat);
                   2731:     if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {
                   2732:         return $stats[9];
                   2733:     } else {
                   2734:         return -1;
1.253     stredwic 2735:     }
1.26      www      2736: }
                   2737: 
                   2738: # -------------------------------------------------------- Value of a Condition
                   2739: 
1.40      www      2740: sub directcondval {
                   2741:     my $number=shift;
                   2742:     if ($ENV{'user.state.'.$ENV{'request.course.id'}}) {
                   2743:        return substr($ENV{'user.state.'.$ENV{'request.course.id'}},$number,1);
                   2744:     } else {
                   2745:        return 2;
                   2746:     }
                   2747: }
                   2748: 
1.26      www      2749: sub condval {
                   2750:     my $condidx=shift;
                   2751:     my $result=0;
1.54      www      2752:     my $allpathcond='';
1.191     harris41 2753:     foreach (split(/\|/,$condidx)) {
1.54      www      2754:        if (defined($ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_})) {
                   2755: 	   $allpathcond.=
                   2756:                '('.$ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_}.')|';
                   2757:        }
1.191     harris41 2758:     }
1.54      www      2759:     $allpathcond=~s/\|$//;
1.33      www      2760:     if ($ENV{'request.course.id'}) {
1.54      www      2761:        if ($allpathcond) {
1.26      www      2762:           my $operand='|';
                   2763: 	  my @stack;
1.191     harris41 2764:            foreach ($allpathcond=~/(\d+|\(|\)|\&|\|)/g) {
1.26      www      2765:               if ($_ eq '(') {
                   2766:                  push @stack,($operand,$result)
                   2767:               } elsif ($_ eq ')') {
                   2768:                   my $before=pop @stack;
                   2769: 		  if (pop @stack eq '&') {
                   2770: 		      $result=$result>$before?$before:$result;
                   2771:                   } else {
                   2772:                       $result=$result>$before?$result:$before;
                   2773:                   }
                   2774:               } elsif (($_ eq '&') || ($_ eq '|')) {
                   2775:                   $operand=$_;
                   2776:               } else {
1.40      www      2777:                   my $new=directcondval($_);
1.26      www      2778:                   if ($operand eq '&') {
                   2779:                      $result=$result>$new?$new:$result;
                   2780:                   } else {
                   2781:                      $result=$result>$new?$result:$new;
1.191     harris41 2782:                   }
1.26      www      2783:               }
1.191     harris41 2784:           }
1.26      www      2785:        }
                   2786:     }
                   2787:     return $result;
1.279     www      2788: }
                   2789: 
                   2790: # ---------------------------------------------------- Devalidate courseresdata
                   2791: 
                   2792: sub devalidatecourseresdata {
                   2793:     my ($coursenum,$coursedomain)=@_;
                   2794:     my $hashid=$coursenum.':'.$coursedomain;
                   2795:     delete $courseresdatacache{$hashid.'.time'};
1.28      www      2796: }
                   2797: 
1.200     www      2798: # --------------------------------------------------- Course Resourcedata Query
                   2799: 
                   2800: sub courseresdata {
                   2801:     my ($coursenum,$coursedomain,@which)=@_;
                   2802:     my $coursehom=&homeserver($coursenum,$coursedomain);
                   2803:     my $hashid=$coursenum.':'.$coursedomain;
1.250     albertel 2804:     my $dodump=0;
                   2805:     if (!defined($courseresdatacache{$hashid.'.time'})) {
                   2806: 	$dodump=1;
                   2807:     } else {
                   2808: 	if (time-$courseresdatacache{$hashid.'.time'}>300) { $dodump=1; }
                   2809:     }
                   2810:     if ($dodump) {
1.251     albertel 2811: 	my %dumpreply=&dump('resourcedata',$coursedomain,$coursenum);
                   2812: 	my ($tmp) = keys(%dumpreply);
                   2813: 	if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
                   2814: 	    $courseresdatacache{$hashid.'.time'}=time;
                   2815: 	    $courseresdatacache{$hashid}=\%dumpreply;
1.306     albertel 2816: 	} elsif ($tmp =~ /^(con_lost|no_such_host)/) {
                   2817: 	    return $tmp;
1.250     albertel 2818: 	}
                   2819:     }
1.251     albertel 2820:     foreach my $item (@which) {
1.287     albertel 2821: 	if (defined($courseresdatacache{$hashid}->{$item})) {
1.251     albertel 2822: 	    return $courseresdatacache{$hashid}->{$item};
                   2823: 	}
1.250     albertel 2824:     }
1.291     albertel 2825:     return undef;
1.200     www      2826: }
                   2827: 
1.28      www      2828: # --------------------------------------------------------- Value of a Variable
                   2829: 
1.58      www      2830: sub EXT {
1.282     albertel 2831:     my ($varname,$symbparm,$udom,$uname,)=@_;
1.218     albertel 2832: 
1.68      www      2833:     unless ($varname) { return ''; }
1.218     albertel 2834: 
                   2835:     #get real user name/domain, courseid and symb
                   2836:     my $courseid;
                   2837:     if (!($uname && $udom)) {
                   2838:       (my $cursymb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();
                   2839:       if (!$symbparm) {	$symbparm=$cursymb; }
                   2840:     } else {
                   2841: 	$courseid=$ENV{'request.course.id'};
                   2842:     }
1.48      www      2843:     my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);
                   2844:     my $rest;
1.320     albertel 2845:     if (defined($therest[0])) {
1.48      www      2846:        $rest=join('.',@therest);
                   2847:     } else {
                   2848:        $rest='';
                   2849:     }
1.320     albertel 2850: 
1.57      www      2851:     my $qualifierrest=$qualifier;
                   2852:     if ($rest) { $qualifierrest.='.'.$rest; }
                   2853:     my $spacequalifierrest=$space;
                   2854:     if ($qualifierrest) { $spacequalifierrest.='.'.$qualifierrest; }
1.28      www      2855:     if ($realm eq 'user') {
1.48      www      2856: # --------------------------------------------------------------- user.resource
                   2857: 	if ($space eq 'resource') {
1.218     albertel 2858: 	    my %restored=&restore(undef,undef,$udom,$uname);
1.57      www      2859:             return $restored{$qualifierrest};
1.48      www      2860: # ----------------------------------------------------------------- user.access
                   2861:         } elsif ($space eq 'access') {
1.218     albertel 2862: 	    # FIXME - not supporting calls for a specific user
1.48      www      2863:             return &allowed($qualifier,$rest);
                   2864: # ------------------------------------------ user.preferences, user.environment
                   2865:         } elsif (($space eq 'preferences') || ($space eq 'environment')) {
1.218     albertel 2866: 	    if (($uname eq $ENV{'user.name'}) &&
                   2867: 		($udom eq $ENV{'user.domain'})) {
                   2868: 		return $ENV{join('.',('environment',$qualifierrest))};
                   2869: 	    } else {
                   2870: 		my %returnhash=&userenvironment($udom,$uname,$qualifierrest);
                   2871: 		return $returnhash{$qualifierrest};
                   2872: 	    }
1.48      www      2873: # ----------------------------------------------------------------- user.course
                   2874:         } elsif ($space eq 'course') {
1.218     albertel 2875: 	    # FIXME - not supporting calls for a specific user
1.48      www      2876:             return $ENV{join('.',('request.course',$qualifier))};
                   2877: # ------------------------------------------------------------------- user.role
                   2878:         } elsif ($space eq 'role') {
1.218     albertel 2879: 	    # FIXME - not supporting calls for a specific user
1.48      www      2880:             my ($role,$where)=split(/\./,$ENV{'request.role'});
                   2881:             if ($qualifier eq 'value') {
                   2882: 		return $role;
                   2883:             } elsif ($qualifier eq 'extent') {
                   2884:                 return $where;
                   2885:             }
                   2886: # ----------------------------------------------------------------- user.domain
                   2887:         } elsif ($space eq 'domain') {
1.218     albertel 2888:             return $udom;
1.48      www      2889: # ------------------------------------------------------------------- user.name
                   2890:         } elsif ($space eq 'name') {
1.218     albertel 2891:             return $uname;
1.48      www      2892: # ---------------------------------------------------- Any other user namespace
1.29      www      2893:         } else {
1.48      www      2894:             my $item=($rest)?$qualifier.'.'.$rest:$qualifier;
1.131     albertel 2895:             my %reply=&get($space,[$item]);
1.48      www      2896:             return $reply{$item};
                   2897:         }
1.236     www      2898:     } elsif ($realm eq 'query') {
                   2899: # ---------------------------------------------- pull stuff out of query string
                   2900:         &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'},[$space]);
                   2901: 	return $ENV{'form.'.$space}; 
                   2902:    } elsif ($realm eq 'request') {
1.48      www      2903: # ------------------------------------------------------------- request.browser
                   2904:         if ($space eq 'browser') {
                   2905: 	    return $ENV{'browser.'.$qualifier};
1.57      www      2906: # ------------------------------------------------------------ request.filename
                   2907:         } else {
                   2908:             return $ENV{'request.'.$spacequalifierrest};
1.29      www      2909:         }
1.28      www      2910:     } elsif ($realm eq 'course') {
1.48      www      2911: # ---------------------------------------------------------- course.description
1.218     albertel 2912:         return $ENV{'course.'.$courseid.'.'.$spacequalifierrest};
1.57      www      2913:     } elsif ($realm eq 'resource') {
1.165     www      2914: 
1.218     albertel 2915: 	if ($courseid eq $ENV{'request.course.id'}) {
1.165     www      2916: 
1.218     albertel 2917: 	    #print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;
1.165     www      2918: 
1.60      www      2919: # ----------------------------------------------------- Cascading lookup scheme
1.218     albertel 2920: 	    if (!$symbparm) { $symbparm=&symbread(); }
                   2921: 	    my $symbp=$symbparm;
                   2922: 	    my $mapp=(split(/\_\_\_/,$symbp))[0];
                   2923: 
                   2924: 	    my $symbparm=$symbp.'.'.$spacequalifierrest;
                   2925: 	    my $mapparm=$mapp.'___(all).'.$spacequalifierrest;
                   2926: 
                   2927: 	    my $section;
                   2928: 	    if (($ENV{'user.name'} eq $uname) &&
                   2929: 		($ENV{'user.domain'} eq $udom)) {
1.255     albertel 2930: 		$section=$ENV{'request.course.sec'};
1.218     albertel 2931: 	    } else {
                   2932: 		$section=&usection($udom,$uname,$courseid);
                   2933: 	    }
                   2934: 
                   2935: 	    my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
                   2936: 	    my $seclevelr=$courseid.'.['.$section.'].'.$symbparm;
                   2937: 	    my $seclevelm=$courseid.'.['.$section.'].'.$mapparm;
                   2938: 
                   2939: 	    my $courselevel=$courseid.'.'.$spacequalifierrest;
                   2940: 	    my $courselevelr=$courseid.'.'.$symbparm;
                   2941: 	    my $courselevelm=$courseid.'.'.$mapparm;
1.69      www      2942: 
1.60      www      2943: # ----------------------------------------------------------- first, check user
1.308     albertel 2944: 	    #most student don't have any data set, check if there is some data
                   2945:             #every thirty minutes
1.309     albertel 2946: 	    if (!
                   2947: 		(exists($ENV{'cache.studentresdata'})
                   2948: 		    && (($ENV{'cache.studentresdata'}+1800) > time))) {
1.308     albertel 2949: 		my %resourcedata=&get('resourcedata',
                   2950: 				      [$courselevelr,$courselevelm,$courselevel],
                   2951: 				      $udom,$uname);
                   2952: 		my ($tmp)=keys(%resourcedata);
                   2953: 		if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) {
                   2954: 		    if ($resourcedata{$courselevelr}) {
                   2955: 			return $resourcedata{$courselevelr}; }
                   2956: 		    if ($resourcedata{$courselevelm}) {
                   2957: 			return $resourcedata{$courselevelm}; }
                   2958: 		    if ($resourcedata{$courselevel}) {
                   2959: 			return $resourcedata{$courselevel}; }
                   2960: 		} else {
                   2961: 		    if ($tmp!~/No such file/) {
                   2962: 			&logthis("<font color=blue>WARNING:".
                   2963: 				 " Trying to get resource data for ".
                   2964: 				 $uname." at ".$udom.": ".
                   2965: 				 $tmp."</font>");
                   2966: 		    } elsif ($tmp=~/error:No such file/) {
1.309     albertel 2967: 			$ENV{'cache.studentresdata'}=time;
                   2968: 			&appenv(('cache.studentresdata'=>
                   2969: 				 $ENV{'cache.studentresdata'}));
1.308     albertel 2970: 		    } elsif ($tmp =~ /^(con_lost|no_such_host)/) {
                   2971: 			return $tmp;
                   2972: 		    }
1.218     albertel 2973: 		}
                   2974: 	    }
1.95      www      2975: 
1.60      www      2976: # -------------------------------------------------------- second, check course
1.96      www      2977: 
1.218     albertel 2978: 	    my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'},
                   2979: 					  $ENV{'course.'.$courseid.'.domain'},
                   2980: 					  ($seclevelr,$seclevelm,$seclevel,
                   2981: 					   $courselevelr,$courselevelm,
                   2982: 					   $courselevel));
1.287     albertel 2983: 	    if (defined($coursereply)) { return $coursereply; }
1.200     www      2984: 
1.60      www      2985: # ------------------------------------------------------ third, check map parms
1.218     albertel 2986: 	    my %parmhash=();
                   2987: 	    my $thisparm='';
                   2988: 	    if (tie(%parmhash,'GDBM_File',
                   2989: 		    $ENV{'request.course.fn'}.'_parms.db',
1.256     albertel 2990: 		    &GDBM_READER(),0640)) {
1.218     albertel 2991: 		$thisparm=$parmhash{$symbparm};
                   2992: 		untie(%parmhash);
                   2993: 	    }
                   2994: 	    if ($thisparm) { return $thisparm; }
                   2995: 	}
1.60      www      2996: # --------------------------------------------- last, look in resource metadata
1.71      www      2997: 
1.218     albertel 2998: 	$spacequalifierrest=~s/\./\_/;
1.282     albertel 2999: 	my $filename;
                   3000: 	if (!$symbparm) { $symbparm=&symbread(); }
                   3001: 	if ($symbparm) {
                   3002: 	    $filename=(split(/\_\_\_/,$symbparm))[2];
                   3003: 	} else {
                   3004: 	    $filename=$ENV{'request.filename'};
                   3005: 	}
                   3006: 	my $metadata=&metadata($filename,$spacequalifierrest);
1.288     albertel 3007: 	if (defined($metadata)) { return $metadata; }
1.282     albertel 3008: 	$metadata=&metadata($filename,'parameter_'.$spacequalifierrest);
1.288     albertel 3009: 	if (defined($metadata)) { return $metadata; }
1.142     www      3010: 
1.145     www      3011: # ------------------------------------------------------------------ Cascade up
1.218     albertel 3012: 	unless ($space eq '0') {
                   3013: 	    my ($part,$id)=split(/\_/,$space);
                   3014: 	    if ($id) {
                   3015: 		my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,
                   3016: 				     $symbparm,$udom,$uname);
1.288     albertel 3017: 		if (defined($partgeneral)) { return $partgeneral; }
1.218     albertel 3018: 	    } else {
                   3019: 		my $resourcegeneral=&EXT('resource.0.'.$qualifierrest,
                   3020: 					 $symbparm,$udom,$uname);
1.288     albertel 3021: 		if (defined($resourcegeneral)) { return $resourcegeneral; }
1.218     albertel 3022: 	    }
                   3023: 	}
1.71      www      3024: 
1.48      www      3025: # ---------------------------------------------------- Any other user namespace
                   3026:     } elsif ($realm eq 'environment') {
                   3027: # ----------------------------------------------------------------- environment
1.219     albertel 3028: 	if (($uname eq $ENV{'user.name'})&&($udom eq $ENV{'user.domain'})) {
                   3029: 	    return $ENV{'environment.'.$spacequalifierrest};
                   3030: 	} else {
                   3031: 	    my %returnhash=&userenvironment($udom,$uname,
                   3032: 					    $spacequalifierrest);
                   3033: 	    return $returnhash{$spacequalifierrest};
                   3034: 	}
1.28      www      3035:     } elsif ($realm eq 'system') {
1.48      www      3036: # ----------------------------------------------------------------- system.time
                   3037: 	if ($space eq 'time') {
                   3038: 	    return time;
                   3039:         }
1.28      www      3040:     }
1.48      www      3041:     return '';
1.61      www      3042: }
                   3043: 
1.71      www      3044: # ---------------------------------------------------------------- Get metadata
                   3045: 
                   3046: sub metadata {
1.176     www      3047:     my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
1.78      www      3048: 
1.71      www      3049:     $uri=&declutter($uri);
1.288     albertel 3050:     # if it is a non metadata possible uri return quickly
1.293     matthew  3051:     if (($uri eq '') || (($uri =~ m|^/*adm/|) && ($uri !~ m|^adm/includes|)) ||
                   3052:         ($uri =~ m|/$|) || ($uri =~ m|/.meta$|)) {
1.288     albertel 3053: 	return '';
                   3054:     }
1.73      www      3055:     my $filename=$uri;
                   3056:     $uri=~s/\.meta$//;
1.172     www      3057: #
                   3058: # Is the metadata already cached?
1.177     www      3059: # Look at timestamp of caching
1.172     www      3060: # Everything is cached by the main uri, libraries are never directly cached
                   3061: #
1.277     albertel 3062:     unless (abs($metacache{$uri.':cachedtimestamp'}-time)<600 && !defined($liburi)) {
1.172     www      3063: #
                   3064: # Is this a recursive call for a library?
                   3065: #
1.171     www      3066:         if ($liburi) {
                   3067: 	    $liburi=&declutter($liburi);
                   3068:             $filename=$liburi;
                   3069:         }
1.140     www      3070:         my %metathesekeys=();
1.73      www      3071:         unless ($filename=~/\.meta$/) { $filename.='.meta'; }
                   3072: 	my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename);
1.208     albertel 3073:         my $parser=HTML::LCParser->new(\$metastring);
1.71      www      3074:         my $token;
1.140     www      3075:         undef %metathesekeys;
1.71      www      3076:         while ($token=$parser->get_token) {
                   3077:            if ($token->[0] eq 'S') {
1.135     www      3078: 	     if (defined($token->[2]->{'package'})) {
1.172     www      3079: #
                   3080: # This is a package - get package info
                   3081: #
1.136     www      3082: 	      my $package=$token->[2]->{'package'};
                   3083: 	      my $keyroot='';
1.333   ! albertel 3084:               if (defined($prefix) && $prefix !~ /^__/) {
        !          3085: 		  # prefix that has a part already
        !          3086: 		  $keyroot=$prefix;
        !          3087:               } elsif (defined($prefix)) {
        !          3088: 		  # prefix that is missing a part
        !          3089: 		  if (defined($token->[2]->{'part'})) {
        !          3090: 		      $keyroot='_'.$token->[2]->{'part'}.substr($prefix,1);
        !          3091: 		  }
        !          3092: 	      } else {
        !          3093: 		  # no prefix at all
        !          3094: 		  if (defined($token->[2]->{'part'})) {
        !          3095: 		      $keyroot='_'.$token->[2]->{'part'};
        !          3096: 		  }
1.136     www      3097: 	      }
                   3098:               if (defined($token->[2]->{'id'})) { 
1.165     www      3099:                  $keyroot.='_'.$token->[2]->{'id'}; 
1.136     www      3100: 	      }
                   3101:               if ($metacache{$uri.':packages'}) {
                   3102:                  $metacache{$uri.':packages'}.=','.$package.$keyroot;
                   3103:               } else {
                   3104:                  $metacache{$uri.':packages'}=$package.$keyroot;
                   3105: 	      }
1.191     harris41 3106:               foreach (keys %packagetab) {
1.137     www      3107: 		  if ($_=~/^$package\&/) {
                   3108: 		      my ($pack,$name,$subp)=split(/\&/,$_);
1.139     www      3109:                       my $value=$packagetab{$_};
1.144     www      3110: 		      my $part=$keyroot;
                   3111:                       $part=~s/^\_//;
1.139     www      3112:                       if ($subp eq 'display') {
                   3113: 			  $value.=' [Part: '.$part.']';
                   3114:                       }
                   3115:                       my $unikey='parameter'.$keyroot.'_'.$name;
1.140     www      3116:                       $metathesekeys{$unikey}=1;
1.144     www      3117:                       $metacache{$uri.':'.$unikey.'.part'}=$part;
1.322     albertel 3118:                       unless (defined($metacache{$uri.':'.$unikey.'.'.$subp})) {
                   3119: 			  $metacache{$uri.':'.$unikey.'.'.$subp}=$value;
                   3120: 		      }
                   3121: 		      if (defined($metacache{$uri.':'.$unikey.'.default'})) {
                   3122: 			  $metacache{$uri.':'.$unikey}=
                   3123: 			     $metacache{$uri.':'.$unikey.'.default'}
1.141     www      3124: 		      }
1.137     www      3125:                   }
1.191     harris41 3126:               }
1.135     www      3127:              } else {
1.172     www      3128: #
                   3129: # This is not a package - some other kind of start tag
                   3130: # 
1.175     www      3131:               my $entry=$token->[1];
1.176     www      3132:               my $unikey;
                   3133:               if ($entry eq 'import') {
                   3134:                  $unikey='';
                   3135:               } else {
                   3136:                  $unikey=$entry;
                   3137: 	      }
1.172     www      3138:               if ($prefix) {
1.176     www      3139: 		  $unikey.=$prefix;
1.172     www      3140:               } else {
                   3141:                 if (defined($token->[2]->{'part'})) { 
                   3142:                    $unikey.='_'.$token->[2]->{'part'}; 
                   3143: 	        }
1.136     www      3144: 	      }
                   3145:               if (defined($token->[2]->{'id'})) { 
1.165     www      3146:                  $unikey.='_'.$token->[2]->{'id'}; 
1.71      www      3147: 	      }
1.175     www      3148: 
                   3149:              if ($entry eq 'import') {
                   3150: #
                   3151: # Importing a library here
1.176     www      3152: #                
                   3153:                  if ($depthcount<20) {
1.276     albertel 3154: 		     my $location=$parser->get_text('/import');
                   3155: 		     my $dir=$filename;
                   3156: 		     $dir=~s|[^/]*$||;
                   3157: 		     $location=&filelocation($dir,$location);
                   3158: 		     foreach (sort(split(/\,/,&metadata($uri,'keys',
                   3159: 							$location,$unikey,
                   3160: 							$depthcount+1)))) {
1.177     www      3161:                          $metathesekeys{$_}=1;
1.191     harris41 3162: 		     }
1.176     www      3163: 		 }
1.175     www      3164:              } else { 
                   3165: 
1.72      www      3166:               if (defined($token->[2]->{'name'})) { 
1.71      www      3167:                  $unikey.='_'.$token->[2]->{'name'}; 
                   3168: 	      }
1.140     www      3169:               $metathesekeys{$unikey}=1;
1.191     harris41 3170:               foreach (@{$token->[3]}) {
1.71      www      3171: 		  $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};
1.191     harris41 3172:               }
1.321     albertel 3173: 	      my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));
                   3174: 	      my $default=$metacache{$uri.':'.$unikey.'.default'};
                   3175: 	      if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) {
                   3176: 		  # only ws inside the tag, and not in default, so use default
                   3177:                   # as value
                   3178: 		  $metacache{$uri.':'.$unikey}=$default;
                   3179: 	      } else {
                   3180: 		  # either something interesting inside the tag or default
                   3181:                   # uninteresting
                   3182: 		  $metacache{$uri.':'.$unikey}=$internaltext;
                   3183: 	      }
1.172     www      3184: # end of not-a-package not-a-library import
1.175     www      3185: 	   }
1.172     www      3186: # end of not-a-package start tag
                   3187: 	  }
                   3188: # the next is the end of "start tag"
1.140     www      3189: 	 }
1.71      www      3190:        }
1.274     albertel 3191:        $metacache{$uri.':keys'}=join(',',keys %metathesekeys);
1.261     albertel 3192: 	&metadata_generate_part0(\%metathesekeys,\%metacache,$uri);
1.274     albertel 3193:        $metacache{$uri.':allpossiblekeys'}=join(',',keys %metathesekeys);
1.174     www      3194:        $metacache{$uri.':cachedtimestamp'}=time;
1.177     www      3195: # this is the end of "was not already recently cached
1.71      www      3196:     }
                   3197:     return $metacache{$uri.':'.$what};
1.261     albertel 3198: }
                   3199: 
                   3200: sub metadata_generate_part0 {
                   3201:     my ($metadata,$metacache,$uri) = @_;
                   3202:     my %allnames;
                   3203:     foreach my $metakey (sort keys %$metadata) {
                   3204: 	if ($metakey=~/^parameter\_(.*)/) {
                   3205: 	  my $part=$$metacache{$uri.':'.$metakey.'.part'};
                   3206: 	  my $name=$$metacache{$uri.':'.$metakey.'.name'};
                   3207: 	  if (! exists($$metadata{'parameter_0_'.$name})) {
                   3208: 	    $allnames{$name}=$part;
                   3209: 	  }
                   3210: 	}
                   3211:     }
                   3212:     foreach my $name (keys(%allnames)) {
                   3213:       $$metadata{"parameter_0_$name"}=1;
                   3214:       my $key="$uri:parameter_0_$name";
                   3215:       $$metacache{"$key.part"}='0';
                   3216:       $$metacache{"$key.name"}=$name;
                   3217:       $$metacache{"$key.type"}=$$metacache{$uri.':parameter_'.
                   3218: 					   $allnames{$name}.'_'.$name.
                   3219: 					   '.type'};
                   3220:       my $olddis=$$metacache{$uri.':parameter_'.$allnames{$name}.'_'.$name.
                   3221: 			     '.display'};
                   3222:       my $expr='\\[Part: '.$allnames{$name}.'\\]';
                   3223:       $olddis=~s/$expr/\[Part: 0\]/;
                   3224:       $$metacache{"$key.display"}=$olddis;
                   3225:     }
1.71      www      3226: }
                   3227: 
1.301     www      3228: # ------------------------------------------------- Get the title of a resource
                   3229: 
                   3230: sub gettitle {
                   3231:     my $urlsymb=shift;
                   3232:     my $symb=&symbread($urlsymb);
                   3233:     unless ($symb) {
                   3234: 	unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; }
                   3235:         return &metadata($urlsymb,'title'); 
                   3236:     }
                   3237:     if ($titlecache{$symb}) { return $titlecache{$symb}; }
                   3238:     my ($map,$resid,$url)=split(/\_\_\_/,$symb);
                   3239:     my $title='';
                   3240:     my %bighash;
                   3241:     if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
                   3242:                             &GDBM_READER(),0640)) {
                   3243:         my $mapid=$bighash{'map_pc_'.&clutter($map)};
                   3244:         $title=$bighash{'title_'.$mapid.'.'.$resid};
                   3245:         untie %bighash;
                   3246:     }
                   3247:     if ($title) {
                   3248:         $titlecache{$symb}=$title;
                   3249:         return $title;
                   3250:     } else {
                   3251: 	return &metadata($urlsymb,'title');
                   3252:     }
                   3253: }
                   3254:     
1.31      www      3255: # ------------------------------------------------- Update symbolic store links
                   3256: 
                   3257: sub symblist {
                   3258:     my ($mapname,%newhash)=@_;
                   3259:     $mapname=declutter($mapname);
                   3260:     my %hash;
                   3261:     if (($ENV{'request.course.fn'}) && (%newhash)) {
                   3262:         if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',
1.256     albertel 3263:                       &GDBM_WRCREAT(),0640)) {
1.191     harris41 3264: 	    foreach (keys %newhash) {
1.211     www      3265:                 $hash{declutter($_)}=$mapname.'___'.$newhash{$_};
1.191     harris41 3266:             }
1.31      www      3267:             if (untie(%hash)) {
                   3268: 		return 'ok';
                   3269:             }
                   3270:         }
                   3271:     }
                   3272:     return 'error';
1.212     www      3273: }
                   3274: 
                   3275: # --------------------------------------------------------------- Verify a symb
                   3276: 
                   3277: sub symbverify {
                   3278:     my ($symb,$thisfn)=@_;
1.213     www      3279:     $thisfn=&declutter($thisfn);
1.215     www      3280: # direct jump to resource in page or to a sequence - will construct own symbs
                   3281:     if ($thisfn=~/\.(page|sequence)$/) { return 1; }
                   3282: # check URL part
1.213     www      3283:     my ($map,$resid,$url)=split(/\_\_\_/,$symb);
                   3284:     unless (&symbclean($url) eq &symbclean($thisfn)) { return 0; }
                   3285: 
1.216     www      3286:     $symb=&symbclean($symb);
1.213     www      3287: 
                   3288:     my %bighash;
                   3289:     my $okay=0;
                   3290:     if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
1.256     albertel 3291:                             &GDBM_READER(),0640)) {
1.280     www      3292:         my $ids=$bighash{'ids_'.&clutter($thisfn)};
1.216     www      3293:         unless ($ids) { 
                   3294:            $ids=$bighash{'ids_/'.$thisfn};
                   3295:         }
                   3296:         if ($ids) {
                   3297: # ------------------------------------------------------------------- Has ID(s)
                   3298: 	    foreach (split(/\,/,$ids)) {
                   3299:                my ($mapid,$resid)=split(/\./,$_);
                   3300:                if (
                   3301:   &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)
                   3302:    eq $symb) { 
                   3303:                   $okay=1; 
                   3304:                }
                   3305: 	   }
                   3306:         }
1.213     www      3307: 	untie(%bighash);
                   3308:     }
                   3309:     return $okay;
1.31      www      3310: }
                   3311: 
1.210     www      3312: # --------------------------------------------------------------- Clean-up symb
                   3313: 
                   3314: sub symbclean {
                   3315:     my $symb=shift;
1.213     www      3316: 
1.210     www      3317: # remove version from map
                   3318:     $symb=~s/\.(\d+)\.(\w+)\_\_\_/\.$2\_\_\_/;
1.215     www      3319: 
1.210     www      3320: # remove version from URL
                   3321:     $symb=~s/\.(\d+)\.(\w+)$/\.$2/;
1.213     www      3322: 
1.210     www      3323:     return $symb;
                   3324: }
                   3325: 
1.31      www      3326: # ------------------------------------------------------ Return symb list entry
                   3327: 
                   3328: sub symbread {
1.249     www      3329:     my ($thisfn,$donotrecurse)=@_;
1.242     www      3330: # no filename provided? try from environment
1.44      www      3331:     unless ($thisfn) {
1.210     www      3332:         if ($ENV{'request.symb'}) { return &symbclean($ENV{'request.symb'}); }
1.44      www      3333: 	$thisfn=$ENV{'request.filename'};
                   3334:     }
1.242     www      3335: # is that filename actually a symb? Verify, clean, and return
                   3336:     if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) {
                   3337: 	if (&symbverify($thisfn,$1)) { return &symbclean($thisfn); }
                   3338:     }
1.44      www      3339:     $thisfn=declutter($thisfn);
1.31      www      3340:     my %hash;
1.37      www      3341:     my %bighash;
                   3342:     my $syval='';
1.45      www      3343:     if (($ENV{'request.course.fn'}) && ($thisfn)) {
1.31      www      3344:         if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',
1.256     albertel 3345:                       &GDBM_READER(),0640)) {
1.31      www      3346: 	    $syval=$hash{$thisfn};
1.37      www      3347:             untie(%hash);
                   3348:         }
                   3349: # ---------------------------------------------------------- There was an entry
                   3350:         if ($syval) {
                   3351:            unless ($syval=~/\_\d+$/) {
                   3352: 	       unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) {
1.44      www      3353:                   &appenv('request.ambiguous' => $thisfn);
1.37      www      3354:                   return '';
                   3355:                }    
                   3356:                $syval.=$1;
                   3357: 	   }
                   3358:         } else {
                   3359: # ------------------------------------------------------- Was not in symb table
                   3360:            if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
1.256     albertel 3361:                             &GDBM_READER(),0640)) {
1.37      www      3362: # ---------------------------------------------- Get ID(s) for current resource
1.280     www      3363:               my $ids=$bighash{'ids_'.&clutter($thisfn)};
1.65      www      3364:               unless ($ids) { 
                   3365:                  $ids=$bighash{'ids_/'.$thisfn};
1.242     www      3366:               }
                   3367:               unless ($ids) {
                   3368: # alias?
                   3369: 		  $ids=$bighash{'mapalias_'.$thisfn};
1.65      www      3370:               }
1.37      www      3371:               if ($ids) {
                   3372: # ------------------------------------------------------------------- Has ID(s)
                   3373:                  my @possibilities=split(/\,/,$ids);
1.39      www      3374:                  if ($#possibilities==0) {
                   3375: # ----------------------------------------------- There is only one possibility
1.37      www      3376: 		     my ($mapid,$resid)=split(/\./,$ids);
                   3377:                      $syval=declutter($bighash{'map_id_'.$mapid}).'___'.$resid;
1.249     www      3378:                  } elsif (!$donotrecurse) {
1.39      www      3379: # ------------------------------------------ There is more than one possibility
                   3380:                      my $realpossible=0;
1.191     harris41 3381:                      foreach (@possibilities) {
1.39      www      3382: 			 my $file=$bighash{'src_'.$_};
                   3383:                          if (&allowed('bre',$file)) {
                   3384:          		    my ($mapid,$resid)=split(/\./,$_);
                   3385:                             if ($bighash{'map_type_'.$mapid} ne 'page') {
                   3386: 				$realpossible++;
                   3387:                                 $syval=declutter($bighash{'map_id_'.$mapid}).
                   3388:                                        '___'.$resid;
                   3389:                             }
                   3390: 			 }
1.191     harris41 3391:                      }
1.39      www      3392: 		     if ($realpossible!=1) { $syval=''; }
1.249     www      3393:                  } else {
                   3394:                      $syval='';
1.37      www      3395:                  }
                   3396: 	      }
                   3397:               untie(%bighash)
                   3398:            } 
1.31      www      3399:         }
1.62      www      3400:         if ($syval) {
1.210     www      3401:            return &symbclean($syval.'___'.$thisfn); 
1.62      www      3402:         }
1.31      www      3403:     }
1.44      www      3404:     &appenv('request.ambiguous' => $thisfn);
1.31      www      3405:     return '';
                   3406: }
                   3407: 
                   3408: # ---------------------------------------------------------- Return random seed
                   3409: 
1.32      www      3410: sub numval {
                   3411:     my $txt=shift;
                   3412:     $txt=~tr/A-J/0-9/;
                   3413:     $txt=~tr/a-j/0-9/;
                   3414:     $txt=~tr/K-T/0-9/;
                   3415:     $txt=~tr/k-t/0-9/;
                   3416:     $txt=~tr/U-Z/0-5/;
                   3417:     $txt=~tr/u-z/0-5/;
                   3418:     $txt=~s/\D//g;
                   3419:     return int($txt);
                   3420: }    
                   3421: 
1.31      www      3422: sub rndseed {
1.155     albertel 3423:     my ($symb,$courseid,$domain,$username)=@_;
                   3424:     if (!$symb) {
                   3425:       unless ($symb=&symbread()) { return time; }
                   3426:     }
                   3427:     if (!$courseid) { $courseid=$ENV{'request.course.id'};}
                   3428:     if (!$domain) {$domain=$ENV{'user.domain'};}
                   3429:     if (!$username) {$username=$ENV{'user.name'};}
                   3430:     {
1.98      albertel 3431:       use integer;
                   3432:       my $symbchck=unpack("%32C*",$symb) << 27;
1.100     albertel 3433:       my $symbseed=numval($symb) << 22;
1.155     albertel 3434:       my $namechck=unpack("%32C*",$username) << 17;
                   3435:       my $nameseed=numval($username) << 12;
                   3436:       my $domainseed=unpack("%32C*",$domain) << 7;
                   3437:       my $courseseed=unpack("%32C*",$courseid);
1.98      albertel 3438:       my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;
1.99      albertel 3439:       #uncommenting these lines can break things!
                   3440:       #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
                   3441:       #&Apache::lonxml::debug("rndseed :$num:$symb");
1.98      albertel 3442:       return $num;
                   3443:     }
1.36      albertel 3444: }
                   3445: 
1.76      www      3446: sub ireceipt {
                   3447:     my ($funame,$fudom,$fucourseid,$fusymb)=@_;
                   3448:     my $cuname=unpack("%32C*",$funame);
                   3449:     my $cudom=unpack("%32C*",$fudom);
                   3450:     my $cucourseid=unpack("%32C*",$fucourseid);
                   3451:     my $cusymb=unpack("%32C*",$fusymb);
1.77      www      3452:     my $cunique=unpack("%32C*",$perlvar{'lonReceipt'});
1.76      www      3453:     return unpack("%32C*",$perlvar{'lonHostID'}).'-'.
                   3454:            ($cunique%$cuname+
                   3455:             $cunique%$cudom+
                   3456:             $cusymb%$cuname+
                   3457:             $cusymb%$cudom+
                   3458:             $cucourseid%$cuname+
                   3459:             $cucourseid%$cudom);
                   3460: }
                   3461: 
                   3462: sub receipt {
1.260     ng       3463:   my ($symb,$courseid,$domain,$name) = &Apache::lonxml::whichuser();
                   3464:   return &ireceipt($name,$domain,$courseid,$symb);
1.76      www      3465: }
1.260     ng       3466: 
1.36      albertel 3467: # ------------------------------------------------------------ Serves up a file
                   3468: # returns either the contents of the file or a -1
                   3469: sub getfile {
1.269     www      3470:  my $file=shift;
                   3471:  if ($file=~/^\/*uploaded\//) { # user file
                   3472:     my $ua=new LWP::UserAgent;
                   3473:     my $request=new HTTP::Request('GET',&tokenwrapper($file));
                   3474:     my $response=$ua->request($request);
                   3475:     if ($response->is_success()) {
                   3476:        return $response->content;
                   3477:     } else { 
                   3478:        return -1; 
                   3479:     }
                   3480:  } else { # normal file from res space
1.37      www      3481:   &repcopy($file);
1.36      albertel 3482:   if (! -e $file ) { return -1; };
                   3483:   my $fh=Apache::File->new($file);
                   3484:   my $a='';
                   3485:   while (<$fh>) { $a .=$_; }
1.269     www      3486:   return $a;
                   3487:  }
1.36      albertel 3488: }
                   3489: 
                   3490: sub filelocation {
                   3491:   my ($dir,$file) = @_;
                   3492:   my $location;
                   3493:   $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces
1.59      albertel 3494:   if ($file=~m:^/~:) { # is a contruction space reference
                   3495:     $location = $file;
                   3496:     $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;
1.270     www      3497:   } elsif ($file=~/^\/*uploaded/) { # is an uploaded file
                   3498:     $location=$file;
1.36      albertel 3499:   } else {
1.59      albertel 3500:     $file=~s/^$perlvar{'lonDocRoot'}//;
                   3501:     $file=~s:^/*res::;
                   3502:     if ( !( $file =~ m:^/:) ) {
                   3503:       $location = $dir. '/'.$file;
                   3504:     } else {
                   3505:       $location = '/home/httpd/html/res'.$file;
                   3506:     }
1.36      albertel 3507:   }
                   3508:   $location=~s://+:/:g; # remove duplicate /
1.46      www      3509:   while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..
                   3510:   return $location;
                   3511: }
1.36      albertel 3512: 
1.46      www      3513: sub hreflocation {
                   3514:     my ($dir,$file)=@_;
1.191     harris41 3515:     unless (($file=~/^http:\/\//i) || ($file=~/^\//)) {
1.46      www      3516:        my $finalpath=filelocation($dir,$file);
                   3517:        $finalpath=~s/^\/home\/httpd\/html//;
1.225     albertel 3518:        $finalpath=~s-/home/(\w+)/public_html/-/~$1/-;
1.46      www      3519:        return $finalpath;
                   3520:     } else {
                   3521:        return $file;
                   3522:     }
1.31      www      3523: }
                   3524: 
                   3525: # ------------------------------------------------------------- Declutters URLs
                   3526: 
                   3527: sub declutter {
                   3528:     my $thisfn=shift;
                   3529:     $thisfn=~s/^$perlvar{'lonDocRoot'}//;
                   3530:     $thisfn=~s/^\///;
                   3531:     $thisfn=~s/^res\///;
1.235     www      3532:     $thisfn=~s/\?.+$//;
1.268     www      3533:     return $thisfn;
                   3534: }
                   3535: 
                   3536: # ------------------------------------------------------------- Clutter up URLs
                   3537: 
                   3538: sub clutter {
                   3539:     my $thisfn='/'.&declutter(shift);
1.270     www      3540:     unless ($thisfn=~/^\/(uploaded|adm|userfiles|ext|raw|priv)\//) { 
                   3541:        $thisfn='/res'.$thisfn; 
                   3542:     }
1.31      www      3543:     return $thisfn;
1.12      www      3544: }
                   3545: 
                   3546: # -------------------------------------------------------- Escape Special Chars
                   3547: 
                   3548: sub escape {
                   3549:     my $str=shift;
                   3550:     $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
                   3551:     return $str;
                   3552: }
                   3553: 
                   3554: # ----------------------------------------------------- Un-Escape Special Chars
                   3555: 
                   3556: sub unescape {
                   3557:     my $str=shift;
                   3558:     $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
                   3559:     return $str;
                   3560: }
1.11      www      3561: 
1.1       albertel 3562: # ================================================================ Main Program
                   3563: 
1.184     www      3564: sub goodbye {
1.204     albertel 3565:    &logthis("Starting Shut down");
1.184     www      3566:    &flushcourselogs();
                   3567:    &logthis("Shutting down");
                   3568: }
                   3569: 
1.179     www      3570: BEGIN {
1.228     harris41 3571: # ----------------------------------- Read loncapa.conf and loncapa_apache.conf
1.195     www      3572:     unless ($readit) {
1.217     harris41 3573: {
                   3574:     my $config=Apache::File->new("/etc/httpd/conf/loncapa.conf");
                   3575: 
                   3576:     while (my $configline=<$config>) {
                   3577:         if ($configline =~ /^[^\#]*PerlSetVar/) {
1.1       albertel 3578: 	   my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
1.8       www      3579:            chomp($varvalue);
1.1       albertel 3580:            $perlvar{$varname}=$varvalue;
                   3581:         }
                   3582:     }
                   3583: }
1.227     harris41 3584: {
                   3585:     my $config=Apache::File->new("/etc/httpd/conf/loncapa_apache.conf");
                   3586: 
                   3587:     while (my $configline=<$config>) {
                   3588:         if ($configline =~ /^[^\#]*PerlSetVar/) {
                   3589: 	   my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
                   3590:            chomp($varvalue);
                   3591:            $perlvar{$varname}=$varvalue;
                   3592:         }
                   3593:     }
                   3594: }
1.1       albertel 3595: 
1.327     albertel 3596: # ------------------------------------------------------------ Read domain file
                   3597: {
                   3598:     my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.
                   3599:                             '/domain.tab');
                   3600:     %domaindescription = ();
                   3601:     %domain_auth_def = ();
                   3602:     %domain_auth_arg_def = ();
                   3603:     if ($fh) {
                   3604:        while (<$fh>) {
                   3605:            next if /^\#/;
                   3606:            chomp;
                   3607:            my ($domain, $domain_description, $def_auth, $def_auth_arg)
                   3608:                = split(/:/,$_,4);
                   3609:            $domain_auth_def{$domain}=$def_auth;
                   3610:            $domain_auth_arg_def{$domain}=$def_auth_arg;
                   3611:            $domaindescription{$domain}=$domain_description;
                   3612: #          &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}");
                   3613: #          &logthis("Domain.tab: $domain ".$domaindescription{$domain} );
                   3614:        }
                   3615:     }
                   3616: }
                   3617: 
                   3618: 
1.1       albertel 3619: # ------------------------------------------------------------- Read hosts file
                   3620: {
                   3621:     my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab");
                   3622: 
                   3623:     while (my $configline=<$config>) {
1.303     matthew  3624:        next if ($configline =~ /^(\#|\s*$)/);
1.154     www      3625:        chomp($configline);
1.245     www      3626:        my ($id,$domain,$role,$name,$ip,$domdescr)=split(/:/,$configline);
1.252     albertel 3627:        if ($id && $domain && $role && $name && $ip) {
                   3628: 	 $hostname{$id}=$name;
                   3629: 	 $hostdom{$id}=$domain;
                   3630: 	 $hostip{$id}=$ip;
1.300     albertel 3631: 	 $iphost{$ip}=$id;
1.252     albertel 3632: 	 if ($role eq 'library') { $libserv{$id}=$name; }
                   3633:        } else {
                   3634: 	 if ($configline) {
                   3635: 	   &logthis("Skipping hosts.tab line -$configline-");
                   3636: 	 }
1.245     www      3637:        }
1.1       albertel 3638:     }
                   3639: }
                   3640: 
                   3641: # ------------------------------------------------------ Read spare server file
                   3642: {
                   3643:     my $config=Apache::File->new("$perlvar{'lonTabDir'}/spare.tab");
                   3644: 
                   3645:     while (my $configline=<$config>) {
                   3646:        chomp($configline);
1.284     matthew  3647:        if ($configline) {
1.1       albertel 3648:           $spareid{$configline}=1;
                   3649:        }
                   3650:     }
                   3651: }
1.11      www      3652: # ------------------------------------------------------------ Read permissions
                   3653: {
                   3654:     my $config=Apache::File->new("$perlvar{'lonTabDir'}/roles.tab");
                   3655: 
                   3656:     while (my $configline=<$config>) {
                   3657:        chomp($configline);
1.160     www      3658:       if ($configline) {
1.11      www      3659:        my ($role,$perm)=split(/ /,$configline);
                   3660:        if ($perm ne '') { $pr{$role}=$perm; }
1.160     www      3661:       }
1.11      www      3662:     }
                   3663: }
                   3664: 
                   3665: # -------------------------------------------- Read plain texts for permissions
                   3666: {
                   3667:     my $config=Apache::File->new("$perlvar{'lonTabDir'}/rolesplain.tab");
                   3668: 
                   3669:     while (my $configline=<$config>) {
                   3670:        chomp($configline);
1.160     www      3671:       if ($configline) {
1.11      www      3672:        my ($short,$plain)=split(/:/,$configline);
                   3673:        if ($plain ne '') { $prp{$short}=$plain; }
1.160     www      3674:       }
1.135     www      3675:     }
                   3676: }
                   3677: 
                   3678: # ---------------------------------------------------------- Read package table
                   3679: {
                   3680:     my $config=Apache::File->new("$perlvar{'lonTabDir'}/packages.tab");
                   3681: 
                   3682:     while (my $configline=<$config>) {
                   3683:        chomp($configline);
                   3684:        my ($short,$plain)=split(/:/,$configline);
1.143     www      3685:        my ($pack,$name)=split(/\&/,$short);
                   3686:        if ($plain ne '') {
                   3687:           $packagetab{$pack.'&'.$name.'&name'}=$name; 
                   3688:           $packagetab{$short}=$plain; 
1.25      www      3689:        }
1.11      www      3690:     }
1.329     matthew  3691: }
                   3692: 
                   3693: # ------------- set up temporary directory
                   3694: {
                   3695:     $tmpdir = $perlvar{'lonDaemons'}.'/tmp/';
                   3696: 
1.11      www      3697: }
                   3698: 
1.71      www      3699: %metacache=();
1.185     www      3700: 
1.281     www      3701: $processmarker='_'.time.'_'.$perlvar{'lonHostID'};
1.186     www      3702: $dumpcount=0;
1.22      www      3703: 
1.163     harris41 3704: &logtouch();
1.12      www      3705: &logthis('<font color=yellow>INFO: Read configuration</font>');
1.195     www      3706: $readit=1;
                   3707: }
1.1       albertel 3708: }
1.179     www      3709: 
1.1       albertel 3710: 1;
1.191     harris41 3711: __END__
                   3712: 
1.243     albertel 3713: =pod
                   3714: 
1.191     harris41 3715: =head1 NAME
                   3716: 
1.243     albertel 3717: Apache::lonnet - Subroutines to ask questions about things in the network.
1.191     harris41 3718: 
                   3719: =head1 SYNOPSIS
                   3720: 
1.243     albertel 3721: Invoked by other LON-CAPA modules, when they need to talk to or about objects in the network.
1.191     harris41 3722: 
                   3723:  &Apache::lonnet::SUBROUTINENAME(ARGUMENTS);
                   3724: 
1.243     albertel 3725: Common parameters:
                   3726: 
                   3727: =over 4
                   3728: 
                   3729: =item *
                   3730: 
                   3731: $uname : an internal username (if $cname expecting a course Id specifically)
                   3732: 
                   3733: =item *
                   3734: 
                   3735: $udom : a domain (if $cdom expecting a course's domain specifically)
                   3736: 
                   3737: =item *
                   3738: 
                   3739: $symb : a resource instance identifier
                   3740: 
                   3741: =item *
                   3742: 
                   3743: $namespace : the name of a .db file that contains the data needed or
                   3744: being set.
                   3745: 
                   3746: =back
                   3747: 
1.191     harris41 3748: =head1 INTRODUCTION
                   3749: 
                   3750: This module provides subroutines which interact with the
1.243     albertel 3751: lonc/lond (TCP) network layer of LON-CAPA. And Can be used to ask about 
                   3752: - classes
                   3753: - users 
                   3754: - resources
                   3755: 
                   3756: For many of these objects you can also use this to store data about
                   3757: them or modify them in various ways.
1.191     harris41 3758: 
                   3759: This is part of the LearningOnline Network with CAPA project
                   3760: described at http://www.lon-capa.org.
                   3761: 
1.243     albertel 3762: =head1 RETURN MESSAGES
1.191     harris41 3763: 
                   3764: =over 4
                   3765: 
                   3766: =item *
                   3767: 
1.243     albertel 3768: con_lost : unable to contact remote host
1.191     harris41 3769: 
                   3770: =item *
                   3771: 
1.243     albertel 3772: con_delayed : unable to contact remote host, message will be delivered
                   3773: when the connection is brought back up
1.191     harris41 3774: 
                   3775: =item *
                   3776: 
1.243     albertel 3777: con_failed : unable to contact remote host and unable to save message
                   3778: for later delivery
1.191     harris41 3779: 
                   3780: =item *
                   3781: 
1.243     albertel 3782: error: : an error a occured, a description of the error follows the :
1.191     harris41 3783: 
                   3784: =item *
                   3785: 
1.243     albertel 3786: no_such_host : unable to fund a host associated with the user/domain
                   3787: that was requested
1.191     harris41 3788: 
1.243     albertel 3789: =back
1.191     harris41 3790: 
1.243     albertel 3791: =head1 PUBLIC SUBROUTINES
1.191     harris41 3792: 
1.243     albertel 3793: =head2 Session Environment Functions
1.191     harris41 3794: 
1.243     albertel 3795: =over 4
1.191     harris41 3796: 
                   3797: =item *
                   3798: 
1.243     albertel 3799: appenv(%hash) : the value of %hash is written to the user envirnoment
                   3800: file, and will be restored for each access this user makes during this
                   3801: session, also modifies the %ENV for the current process
1.191     harris41 3802: 
                   3803: =item *
                   3804: 
1.243     albertel 3805: delenv($regexp) : removes all items from the session environment file that matches the regular expression in $regexp. The values are also delted from the current processes %ENV.
1.191     harris41 3806: 
1.243     albertel 3807: =back
                   3808: 
                   3809: =head2 User Information
1.191     harris41 3810: 
1.243     albertel 3811: =over 4
1.191     harris41 3812: 
                   3813: =item *
                   3814: 
                   3815: queryauthenticate($uname,$udom) : try to determine user's current
                   3816: authentication scheme
                   3817: 
                   3818: =item *
                   3819: 
                   3820: authenticate($uname,$upass,$udom) : try to authenticate user from domain's lib
1.243     albertel 3821: servers (first use the current one), $upass should be the users password
1.191     harris41 3822: 
                   3823: =item *
                   3824: 
1.243     albertel 3825: homeserver($uname,$udom) : find the server which has the user's
                   3826: directory and files (there must be only one), this caches the answer,
                   3827: and also caches if there is a borken connection.
1.191     harris41 3828: 
                   3829: =item *
                   3830: 
1.243     albertel 3831: idget($udom,@ids) : find the usernames behind a list of IDs (IDs are a
                   3832: unique resource in a domain, there must be only 1 ID per username, and
                   3833: only 1 username per ID in a specific domain) (returns hash:
1.191     harris41 3834: id=>name,id=>name)
                   3835: 
                   3836: =item *
                   3837: 
                   3838: idrget($udom,@unames) : find the IDs behind a list of usernames (returns hash:
                   3839: name=>id,name=>id)
                   3840: 
                   3841: =item *
                   3842: 
                   3843: idput($udom,%ids) : store away a list of names and associated IDs
                   3844: 
                   3845: =item *
                   3846: 
1.243     albertel 3847: rolesinit($udom,$username,$authhost) : get user privileges
                   3848: 
                   3849: =item *
                   3850: 
                   3851: usection($udom,$uname,$cname) : finds the section of student in the
                   3852: course $cname, return section name/number or '' for "not in course"
                   3853: and '-1' for "no section"
                   3854: 
                   3855: =item *
                   3856: 
                   3857: userenvironment($udom,$uname,@what) : gets the values of the keys
                   3858: passed in @what from the requested user's environment, returns a hash
                   3859: 
                   3860: =back
                   3861: 
                   3862: =head2 User Roles
                   3863: 
                   3864: =over 4
                   3865: 
                   3866: =item *
                   3867: 
                   3868: allowed($priv,$uri) : check for a user privilege; returns codes for allowed
                   3869: actions
                   3870:  F: full access
                   3871:  U,I,K: authentication modes (cxx only)
                   3872:  '': forbidden
                   3873:  1: user needs to choose course
                   3874:  2: browse allowed
                   3875: 
                   3876: =item *
                   3877: 
                   3878: definerole($rolename,$sysrole,$domrole,$courole) : define role; define a custom
                   3879: role rolename set privileges in format of lonTabs/roles.tab for system, domain,
                   3880: and course level
                   3881: 
                   3882: =item *
                   3883: 
                   3884: plaintext($short) : return value in %prp hash (rolesplain.tab); plain text
                   3885: explanation of a user role term
                   3886: 
                   3887: =back
                   3888: 
                   3889: =head2 User Modification
                   3890: 
                   3891: =over 4
                   3892: 
                   3893: =item *
                   3894: 
                   3895: assignrole($udom,$uname,$url,$role,$end,$start) : assign role; give a role to a
                   3896: user for the level given by URL.  Optional start and end dates (leave empty
                   3897: string or zero for "no date")
1.191     harris41 3898: 
                   3899: =item *
                   3900: 
1.243     albertel 3901: changepass($uname,$udom,$currentpass,$newpass,$server) : attempts to
                   3902: change a users, password, possible return values are: ok,
                   3903: pwchange_failure, non_authorized, auth_mode_error, unknown_user,
                   3904: refused
1.191     harris41 3905: 
                   3906: =item *
                   3907: 
1.243     albertel 3908: modifyuserauth($udom,$uname,$umode,$upass) : modify user authentication
1.191     harris41 3909: 
                   3910: =item *
                   3911: 
1.243     albertel 3912: modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene) : 
                   3913: modify user
1.191     harris41 3914: 
                   3915: =item *
                   3916: 
1.286     matthew  3917: modifystudent
                   3918: 
                   3919: modify a students enrollment and identification information.
                   3920: The course id is resolved based on the current users environment.  
                   3921: This means the envoking user must be a course coordinator or otherwise
                   3922: associated with a course.
                   3923: 
1.297     matthew  3924: This call is essentially a wrapper for lonnet::modifyuser and
                   3925: lonnet::modify_student_enrollment
1.286     matthew  3926: 
                   3927: Inputs: 
                   3928: 
                   3929: =over 4
                   3930: 
                   3931: =item B<$udom> Students loncapa domain
                   3932: 
                   3933: =item B<$uname> Students loncapa login name
                   3934: 
                   3935: =item B<$uid> Students id/student number
                   3936: 
                   3937: =item B<$umode> Students authentication mode
                   3938: 
                   3939: =item B<$upass> Students password
                   3940: 
                   3941: =item B<$first> Students first name
                   3942: 
                   3943: =item B<$middle> Students middle name
                   3944: 
                   3945: =item B<$last> Students last name
                   3946: 
                   3947: =item B<$gene> Students generation
                   3948: 
                   3949: =item B<$usec> Students section in course
                   3950: 
                   3951: =item B<$end> Unix time of the roles expiration
                   3952: 
                   3953: =item B<$start> Unix time of the roles start date
                   3954: 
                   3955: =item B<$forceid> If defined, allow $uid to be changed
                   3956: 
                   3957: =item B<$desiredhome> server to use as home server for student
                   3958: 
                   3959: =back
1.297     matthew  3960: 
                   3961: =item *
                   3962: 
                   3963: modify_student_enrollment
                   3964: 
                   3965: Change a students enrollment status in a class.  The environment variable
                   3966: 'role.request.course' must be defined for this function to proceed.
                   3967: 
                   3968: Inputs:
                   3969: 
                   3970: =over 4
                   3971: 
                   3972: =item $udom, students domain
                   3973: 
                   3974: =item $uname, students name
                   3975: 
                   3976: =item $uid, students user id
                   3977: 
                   3978: =item $first, students first name
                   3979: 
                   3980: =item $middle
                   3981: 
                   3982: =item $last
                   3983: 
                   3984: =item $gene
                   3985: 
                   3986: =item $usec
                   3987: 
                   3988: =item $end
                   3989: 
                   3990: =item $start
                   3991: 
                   3992: =back
                   3993: 
1.191     harris41 3994: 
                   3995: =item *
                   3996: 
1.243     albertel 3997: assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start) : assign
                   3998: custom role; give a custom role to a user for the level given by URL.  Specify
                   3999: name and domain of role author, and role name
1.191     harris41 4000: 
                   4001: =item *
                   4002: 
1.243     albertel 4003: revokerole($udom,$uname,$url,$role) : revoke a role for url
1.191     harris41 4004: 
                   4005: =item *
                   4006: 
1.243     albertel 4007: revokecustomrole($udom,$uname,$url,$role) : revoke a custom role
                   4008: 
                   4009: =back
                   4010: 
                   4011: =head2 Course Infomation
                   4012: 
                   4013: =over 4
1.191     harris41 4014: 
                   4015: =item *
                   4016: 
1.243     albertel 4017: coursedescription($courseid) : course description
1.191     harris41 4018: 
                   4019: =item *
                   4020: 
1.243     albertel 4021: courseresdata($coursenum,$coursedomain,@which) : request for current
                   4022: parameter setting for a specific course, @what should be a list of
                   4023: parameters to ask about. This routine caches answers for 5 minutes.
                   4024: 
                   4025: =back
                   4026: 
                   4027: =head2 Course Modification
                   4028: 
                   4029: =over 4
1.191     harris41 4030: 
                   4031: =item *
                   4032: 
1.243     albertel 4033: writecoursepref($courseid,%prefs) : write preferences (environment
                   4034: database) for a course
1.191     harris41 4035: 
                   4036: =item *
                   4037: 
1.243     albertel 4038: createcourse($udom,$description,$url) : make/modify course
                   4039: 
                   4040: =back
                   4041: 
                   4042: =head2 Resource Subroutines
                   4043: 
                   4044: =over 4
1.191     harris41 4045: 
                   4046: =item *
                   4047: 
1.243     albertel 4048: subscribe($fname) : subscribe to a resource, returns URL if possible (probably should use repcopy instead)
1.191     harris41 4049: 
                   4050: =item *
                   4051: 
1.243     albertel 4052: repcopy($filename) : subscribes to the requested file, and attempts to
                   4053: replicate from the owning library server, Might return
                   4054: HTTP_SERVICE_UNAVAILABLE, HTTP_NOT_FOUND, FORBIDDEN, OK, or
                   4055: HTTP_BAD_REQUEST, also attempts to grab the metadata for the
                   4056: resource. Expects the local filesystem pathname
                   4057: (/home/httpd/html/res/....)
                   4058: 
                   4059: =back
                   4060: 
                   4061: =head2 Resource Information
                   4062: 
                   4063: =over 4
1.191     harris41 4064: 
                   4065: =item *
                   4066: 
1.243     albertel 4067: EXT($varname,$symb,$udom,$uname) : evaluates and returns the value of
                   4068: a vairety of different possible values, $varname should be a request
                   4069: string, and the other parameters can be used to specify who and what
                   4070: one is asking about.
                   4071: 
                   4072: Possible values for $varname are environment.lastname (or other item
                   4073: from the envirnment hash), user.name (or someother aspect about the
                   4074: user), resource.0.maxtries (or some other part and parameter of a
                   4075: resource)
1.204     albertel 4076: 
                   4077: =item *
                   4078: 
1.243     albertel 4079: directcondval($number) : get current value of a condition; reads from a state
                   4080: string
1.204     albertel 4081: 
                   4082: =item *
                   4083: 
1.243     albertel 4084: condval($condidx) : value of condition index based on state
1.204     albertel 4085: 
                   4086: =item *
                   4087: 
1.243     albertel 4088: metadata($uri,$what,$liburi,$prefix,$depthcount) : request a
                   4089: resource's metadata, $what should be either a specific key, or either
                   4090: 'keys' (to get a list of possible keys) or 'packages' to get a list of
                   4091: packages that this resource currently uses, the last 3 arguments are only used internally for recursive metadata.
                   4092: 
                   4093: this function automatically caches all requests
1.191     harris41 4094: 
                   4095: =item *
                   4096: 
1.243     albertel 4097: metadata_query($query,$custom,$customshow) : make a metadata query against the
                   4098: network of library servers; returns file handle of where SQL and regex results
                   4099: will be stored for query
1.191     harris41 4100: 
                   4101: =item *
                   4102: 
1.243     albertel 4103: symbread($filename) : return symbolic list entry (filename argument optional);
                   4104: returns the data handle
1.191     harris41 4105: 
                   4106: =item *
                   4107: 
1.243     albertel 4108: symbverify($symb,$thisfn) : verifies that $symb actually exists and is
                   4109: a possible symb for the URL in $thisfn, returns a 1 on success, 0 on
                   4110: failure, user must be in a course, as it assumes the existance of the
                   4111: course initi hash, and uses $ENV('request.course.id'}
                   4112: 
1.191     harris41 4113: 
                   4114: =item *
                   4115: 
1.243     albertel 4116: symbclean($symb) : removes versions numbers from a symb, returns the
                   4117: cleaned symb
1.191     harris41 4118: 
                   4119: =item *
                   4120: 
1.243     albertel 4121: is_on_map($uri) : checks if the $uri is somewhere on the current
                   4122: course map, user must be in a course for it to work.
1.191     harris41 4123: 
                   4124: =item *
                   4125: 
1.243     albertel 4126: numval($salt) : return random seed value (addend for rndseed)
1.191     harris41 4127: 
                   4128: =item *
                   4129: 
1.243     albertel 4130: rndseed($symb,$courseid,$udom,$uname) : create a random sum; returns
                   4131: a random seed, all arguments are optional, if they aren't sent it uses the
                   4132: environment to derive them. Note: if symb isn't sent and it can't get one
                   4133: from &symbread it will use the current time as its return value
1.191     harris41 4134: 
                   4135: =item *
                   4136: 
1.243     albertel 4137: ireceipt($funame,$fudom,$fucourseid,$fusymb) : return unique,
                   4138: unfakeable, receipt
1.191     harris41 4139: 
                   4140: =item *
                   4141: 
1.243     albertel 4142: receipt() : API to ireceipt working off of ENV values; given out to users
1.191     harris41 4143: 
                   4144: =item *
                   4145: 
1.243     albertel 4146: countacc($url) : count the number of accesses to a given URL
1.191     harris41 4147: 
                   4148: =item *
                   4149: 
1.243     albertel 4150: 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 4151: 
                   4152: =item *
                   4153: 
1.243     albertel 4154: 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 4155: 
                   4156: =item *
                   4157: 
1.243     albertel 4158: expirespread($uname,$udom,$stype,$usymb) : set expire date for spreadsheet
1.191     harris41 4159: 
                   4160: =item *
                   4161: 
1.243     albertel 4162: devalidate($symb) : devalidate temporary spreadsheet calculations,
                   4163: forcing spreadsheet to reevaluate the resource scores next time.
                   4164: 
                   4165: =back
                   4166: 
                   4167: =head2 Storing/Retreiving Data
                   4168: 
                   4169: =over 4
1.191     harris41 4170: 
                   4171: =item *
                   4172: 
1.243     albertel 4173: store($storehash,$symb,$namespace,$udom,$uname) : stores hash permanently
                   4174: for this url; hashref needs to be given and should be a \%hashname; the
                   4175: remaining args aren't required and if they aren't passed or are '' they will
                   4176: be derived from the ENV
1.191     harris41 4177: 
                   4178: =item *
                   4179: 
1.243     albertel 4180: cstore($storehash,$symb,$namespace,$udom,$uname) : same as store but
                   4181: uses critical subroutine
1.191     harris41 4182: 
                   4183: =item *
                   4184: 
1.243     albertel 4185: restore($symb,$namespace,$udom,$uname) : returns hash for this symb;
                   4186: all args are optional
1.191     harris41 4187: 
                   4188: =item *
                   4189: 
1.243     albertel 4190: tmpstore($storehash,$symb,$namespace,$udom,$uname) : storage that
                   4191: works very similar to store/cstore, but all data is stored in a
                   4192: temporary location and can be reset using tmpreset, $storehash should
                   4193: be a hash reference, returns nothing on success
1.191     harris41 4194: 
                   4195: =item *
                   4196: 
1.243     albertel 4197: tmprestore($symb,$namespace,$udom,$uname) : storage that works very
                   4198: similar to restore, but all data is stored in a temporary location and
                   4199: can be reset using tmpreset. Returns a hash of values on success,
                   4200: error string otherwise.
1.191     harris41 4201: 
                   4202: =item *
                   4203: 
1.243     albertel 4204: tmpreset($symb,$namespace,$udom,$uname) : temporary storage reset,
                   4205: deltes all keys for $symb form the temporary storage hash.
1.191     harris41 4206: 
                   4207: =item *
                   4208: 
1.243     albertel 4209: get($namespace,$storearr,$udom,$uname) : returns hash with keys from array
                   4210: reference filled in from namesp ($udom and $uname are optional)
1.191     harris41 4211: 
                   4212: =item *
                   4213: 
1.243     albertel 4214: del($namespace,$storearr,$udom,$uname) : deletes keys out of array from
                   4215: namesp ($udom and $uname are optional)
1.191     harris41 4216: 
                   4217: =item *
                   4218: 
1.243     albertel 4219: dump($namespace,$udom,$uname,$regexp) : 
                   4220: dumps the complete (or key matching regexp) namespace into a hash
                   4221: ($udom, $uname and $regexp are optional)
1.191     harris41 4222: 
                   4223: =item *
                   4224: 
1.243     albertel 4225: put($namespace,$storehash,$udom,$uname) : stores hash in namesp
                   4226: ($udom and $uname are optional)
1.191     harris41 4227: 
                   4228: =item *
                   4229: 
1.243     albertel 4230: cput($namespace,$storehash,$udom,$uname) : critical put
                   4231: ($udom and $uname are optional)
1.191     harris41 4232: 
                   4233: =item *
                   4234: 
1.243     albertel 4235: eget($namespace,$storearr,$udom,$uname) : returns hash with keys from array
                   4236: reference filled in from namesp (encrypts the return communication)
                   4237: ($udom and $uname are optional)
1.191     harris41 4238: 
                   4239: =item *
                   4240: 
1.243     albertel 4241: log($udom,$name,$home,$message) : write to permanent log for user; use
                   4242: critical subroutine
                   4243: 
                   4244: =back
                   4245: 
                   4246: =head2 Network Status Functions
                   4247: 
                   4248: =over 4
1.191     harris41 4249: 
                   4250: =item *
                   4251: 
                   4252: dirlist($uri) : return directory list based on URI
                   4253: 
                   4254: =item *
                   4255: 
1.243     albertel 4256: spareserver() : find server with least workload from spare.tab
                   4257: 
                   4258: =back
                   4259: 
                   4260: =head2 Apache Request
                   4261: 
                   4262: =over 4
1.191     harris41 4263: 
                   4264: =item *
                   4265: 
1.243     albertel 4266: ssi($url,%hash) : server side include, does a complete request cycle on url to
                   4267: localhost, posts hash
                   4268: 
                   4269: =back
                   4270: 
                   4271: =head2 Data to String to Data
                   4272: 
                   4273: =over 4
1.191     harris41 4274: 
                   4275: =item *
                   4276: 
1.243     albertel 4277: hash2str(%hash) : convert a hash into a string complete with escaping and '='
                   4278: and '&' separators, supports elements that are arrayrefs and hashrefs
1.191     harris41 4279: 
                   4280: =item *
                   4281: 
1.243     albertel 4282: hashref2str($hashref) : convert a hashref into a string complete with
                   4283: escaping and '=' and '&' separators, supports elements that are
                   4284: arrayrefs and hashrefs
1.191     harris41 4285: 
                   4286: =item *
                   4287: 
1.243     albertel 4288: arrayref2str($arrayref) : convert an arrayref into a string complete
                   4289: with escaping and '&' separators, supports elements that are arrayrefs
                   4290: and hashrefs
1.191     harris41 4291: 
                   4292: =item *
                   4293: 
1.243     albertel 4294: str2hash($string) : convert string to hash using unescaping and
                   4295: splitting on '=' and '&', supports elements that are arrayrefs and
                   4296: hashrefs
1.191     harris41 4297: 
                   4298: =item *
                   4299: 
1.243     albertel 4300: str2array($string) : convert string to hash using unescaping and
                   4301: splitting on '&', supports elements that are arrayrefs and hashrefs
                   4302: 
                   4303: =back
                   4304: 
                   4305: =head2 Logging Routines
                   4306: 
                   4307: =over 4
                   4308: 
                   4309: These routines allow one to make log messages in the lonnet.log and
                   4310: lonnet.perm logfiles.
1.191     harris41 4311: 
                   4312: =item *
                   4313: 
1.243     albertel 4314: logtouch() : make sure the logfile, lonnet.log, exists
1.191     harris41 4315: 
                   4316: =item *
                   4317: 
1.243     albertel 4318: logthis() : append message to the normal lonnet.log file, it gets
                   4319: preiodically rolled over and deleted.
1.191     harris41 4320: 
                   4321: =item *
                   4322: 
1.243     albertel 4323: logperm() : append a permanent message to lonnet.perm.log, this log
                   4324: file never gets deleted by any automated portion of the system, only
                   4325: messages of critical importance should go in here.
                   4326: 
                   4327: =back
                   4328: 
                   4329: =head2 General File Helper Routines
                   4330: 
                   4331: =over 4
1.191     harris41 4332: 
                   4333: =item *
                   4334: 
1.243     albertel 4335: getfile($file) : returns the entire contents of a file or -1; it
                   4336: properly subscribes to and replicates the file if neccessary.
1.191     harris41 4337: 
                   4338: =item *
                   4339: 
1.243     albertel 4340: filelocation($dir,$file) : returns file system location of a file
                   4341: based on URI; meant to be "fairly clean" absolute reference, $dir is a
                   4342: directory that relative $file lookups are to looked in ($dir of /a/dir
                   4343: and a file of ../bob will become /a/bob)
1.191     harris41 4344: 
                   4345: =item *
                   4346: 
                   4347: hreflocation($dir,$file) : returns file system location or a URL; same as
                   4348: filelocation except for hrefs
                   4349: 
                   4350: =item *
                   4351: 
                   4352: declutter() : declutters URLs (remove docroot, beginning slashes, 'res' etc)
                   4353: 
1.243     albertel 4354: =back
                   4355: 
                   4356: =head2 HTTP Helper Routines
                   4357: 
                   4358: =over 4
                   4359: 
1.191     harris41 4360: =item *
                   4361: 
                   4362: escape() : unpack non-word characters into CGI-compatible hex codes
                   4363: 
                   4364: =item *
                   4365: 
                   4366: unescape() : pack CGI-compatible hex codes into actual non-word ASCII character
                   4367: 
1.243     albertel 4368: =back
                   4369: 
                   4370: =head1 PRIVATE SUBROUTINES
                   4371: 
                   4372: =head2 Underlying communication routines (Shouldn't call)
                   4373: 
                   4374: =over 4
                   4375: 
                   4376: =item *
                   4377: 
                   4378: subreply() : tries to pass a message to lonc, returns con_lost if incapable
                   4379: 
                   4380: =item *
                   4381: 
                   4382: reply() : uses subreply to send a message to remote machine, logs all failures
                   4383: 
                   4384: =item *
                   4385: 
                   4386: critical() : passes a critical message to another server; if cannot
                   4387: get through then place message in connection buffer directory and
                   4388: returns con_delayed, if incapable of saving message, returns
                   4389: con_failed
                   4390: 
                   4391: =item *
                   4392: 
                   4393: reconlonc() : tries to reconnect lonc client processes.
                   4394: 
                   4395: =back
                   4396: 
                   4397: =head2 Resource Access Logging
                   4398: 
                   4399: =over 4
                   4400: 
                   4401: =item *
                   4402: 
                   4403: flushcourselogs() : flush (save) buffer logs and access logs
                   4404: 
                   4405: =item *
                   4406: 
                   4407: courselog($what) : save message for course in hash
                   4408: 
                   4409: =item *
                   4410: 
                   4411: courseacclog($what) : save message for course using &courselog().  Perform
                   4412: special processing for specific resource types (problems, exams, quizzes, etc).
                   4413: 
1.191     harris41 4414: =item *
                   4415: 
                   4416: goodbye() : flush course logs and log shutting down; it is called in srm.conf
                   4417: as a PerlChildExitHandler
1.243     albertel 4418: 
                   4419: =back
                   4420: 
                   4421: =head2 Other
                   4422: 
                   4423: =over 4
                   4424: 
                   4425: =item *
                   4426: 
                   4427: symblist($mapname,%newhash) : update symbolic storage links
1.191     harris41 4428: 
                   4429: =back
                   4430: 
                   4431: =cut

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