File:  [LON-CAPA] / loncom / lonnet / perl / lonnet.pm
Revision 1.316: download - view: text, annotated - select for diffs
Fri Jan 10 20:55:44 2003 UTC (21 years, 6 months ago) by www
Branches: MAIN
CVS tags: HEAD
Wonderful ... allow plus and minus in uploaded filenames ... don't know
why it matters, cause nobody is going to see them anyway ...

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

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