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

1.1       albertel    1: # The LearningOnline Network
                      2: # TCP networking package
1.12      www         3: #
1.211   ! www         4: # $Id: lonnet.pm,v 1.210 2002/05/05 01:59:42 www Exp $
1.178     www         5: #
                      6: # Copyright Michigan State University Board of Trustees
                      7: #
                      8: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
                      9: #
                     10: # LON-CAPA is free software; you can redistribute it and/or modify
                     11: # it under the terms of the GNU General Public License as published by
                     12: # the Free Software Foundation; either version 2 of the License, or
                     13: # (at your option) any later version.
                     14: #
                     15: # LON-CAPA is distributed in the hope that it will be useful,
                     16: # but WITHOUT ANY WARRANTY; without even the implied warranty of
                     17: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
                     18: # GNU General Public License for more details.
                     19: #
                     20: # You should have received a copy of the GNU General Public License
                     21: # along with LON-CAPA; if not, write to the Free Software
                     22: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
                     23: #
                     24: # /home/httpd/html/adm/gpl.txt
                     25: #
                     26: # http://www.lon-capa.org/
                     27: #
1.169     harris41   28: # 6/1/99,6/2,6/10,6/11,6/12,6/14,6/26,6/28,6/29,6/30,
                     29: # 7/1,7/2,7/9,7/10,7/12,7/14,7/15,7/19,
                     30: # 11/8,11/16,11/18,11/22,11/23,12/22,
                     31: # 01/06,01/13,02/24,02/28,02/29,
                     32: # 03/01,03/02,03/06,03/07,03/13,
                     33: # 04/05,05/29,05/31,06/01,
                     34: # 06/05,06/26 Gerd Kortemeyer
                     35: # 06/26 Ben Tyszka
                     36: # 06/30,07/15,07/17,07/18,07/20,07/21,07/22,07/25 Gerd Kortemeyer
                     37: # 08/14 Ben Tyszka
                     38: # 08/22,08/28,08/31,09/01,09/02,09/04,09/05,09/25,09/28,09/30 Gerd Kortemeyer
                     39: # 10/04 Gerd Kortemeyer
                     40: # 10/04 Guy Albertelli
                     41: # 10/06,10/09,10/10,10/11,10/14,10/20,10/23,10/25,10/26,10/27,10/28,10/29, 
                     42: # 10/30,10/31,
                     43: # 11/2,11/14,11/15,11/16,11/20,11/21,11/22,11/25,11/27,
                     44: # 12/02,12/12,12/13,12/14,12/28,12/29 Gerd Kortemeyer
                     45: # 05/01/01 Guy Albertelli
                     46: # 05/01,06/01,09/01 Gerd Kortemeyer
                     47: # 09/01 Guy Albertelli
                     48: # 09/01,10/01,11/01 Gerd Kortemeyer
                     49: # YEAR=2001
                     50: # 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
1.179     www        62: # 11/17,11/20,11/22,11/29 Gerd Kortemeyer
1.182     matthew    63: # 12/5 Matthew Hall
1.184     www        64: # 12/5 Guy Albertelli
1.190     www        65: # 12/6,12/7,12/12 Gerd Kortemeyer
1.191     harris41   66: # 12/18 Scott Harrison
1.195     www        67: # 12/21,12/22,12/27,12/28 Gerd Kortemeyer
1.196     www        68: # YEAR=2002
1.200     www        69: # 1/4,2/4,2/7 Gerd Kortemeyer
1.171     www        70: #
1.169     harris41   71: ###
                     72: 
1.1       albertel   73: package Apache::lonnet;
                     74: 
                     75: use strict;
                     76: use Apache::File;
1.8       www        77: use LWP::UserAgent();
1.15      www        78: use HTTP::Headers;
1.11      www        79: use vars 
1.188     www        80: qw(%perlvar %hostname %homecache %hostip %spareid %hostdom 
1.192     www        81:    %libserv %pr %prp %metacache %packagetab 
1.188     www        82:    %courselogs %accesshash $processmarker $dumpcount 
1.200     www        83:    %coursedombuf %coursehombuf %courseresdatacache);
1.1       albertel   84: use IO::Socket;
1.31      www        85: use GDBM_File;
1.8       www        86: use Apache::Constants qw(:common :http);
1.208     albertel   87: use HTML::LCParser;
1.88      www        88: use Fcntl qw(:flock);
1.195     www        89: my $readit;
1.1       albertel   90: 
                     91: # --------------------------------------------------------------------- Logging
                     92: 
1.163     harris41   93: sub logtouch {
                     94:     my $execdir=$perlvar{'lonDaemons'};
                     95:     unless (-e "$execdir/logs/lonnet.log") {
                     96: 	my $fh=Apache::File->new(">>$execdir/logs/lonnet.log");
                     97: 	close $fh;
                     98:     }
                     99:     my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3];
                    100:     chown($wwwuid,$wwwgid,$execdir.'/logs/lonnet.log');
                    101: }
                    102: 
1.1       albertel  103: sub logthis {
                    104:     my $message=shift;
                    105:     my $execdir=$perlvar{'lonDaemons'};
                    106:     my $now=time;
                    107:     my $local=localtime($now);
1.162     harris41  108:     my $fh=Apache::File->new(">>$execdir/logs/lonnet.log");
                    109:     print $fh "$local ($$): $message\n";
1.1       albertel  110:     return 1;
                    111: }
                    112: 
                    113: sub logperm {
                    114:     my $message=shift;
                    115:     my $execdir=$perlvar{'lonDaemons'};
                    116:     my $now=time;
                    117:     my $local=localtime($now);
1.162     harris41  118:     my $fh=Apache::File->new(">>$execdir/logs/lonnet.perm.log");
                    119:     print $fh "$now:$message:$local\n";
1.1       albertel  120:     return 1;
                    121: }
                    122: 
                    123: # -------------------------------------------------- Non-critical communication
                    124: sub subreply {
                    125:     my ($cmd,$server)=@_;
                    126:     my $peerfile="$perlvar{'lonSockDir'}/$server";
                    127:     my $client=IO::Socket::UNIX->new(Peer    =>"$peerfile",
                    128:                                      Type    => SOCK_STREAM,
                    129:                                      Timeout => 10)
                    130:        or return "con_lost";
                    131:     print $client "$cmd\n";
                    132:     my $answer=<$client>;
1.9       www       133:     if (!$answer) { $answer="con_lost"; }
1.1       albertel  134:     chomp($answer);
                    135:     return $answer;
                    136: }
                    137: 
                    138: sub reply {
                    139:     my ($cmd,$server)=@_;
1.205     www       140:     unless (defined($hostname{$server})) { return 'no_such_host'; }
1.1       albertel  141:     my $answer=subreply($cmd,$server);
1.203     www       142:     if ($answer eq 'con_lost') {
                    143:        sleep 5; 
                    144:        $answer=subreply($cmd,$server);
                    145:        if ($answer eq 'con_lost') {
                    146: 	   &logthis("Second attempt con_lost on $server");
                    147:            my $peerfile="$perlvar{'lonSockDir'}/$server";
                    148:            my $client=IO::Socket::UNIX->new(Peer    =>"$peerfile",
                    149:                                             Type    => SOCK_STREAM,
                    150:                                             Timeout => 10)
                    151:                       or return "con_lost";
                    152:            &logthis("Killing socket");
                    153:            print $client "close_connection_exit\n";
                    154:            sleep 5;
                    155:            $answer=subreply($cmd,$server);       
                    156:        }   
                    157:     }
1.65      www       158:     if (($answer=~/^refused/) || ($answer=~/^rejected/)) {
1.12      www       159:        &logthis("<font color=blue>WARNING:".
                    160:                 " $cmd to $server returned $answer</font>");
                    161:     }
1.1       albertel  162:     return $answer;
                    163: }
                    164: 
                    165: # ----------------------------------------------------------- Send USR1 to lonc
                    166: 
                    167: sub reconlonc {
                    168:     my $peerfile=shift;
                    169:     &logthis("Trying to reconnect for $peerfile");
                    170:     my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
                    171:     if (my $fh=Apache::File->new("$loncfile")) {
                    172: 	my $loncpid=<$fh>;
                    173:         chomp($loncpid);
                    174:         if (kill 0 => $loncpid) {
                    175: 	    &logthis("lonc at pid $loncpid responding, sending USR1");
                    176:             kill USR1 => $loncpid;
                    177:             sleep 1;
                    178:             if (-e "$peerfile") { return; }
                    179:             &logthis("$peerfile still not there, give it another try");
                    180:             sleep 5;
                    181:             if (-e "$peerfile") { return; }
1.12      www       182:             &logthis(
                    183:   "<font color=blue>WARNING: $peerfile still not there, giving up</font>");
1.1       albertel  184:         } else {
1.12      www       185: 	    &logthis(
                    186:                "<font color=blue>WARNING:".
                    187:                " lonc at pid $loncpid not responding, giving up</font>");
1.1       albertel  188:         }
                    189:     } else {
1.12      www       190:      &logthis('<font color=blue>WARNING: lonc not running, giving up</font>');
1.1       albertel  191:     }
                    192: }
                    193: 
                    194: # ------------------------------------------------------ Critical communication
1.12      www       195: 
1.1       albertel  196: sub critical {
                    197:     my ($cmd,$server)=@_;
1.89      www       198:     unless ($hostname{$server}) {
                    199:         &logthis("<font color=blue>WARNING:".
                    200:                " Critical message to unknown server ($server)</font>");
                    201:         return 'no_such_host';
                    202:     }
1.1       albertel  203:     my $answer=reply($cmd,$server);
                    204:     if ($answer eq 'con_lost') {
                    205:         my $pingreply=reply('ping',$server);
                    206: 	&reconlonc("$perlvar{'lonSockDir'}/$server");
                    207:         my $pongreply=reply('pong',$server);
                    208:         &logthis("Ping/Pong for $server: $pingreply/$pongreply");
                    209:         $answer=reply($cmd,$server);
                    210:         if ($answer eq 'con_lost') {
                    211:             my $now=time;
                    212:             my $middlename=$cmd;
1.5       www       213:             $middlename=substr($middlename,0,16);
1.1       albertel  214:             $middlename=~s/\W//g;
                    215:             my $dfilename=
                    216:              "$perlvar{'lonSockDir'}/delayed/$now.$middlename.$server";
                    217:             {
                    218:              my $dfh;
                    219:              if ($dfh=Apache::File->new(">$dfilename")) {
1.7       www       220:                 print $dfh "$cmd\n";
1.1       albertel  221: 	     }
                    222:             }
                    223:             sleep 2;
                    224:             my $wcmd='';
                    225:             {
                    226: 	     my $dfh;
                    227:              if ($dfh=Apache::File->new("$dfilename")) {
                    228:                 $wcmd=<$dfh>;
                    229: 	     }
                    230:             }
                    231:             chomp($wcmd);
1.7       www       232:             if ($wcmd eq $cmd) {
1.12      www       233: 		&logthis("<font color=blue>WARNING: ".
                    234:                          "Connection buffer $dfilename: $cmd</font>");
1.1       albertel  235:                 &logperm("D:$server:$cmd");
                    236: 	        return 'con_delayed';
                    237:             } else {
1.12      www       238:                 &logthis("<font color=red>CRITICAL:"
                    239:                         ." Critical connection failed: $server $cmd</font>");
1.1       albertel  240:                 &logperm("F:$server:$cmd");
                    241:                 return 'con_failed';
                    242:             }
                    243:         }
                    244:     }
                    245:     return $answer;
                    246: }
                    247: 
1.5       www       248: # ---------------------------------------------------------- Append Environment
                    249: 
                    250: sub appenv {
1.6       www       251:     my %newenv=@_;
1.191     harris41  252:     foreach (keys %newenv) {
1.35      www       253: 	if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) {
                    254:             &logthis("<font color=blue>WARNING: ".
1.151     www       255:                 "Attempt to modify environment ".$_." to ".$newenv{$_}
                    256:                 .'</font>');
1.35      www       257: 	    delete($newenv{$_});
                    258:         } else {
                    259:             $ENV{$_}=$newenv{$_};
                    260:         }
1.191     harris41  261:     }
1.95      www       262: 
                    263:     my $lockfh;
                    264:     unless ($lockfh=Apache::File->new("$ENV{'user.environment'}")) {
1.97      www       265:        return 'error: '.$!;
1.95      www       266:     }
                    267:     unless (flock($lockfh,LOCK_EX)) {
                    268:          &logthis("<font color=blue>WARNING: ".
                    269:                   'Could not obtain exclusive lock in appenv: '.$!);
                    270:          $lockfh->close();
                    271:          return 'error: '.$!;
                    272:     }
                    273: 
1.6       www       274:     my @oldenv;
                    275:     {
                    276:      my $fh;
                    277:      unless ($fh=Apache::File->new("$ENV{'user.environment'}")) {
1.97      www       278: 	return 'error: '.$!;
1.6       www       279:      }
                    280:      @oldenv=<$fh>;
1.89      www       281:      $fh->close();
1.6       www       282:     }
                    283:     for (my $i=0; $i<=$#oldenv; $i++) {
                    284:         chomp($oldenv[$i]);
1.9       www       285:         if ($oldenv[$i] ne '') {
                    286:            my ($name,$value)=split(/=/,$oldenv[$i]);
1.24      www       287:            unless (defined($newenv{$name})) {
                    288: 	      $newenv{$name}=$value;
                    289: 	   }
1.9       www       290:         }
1.6       www       291:     }
                    292:     {
                    293:      my $fh;
                    294:      unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) {
                    295: 	return 'error';
                    296:      }
                    297:      my $newname;
1.93      www       298:      foreach $newname (keys %newenv) {
1.6       www       299: 	 print $fh "$newname=$newenv{$newname}\n";
                    300:      }
1.86      albertel  301:      $fh->close();
1.56      www       302:     }
1.95      www       303: 
                    304:     $lockfh->close();
1.56      www       305:     return 'ok';
                    306: }
                    307: # ----------------------------------------------------- Delete from Environment
                    308: 
                    309: sub delenv {
                    310:     my $delthis=shift;
                    311:     my %newenv=();
                    312:     if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {
                    313:         &logthis("<font color=blue>WARNING: ".
                    314:                 "Attempt to delete from environment ".$delthis);
                    315:         return 'error';
                    316:     }
                    317:     my @oldenv;
                    318:     {
                    319:      my $fh;
                    320:      unless ($fh=Apache::File->new("$ENV{'user.environment'}")) {
                    321: 	return 'error';
                    322:      }
1.89      www       323:      unless (flock($fh,LOCK_SH)) {
                    324:          &logthis("<font color=blue>WARNING: ".
                    325:                   'Could not obtain shared lock in delenv: '.$!);
                    326:          $fh->close();
                    327:          return 'error: '.$!;
                    328:      }
1.56      www       329:      @oldenv=<$fh>;
1.89      www       330:      $fh->close();
1.56      www       331:     }
                    332:     {
                    333:      my $fh;
                    334:      unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) {
                    335: 	return 'error';
                    336:      }
1.89      www       337:      unless (flock($fh,LOCK_EX)) {
                    338:          &logthis("<font color=blue>WARNING: ".
                    339:                   'Could not obtain exclusive lock in delenv: '.$!);
                    340:          $fh->close();
                    341:          return 'error: '.$!;
                    342:      }
1.191     harris41  343:      foreach (@oldenv) {
1.56      www       344: 	 unless ($_=~/^$delthis/) { print $fh $_; }
1.191     harris41  345:      }
1.87      www       346:      $fh->close();
1.5       www       347:     }
                    348:     return 'ok';
                    349: }
1.1       albertel  350: 
                    351: # ------------------------------ Find server with least workload from spare.tab
1.11      www       352: 
1.1       albertel  353: sub spareserver {
                    354:     my $tryserver;
                    355:     my $spareserver='';
                    356:     my $lowestserver=100;
                    357:     foreach $tryserver (keys %spareid) {
                    358:        my $answer=reply('load',$tryserver);
                    359:        if (($answer =~ /\d/) && ($answer<$lowestserver)) {
                    360: 	   $spareserver="http://$hostname{$tryserver}";
                    361:            $lowestserver=$answer;
                    362:        }
                    363:     }    
                    364:     return $spareserver;
1.202     matthew   365: }
                    366: 
                    367: # --------------------------------------------- Try to change a user's password
                    368: 
                    369: sub changepass {
                    370:     my ($uname,$udom,$currentpass,$newpass,$server)=@_;
                    371:     $currentpass = &escape($currentpass);
                    372:     $newpass     = &escape($newpass);
                    373:     my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass",
                    374: 		       $server);
                    375:     if (! $answer) {
                    376: 	&logthis("No reply on password change request to $server ".
                    377: 		 "by $uname in domain $udom.");
                    378:     } elsif ($answer =~ "^ok") {
                    379:         &logthis("$uname in $udom successfully changed their password ".
                    380: 		 "on $server.");
                    381:     } elsif ($answer =~ "^pwchange_failure") {
                    382: 	&logthis("$uname in $udom was unable to change their password ".
                    383: 		 "on $server.  The action was blocked by either lcpasswd ".
                    384: 		 "or pwchange");
                    385:     } elsif ($answer =~ "^non_authorized") {
                    386:         &logthis("$uname in $udom did not get their password correct when ".
                    387: 		 "attempting to change it on $server.");
                    388:     } elsif ($answer =~ "^auth_mode_error") {
                    389:         &logthis("$uname in $udom attempted to change their password despite ".
                    390: 		 "not being locally or internally authenticated on $server.");
                    391:     } elsif ($answer =~ "^unknown_user") {
                    392:         &logthis("$uname in $udom attempted to change their password ".
                    393: 		 "on $server but were unable to because $server is not ".
                    394: 		 "their home server.");
                    395:     } elsif ($answer =~ "^refused") {
                    396: 	&logthis("$server refused to change $uname in $udom password because ".
                    397: 		 "it was sent an unencrypted request to change the password.");
                    398:     }
                    399:     return $answer;
1.1       albertel  400: }
                    401: 
1.169     harris41  402: # ----------------------- Try to determine user's current authentication scheme
                    403: 
                    404: sub queryauthenticate {
                    405:     my ($uname,$udom)=@_;
                    406:     if (($perlvar{'lonRole'} eq 'library') && 
                    407:         ($udom eq $perlvar{'lonDefDomain'})) {
                    408: 	my $answer=reply("encrypt:currentauth:$udom:$uname",
                    409: 			 $perlvar{'lonHostID'});
                    410: 	unless ($answer eq 'unknown_user' or $answer eq 'refused') {
                    411: 	    if (length($answer)) {
                    412: 		return $answer;
                    413: 	    }
                    414: 	    else {
                    415: 	&logthis("User $uname at $udom lacks an authentication mechanism");
                    416: 		return 'no_host';
                    417: 	    }
                    418: 	}
                    419:     }
                    420: 
                    421:     my $tryserver;
                    422:     foreach $tryserver (keys %libserv) {
                    423: 	if ($hostdom{$tryserver} eq $udom) {
                    424:            my $answer=reply("encrypt:currentauth:$udom:$uname",$tryserver);
                    425: 	   unless ($answer eq 'unknown_user' or $answer eq 'refused') {
                    426: 	       if (length($answer)) {
                    427: 		   return $answer;
                    428: 	       }
                    429: 	       else {
                    430: 	   &logthis("User $uname at $udom lacks an authentication mechanism");
                    431: 		   return 'no_host';
                    432: 	       }
                    433: 	   }
                    434:        }
                    435:     }
                    436:     &logthis("User $uname at $udom lacks an authentication mechanism");    
                    437:     return 'no_host';
                    438: }
                    439: 
1.1       albertel  440: # --------- Try to authenticate user from domain's lib servers (first this one)
1.11      www       441: 
1.1       albertel  442: sub authenticate {
                    443:     my ($uname,$upass,$udom)=@_;
1.12      www       444:     $upass=escape($upass);
1.199     www       445:     $uname=~s/\W//g;
1.1       albertel  446:     if (($perlvar{'lonRole'} eq 'library') && 
                    447:         ($udom eq $perlvar{'lonDefDomain'})) {
1.3       www       448:     my $answer=reply("encrypt:auth:$udom:$uname:$upass",$perlvar{'lonHostID'});
1.2       www       449:         if ($answer =~ /authorized/) {
1.9       www       450:               if ($answer eq 'authorized') {
                    451:                  &logthis("User $uname at $udom authorized by local server"); 
                    452:                  return $perlvar{'lonHostID'}; 
                    453:               }
                    454:               if ($answer eq 'non_authorized') {
                    455:                  &logthis("User $uname at $udom rejected by local server"); 
                    456:                  return 'no_host'; 
                    457:               }
1.2       www       458: 	}
1.1       albertel  459:     }
                    460: 
                    461:     my $tryserver;
                    462:     foreach $tryserver (keys %libserv) {
                    463: 	if ($hostdom{$tryserver} eq $udom) {
1.10      www       464:            my $answer=reply("encrypt:auth:$udom:$uname:$upass",$tryserver);
1.1       albertel  465:            if ($answer =~ /authorized/) {
1.9       www       466:               if ($answer eq 'authorized') {
                    467:                  &logthis("User $uname at $udom authorized by $tryserver"); 
                    468:                  return $tryserver; 
                    469:               }
                    470:               if ($answer eq 'non_authorized') {
                    471:                  &logthis("User $uname at $udom rejected by $tryserver");
                    472:                  return 'no_host';
                    473:               } 
1.1       albertel  474: 	   }
                    475:        }
1.9       www       476:     }
                    477:     &logthis("User $uname at $udom could not be authenticated");    
1.1       albertel  478:     return 'no_host';
                    479: }
                    480: 
                    481: # ---------------------- Find the homebase for a user from domain's lib servers
1.11      www       482: 
1.1       albertel  483: sub homeserver {
                    484:     my ($uname,$udom)=@_;
                    485: 
                    486:     my $index="$uname:$udom";
                    487:     if ($homecache{$index}) { return "$homecache{$index}"; }
                    488: 
                    489:     my $tryserver;
                    490:     foreach $tryserver (keys %libserv) {
                    491: 	if ($hostdom{$tryserver} eq $udom) {
                    492:            my $answer=reply("home:$udom:$uname",$tryserver);
                    493:            if ($answer eq 'found') { 
                    494: 	      $homecache{$index}=$tryserver;
                    495:               return $tryserver; 
                    496: 	   }
                    497:        }
                    498:     }    
                    499:     return 'no_host';
1.70      www       500: }
                    501: 
                    502: # ------------------------------------- Find the usernames behind a list of IDs
                    503: 
                    504: sub idget {
                    505:     my ($udom,@ids)=@_;
                    506:     my %returnhash=();
                    507:     
                    508:     my $tryserver;
                    509:     foreach $tryserver (keys %libserv) {
                    510:        if ($hostdom{$tryserver} eq $udom) {
                    511: 	  my $idlist=join('&',@ids);
                    512:           $idlist=~tr/A-Z/a-z/; 
                    513: 	  my $reply=&reply("idget:$udom:".$idlist,$tryserver);
                    514:           my @answer=();
1.76      www       515:           if (($reply ne 'con_lost') && ($reply!~/^error\:/)) {
1.70      www       516: 	      @answer=split(/\&/,$reply);
                    517:           }                    ;
                    518:           my $i;
                    519:           for ($i=0;$i<=$#ids;$i++) {
                    520:               if ($answer[$i]) {
                    521: 		  $returnhash{$ids[$i]}=$answer[$i];
                    522:               } 
                    523:           }
                    524:        }
                    525:     }    
                    526:     return %returnhash;
                    527: }
                    528: 
                    529: # ------------------------------------- Find the IDs behind a list of usernames
                    530: 
                    531: sub idrget {
                    532:     my ($udom,@unames)=@_;
                    533:     my %returnhash=();
1.191     harris41  534:     foreach (@unames) {
1.70      www       535:         $returnhash{$_}=(&userenvironment($udom,$_,'id'))[1];
1.191     harris41  536:     }
1.70      www       537:     return %returnhash;
                    538: }
                    539: 
                    540: # ------------------------------- Store away a list of names and associated IDs
                    541: 
                    542: sub idput {
                    543:     my ($udom,%ids)=@_;
                    544:     my %servers=();
1.191     harris41  545:     foreach (keys %ids) {
1.70      www       546:         my $uhom=&homeserver($_,$udom);
                    547:         if ($uhom ne 'no_host') {
                    548:             my $id=&escape($ids{$_});
                    549:             $id=~tr/A-Z/a-z/;
                    550:             my $unam=&escape($_);
                    551: 	    if ($servers{$uhom}) {
                    552: 		$servers{$uhom}.='&'.$id.'='.$unam;
                    553:             } else {
                    554:                 $servers{$uhom}=$id.'='.$unam;
                    555:             }
                    556:             &critical('put:'.$udom.':'.$unam.':environment:id='.$id,$uhom);
                    557:         }
1.191     harris41  558:     }
                    559:     foreach (keys %servers) {
1.70      www       560:         &critical('idput:'.$udom.':'.$servers{$_},$_);
1.191     harris41  561:     }
1.70      www       562: }
                    563: 
                    564: # ------------------------------------- Find the section of student in a course
                    565: 
                    566: sub usection {
                    567:     my ($udom,$unam,$courseid)=@_;
                    568:     $courseid=~s/\_/\//g;
                    569:     $courseid=~s/^(\w)/\/$1/;
1.191     harris41  570:     foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',
                    571:                         &homeserver($unam,$udom)))) {
1.70      www       572:         my ($key,$value)=split(/\=/,$_);
                    573:         $key=&unescape($key);
                    574:         if ($key=~/^$courseid(?:\/)*(\w+)*\_st$/) {
                    575:             my $section=$1;
                    576:             if ($key eq $courseid.'_st') { $section=''; }
                    577: 	    my ($dummy,$end,$start)=split(/\_/,&unescape($value));
                    578:             my $now=time;
                    579:             my $notactive=0;
                    580:             if ($start) {
                    581: 		if ($now<$start) { $notactive=1; }
                    582:             }
                    583:             if ($end) {
                    584:                 if ($now>$end) { $notactive=1; }
                    585:             } 
                    586:             unless ($notactive) { return $section; }
                    587:         }
1.191     harris41  588:     }
1.70      www       589:     return '-1';
                    590: }
                    591: 
                    592: # ------------------------------------- Read an entry from a user's environment
                    593: 
                    594: sub userenvironment {
                    595:     my ($udom,$unam,@what)=@_;
                    596:     my %returnhash=();
                    597:     my @answer=split(/\&/,
                    598:                 &reply('get:'.$udom.':'.$unam.':environment:'.join('&',@what),
                    599:                       &homeserver($unam,$udom)));
                    600:     my $i;
                    601:     for ($i=0;$i<=$#what;$i++) {
                    602: 	$returnhash{$what[$i]}=&unescape($answer[$i]);
                    603:     }
                    604:     return %returnhash;
1.1       albertel  605: }
                    606: 
                    607: # ----------------------------- Subscribe to a resource, return URL if possible
1.11      www       608: 
1.1       albertel  609: sub subscribe {
                    610:     my $fname=shift;
                    611:     my $author=$fname;
                    612:     $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
                    613:     my ($udom,$uname)=split(/\//,$author);
                    614:     my $home=homeserver($uname,$udom);
                    615:     if (($home eq 'no_host') || ($home eq $perlvar{'lonHostID'})) { 
                    616:         return 'not_found'; 
                    617:     }
                    618:     my $answer=reply("sub:$fname",$home);
1.64      www       619:     if (($answer eq 'con_lost') || ($answer eq 'rejected')) {
                    620: 	$answer.=' by '.$home;
                    621:     }
1.1       albertel  622:     return $answer;
                    623: }
                    624:     
1.8       www       625: # -------------------------------------------------------------- Replicate file
                    626: 
                    627: sub repcopy {
                    628:     my $filename=shift;
1.23      www       629:     $filename=~s/\/+/\//g;
1.8       www       630:     my $transname="$filename.in.transfer";
1.17      www       631:     if ((-e $filename) || (-e $transname)) { return OK; }
1.8       www       632:     my $remoteurl=subscribe($filename);
1.64      www       633:     if ($remoteurl =~ /^con_lost by/) {
                    634: 	   &logthis("Subscribe returned $remoteurl: $filename");
1.8       www       635:            return HTTP_SERVICE_UNAVAILABLE;
                    636:     } elsif ($remoteurl eq 'not_found') {
                    637: 	   &logthis("Subscribe returned not_found: $filename");
                    638: 	   return HTTP_NOT_FOUND;
1.64      www       639:     } elsif ($remoteurl =~ /^rejected by/) {
                    640: 	   &logthis("Subscribe returned $remoteurl: $filename");
1.8       www       641:            return FORBIDDEN;
1.20      www       642:     } elsif ($remoteurl eq 'directory') {
                    643:            return OK;
1.8       www       644:     } else {
                    645:            my @parts=split(/\//,$filename);
                    646:            my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";
                    647:            if ($path ne "$perlvar{'lonDocRoot'}/res") {
                    648:                &logthis("Malconfiguration for replication: $filename");
                    649: 	       return HTTP_BAD_REQUEST;
                    650:            }
                    651:            my $count;
                    652:            for ($count=5;$count<$#parts;$count++) {
                    653:                $path.="/$parts[$count]";
                    654:                if ((-e $path)!=1) {
                    655: 		   mkdir($path,0777);
                    656:                }
                    657:            }
                    658:            my $ua=new LWP::UserAgent;
                    659:            my $request=new HTTP::Request('GET',"$remoteurl");
                    660:            my $response=$ua->request($request,$transname);
                    661:            if ($response->is_error()) {
                    662: 	       unlink($transname);
                    663:                my $message=$response->status_line;
1.12      www       664:                &logthis("<font color=blue>WARNING:"
                    665:                        ." LWP get: $message: $filename</font>");
1.8       www       666:                return HTTP_SERVICE_UNAVAILABLE;
                    667:            } else {
1.16      www       668: 	       if ($remoteurl!~/\.meta$/) {
                    669:                   my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');
                    670:                   my $mresponse=$ua->request($mrequest,$filename.'.meta');
                    671:                   if ($mresponse->is_error()) {
                    672: 		      unlink($filename.'.meta');
                    673:                       &logthis(
                    674:                      "<font color=yellow>INFO: No metadata: $filename</font>");
                    675:                   }
                    676: 	       }
1.8       www       677:                rename($transname,$filename);
                    678:                return OK;
                    679:            }
                    680:     }
                    681: }
                    682: 
1.15      www       683: # --------------------------------------------------------- Server Side Include
                    684: 
                    685: sub ssi {
                    686: 
1.23      www       687:     my ($fn,%form)=@_;
1.15      www       688: 
                    689:     my $ua=new LWP::UserAgent;
1.23      www       690:     
                    691:     my $request;
                    692:     
                    693:     if (%form) {
                    694:       $request=new HTTP::Request('POST',"http://".$ENV{'HTTP_HOST'}.$fn);
1.201     albertel  695:       $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form));
1.23      www       696:     } else {
                    697:       $request=new HTTP::Request('GET',"http://".$ENV{'HTTP_HOST'}.$fn);
                    698:     }
                    699: 
1.15      www       700:     $request->header(Cookie => $ENV{'HTTP_COOKIE'});
                    701:     my $response=$ua->request($request);
                    702: 
                    703:     return $response->content;
                    704: }
                    705: 
1.14      www       706: # ------------------------------------------------------------------------- Log
                    707: 
                    708: sub log {
                    709:     my ($dom,$nam,$hom,$what)=@_;
1.47      www       710:     return critical("log:$dom:$nam:$what",$hom);
1.157     www       711: }
                    712: 
                    713: # ------------------------------------------------------------------ Course Log
                    714: 
                    715: sub flushcourselogs {
                    716:     &logthis('Flushing course log buffers');
1.191     harris41  717:     foreach (keys %courselogs) {
1.157     www       718:         my $crsid=$_;
1.204     albertel  719: 	&logthis(":$crsid:$coursehombuf{$crsid}");
1.188     www       720:         if (&reply('log:'.$coursedombuf{$crsid}.':'.
                    721: 		          &escape($courselogs{$crsid}),
                    722: 		          $coursehombuf{$crsid}) eq 'ok') {
1.157     www       723: 	    delete $courselogs{$crsid};
                    724:         } else {
                    725:             &logthis('Failed to flush log buffer for '.$crsid);
                    726:             if (length($courselogs{$crsid})>40000) {
                    727:                &logthis("<font color=blue>WARNING: Buffer for ".$crsid.
                    728:                         " exceeded maximum size, deleting.</font>");
                    729:                delete $courselogs{$crsid};
                    730:             }
                    731:         }        
1.191     harris41  732:     }
1.185     www       733:     &logthis('Flushing access logs');
1.191     harris41  734:     foreach (keys %accesshash) {
1.185     www       735:         my $entry=$_;
                    736:         $entry=~/\_\_\_(\w+)\/(\w+)\/(.*)\_\_\_(\w+)$/;
                    737:         my %temphash=($entry => $accesshash{$entry});
                    738:         if (&Apache::lonnet::put('resevaldata',\%temphash,$1,$2) eq 'ok') {
                    739: 	    delete $accesshash{$entry};
                    740:         }
1.191     harris41  741:     }
1.186     www       742:     $dumpcount++;
1.157     www       743: }
                    744: 
                    745: sub courselog {
                    746:     my $what=shift;
1.158     www       747:     $what=time.':'.$what;
1.157     www       748:     unless ($ENV{'request.course.id'}) { return ''; }
1.188     www       749:     $coursedombuf{$ENV{'request.course.id'}}=
                    750:        $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.':'.
                    751:        $ENV{'course.'.$ENV{'request.course.id'}.'.num'};
                    752:     $coursehombuf{$ENV{'request.course.id'}}=
                    753:        $ENV{'course.'.$ENV{'request.course.id'}.'.home'};
1.157     www       754:     if (defined $courselogs{$ENV{'request.course.id'}}) {
                    755: 	$courselogs{$ENV{'request.course.id'}}.='&'.$what;
                    756:     } else {
                    757: 	$courselogs{$ENV{'request.course.id'}}.=$what;
                    758:     }
                    759:     if (length($courselogs{$ENV{'request.course.id'}})>4048) {
                    760: 	&flushcourselogs();
                    761:     }
1.158     www       762: }
                    763: 
                    764: sub courseacclog {
                    765:     my $fnsymb=shift;
                    766:     unless ($ENV{'request.course.id'}) { return ''; }
                    767:     my $what=$fnsymb.':'.$ENV{'user.name'}.':'.$ENV{'user.domain'};
1.192     www       768:     if ($fnsymb=~/(problem|exam|quiz|assess|survey|form)$/) {
1.187     www       769:         $what.=':POST';
1.191     harris41  770: 	foreach (keys %ENV) {
1.158     www       771:             if ($_=~/^form\.(.*)/) {
                    772: 		$what.=':'.$1.'='.$ENV{$_};
                    773:             }
1.191     harris41  774:         }
1.158     www       775:     }
                    776:     &courselog($what);
1.149     www       777: }
                    778: 
1.185     www       779: sub countacc {
                    780:     my $url=&declutter(shift);
                    781:     unless ($ENV{'request.course.id'}) { return ''; }
                    782:     $accesshash{$ENV{'request.course.id'}.'___'.$url.'___course'}=1;
1.186     www       783:     my $key=$processmarker.'_'.$dumpcount.'___'.$url.'___count';
1.185     www       784:     if (defined($accesshash{$key})) {
                    785: 	$accesshash{$key}++;
                    786:     } else {
                    787:         $accesshash{$key}=1;
                    788:     }
                    789: }
                    790:     
1.149     www       791: # ----------------------------------------------------------- Check out an item
                    792: 
                    793: sub checkout {
                    794:     my ($symb,$tuname,$tudom,$tcrsid)=@_;
                    795:     my $now=time;
                    796:     my $lonhost=$perlvar{'lonHostID'};
                    797:     my $infostr=&escape(
                    798:                  $tuname.'&'.
                    799:                  $tudom.'&'.
                    800:                  $tcrsid.'&'.
                    801:                  $symb.'&'.
                    802: 		 $now.'&'.$ENV{'REMOTE_ADDR'});
                    803:     my $token=&reply('tmpput:'.$infostr,$lonhost);
1.151     www       804:     if ($token=~/^error\:/) { 
                    805:         &logthis("<font color=blue>WARNING: ".
                    806:                 "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.
                    807:                  "</font>");
                    808:         return ''; 
                    809:     }
                    810: 
1.149     www       811:     $token=~s/^(\d+)\_.*\_(\d+)$/$1\*$2\*$lonhost/;
                    812:     $token=~tr/a-z/A-Z/;
                    813: 
1.153     www       814:     my %infohash=('resource.0.outtoken' => $token,
                    815:                   'resource.0.checkouttime' => $now,
                    816:                   'resource.0.outremote' => $ENV{'REMOTE_ADDR'});
1.149     www       817: 
                    818:     unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
                    819:        return '';
1.151     www       820:     } else {
                    821:         &logthis("<font color=blue>WARNING: ".
                    822:                 "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.
                    823:                  "</font>");
1.149     www       824:     }    
                    825: 
                    826:     if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
                    827:                          &escape('Checkout '.$infostr.' - '.
                    828:                                                  $token)) ne 'ok') {
                    829: 	return '';
1.151     www       830:     } else {
                    831:         &logthis("<font color=blue>WARNING: ".
                    832:                 "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.
                    833:                  "</font>");
1.149     www       834:     }
1.151     www       835:     return $token;
1.149     www       836: }
                    837: 
                    838: # ------------------------------------------------------------ Check in an item
                    839: 
                    840: sub checkin {
                    841:     my $token=shift;
1.150     www       842:     my $now=time;
                    843:     my ($ta,$tb,$lonhost)=split(/\*/,$token);
                    844:     $lonhost=~tr/A-Z/a-z/;
                    845:     my $dtoken=$ta.'_'.$hostip{$lonhost}.'_'.$tb;
                    846:     $dtoken=~s/\W/\_/g;
                    847:     my ($tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
                    848:                  split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));
                    849: 
1.154     www       850:     unless (($tuname) && ($tudom)) {
                    851:         &logthis('Check in '.$token.' ('.$dtoken.') failed');
                    852:         return '';
                    853:     }
                    854:     
                    855:     unless (&allowed('mgr',$tcrsid)) {
                    856:         &logthis('Check in '.$token.' ('.$dtoken.') unauthorized: '.
                    857:                  $ENV{'user.name'}.' - '.$ENV{'user.domain'});
                    858:         return '';
                    859:     }
                    860: 
1.153     www       861:     my %infohash=('resource.0.intoken' => $token,
                    862:                   'resource.0.checkintime' => $now,
                    863:                   'resource.0.inremote' => $ENV{'REMOTE_ADDR'});
1.150     www       864: 
                    865:     unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
                    866:        return '';
                    867:     }    
                    868: 
                    869:     if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
                    870:                          &escape('Checkin - '.$token)) ne 'ok') {
                    871: 	return '';
                    872:     }
                    873: 
                    874:     return ($symb,$tuname,$tudom,$tcrsid);    
1.110     www       875: }
                    876: 
                    877: # --------------------------------------------- Set Expire Date for Spreadsheet
                    878: 
                    879: sub expirespread {
                    880:     my ($uname,$udom,$stype,$usymb)=@_;
                    881:     my $cid=$ENV{'request.course.id'}; 
                    882:     if ($cid) {
                    883:        my $now=time;
                    884:        my $key=$uname.':'.$udom.':'.$stype.':'.$usymb;
                    885:        return &reply('put:'.$ENV{'course.'.$cid.'.domain'}.':'.
                    886:                             $ENV{'course.'.$cid.'.num'}.
                    887: 	        	    ':nohist_expirationdates:'.
                    888:                             &escape($key).'='.$now,
                    889:                             $ENV{'course.'.$cid.'.home'})
                    890:     }
                    891:     return 'ok';
1.14      www       892: }
                    893: 
1.109     www       894: # ----------------------------------------------------- Devalidate Spreadsheets
                    895: 
                    896: sub devalidate {
                    897:     my $symb=shift;
                    898:     my $cid=$ENV{'request.course.id'}; 
                    899:     if ($cid) {
                    900: 	my $key=$ENV{'user.name'}.':'.$ENV{'user.domain'}.':';
                    901:         my $status=
1.133     albertel  902: 	    &del('nohist_calculatedsheet',
                    903: 		 [$key.'studentcalc'],
                    904: 		 $ENV{'course.'.$cid.'.domain'},
                    905: 		 $ENV{'course.'.$cid.'.num'})
                    906: 		.' '.
                    907: 	    &del('nohist_calculatedsheets_'.$cid,
                    908: 		 [$key.'assesscalc:'.$symb]);
1.109     www       909:         unless ($status eq 'ok ok') {
                    910:            &logthis('Could not devalidate spreadsheet '.
                    911:                     $ENV{'user.name'}.' at '.$ENV{'user.domain'}.' for '.
                    912: 		    $symb.': '.$status);
1.133     albertel  913:         }
1.109     www       914:     }
                    915: }
                    916: 
1.204     albertel  917: sub arrayref2str {
                    918:   my ($arrayref) = @_;
                    919:   my $result='_ARRAY_REF__';
                    920:   foreach my $elem (@$arrayref) {
                    921:     if (ref($elem) eq 'ARRAY') {
                    922:       $result.=&escape(&arrayref2str($elem)).'&';
                    923:     } elsif (ref($elem) eq 'HASH') {
                    924:       $result.=&escape(&hashref2str($elem)).'&';
                    925:     } elsif (ref($elem)) {
                    926:       &logthis("Got a ref of ".(ref($elem))." skipping.");
                    927:     } else {
                    928:       $result.=&escape($elem).'&';
                    929:     }
                    930:   }
                    931:   $result=~s/\&$//;
                    932:   return $result;
                    933: }
                    934: 
1.168     albertel  935: sub hash2str {
1.204     albertel  936:   my (%hash) = @_;
                    937:   my $result=&hashref2str(\%hash);
                    938:   $result=~s/^_HASH_REF__//;
                    939:   return $result;
                    940: }
                    941: 
                    942: sub hashref2str {
                    943:   my ($hashref)=@_;
                    944:   my $result='_HASH_REF__';
                    945:   foreach (keys(%$hashref)) {
                    946:     if (ref($_) eq 'ARRAY') {
                    947:       $result.=&escape(&arrayref2str($_)).'=';
                    948:     } elsif (ref($_) eq 'HASH') {
                    949:       $result.=&escape(&hashref2str($_)).'=';
                    950:     } elsif (ref($_)) {
                    951:       &logthis("Got a ref of ".(ref($_))." skipping.");
                    952:     } else {
                    953:       $result.=&escape($_).'=';
                    954:     }
                    955: 
                    956:     if (ref($$hashref{$_}) eq 'ARRAY') {
                    957:       $result.=&escape(&arrayref2str($$hashref{$_})).'&';
                    958:     } elsif (ref($$hashref{$_}) eq 'HASH') {
                    959:       $result.=&escape(&hashref2str($$hashref{$_})).'&';
                    960:     } elsif (ref($$hashref{$_})) {
                    961:       &logthis("Got a ref of ".(ref($$hashref{$_}))." skipping.");
                    962:     } else {
                    963:       $result.=&escape($$hashref{$_}).'&';
                    964:     }
                    965:   }
1.168     albertel  966:   $result=~s/\&$//;
                    967:   return $result;
                    968: }
                    969: 
                    970: sub str2hash {
                    971:   my ($string) = @_;
                    972:   my %returnhash;
1.191     harris41  973:   foreach (split(/\&/,$string)) {
1.168     albertel  974:     my ($name,$value)=split(/\=/,$_);
1.204     albertel  975:     $name=&unescape($name);
                    976:     $value=&unescape($value);
                    977:     if ($value =~ /^_HASH_REF__/) {
                    978:       $value =~ s/^_HASH_REF__//;
                    979:       my %hash=&str2hash($value);
                    980:       $value=\%hash;
                    981:     } elsif ($value =~ /^_ARRAY_REF__/) {
                    982:       $value =~ s/^_ARRAY_REF__//;
                    983:       my @array=&str2array($value);
                    984:       $value=\@array;
                    985:     }
                    986:     $returnhash{$name}=$value;
                    987:   }
                    988:   return (%returnhash);
                    989: }
                    990: 
                    991: sub str2array {
                    992:   my ($string) = @_;
                    993:   my @returnarray;
                    994:   foreach my $value (split(/\&/,$string)) {
                    995:     $value=&unescape($value);
                    996:     if ($value =~ /^_HASH_REF__/) {
                    997:       $value =~ s/^_HASH_REF__//;
                    998:       my %hash=&str2hash($value);
                    999:       $value=\%hash;
                   1000:     } elsif ($value =~ /^_ARRAY_REF__/) {
                   1001:       $value =~ s/^_ARRAY_REF__//;
                   1002:       my @array=&str2array($value);
                   1003:       $value=\@array;
                   1004:     }
                   1005:     push(@returnarray,$value);
1.191     harris41 1006:   }
1.204     albertel 1007:   return (@returnarray);
1.168     albertel 1008: }
                   1009: 
1.167     albertel 1010: # -------------------------------------------------------------------Temp Store
                   1011: 
1.168     albertel 1012: sub tmpreset {
                   1013:   my ($symb,$namespace,$domain,$stuname) = @_;
                   1014:   if (!$symb) {
                   1015:     $symb=&symbread();
                   1016:     if (!$symb) { $symb= $ENV{'REQUEST_URI'}; }
                   1017:   }
                   1018:   $symb=escape($symb);
                   1019: 
                   1020:   if (!$namespace) { $namespace=$ENV{'request.state'}; }
                   1021:   $namespace=~s/\//\_/g;
                   1022:   $namespace=~s/\W//g;
                   1023: 
                   1024:   #FIXME needs to do something for /pub resources
                   1025:   if (!$domain) { $domain=$ENV{'user.domain'}; }
                   1026:   if (!$stuname) { $stuname=$ENV{'user.name'}; }
                   1027:   my $path=$perlvar{'lonDaemons'}.'/tmp';
                   1028:   my %hash;
                   1029:   if (tie(%hash,'GDBM_File',
                   1030: 	  $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
                   1031: 	  &GDBM_WRCREAT,0640)) {
                   1032:     foreach my $key (keys %hash) {
1.180     albertel 1033:       if ($key=~ /:$symb/) {
1.168     albertel 1034: 	delete($hash{$key});
                   1035:       }
                   1036:     }
                   1037:   }
                   1038: }
                   1039: 
1.167     albertel 1040: sub tmpstore {
1.168     albertel 1041:   my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
                   1042: 
                   1043:   if (!$symb) {
                   1044:     $symb=&symbread();
                   1045:     if (!$symb) { $symb= $ENV{'request.url'}; }
                   1046:   }
                   1047:   $symb=escape($symb);
                   1048: 
                   1049:   if (!$namespace) {
                   1050:     # I don't think we would ever want to store this for a course.
                   1051:     # it seems this will only be used if we don't have a course.
                   1052:     #$namespace=$ENV{'request.course.id'};
                   1053:     #if (!$namespace) {
                   1054:       $namespace=$ENV{'request.state'};
                   1055:     #}
                   1056:   }
                   1057:   $namespace=~s/\//\_/g;
                   1058:   $namespace=~s/\W//g;
                   1059: #FIXME needs to do something for /pub resources
                   1060:   if (!$domain) { $domain=$ENV{'user.domain'}; }
                   1061:   if (!$stuname) { $stuname=$ENV{'user.name'}; }
                   1062:   my $now=time;
                   1063:   my %hash;
                   1064:   my $path=$perlvar{'lonDaemons'}.'/tmp';
                   1065:   if (tie(%hash,'GDBM_File',
                   1066: 	  $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
                   1067: 	  &GDBM_WRCREAT,0640)) {
                   1068:     $hash{"version:$symb"}++;
                   1069:     my $version=$hash{"version:$symb"};
                   1070:     my $allkeys=''; 
                   1071:     foreach my $key (keys(%$storehash)) {
                   1072:       $allkeys.=$key.':';
                   1073:       $hash{"$version:$symb:$key"}=$$storehash{$key};
                   1074:     }
                   1075:     $hash{"$version:$symb:timestamp"}=$now;
                   1076:     $allkeys.='timestamp';
                   1077:     $hash{"$version:keys:$symb"}=$allkeys;
                   1078:     if (untie(%hash)) {
                   1079:       return 'ok';
                   1080:     } else {
                   1081:       return "error:$!";
                   1082:     }
                   1083:   } else {
                   1084:     return "error:$!";
                   1085:   }
                   1086: }
1.167     albertel 1087: 
1.168     albertel 1088: # -----------------------------------------------------------------Temp Restore
1.167     albertel 1089: 
1.168     albertel 1090: sub tmprestore {
                   1091:   my ($symb,$namespace,$domain,$stuname) = @_;
1.167     albertel 1092: 
1.168     albertel 1093:   if (!$symb) {
                   1094:     $symb=&symbread();
                   1095:     if (!$symb) { $symb= $ENV{'request.url'}; }
                   1096:   }
                   1097:   $symb=escape($symb);
                   1098: 
                   1099:   if (!$namespace) { $namespace=$ENV{'request.state'}; }
                   1100:   #FIXME needs to do something for /pub resources
                   1101:   if (!$domain) { $domain=$ENV{'user.domain'}; }
                   1102:   if (!$stuname) { $stuname=$ENV{'user.name'}; }
                   1103: 
                   1104:   my %returnhash;
                   1105:   $namespace=~s/\//\_/g;
                   1106:   $namespace=~s/\W//g;
                   1107:   my %hash;
                   1108:   my $path=$perlvar{'lonDaemons'}.'/tmp';
                   1109:   if (tie(%hash,'GDBM_File',
                   1110: 	  $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
                   1111: 	  &GDBM_READER,0640)) {
                   1112:     my $version=$hash{"version:$symb"};
                   1113:     $returnhash{'version'}=$version;
                   1114:     my $scope;
                   1115:     for ($scope=1;$scope<=$version;$scope++) {
                   1116:       my $vkeys=$hash{"$scope:keys:$symb"};
                   1117:       my @keys=split(/:/,$vkeys);
                   1118:       my $key;
                   1119:       $returnhash{"$scope:keys"}=$vkeys;
                   1120:       foreach $key (@keys) {
                   1121: 	$returnhash{"$scope:$key"}=$hash{"$scope:$symb:$key"};
                   1122: 	$returnhash{"$key"}=$hash{"$scope:$symb:$key"};
1.167     albertel 1123:       }
                   1124:     }
1.168     albertel 1125:     if (!(untie(%hash))) {
                   1126:       return "error:$!";
                   1127:     }
                   1128:   } else {
                   1129:     return "error:$!";
                   1130:   }
                   1131:   return %returnhash;
1.167     albertel 1132: }
                   1133: 
1.9       www      1134: # ----------------------------------------------------------------------- Store
                   1135: 
                   1136: sub store {
1.124     www      1137:     my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
                   1138:     my $home='';
                   1139: 
1.168     albertel 1140:     if ($stuname) { $home=&homeserver($stuname,$domain); }
1.124     www      1141: 
1.122     albertel 1142:     if (!$symb) { unless ($symb=&symbread()) { return ''; } }
1.109     www      1143: 
                   1144:     &devalidate($symb);
                   1145: 
                   1146:     $symb=escape($symb);
1.187     www      1147:     if (!$namespace) { 
                   1148:        unless ($namespace=$ENV{'request.course.id'}) { 
                   1149:           return ''; 
                   1150:        } 
                   1151:     }
1.122     albertel 1152:     if (!$domain) { $domain=$ENV{'user.domain'}; }
                   1153:     if (!$stuname) { $stuname=$ENV{'user.name'}; }
                   1154:     if (!$home) { $home=$ENV{'user.home'}; }
1.12      www      1155:     my $namevalue='';
1.191     harris41 1156:     foreach (keys %$storehash) {
1.122     albertel 1157:         $namevalue.=escape($_).'='.escape($$storehash{$_}).'&';
1.191     harris41 1158:     }
1.12      www      1159:     $namevalue=~s/\&$//;
1.187     www      1160:     &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue);
1.124     www      1161:     return reply("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");
1.9       www      1162: }
                   1163: 
1.47      www      1164: # -------------------------------------------------------------- Critical Store
                   1165: 
                   1166: sub cstore {
1.124     www      1167:     my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
                   1168:     my $home='';
                   1169: 
1.168     albertel 1170:     if ($stuname) { $home=&homeserver($stuname,$domain); }
1.124     www      1171: 
1.122     albertel 1172:     if (!$symb) { unless ($symb=&symbread()) { return ''; } }
1.109     www      1173: 
                   1174:     &devalidate($symb);
                   1175: 
                   1176:     $symb=escape($symb);
1.187     www      1177:     if (!$namespace) { 
                   1178:        unless ($namespace=$ENV{'request.course.id'}) { 
                   1179:           return ''; 
                   1180:        } 
                   1181:     }
1.122     albertel 1182:     if (!$domain) { $domain=$ENV{'user.domain'}; }
                   1183:     if (!$stuname) { $stuname=$ENV{'user.name'}; }
                   1184:     if (!$home) { $home=$ENV{'user.home'}; }
                   1185: 
1.47      www      1186:     my $namevalue='';
1.191     harris41 1187:     foreach (keys %$storehash) {
1.122     albertel 1188:         $namevalue.=escape($_).'='.escape($$storehash{$_}).'&';
1.191     harris41 1189:     }
1.47      www      1190:     $namevalue=~s/\&$//;
1.187     www      1191:     &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue);
1.188     www      1192:     return critical
                   1193:                 ("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");
1.47      www      1194: }
                   1195: 
1.9       www      1196: # --------------------------------------------------------------------- Restore
                   1197: 
                   1198: sub restore {
1.124     www      1199:     my ($symb,$namespace,$domain,$stuname) = @_;
                   1200:     my $home='';
                   1201: 
1.168     albertel 1202:     if ($stuname) { $home=&homeserver($stuname,$domain); }
1.124     www      1203: 
1.122     albertel 1204:     if (!$symb) {
                   1205:       unless ($symb=escape(&symbread())) { return ''; }
                   1206:     } else {
                   1207:       $symb=&escape($symb);
                   1208:     }
1.188     www      1209:     if (!$namespace) { 
                   1210:        unless ($namespace=$ENV{'request.course.id'}) { 
                   1211:           return ''; 
                   1212:        } 
                   1213:     }
1.122     albertel 1214:     if (!$domain) { $domain=$ENV{'user.domain'}; }
                   1215:     if (!$stuname) { $stuname=$ENV{'user.name'}; }
                   1216:     if (!$home) { $home=$ENV{'user.home'}; }
                   1217:     my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home");
                   1218: 
1.12      www      1219:     my %returnhash=();
1.191     harris41 1220:     foreach (split(/\&/,$answer)) {
1.12      www      1221: 	my ($name,$value)=split(/\=/,$_);
                   1222:         $returnhash{&unescape($name)}=&unescape($value);
1.191     harris41 1223:     }
1.75      www      1224:     my $version;
                   1225:     for ($version=1;$version<=$returnhash{'version'};$version++) {
1.191     harris41 1226:        foreach (split(/\:/,$returnhash{$version.':keys'})) {
1.75      www      1227:           $returnhash{$_}=$returnhash{$version.':'.$_};
1.191     harris41 1228:        }
1.75      www      1229:     }
1.13      www      1230:     return %returnhash;
1.34      www      1231: }
                   1232: 
                   1233: # ---------------------------------------------------------- Course Description
                   1234: 
                   1235: sub coursedescription {
                   1236:     my $courseid=shift;
                   1237:     $courseid=~s/^\///;
1.49      www      1238:     $courseid=~s/\_/\//g;
1.34      www      1239:     my ($cdomain,$cnum)=split(/\//,$courseid);
1.129     albertel 1240:     my $chome=&homeserver($cnum,$cdomain);
1.34      www      1241:     if ($chome ne 'no_host') {
1.129     albertel 1242:        my %returnhash=&dump('environment',$cdomain,$cnum);
                   1243:        if (!exists($returnhash{'con_lost'})) {
1.96      www      1244:            my $normalid=$cdomain.'_'.$cnum;
1.53      www      1245:            my %envhash=();
1.129     albertel 1246:            $returnhash{'home'}= $chome;
                   1247: 	   $returnhash{'domain'} = $cdomain;
                   1248: 	   $returnhash{'num'} = $cnum;
1.130     albertel 1249:            while (my ($name,$value) = each %returnhash) {
1.53      www      1250:                $envhash{'course.'.$normalid.'.'.$name}=$value;
1.129     albertel 1251:            }
1.34      www      1252:            $returnhash{'url'}='/res/'.declutter($returnhash{'url'});
                   1253:            $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'.
1.38      www      1254: 	       $ENV{'user.name'}.'_'.$cdomain.'_'.$cnum;
1.54      www      1255:            $envhash{'course.'.$normalid.'.last_cache'}=time;
1.60      www      1256:            $envhash{'course.'.$normalid.'.home'}=$chome;
                   1257:            $envhash{'course.'.$normalid.'.domain'}=$cdomain;
                   1258:            $envhash{'course.'.$normalid.'.num'}=$cnum;
1.53      www      1259:            &appenv(%envhash);
1.34      www      1260:            return %returnhash;
                   1261:        }
                   1262:     }
                   1263:     return ();
1.9       www      1264: }
1.1       albertel 1265: 
1.103     harris41 1266: # -------------------------------------------------------- Get user privileges
1.11      www      1267: 
                   1268: sub rolesinit {
                   1269:     my ($domain,$username,$authhost)=@_;
                   1270:     my $rolesdump=reply("dump:$domain:$username:roles",$authhost);
1.12      www      1271:     if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; }
1.11      www      1272:     my %allroles=();
                   1273:     my %thesepriv=();
                   1274:     my $now=time;
1.21      www      1275:     my $userroles="user.login.time=$now\n";
1.11      www      1276:     my $thesestr;
                   1277: 
                   1278:     if ($rolesdump ne '') {
1.191     harris41 1279:         foreach (split(/&/,$rolesdump)) {
1.21      www      1280: 	  if ($_!~/^rolesdef\&/) {
1.11      www      1281:             my ($area,$role)=split(/=/,$_);
1.21      www      1282:             $area=~s/\_\w\w$//;
1.11      www      1283:             my ($trole,$tend,$tstart)=split(/_/,$role);
1.21      www      1284:             $userroles.='user.role.'.$trole.'.'.$area.'='.
                   1285:                         $tstart.'.'.$tend."\n";
1.11      www      1286:             if ($tend!=0) {
                   1287: 	        if ($tend<$now) {
                   1288: 	            $trole='';
                   1289:                 } 
                   1290:             }
                   1291:             if ($tstart!=0) {
                   1292:                 if ($tstart>$now) {
                   1293:                    $trole='';        
                   1294:                 }
                   1295:             }
                   1296:             if (($area ne '') && ($trole ne '')) {
1.50      www      1297: 	       my $spec=$trole.'.'.$area;
1.12      www      1298:                my ($tdummy,$tdomain,$trest)=split(/\//,$area);
                   1299:                if ($trole =~ /^cr\//) {
                   1300: 		   my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
                   1301:                    my $homsvr=homeserver($rauthor,$rdomain);
                   1302:                    if ($hostname{$homsvr} ne '') {
                   1303:                       my $roledef=
1.21      www      1304: 			  reply("get:$rdomain:$rauthor:roles:rolesdef_$rrole",
1.12      www      1305:                                 $homsvr);
                   1306:                       if (($roledef ne 'con_lost') && ($roledef ne '')) {
                   1307:                          my ($syspriv,$dompriv,$coursepriv)=
1.21      www      1308: 			     split(/\_/,unescape($roledef));
1.50      www      1309:  	                 $allroles{'cm./'}.=':'.$syspriv;
                   1310:                          $allroles{$spec.'./'}.=':'.$syspriv;
1.12      www      1311:                          if ($tdomain ne '') {
1.50      www      1312:                              $allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv;
                   1313:                              $allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv;
1.12      www      1314:                              if ($trest ne '') {
1.50      www      1315: 		                $allroles{'cm.'.$area}.=':'.$coursepriv;
                   1316: 		                $allroles{$spec.'.'.$area}.=':'.$coursepriv;
1.12      www      1317:                              }
                   1318: 	                 }
                   1319:                       }
1.11      www      1320:                    }
1.12      www      1321:                } else {
1.50      www      1322: 	           $allroles{'cm./'}.=':'.$pr{$trole.':s'};
                   1323: 	           $allroles{$spec.'./'}.=':'.$pr{$trole.':s'};
1.12      www      1324:                    if ($tdomain ne '') {
1.50      www      1325:                      $allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
                   1326:                      $allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
1.12      www      1327:                       if ($trest ne '') {
1.50      www      1328: 		          $allroles{'cm.'.$area}.=':'.$pr{$trole.':c'};
                   1329: 		          $allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'};
1.12      www      1330:                       }
                   1331: 	           }
1.11      www      1332: 	       }
1.12      www      1333:             }
                   1334:           } 
1.191     harris41 1335:         }
1.125     www      1336:         my $adv=0;
1.128     www      1337:         my $author=0;
1.191     harris41 1338:         foreach (keys %allroles) {
1.11      www      1339:             %thesepriv=();
1.146     www      1340:             if (($_!~/^st/) && ($_!~/^ta/) && ($_!~/^cm/)) { $adv=1; }
1.128     www      1341:             if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; }
1.191     harris41 1342:             foreach (split(/:/,$allroles{$_})) {
1.11      www      1343:                 if ($_ ne '') {
1.103     harris41 1344: 		    my ($privilege,$restrictions)=split(/&/,$_);
1.11      www      1345:                     if ($restrictions eq '') {
1.103     harris41 1346: 			$thesepriv{$privilege}='F';
1.11      www      1347:                     } else {
1.103     harris41 1348:                         if ($thesepriv{$privilege} ne 'F') {
                   1349: 			    $thesepriv{$privilege}.=$restrictions;
1.11      www      1350:                         }
                   1351:                     }
                   1352:                 }
1.191     harris41 1353:             }
1.11      www      1354:             $thesestr='';
1.191     harris41 1355:             foreach (keys %thesepriv) { $thesestr.=':'.$_.'&'.$thesepriv{$_}; }
1.11      www      1356:             $userroles.='user.priv.'.$_.'='.$thesestr."\n";
1.191     harris41 1357:         }
1.128     www      1358:         $userroles.='user.adv='.$adv."\n".
                   1359: 	            'user.author='.$author."\n";
1.126     www      1360:         $ENV{'user.adv'}=$adv;
1.11      www      1361:     }
                   1362:     return $userroles;  
                   1363: }
                   1364: 
1.12      www      1365: # --------------------------------------------------------------- get interface
                   1366: 
                   1367: sub get {
1.131     albertel 1368:    my ($namespace,$storearr,$udomain,$uname)=@_;
1.12      www      1369:    my $items='';
1.191     harris41 1370:    foreach (@$storearr) {
1.12      www      1371:        $items.=escape($_).'&';
1.191     harris41 1372:    }
1.12      www      1373:    $items=~s/\&$//;
1.131     albertel 1374:    if (!$udomain) { $udomain=$ENV{'user.domain'}; }
                   1375:    if (!$uname) { $uname=$ENV{'user.name'}; }
                   1376:    my $uhome=&homeserver($uname,$udomain);
                   1377: 
1.133     albertel 1378:    my $rep=&reply("get:$udomain:$uname:$namespace:$items",$uhome);
1.15      www      1379:    my @pairs=split(/\&/,$rep);
                   1380:    my %returnhash=();
1.42      www      1381:    my $i=0;
1.191     harris41 1382:    foreach (@$storearr) {
1.42      www      1383:       $returnhash{$_}=unescape($pairs[$i]);
                   1384:       $i++;
1.191     harris41 1385:    }
1.15      www      1386:    return %returnhash;
1.27      www      1387: }
                   1388: 
                   1389: # --------------------------------------------------------------- del interface
                   1390: 
                   1391: sub del {
1.133     albertel 1392:    my ($namespace,$storearr,$udomain,$uname)=@_;
1.27      www      1393:    my $items='';
1.191     harris41 1394:    foreach (@$storearr) {
1.27      www      1395:        $items.=escape($_).'&';
1.191     harris41 1396:    }
1.27      www      1397:    $items=~s/\&$//;
1.133     albertel 1398:    if (!$udomain) { $udomain=$ENV{'user.domain'}; }
                   1399:    if (!$uname) { $uname=$ENV{'user.name'}; }
                   1400:    my $uhome=&homeserver($uname,$udomain);
                   1401: 
                   1402:    return &reply("del:$udomain:$uname:$namespace:$items",$uhome);
1.15      www      1403: }
                   1404: 
                   1405: # -------------------------------------------------------------- dump interface
                   1406: 
                   1407: sub dump {
1.193     www      1408:    my ($namespace,$udomain,$uname,$regexp)=@_;
1.129     albertel 1409:    if (!$udomain) { $udomain=$ENV{'user.domain'}; }
                   1410:    if (!$uname) { $uname=$ENV{'user.name'}; }
                   1411:    my $uhome=&homeserver($uname,$udomain);
1.193     www      1412:    if ($regexp) {
                   1413:        $regexp=&escape($regexp);
                   1414:    } else {
                   1415:        $regexp='.';
                   1416:    }
                   1417:    my $rep=reply("dump:$udomain:$uname:$namespace:$regexp",$uhome);
1.12      www      1418:    my @pairs=split(/\&/,$rep);
                   1419:    my %returnhash=();
1.191     harris41 1420:    foreach (@pairs) {
1.12      www      1421:       my ($key,$value)=split(/=/,$_);
1.29      www      1422:       $returnhash{unescape($key)}=unescape($value);
1.191     harris41 1423:    }
1.12      www      1424:    return %returnhash;
                   1425: }
                   1426: 
                   1427: # --------------------------------------------------------------- put interface
                   1428: 
                   1429: sub put {
1.134     albertel 1430:    my ($namespace,$storehash,$udomain,$uname)=@_;
                   1431:    if (!$udomain) { $udomain=$ENV{'user.domain'}; }
                   1432:    if (!$uname) { $uname=$ENV{'user.name'}; }
                   1433:    my $uhome=&homeserver($uname,$udomain);
1.12      www      1434:    my $items='';
1.191     harris41 1435:    foreach (keys %$storehash) {
1.134     albertel 1436:        $items.=&escape($_).'='.&escape($$storehash{$_}).'&';
1.191     harris41 1437:    }
1.12      www      1438:    $items=~s/\&$//;
1.134     albertel 1439:    return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
1.47      www      1440: }
                   1441: 
                   1442: # ------------------------------------------------------ critical put interface
                   1443: 
                   1444: sub cput {
1.134     albertel 1445:    my ($namespace,$storehash,$udomain,$uname)=@_;
                   1446:    if (!$udomain) { $udomain=$ENV{'user.domain'}; }
                   1447:    if (!$uname) { $uname=$ENV{'user.name'}; }
                   1448:    my $uhome=&homeserver($uname,$udomain);
1.47      www      1449:    my $items='';
1.191     harris41 1450:    foreach (keys %$storehash) {
1.134     albertel 1451:        $items.=escape($_).'='.escape($$storehash{$_}).'&';
1.191     harris41 1452:    }
1.47      www      1453:    $items=~s/\&$//;
1.134     albertel 1454:    return &critical("put:$udomain:$uname:$namespace:$items",$uhome);
1.12      www      1455: }
                   1456: 
                   1457: # -------------------------------------------------------------- eget interface
                   1458: 
                   1459: sub eget {
1.133     albertel 1460:    my ($namespace,$storearr,$udomain,$uname)=@_;
1.12      www      1461:    my $items='';
1.191     harris41 1462:    foreach (@$storearr) {
1.12      www      1463:        $items.=escape($_).'&';
1.191     harris41 1464:    }
1.12      www      1465:    $items=~s/\&$//;
1.133     albertel 1466:    if (!$udomain) { $udomain=$ENV{'user.domain'}; }
                   1467:    if (!$uname) { $uname=$ENV{'user.name'}; }
                   1468:    my $uhome=&homeserver($uname,$udomain);
                   1469:    my $rep=&reply("eget:$udomain:$uname:$namespace:$items",$uhome);
1.12      www      1470:    my @pairs=split(/\&/,$rep);
                   1471:    my %returnhash=();
1.42      www      1472:    my $i=0;
1.191     harris41 1473:    foreach (@$storearr) {
1.42      www      1474:       $returnhash{$_}=unescape($pairs[$i]);
                   1475:       $i++;
1.191     harris41 1476:    }
1.12      www      1477:    return %returnhash;
                   1478: }
                   1479: 
1.103     harris41 1480: # ------------------------------------------------- Check for a user privilege
1.12      www      1481: 
                   1482: sub allowed {
                   1483:     my ($priv,$uri)=@_;
1.152     www      1484: 
                   1485:     my $orguri=$uri;
1.52      www      1486:     $uri=&declutter($uri);
1.29      www      1487: 
1.54      www      1488: # Free bre access to adm and meta resources
1.29      www      1489: 
1.54      www      1490:     if ((($uri=~/^adm\//) || ($uri=~/\.meta$/)) && ($priv eq 'bre')) {
1.14      www      1491: 	return 'F';
1.159     www      1492:     }
                   1493: 
                   1494: # Free bre to public access
                   1495: 
                   1496:     if ($priv eq 'bre') {
                   1497: 	if (&metadata($uri,'copyright') eq 'public') { return 'F'; }
1.14      www      1498:     }
1.29      www      1499: 
1.52      www      1500:     my $thisallowed='';
                   1501:     my $statecond=0;
                   1502:     my $courseprivid='';
                   1503: 
                   1504: # Course
                   1505: 
                   1506:     if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'}=~/$priv\&([^\:]*)/) {
                   1507:        $thisallowed.=$1;
                   1508:     }
1.29      www      1509: 
1.52      www      1510: # Domain
                   1511: 
                   1512:     if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.(split(/\//,$uri))[0].'/'}
                   1513:        =~/$priv\&([^\:]*)/) {
1.12      www      1514:        $thisallowed.=$1;
                   1515:     }
1.52      www      1516: 
                   1517: # Course: uri itself is a course
1.66      www      1518:     my $courseuri=$uri;
                   1519:     $courseuri=~s/\_(\d)/\/$1/;
1.83      www      1520:     $courseuri=~s/^([^\/])/\/$1/;
1.81      www      1521: 
1.83      www      1522:     if ($ENV{'user.priv.'.$ENV{'request.role'}.'.'.$courseuri}
1.52      www      1523:        =~/$priv\&([^\:]*)/) {
1.12      www      1524:        $thisallowed.=$1;
                   1525:     }
1.29      www      1526: 
1.52      www      1527: # Full access at system, domain or course-wide level? Exit.
1.29      www      1528: 
                   1529:     if ($thisallowed=~/F/) {
                   1530: 	return 'F';
                   1531:     }
                   1532: 
1.52      www      1533: # If this is generating or modifying users, exit with special codes
1.29      www      1534: 
1.166     www      1535:     if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:'=~/\:$priv\:/) {
1.52      www      1536: 	return $thisallowed;
                   1537:     }
                   1538: #
1.103     harris41 1539: # Gathered so far: system, domain and course wide privileges
1.52      www      1540: #
                   1541: # Course: See if uri or referer is an individual resource that is part of 
                   1542: # the course
                   1543: 
                   1544:     if ($ENV{'request.course.id'}) {
                   1545:        $courseprivid=$ENV{'request.course.id'};
                   1546:        if ($ENV{'request.course.sec'}) {
                   1547:           $courseprivid.='/'.$ENV{'request.course.sec'};
                   1548:        }
                   1549:        $courseprivid=~s/\_/\//;
                   1550:        my $checkreferer=1;
                   1551:        my @uriparts=split(/\//,$uri);
                   1552:        my $filename=$uriparts[$#uriparts];
                   1553:        my $pathname=$uri;
                   1554:        $pathname=~s/\/$filename$//;
                   1555:        if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~
1.54      www      1556:            /\&$filename\:([\d\|]+)\&/) {
1.52      www      1557:            $statecond=$1;
                   1558:            if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid}
                   1559:                =~/$priv\&([^\:]*)/) {
                   1560:                $thisallowed.=$1;
                   1561:                $checkreferer=0;
                   1562:            }
1.29      www      1563:        }
1.83      www      1564:        
1.148     www      1565:        if ($checkreferer) {
1.152     www      1566: 	  my $refuri=$ENV{'httpref.'.$orguri};
1.148     www      1567: 
                   1568:             unless ($refuri) {
1.191     harris41 1569:                 foreach (keys %ENV) {
1.148     www      1570: 		    if ($_=~/^httpref\..*\*/) {
                   1571: 			my $pattern=$_;
1.156     www      1572:                         $pattern=~s/^httpref\.\/res\///;
1.148     www      1573:                         $pattern=~s/\*/\[\^\/\]\+/g;
                   1574:                         $pattern=~s/\//\\\//g;
1.152     www      1575:                         if ($orguri=~/$pattern/) {
1.148     www      1576: 			    $refuri=$ENV{$_};
                   1577:                         }
                   1578:                     }
1.191     harris41 1579:                 }
1.148     www      1580:             }
                   1581:          if ($refuri) { 
1.152     www      1582: 	  $refuri=&declutter($refuri);
1.53      www      1583:           my @uriparts=split(/\//,$refuri);
1.52      www      1584:           my $filename=$uriparts[$#uriparts];
1.53      www      1585:           my $pathname=$refuri;
1.52      www      1586:           $pathname=~s/\/$filename$//;
1.53      www      1587:             if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~
1.54      www      1588:               /\&$filename\:([\d\|]+)\&/) {
1.53      www      1589:               my $refstatecond=$1;
1.52      www      1590:               if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid}
                   1591:                   =~/$priv\&([^\:]*)/) {
                   1592:                   $thisallowed.=$1;
1.53      www      1593:                   $uri=$refuri;
                   1594:                   $statecond=$refstatecond;
1.52      www      1595:               }
                   1596:           }
1.148     www      1597:         }
1.29      www      1598:        }
1.52      www      1599:    }
1.29      www      1600: 
1.52      www      1601: #
1.103     harris41 1602: # Gathered now: all privileges that could apply, and condition number
1.52      www      1603: # 
                   1604: #
                   1605: # Full or no access?
                   1606: #
1.29      www      1607: 
1.52      www      1608:     if ($thisallowed=~/F/) {
                   1609: 	return 'F';
                   1610:     }
1.29      www      1611: 
1.52      www      1612:     unless ($thisallowed) {
                   1613:         return '';
                   1614:     }
1.29      www      1615: 
1.52      www      1616: # Restrictions exist, deal with them
                   1617: #
                   1618: #   C:according to course preferences
                   1619: #   R:according to resource settings
                   1620: #   L:unless locked
                   1621: #   X:according to user session state
                   1622: #
                   1623: 
                   1624: # Possibly locked functionality, check all courses
1.54      www      1625: # Locks might take effect only after 10 minutes cache expiration for other
                   1626: # courses, and 2 minutes for current course
1.52      www      1627: 
                   1628:     my $envkey;
                   1629:     if ($thisallowed=~/L/) {
                   1630:         foreach $envkey (keys %ENV) {
1.54      www      1631:            if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) {
                   1632:                my $courseid=$2;
                   1633:                my $roleid=$1.'.'.$2;
1.92      www      1634:                $courseid=~s/^\///;
1.54      www      1635:                my $expiretime=600;
                   1636:                if ($ENV{'request.role'} eq $roleid) {
                   1637: 		  $expiretime=120;
                   1638:                }
                   1639: 	       my ($cdom,$cnum,$csec)=split(/\//,$courseid);
                   1640:                my $prefix='course.'.$cdom.'_'.$cnum.'.';
                   1641:                if ((time-$ENV{$prefix.'last_cache'})>$expiretime) {
                   1642: 		   &coursedescription($courseid);
                   1643:                }
                   1644:                if (($ENV{$prefix.'res.'.$uri.'.lock.sections'}=~/\,$csec\,/)
                   1645:                 || ($ENV{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) {
                   1646: 		   if ($ENV{$prefix.'res.'.$uri.'.lock.expire'}>time) {
1.57      www      1647:                        &log($ENV{'user.domain'},$ENV{'user.name'},
                   1648:                             $ENV{'user.host'},
                   1649:                             'Locked by res: '.$priv.' for '.$uri.' due to '.
1.52      www      1650:                             $cdom.'/'.$cnum.'/'.$csec.' expire '.
1.54      www      1651:                             $ENV{$prefix.'priv.'.$priv.'.lock.expire'});
1.52      www      1652: 		       return '';
                   1653:                    }
                   1654:                }
1.54      www      1655:                if (($ENV{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,$csec\,/)
                   1656:                 || ($ENV{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) {
                   1657: 		   if ($ENV{'priv.'.$priv.'.lock.expire'}>time) {
1.57      www      1658:                        &log($ENV{'user.domain'},$ENV{'user.name'},
                   1659:                             $ENV{'user.host'},
                   1660:                             'Locked by priv: '.$priv.' for '.$uri.' due to '.
1.52      www      1661:                             $cdom.'/'.$cnum.'/'.$csec.' expire '.
1.54      www      1662:                             $ENV{$prefix.'priv.'.$priv.'.lock.expire'});
1.52      www      1663: 		       return '';
                   1664:                    }
                   1665:                }
                   1666: 	   }
1.29      www      1667:        }
1.52      www      1668:     }
                   1669:    
                   1670: #
                   1671: # Rest of the restrictions depend on selected course
                   1672: #
                   1673: 
                   1674:     unless ($ENV{'request.course.id'}) {
                   1675:        return '1';
                   1676:     }
1.29      www      1677: 
1.52      www      1678: #
                   1679: # Now user is definitely in a course
                   1680: #
1.53      www      1681: 
                   1682: 
                   1683: # Course preferences
                   1684: 
                   1685:    if ($thisallowed=~/C/) {
1.54      www      1686:        my $rolecode=(split(/\./,$ENV{'request.role'}))[0];
                   1687:        if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.roles.denied'}
1.194     www      1688: 	   =~/$rolecode/) {
1.57      www      1689:            &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},
                   1690:                 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
1.54      www      1691:                 $ENV{'request.course.id'});
                   1692:            return '';
                   1693:        }
1.53      www      1694:    }
                   1695: 
                   1696: # Resource preferences
                   1697: 
                   1698:    if ($thisallowed=~/R/) {
1.54      www      1699:        my $rolecode=(split(/\./,$ENV{'request.role'}))[0];
                   1700:        my $filename=$perlvar{'lonDocRoot'}.'/res/'.$uri.'.meta';
                   1701:        if (-e $filename) {
                   1702:            my @content;
                   1703:            {
                   1704: 	     my $fh=Apache::File->new($filename);
                   1705:              @content=<$fh>;
                   1706: 	   }
                   1707:            if (join('',@content)=~
                   1708:                     /\<roledeny[^\>]*\>[^\<]*$rolecode[^\<]*\<\/roledeny\>/) {
1.57      www      1709: 	       &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},
                   1710:                     'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
1.54      www      1711:            return '';
                   1712: 
                   1713:            }
                   1714:        }
1.53      www      1715:    }
1.30      www      1716: 
1.52      www      1717: # Restricted by state?
1.30      www      1718: 
1.52      www      1719:    if ($thisallowed=~/X/) {
                   1720:       if (&condval($statecond)) {
                   1721: 	 return '2';
                   1722:       } else {
                   1723:          return '';
                   1724:       }
                   1725:    }
1.30      www      1726: 
1.52      www      1727:    return 'F';
1.12      www      1728: }
                   1729: 
                   1730: # ----------------------------------------------------------------- Define Role
                   1731: 
                   1732: sub definerole {
                   1733:   if (allowed('mcr','/')) {
                   1734:     my ($rolename,$sysrole,$domrole,$courole)=@_;
1.191     harris41 1735:     foreach (split('/',$sysrole)) {
1.21      www      1736: 	my ($crole,$cqual)=split(/\&/,$_);
                   1737:         if ($pr{'cr:s'}!~/$crole/) { return "refused:s:$crole"; }
                   1738:         if ($pr{'cr:s'}=~/$crole\&/) {
                   1739: 	    if ($pr{'cr:s'}!~/$crole\&\w*$cqual/) { 
                   1740:                return "refused:s:$crole&$cqual"; 
                   1741:             }
                   1742:         }
1.191     harris41 1743:     }
                   1744:     foreach (split('/',$domrole)) {
1.21      www      1745: 	my ($crole,$cqual)=split(/\&/,$_);
                   1746:         if ($pr{'cr:d'}!~/$crole/) { return "refused:d:$crole"; }
                   1747:         if ($pr{'cr:d'}=~/$crole\&/) {
                   1748: 	    if ($pr{'cr:d'}!~/$crole\&\w*$cqual/) { 
                   1749:                return "refused:d:$crole&$cqual"; 
                   1750:             }
                   1751:         }
1.191     harris41 1752:     }
                   1753:     foreach (split('/',$courole)) {
1.21      www      1754: 	my ($crole,$cqual)=split(/\&/,$_);
                   1755:         if ($pr{'cr:c'}!~/$crole/) { return "refused:c:$crole"; }
                   1756:         if ($pr{'cr:c'}=~/$crole\&/) {
                   1757: 	    if ($pr{'cr:c'}!~/$crole\&\w*$cqual/) { 
                   1758:                return "refused:c:$crole&$cqual"; 
                   1759:             }
                   1760:         }
1.191     harris41 1761:     }
1.12      www      1762:     my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:".
                   1763:                 "$ENV{'user.domain'}:$ENV{'user.name'}:".
1.21      www      1764: 	        "rolesdef_$rolename=".
                   1765:                 escape($sysrole.'_'.$domrole.'_'.$courole);
1.12      www      1766:     return reply($command,$ENV{'user.home'});
                   1767:   } else {
                   1768:     return 'refused';
                   1769:   }
1.105     harris41 1770: }
                   1771: 
                   1772: # ---------------- Make a metadata query against the network of library servers
                   1773: 
                   1774: sub metadata_query {
1.116     harris41 1775:     my ($query,$custom,$customshow)=@_;
1.120     harris41 1776:     my %rhash;
1.123     harris41 1777:     for my $server (keys %libserv) {
1.118     harris41 1778: 	unless ($custom or $customshow) {
                   1779: 	    my $reply=&reply("querysend:".&escape($query),$server);
                   1780: 	    $rhash{$server}=$reply;
                   1781: 	}
                   1782: 	else {
                   1783: 	    my $reply=&reply("querysend:".&escape($query).':'.
                   1784: 			     &escape($custom).':'.&escape($customshow),
                   1785: 			     $server);
                   1786: 	    $rhash{$server}=$reply;
                   1787: 	}
1.112     harris41 1788:     }
1.118     harris41 1789:     return \%rhash;
1.12      www      1790: }
                   1791: 
                   1792: # ------------------------------------------------------------------ Plain Text
                   1793: 
                   1794: sub plaintext {
1.22      www      1795:     my $short=shift;
                   1796:     return $prp{$short};
1.12      www      1797: }
                   1798: 
                   1799: # ----------------------------------------------------------------- Assign Role
                   1800: 
                   1801: sub assignrole {
1.21      www      1802:     my ($udom,$uname,$url,$role,$end,$start)=@_;
                   1803:     my $mrole;
                   1804:     if ($role =~ /^cr\//) {
1.104     www      1805: 	unless (&allowed('ccr',$url)) {
                   1806:            &logthis('Refused custom assignrole: '.
                   1807:              $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
                   1808: 		    $ENV{'user.name'}.' at '.$ENV{'user.domain'});
                   1809:            return 'refused'; 
                   1810:         }
1.21      www      1811:         $mrole='cr';
                   1812:     } else {
1.82      www      1813:         my $cwosec=$url;
1.83      www      1814:         $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;
1.104     www      1815:         unless (&allowed('c'.$role,$cwosec)) { 
                   1816:            &logthis('Refused assignrole: '.
                   1817:              $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
                   1818: 		    $ENV{'user.name'}.' at '.$ENV{'user.domain'});
                   1819:            return 'refused'; 
                   1820:         }
1.21      www      1821:         $mrole=$role;
                   1822:     }
                   1823:     my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:".
                   1824:                 "$udom:$uname:$url".'_'."$mrole=$role";
1.81      www      1825:     if ($end) { $command.='_'.$end; }
1.21      www      1826:     if ($start) {
                   1827: 	if ($end) { 
1.81      www      1828:            $command.='_'.$start; 
1.21      www      1829:         } else {
1.81      www      1830:            $command.='_0_'.$start;
1.21      www      1831:         }
                   1832:     }
                   1833:     return &reply($command,&homeserver($uname,$udom));
1.169     harris41 1834: }
                   1835: 
                   1836: # -------------------------------------------------- Modify user authentication
1.197     www      1837: # Overrides without validation
                   1838: 
1.169     harris41 1839: sub modifyuserauth {
                   1840:     my ($udom,$uname,$umode,$upass)=@_;
                   1841:     my $uhome=&homeserver($uname,$udom);
1.197     www      1842:     unless (&allowed('mau',$udom)) { return 'refused'; }
                   1843:     &logthis('Call to modify user authentication '.$udom.', '.$uname.', '.
1.169     harris41 1844:              $umode.' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'});  
                   1845:     my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'.
                   1846: 		     &escape($upass),$uhome);
1.197     www      1847:     &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.home'},
                   1848:         'Authentication changed for '.$udom.', '.$uname.', '.$umode.
                   1849:          '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply);
                   1850:     &log($udom,,$uname,$uhome,
                   1851:         'Authentication changed by '.$ENV{'user.domain'}.', '.
                   1852:                                      $ENV{'user.name'}.', '.$umode.
                   1853:          '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply);
1.169     harris41 1854:     unless ($reply eq 'ok') {
1.197     www      1855:         &logthis('Authentication mode error: '.$reply);
1.169     harris41 1856: 	return 'error: '.$reply;
                   1857:     }   
1.170     harris41 1858:     return 'ok';
1.80      www      1859: }
                   1860: 
1.81      www      1861: # --------------------------------------------------------------- Modify a user
1.80      www      1862: 
1.81      www      1863: sub modifyuser {
1.206     matthew  1864:     my ($udom,    $uname, $uid,
                   1865:         $umode,   $upass, $first,
                   1866:         $middle,  $last,  $gene,
                   1867:         $forceid, $desiredhome)=@_;
1.198     www      1868:     $udom=~s/\W//g;
                   1869:     $uname=~s/\W//g;
1.81      www      1870:     &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
1.80      www      1871:              $umode.', '.$first.', '.$middle.', '.
1.206     matthew  1872: 	     $last.', '.$gene.'(forceid: '.$forceid.')'.
                   1873:              (defined($desiredhome) ? ' desiredhome = '.$desiredhome :
                   1874:                                      ' desiredhome not specified'). 
                   1875:              ' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'});
1.80      www      1876:     my $uhome=&homeserver($uname,$udom);
                   1877: # ----------------------------------------------------------------- Create User
1.81      www      1878:     if (($uhome eq 'no_host') && ($umode) && ($upass)) {
1.80      www      1879:         my $unhome='';
1.209     matthew  1880:         if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) { 
                   1881:             $unhome = $desiredhome;
                   1882: 	} elsif($ENV{'course.'.$ENV{'request.course.id'}.'.domain'} eq $udom) {
1.80      www      1883: 	    $unhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'};
1.209     matthew  1884:         } else { # load balancing routine for determining $unhome
1.80      www      1885:             my $tryserver;
1.81      www      1886:             my $loadm=10000000;
1.80      www      1887:             foreach $tryserver (keys %libserv) {
                   1888: 	       if ($hostdom{$tryserver} eq $udom) {
                   1889:                   my $answer=reply('load',$tryserver);
                   1890:                   if (($answer=~/\d+/) && ($answer<$loadm)) {
                   1891: 		      $loadm=$answer;
                   1892:                       $unhome=$tryserver;
                   1893:                   }
                   1894: 	       }
                   1895: 	    }
                   1896:         }
                   1897:         if (($unhome eq '') || ($unhome eq 'no_host')) {
1.206     matthew  1898: 	    return 'error: unable to find a home server for '.$uname.
                   1899:                    ' in domain '.$udom;
1.80      www      1900:         }
                   1901:         my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':'.$umode.':'.
                   1902:                          &escape($upass),$unhome);
                   1903: 	unless ($reply eq 'ok') {
                   1904:             return 'error: '.$reply;
                   1905:         }   
                   1906:         $uhome=&homeserver($uname,$udom);
                   1907:         if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) {
                   1908: 	    return 'error: verify home';
                   1909:         }
1.209     matthew  1910:     }   # End of creation of new user
1.80      www      1911: # ---------------------------------------------------------------------- Add ID
                   1912:     if ($uid) {
                   1913:        $uid=~tr/A-Z/a-z/;
                   1914:        my %uidhash=&idrget($udom,$uname);
1.196     www      1915:        if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/) 
                   1916:          && (!$forceid)) {
1.80      www      1917: 	  unless ($uid eq $uidhash{$uname}) {
                   1918: 	      return 'error: mismatch '.$uidhash{$uname}.' versus '.$uid;
                   1919:           }
                   1920:        } else {
                   1921: 	  &idput($udom,($uname => $uid));
                   1922:        }
                   1923:     }
                   1924: # -------------------------------------------------------------- Add names, etc
1.134     albertel 1925:     my %names=&get('environment',
                   1926: 		   ['firstname','middlename','lastname','generation'],
                   1927: 		   $udom,$uname);
1.207     albertel 1928:     if ($names{'firstname'} =~ m/^error:.*/) { %names=(); }
1.134     albertel 1929:     if ($first)  { $names{'firstname'}  = $first; }
                   1930:     if ($middle) { $names{'middlename'} = $middle; }
                   1931:     if ($last)   { $names{'lastname'}   = $last; }
                   1932:     if ($gene)   { $names{'generation'} = $gene; }
                   1933:     my $reply = &put('environment', \%names, $udom,$uname);
                   1934:     if ($reply ne 'ok') { return 'error: '.$reply; }
1.81      www      1935:     &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
1.80      www      1936:              $umode.', '.$first.', '.$middle.', '.
                   1937: 	     $last.', '.$gene.' by '.
                   1938:              $ENV{'user.name'}.' at '.$ENV{'user.domain'});
1.134     albertel 1939:     return 'ok';
1.80      www      1940: }
                   1941: 
1.81      www      1942: # -------------------------------------------------------------- Modify student
1.80      www      1943: 
1.81      www      1944: sub modifystudent {
                   1945:     my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
1.209     matthew  1946:         $end,$start,$forceid,$desiredhome)=@_;
1.81      www      1947:     my $cid='';
                   1948:     unless ($cid=$ENV{'request.course.id'}) {
1.80      www      1949: 	return 'not_in_class';
                   1950:     }
                   1951: # --------------------------------------------------------------- Make the user
1.81      www      1952:     my $reply=&modifyuser
1.209     matthew  1953: 	($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid,
                   1954:          $desiredhome);
1.80      www      1955:     unless ($reply eq 'ok') { return $reply; }
1.81      www      1956:     my $uhome=&homeserver($uname,$udom);
                   1957:     if (($uhome eq '') || ($uhome eq 'no_host')) { 
                   1958: 	return 'error: no such user';
                   1959:     }
1.80      www      1960: # -------------------------------------------------- Add student to course list
1.160     www      1961:     $reply=critical('put:'.$ENV{'course.'.$cid.'.domain'}.':'.
1.81      www      1962: 	              $ENV{'course.'.$cid.'.num'}.':classlist:'.
                   1963:                       &escape($uname.':'.$udom).'='.
                   1964:                       &escape($end.':'.$start),
                   1965: 	              $ENV{'course.'.$cid.'.home'});
                   1966:     unless (($reply eq 'ok') || ($reply eq 'delayed')) {
                   1967: 	return 'error: '.$reply;
                   1968:     }
1.80      www      1969: # ---------------------------------------------------- Add student role to user
1.83      www      1970:     my $uurl='/'.$cid;
1.81      www      1971:     $uurl=~s/\_/\//g;
                   1972:     if ($usec) {
                   1973: 	$uurl.='/'.$usec;
                   1974:     }
                   1975:     return &assignrole($udom,$uname,$uurl,'st',$end,$start);
1.21      www      1976: }
                   1977: 
1.84      www      1978: # ------------------------------------------------- Write to course preferences
                   1979: 
                   1980: sub writecoursepref {
                   1981:     my ($courseid,%prefs)=@_;
                   1982:     $courseid=~s/^\///;
                   1983:     $courseid=~s/\_/\//g;
                   1984:     my ($cdomain,$cnum)=split(/\//,$courseid);
                   1985:     my $chome=homeserver($cnum,$cdomain);
                   1986:     if (($chome eq '') || ($chome eq 'no_host')) { 
                   1987: 	return 'error: no such course';
                   1988:     }
                   1989:     my $cstring='';
1.191     harris41 1990:     foreach (keys %prefs) {
1.84      www      1991: 	$cstring.=escape($_).'='.escape($prefs{$_}).'&';
1.191     harris41 1992:     }
1.84      www      1993:     $cstring=~s/\&$//;
                   1994:     return reply('put:'.$cdomain.':'.$cnum.':environment:'.$cstring,$chome);
                   1995: }
                   1996: 
                   1997: # ---------------------------------------------------------- Make/modify course
                   1998: 
                   1999: sub createcourse {
                   2000:     my ($udom,$description,$url)=@_;
                   2001:     $url=&declutter($url);
                   2002:     my $cid='';
                   2003:     unless (&allowed('ccc',$ENV{'user.domain'})) {
                   2004:         return 'refused';
                   2005:     }
                   2006:     unless ($udom eq $ENV{'user.domain'}) {
                   2007:         return 'refused';
                   2008:     }
                   2009: # ------------------------------------------------------------------- Create ID
                   2010:    my $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).
                   2011:        unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
                   2012: # ----------------------------------------------- Make sure that does not exist
                   2013:    my $uhome=&homeserver($uname,$udom);
                   2014:    unless (($uhome eq '') || ($uhome eq 'no_host')) {
                   2015:        $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).
                   2016:         unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
                   2017:        $uhome=&homeserver($uname,$udom);       
                   2018:        unless (($uhome eq '') || ($uhome eq 'no_host')) {
                   2019:            return 'error: unable to generate unique course-ID';
                   2020:        } 
                   2021:    }
                   2022: # ------------------------------------------------------------- Make the course
                   2023:     my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',
                   2024:                       $ENV{'user.home'});
                   2025:     unless ($reply eq 'ok') { return 'error: '.$reply; }
1.160     www      2026:     $uhome=&homeserver($uname,$udom);
1.84      www      2027:     if (($uhome eq '') || ($uhome eq 'no_host')) { 
                   2028: 	return 'error: no such course';
                   2029:     }
                   2030:     &writecoursepref($udom.'_'.$uname,
                   2031:                      ('description' => $description,
                   2032:                       'url'         => $url));
                   2033:     return '/'.$udom.'/'.$uname;
                   2034: }
                   2035: 
1.21      www      2036: # ---------------------------------------------------------- Assign Custom Role
                   2037: 
                   2038: sub assigncustomrole {
                   2039:     my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start)=@_;
                   2040:     return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename,
                   2041:                        $end,$start);
                   2042: }
                   2043: 
                   2044: # ----------------------------------------------------------------- Revoke Role
                   2045: 
                   2046: sub revokerole {
                   2047:     my ($udom,$uname,$url,$role)=@_;
                   2048:     my $now=time;
                   2049:     return &assignrole($udom,$uname,$url,$role,$now);
                   2050: }
                   2051: 
                   2052: # ---------------------------------------------------------- Revoke Custom Role
                   2053: 
                   2054: sub revokecustomrole {
                   2055:     my ($udom,$uname,$url,$rdom,$rnam,$rolename)=@_;
                   2056:     my $now=time;
                   2057:     return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now);
1.17      www      2058: }
                   2059: 
                   2060: # ------------------------------------------------------------ Directory lister
                   2061: 
                   2062: sub dirlist {
                   2063:     my $uri=shift;
1.18      www      2064:     $uri=~s/^\///;
                   2065:     $uri=~s/\/$//;
1.19      www      2066:     my ($res,$udom,$uname,@rest)=split(/\//,$uri);
                   2067:     if ($udom) {
                   2068:      if ($uname) {
                   2069:        my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/'.$uri,
                   2070:                       homeserver($uname,$udom));
                   2071:        return split(/:/,$listing);
                   2072:      } else {
                   2073:        my $tryserver;
                   2074:        my %allusers=();
                   2075:        foreach $tryserver (keys %libserv) {
                   2076: 	  if ($hostdom{$tryserver} eq $udom) {
                   2077:              my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.$udom,
                   2078: 			       $tryserver);
                   2079:              if (($listing ne 'no_such_dir') && ($listing ne 'empty')
                   2080:               && ($listing ne 'con_lost')) {
1.191     harris41 2081:                 foreach (split(/:/,$listing)) {
1.19      www      2082:                   my ($entry,@stat)=split(/&/,$_);
                   2083:                   $allusers{$entry}=1;
1.191     harris41 2084:                 }
1.19      www      2085:              }
                   2086: 	  }
                   2087:        }
                   2088:        my $alluserstr='';
1.191     harris41 2089:        foreach (sort keys %allusers) {
1.19      www      2090:            $alluserstr.=$_.'&user:';
1.191     harris41 2091:        }
1.19      www      2092:        $alluserstr=~s/:$//;
                   2093:        return split(/:/,$alluserstr);
                   2094:      } 
                   2095:    } else {
                   2096:        my $tryserver;
                   2097:        my %alldom=();
                   2098:        foreach $tryserver (keys %libserv) {
                   2099: 	   $alldom{$hostdom{$tryserver}}=1;
                   2100:        }
                   2101:        my $alldomstr='';
1.191     harris41 2102:        foreach (sort keys %alldom) {
1.19      www      2103:           $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'&domain:';
1.191     harris41 2104:        }
1.19      www      2105:        $alldomstr=~s/:$//;
                   2106:        return split(/:/,$alldomstr);       
                   2107:    }
1.26      www      2108: }
                   2109: 
                   2110: # -------------------------------------------------------- Value of a Condition
                   2111: 
1.40      www      2112: sub directcondval {
                   2113:     my $number=shift;
                   2114:     if ($ENV{'user.state.'.$ENV{'request.course.id'}}) {
                   2115:        return substr($ENV{'user.state.'.$ENV{'request.course.id'}},$number,1);
                   2116:     } else {
                   2117:        return 2;
                   2118:     }
                   2119: }
                   2120: 
1.26      www      2121: sub condval {
                   2122:     my $condidx=shift;
                   2123:     my $result=0;
1.54      www      2124:     my $allpathcond='';
1.191     harris41 2125:     foreach (split(/\|/,$condidx)) {
1.54      www      2126:        if (defined($ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_})) {
                   2127: 	   $allpathcond.=
                   2128:                '('.$ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_}.')|';
                   2129:        }
1.191     harris41 2130:     }
1.54      www      2131:     $allpathcond=~s/\|$//;
1.33      www      2132:     if ($ENV{'request.course.id'}) {
1.54      www      2133:        if ($allpathcond) {
1.26      www      2134:           my $operand='|';
                   2135: 	  my @stack;
1.191     harris41 2136:            foreach ($allpathcond=~/(\d+|\(|\)|\&|\|)/g) {
1.26      www      2137:               if ($_ eq '(') {
                   2138:                  push @stack,($operand,$result)
                   2139:               } elsif ($_ eq ')') {
                   2140:                   my $before=pop @stack;
                   2141: 		  if (pop @stack eq '&') {
                   2142: 		      $result=$result>$before?$before:$result;
                   2143:                   } else {
                   2144:                       $result=$result>$before?$result:$before;
                   2145:                   }
                   2146:               } elsif (($_ eq '&') || ($_ eq '|')) {
                   2147:                   $operand=$_;
                   2148:               } else {
1.40      www      2149:                   my $new=directcondval($_);
1.26      www      2150:                   if ($operand eq '&') {
                   2151:                      $result=$result>$new?$new:$result;
                   2152:                   } else {
                   2153:                      $result=$result>$new?$result:$new;
1.191     harris41 2154:                   }
1.26      www      2155:               }
1.191     harris41 2156:           }
1.26      www      2157:        }
                   2158:     }
                   2159:     return $result;
1.28      www      2160: }
                   2161: 
1.200     www      2162: # --------------------------------------------------- Course Resourcedata Query
                   2163: 
                   2164: sub courseresdata {
                   2165:     my ($coursenum,$coursedomain,@which)=@_;
                   2166:     my $coursehom=&homeserver($coursenum,$coursedomain);
                   2167:     my $hashid=$coursenum.':'.$coursedomain;
                   2168:     unless (defined($courseresdatacache{$hashid.'.time'})) {
                   2169: 	unless (time-$courseresdatacache{$hashid.'.time'}<300) {
                   2170:            my $coursehom=&homeserver($coursenum,$coursedomain);
                   2171:            if ($coursehom) {
                   2172:               my $dumpreply=&reply('dump:'.$coursedomain.':'.$coursenum.
                   2173: 			     ':resourcedata:.',$coursehom);
                   2174: 	      unless ($dumpreply=~/^error\:/) {
                   2175: 	         $courseresdatacache{$hashid.'.time'}=time;
                   2176:                  $courseresdatacache{$hashid}=$dumpreply;
                   2177: 	     }
                   2178: 	  }
                   2179:        }
                   2180:     }
                   2181:    my @pairs=split(/\&/,$courseresdatacache{$hashid});
                   2182:    my %returnhash=();
                   2183:    foreach (@pairs) {
                   2184:       my ($key,$value)=split(/=/,$_);
                   2185:       $returnhash{unescape($key)}=unescape($value);
                   2186:    }
                   2187:     my $item;
                   2188:    foreach $item (@which) {
                   2189:        if ($returnhash{$item}) { return $returnhash{$item}; }
                   2190:    }
                   2191:    return '';
                   2192: }
                   2193: 
1.28      www      2194: # --------------------------------------------------------- Value of a Variable
                   2195: 
1.58      www      2196: sub EXT {
1.147     www      2197:     my ($varname,$symbparm)=@_;
1.68      www      2198:     unless ($varname) { return ''; }
1.48      www      2199:     my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);
                   2200:     my $rest;
                   2201:     if ($therest[0]) {
                   2202:        $rest=join('.',@therest);
                   2203:     } else {
                   2204:        $rest='';
                   2205:     }
1.57      www      2206:     my $qualifierrest=$qualifier;
                   2207:     if ($rest) { $qualifierrest.='.'.$rest; }
                   2208:     my $spacequalifierrest=$space;
                   2209:     if ($qualifierrest) { $spacequalifierrest.='.'.$qualifierrest; }
1.28      www      2210:     if ($realm eq 'user') {
1.48      www      2211: # --------------------------------------------------------------- user.resource
                   2212: 	if ($space eq 'resource') {
1.122     albertel 2213: 	    my %restored=&restore();
1.57      www      2214:             return $restored{$qualifierrest};
1.48      www      2215: # ----------------------------------------------------------------- user.access
                   2216:         } elsif ($space eq 'access') {
                   2217:             return &allowed($qualifier,$rest);
                   2218: # ------------------------------------------ user.preferences, user.environment
                   2219:         } elsif (($space eq 'preferences') || ($space eq 'environment')) {
1.57      www      2220:             return $ENV{join('.',('environment',$qualifierrest))};
1.48      www      2221: # ----------------------------------------------------------------- user.course
                   2222:         } elsif ($space eq 'course') {
                   2223:             return $ENV{join('.',('request.course',$qualifier))};
                   2224: # ------------------------------------------------------------------- user.role
                   2225:         } elsif ($space eq 'role') {
                   2226:             my ($role,$where)=split(/\./,$ENV{'request.role'});
                   2227:             if ($qualifier eq 'value') {
                   2228: 		return $role;
                   2229:             } elsif ($qualifier eq 'extent') {
                   2230:                 return $where;
                   2231:             }
                   2232: # ----------------------------------------------------------------- user.domain
                   2233:         } elsif ($space eq 'domain') {
                   2234:             return $ENV{'user.domain'};
                   2235: # ------------------------------------------------------------------- user.name
                   2236:         } elsif ($space eq 'name') {
                   2237:             return $ENV{'user.name'};
                   2238: # ---------------------------------------------------- Any other user namespace
1.29      www      2239:         } else {
1.48      www      2240:             my $item=($rest)?$qualifier.'.'.$rest:$qualifier;
1.131     albertel 2241:             my %reply=&get($space,[$item]);
1.48      www      2242:             return $reply{$item};
                   2243:         }
                   2244:     } elsif ($realm eq 'request') {
                   2245: # ------------------------------------------------------------- request.browser
                   2246:         if ($space eq 'browser') {
                   2247: 	    return $ENV{'browser.'.$qualifier};
1.57      www      2248: # ------------------------------------------------------------ request.filename
                   2249:         } else {
                   2250:             return $ENV{'request.'.$spacequalifierrest};
1.29      www      2251:         }
1.28      www      2252:     } elsif ($realm eq 'course') {
1.48      www      2253: # ---------------------------------------------------------- course.description
1.127     ng       2254:         return $ENV{'course.'.$ENV{'request.course.id'}.'.'.
1.57      www      2255:                               $spacequalifierrest};
                   2256:     } elsif ($realm eq 'resource') {
1.127     ng       2257:        if ($ENV{'request.course.id'}) {
1.165     www      2258: 
                   2259: #	   print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;
                   2260: 
                   2261: 
1.60      www      2262: # ----------------------------------------------------- Cascading lookup scheme
1.147     www      2263:          my $symbp;
                   2264:          if ($symbparm) {
                   2265:             $symbp=$symbparm;
                   2266: 	 } else {
                   2267:             $symbp=&symbread();
                   2268:          }            
1.127     ng       2269:          my $mapp=(split(/\_\_\_/,$symbp))[0];
1.69      www      2270: 
1.127     ng       2271:          my $symbparm=$symbp.'.'.$spacequalifierrest;
                   2272:          my $mapparm=$mapp.'___(all).'.$spacequalifierrest;
1.69      www      2273: 
1.127     ng       2274:          my $seclevel=
1.69      www      2275:             $ENV{'request.course.id'}.'.['.
                   2276: 		$ENV{'request.course.sec'}.'].'.$spacequalifierrest;
1.127     ng       2277:          my $seclevelr=
1.69      www      2278:             $ENV{'request.course.id'}.'.['.
                   2279: 		$ENV{'request.course.sec'}.'].'.$symbparm;
1.127     ng       2280:          my $seclevelm=
1.69      www      2281:             $ENV{'request.course.id'}.'.['.
                   2282: 		$ENV{'request.course.sec'}.'].'.$mapparm;
                   2283: 
1.127     ng       2284:          my $courselevel=
1.60      www      2285:             $ENV{'request.course.id'}.'.'.$spacequalifierrest;
1.127     ng       2286:          my $courselevelr=
1.69      www      2287:             $ENV{'request.course.id'}.'.'.$symbparm;
1.127     ng       2288:          my $courselevelm=
1.69      www      2289:             $ENV{'request.course.id'}.'.'.$mapparm;
                   2290: 
1.60      www      2291: # ----------------------------------------------------------- first, check user
1.127     ng       2292:          my %resourcedata=get('resourcedata',
1.131     albertel 2293:                            [$courselevelr,$courselevelm,$courselevel]);
1.127     ng       2294:          if (($resourcedata{$courselevelr}!~/^error\:/) &&
                   2295:              ($resourcedata{$courselevelr}!~/^con_lost/)) {
1.69      www      2296: 
1.127     ng       2297:          if ($resourcedata{$courselevelr}) { 
                   2298:             return $resourcedata{$courselevelr}; }
                   2299:          if ($resourcedata{$courselevelm}) { 
                   2300:             return $resourcedata{$courselevelm}; }
                   2301:          if ($resourcedata{$courselevel}) { return $resourcedata{$courselevel}; }
1.69      www      2302: 
1.94      www      2303:       } else {
                   2304: 	  if ($resourcedata{$courselevelr}!~/No such file/) {
                   2305: 	    &logthis("<font color=blue>WARNING:".
                   2306: 		   " Trying to get resource data for ".$ENV{'user.name'}." at "
                   2307:                    .$ENV{'user.domain'}.": ".$resourcedata{$courselevelr}.
                   2308:                  "</font>");
                   2309: 	  }
1.63      www      2310:       }
1.95      www      2311: 
1.60      www      2312: # -------------------------------------------------------- second, check course
1.96      www      2313: 
1.200     www      2314:         my $coursereply=&courseresdata(
                   2315:                         $ENV{'course.'.$ENV{'request.course.id'}.'.num'},
                   2316:                         $ENV{'course.'.$ENV{'request.course.id'}.'.domain'},
                   2317:                         ($seclevelr,$seclevelm,$seclevel,
                   2318:                          $courselevelr,$courselevelm,$courselevel));
                   2319:         if ($coursereply) { return $coursereply; }
                   2320: 
1.60      www      2321: # ------------------------------------------------------ third, check map parms
1.65      www      2322:        my %parmhash=();
                   2323:        my $thisparm='';       
                   2324:        if (tie(%parmhash,'GDBM_File',
                   2325:           $ENV{'request.course.fn'}.'_parms.db',&GDBM_READER,0640)) {
                   2326:            $thisparm=$parmhash{$symbparm};
                   2327: 	   untie(%parmhash);
1.60      www      2328:        }
1.65      www      2329:        if ($thisparm) { return $thisparm; }
1.60      www      2330:      }
                   2331:      
                   2332: # --------------------------------------------- last, look in resource metadata
1.71      www      2333: 
1.78      www      2334:       $spacequalifierrest=~s/\./\_/;
1.71      www      2335:       my $metadata=&metadata($ENV{'request.filename'},$spacequalifierrest);
                   2336:       if ($metadata) { return $metadata; }
1.78      www      2337:       $metadata=&metadata($ENV{'request.filename'},
                   2338:                                          'parameter_'.$spacequalifierrest);
                   2339:       if ($metadata) { return $metadata; }
1.142     www      2340: 
1.145     www      2341: # ------------------------------------------------------------------ Cascade up
                   2342: 
                   2343:       unless ($space eq '0') {
1.165     www      2344:           my ($part,$id)=split(/\_/,$space);
1.145     www      2345:           if ($id) {
1.147     www      2346: 	      my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,
                   2347:                                    $symbparm);
1.145     www      2348:               if ($partgeneral) { return $partgeneral; }
                   2349:           } else {
1.147     www      2350:               my $resourcegeneral=&EXT('resource.0.'.$qualifierrest,
                   2351:                                        $symbparm);
1.145     www      2352:               if ($resourcegeneral) { return $resourcegeneral; }
                   2353:           }
                   2354:       }
1.71      www      2355: 
1.48      www      2356: # ---------------------------------------------------- Any other user namespace
                   2357:     } elsif ($realm eq 'environment') {
                   2358: # ----------------------------------------------------------------- environment
1.127     ng       2359:         return $ENV{'environment.'.$spacequalifierrest};
1.28      www      2360:     } elsif ($realm eq 'system') {
1.48      www      2361: # ----------------------------------------------------------------- system.time
                   2362: 	if ($space eq 'time') {
                   2363: 	    return time;
                   2364:         }
1.28      www      2365:     }
1.48      www      2366:     return '';
1.61      www      2367: }
                   2368: 
1.71      www      2369: # ---------------------------------------------------------------- Get metadata
                   2370: 
                   2371: sub metadata {
1.176     www      2372:     my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
1.78      www      2373: 
1.71      www      2374:     $uri=&declutter($uri);
1.73      www      2375:     my $filename=$uri;
                   2376:     $uri=~s/\.meta$//;
1.172     www      2377: #
                   2378: # Is the metadata already cached?
1.177     www      2379: # Look at timestamp of caching
1.172     www      2380: # Everything is cached by the main uri, libraries are never directly cached
                   2381: #
1.174     www      2382:     unless (abs($metacache{$uri.':cachedtimestamp'}-time)<600) {
1.172     www      2383: #
                   2384: # Is this a recursive call for a library?
                   2385: #
1.171     www      2386:         if ($liburi) {
                   2387: 	    $liburi=&declutter($liburi);
                   2388:             $filename=$liburi;
                   2389:         }
1.140     www      2390:         my %metathesekeys=();
1.73      www      2391:         unless ($filename=~/\.meta$/) { $filename.='.meta'; }
                   2392: 	my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename);
1.208     albertel 2393:         my $parser=HTML::LCParser->new(\$metastring);
1.71      www      2394:         my $token;
1.140     www      2395:         undef %metathesekeys;
1.71      www      2396:         while ($token=$parser->get_token) {
                   2397:            if ($token->[0] eq 'S') {
1.135     www      2398: 	     if (defined($token->[2]->{'package'})) {
1.172     www      2399: #
                   2400: # This is a package - get package info
                   2401: #
1.136     www      2402: 	      my $package=$token->[2]->{'package'};
                   2403: 	      my $keyroot='';
1.172     www      2404:               if ($prefix) {
                   2405: 		  $keyroot.='_'.$prefix;
                   2406:               } else {
                   2407:                 if (defined($token->[2]->{'part'})) { 
                   2408:                    $keyroot.='_'.$token->[2]->{'part'}; 
                   2409: 	        }
1.136     www      2410: 	      }
                   2411:               if (defined($token->[2]->{'id'})) { 
1.165     www      2412:                  $keyroot.='_'.$token->[2]->{'id'}; 
1.136     www      2413: 	      }
                   2414:               if ($metacache{$uri.':packages'}) {
                   2415:                  $metacache{$uri.':packages'}.=','.$package.$keyroot;
                   2416:               } else {
                   2417:                  $metacache{$uri.':packages'}=$package.$keyroot;
                   2418: 	      }
1.191     harris41 2419:               foreach (keys %packagetab) {
1.137     www      2420: 		  if ($_=~/^$package\&/) {
                   2421: 		      my ($pack,$name,$subp)=split(/\&/,$_);
1.139     www      2422:                       my $value=$packagetab{$_};
1.144     www      2423: 		      my $part=$keyroot;
                   2424:                       $part=~s/^\_//;
1.139     www      2425:                       if ($subp eq 'display') {
                   2426: 			  $value.=' [Part: '.$part.']';
                   2427:                       }
                   2428:                       my $unikey='parameter'.$keyroot.'_'.$name;
1.140     www      2429:                       $metathesekeys{$unikey}=1;
1.144     www      2430:                       $metacache{$uri.':'.$unikey.'.part'}=$part;
1.141     www      2431:                       unless 
                   2432:                        (defined($metacache{$uri.':'.$unikey.'.'.$subp})) {
                   2433:                          $metacache{$uri.':'.$unikey.'.'.$subp}=$value;
                   2434: 		      }
1.137     www      2435:                   }
1.191     harris41 2436:               }
1.135     www      2437:              } else {
1.172     www      2438: #
                   2439: # This is not a package - some other kind of start tag
                   2440: # 
1.175     www      2441:               my $entry=$token->[1];
1.176     www      2442:               my $unikey;
                   2443:               if ($entry eq 'import') {
                   2444:                  $unikey='';
                   2445:               } else {
                   2446:                  $unikey=$entry;
                   2447: 	      }
1.172     www      2448:               if ($prefix) {
1.176     www      2449: 		  $unikey.=$prefix;
1.172     www      2450:               } else {
                   2451:                 if (defined($token->[2]->{'part'})) { 
                   2452:                    $unikey.='_'.$token->[2]->{'part'}; 
                   2453: 	        }
1.136     www      2454: 	      }
                   2455:               if (defined($token->[2]->{'id'})) { 
1.165     www      2456:                  $unikey.='_'.$token->[2]->{'id'}; 
1.71      www      2457: 	      }
1.175     www      2458: 
                   2459:              if ($entry eq 'import') {
                   2460: #
                   2461: # Importing a library here
1.176     www      2462: #                
                   2463: 		 if (defined($depthcount)) { $depthcount++; } else 
                   2464:                                            { $depthcount=0; }
                   2465:                  if ($depthcount<20) {
1.191     harris41 2466: 		     foreach (split(/\,/,&metadata($uri,'keys',
                   2467:                                   $parser->get_text('/import'),$unikey,
                   2468:                                   $depthcount))) {
1.177     www      2469:                          $metathesekeys{$_}=1;
1.191     harris41 2470: 		     }
1.176     www      2471: 		 }
1.175     www      2472:              } else { 
                   2473: 
1.72      www      2474:               if (defined($token->[2]->{'name'})) { 
1.71      www      2475:                  $unikey.='_'.$token->[2]->{'name'}; 
                   2476: 	      }
1.140     www      2477:               $metathesekeys{$unikey}=1;
1.191     harris41 2478:               foreach (@{$token->[3]}) {
1.71      www      2479: 		  $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};
1.191     harris41 2480:               }
1.78      www      2481:               unless (
1.208     albertel 2482:                  $metacache{$uri.':'.$unikey}=&HTML::Entities::decode($parser->get_text('/'.$entry))
1.78      www      2483: 		      ) { $metacache{$uri.':'.$unikey}=
                   2484: 			      $metacache{$uri.':'.$unikey.'.default'};
                   2485: 		      }
1.172     www      2486: # end of not-a-package not-a-library import
1.175     www      2487: 	   }
1.172     www      2488: # end of not-a-package start tag
                   2489: 	  }
                   2490: # the next is the end of "start tag"
1.140     www      2491: 	 }
1.71      www      2492:        }
1.140     www      2493:        $metacache{$uri.':keys'}=join(',',keys %metathesekeys);
1.174     www      2494:        $metacache{$uri.':cachedtimestamp'}=time;
1.177     www      2495: # this is the end of "was not already recently cached
1.71      www      2496:     }
                   2497:     return $metacache{$uri.':'.$what};
                   2498: }
                   2499: 
1.31      www      2500: # ------------------------------------------------- Update symbolic store links
                   2501: 
                   2502: sub symblist {
                   2503:     my ($mapname,%newhash)=@_;
                   2504:     $mapname=declutter($mapname);
                   2505:     my %hash;
                   2506:     if (($ENV{'request.course.fn'}) && (%newhash)) {
                   2507:         if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',
                   2508:                       &GDBM_WRCREAT,0640)) {
1.191     harris41 2509: 	    foreach (keys %newhash) {
1.211   ! www      2510:                 $hash{declutter($_)}=$mapname.'___'.$newhash{$_};
1.191     harris41 2511:             }
1.31      www      2512:             if (untie(%hash)) {
                   2513: 		return 'ok';
                   2514:             }
                   2515:         }
                   2516:     }
                   2517:     return 'error';
                   2518: }
                   2519: 
1.210     www      2520: # --------------------------------------------------------------- Clean-up symb
                   2521: 
                   2522: sub symbclean {
                   2523:     my $symb=shift;
                   2524: # remove version from map
                   2525:     $symb=~s/\.(\d+)\.(\w+)\_\_\_/\.$2\_\_\_/;
                   2526: # remove version from URL
                   2527:     $symb=~s/\.(\d+)\.(\w+)$/\.$2/;
                   2528:     return $symb;
                   2529: }
                   2530: 
1.31      www      2531: # ------------------------------------------------------ Return symb list entry
                   2532: 
                   2533: sub symbread {
1.44      www      2534:     my $thisfn=shift;
                   2535:     unless ($thisfn) {
1.210     www      2536:         if ($ENV{'request.symb'}) { return &symbclean($ENV{'request.symb'}); }
1.44      www      2537: 	$thisfn=$ENV{'request.filename'};
                   2538:     }
                   2539:     $thisfn=declutter($thisfn);
1.31      www      2540:     my %hash;
1.37      www      2541:     my %bighash;
                   2542:     my $syval='';
1.45      www      2543:     if (($ENV{'request.course.fn'}) && ($thisfn)) {
1.31      www      2544:         if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',
                   2545:                       &GDBM_READER,0640)) {
                   2546: 	    $syval=$hash{$thisfn};
1.37      www      2547:             untie(%hash);
                   2548:         }
                   2549: # ---------------------------------------------------------- There was an entry
                   2550:         if ($syval) {
                   2551:            unless ($syval=~/\_\d+$/) {
                   2552: 	       unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) {
1.44      www      2553:                   &appenv('request.ambiguous' => $thisfn);
1.37      www      2554:                   return '';
                   2555:                }    
                   2556:                $syval.=$1;
                   2557: 	   }
                   2558:         } else {
                   2559: # ------------------------------------------------------- Was not in symb table
                   2560:            if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
                   2561:                             &GDBM_READER,0640)) {
                   2562: # ---------------------------------------------- Get ID(s) for current resource
                   2563:               my $ids=$bighash{'ids_/res/'.$thisfn};
1.65      www      2564:               unless ($ids) { 
                   2565:                  $ids=$bighash{'ids_/'.$thisfn};
                   2566:               }
1.37      www      2567:               if ($ids) {
                   2568: # ------------------------------------------------------------------- Has ID(s)
                   2569:                  my @possibilities=split(/\,/,$ids);
1.39      www      2570:                  if ($#possibilities==0) {
                   2571: # ----------------------------------------------- There is only one possibility
1.37      www      2572: 		     my ($mapid,$resid)=split(/\./,$ids);
                   2573:                      $syval=declutter($bighash{'map_id_'.$mapid}).'___'.$resid;
                   2574:                  } else {
1.39      www      2575: # ------------------------------------------ There is more than one possibility
                   2576:                      my $realpossible=0;
1.191     harris41 2577:                      foreach (@possibilities) {
1.39      www      2578: 			 my $file=$bighash{'src_'.$_};
                   2579:                          if (&allowed('bre',$file)) {
                   2580:          		    my ($mapid,$resid)=split(/\./,$_);
                   2581:                             if ($bighash{'map_type_'.$mapid} ne 'page') {
                   2582: 				$realpossible++;
                   2583:                                 $syval=declutter($bighash{'map_id_'.$mapid}).
                   2584:                                        '___'.$resid;
                   2585:                             }
                   2586: 			 }
1.191     harris41 2587:                      }
1.39      www      2588: 		     if ($realpossible!=1) { $syval=''; }
1.37      www      2589:                  }
                   2590: 	      }
                   2591:               untie(%bighash)
                   2592:            } 
1.31      www      2593:         }
1.62      www      2594:         if ($syval) {
1.210     www      2595:            return &symbclean($syval.'___'.$thisfn); 
1.62      www      2596:         }
1.31      www      2597:     }
1.44      www      2598:     &appenv('request.ambiguous' => $thisfn);
1.31      www      2599:     return '';
                   2600: }
                   2601: 
                   2602: # ---------------------------------------------------------- Return random seed
                   2603: 
1.32      www      2604: sub numval {
                   2605:     my $txt=shift;
                   2606:     $txt=~tr/A-J/0-9/;
                   2607:     $txt=~tr/a-j/0-9/;
                   2608:     $txt=~tr/K-T/0-9/;
                   2609:     $txt=~tr/k-t/0-9/;
                   2610:     $txt=~tr/U-Z/0-5/;
                   2611:     $txt=~tr/u-z/0-5/;
                   2612:     $txt=~s/\D//g;
                   2613:     return int($txt);
                   2614: }    
                   2615: 
1.31      www      2616: sub rndseed {
1.155     albertel 2617:     my ($symb,$courseid,$domain,$username)=@_;
                   2618:     if (!$symb) {
                   2619:       unless ($symb=&symbread()) { return time; }
                   2620:     }
                   2621:     if (!$courseid) { $courseid=$ENV{'request.course.id'};}
                   2622:     if (!$domain) {$domain=$ENV{'user.domain'};}
                   2623:     if (!$username) {$username=$ENV{'user.name'};}
                   2624:     {
1.98      albertel 2625:       use integer;
                   2626:       my $symbchck=unpack("%32C*",$symb) << 27;
1.100     albertel 2627:       my $symbseed=numval($symb) << 22;
1.155     albertel 2628:       my $namechck=unpack("%32C*",$username) << 17;
                   2629:       my $nameseed=numval($username) << 12;
                   2630:       my $domainseed=unpack("%32C*",$domain) << 7;
                   2631:       my $courseseed=unpack("%32C*",$courseid);
1.98      albertel 2632:       my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;
1.99      albertel 2633:       #uncommenting these lines can break things!
                   2634:       #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
                   2635:       #&Apache::lonxml::debug("rndseed :$num:$symb");
1.98      albertel 2636:       return $num;
                   2637:     }
1.36      albertel 2638: }
                   2639: 
1.76      www      2640: sub ireceipt {
                   2641:     my ($funame,$fudom,$fucourseid,$fusymb)=@_;
                   2642:     my $cuname=unpack("%32C*",$funame);
                   2643:     my $cudom=unpack("%32C*",$fudom);
                   2644:     my $cucourseid=unpack("%32C*",$fucourseid);
                   2645:     my $cusymb=unpack("%32C*",$fusymb);
1.77      www      2646:     my $cunique=unpack("%32C*",$perlvar{'lonReceipt'});
1.76      www      2647:     return unpack("%32C*",$perlvar{'lonHostID'}).'-'.
                   2648:            ($cunique%$cuname+
                   2649:             $cunique%$cudom+
                   2650:             $cusymb%$cuname+
                   2651:             $cusymb%$cudom+
                   2652:             $cucourseid%$cuname+
                   2653:             $cucourseid%$cudom);
                   2654: }
                   2655: 
                   2656: sub receipt {
                   2657:     return &ireceipt($ENV{'user.name'},$ENV{'user.domain'},
                   2658:                      $ENV{'request.course.id'},&symbread());
                   2659: }
                   2660:   
1.36      albertel 2661: # ------------------------------------------------------------ Serves up a file
                   2662: # returns either the contents of the file or a -1
                   2663: sub getfile {
                   2664:   my $file=shift;
1.37      www      2665:   &repcopy($file);
1.36      albertel 2666:   if (! -e $file ) { return -1; };
                   2667:   my $fh=Apache::File->new($file);
                   2668:   my $a='';
                   2669:   while (<$fh>) { $a .=$_; }
                   2670:   return $a
                   2671: }
                   2672: 
                   2673: sub filelocation {
                   2674:   my ($dir,$file) = @_;
                   2675:   my $location;
                   2676:   $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces
1.59      albertel 2677:   if ($file=~m:^/~:) { # is a contruction space reference
                   2678:     $location = $file;
                   2679:     $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;
1.36      albertel 2680:   } else {
1.59      albertel 2681:     $file=~s/^$perlvar{'lonDocRoot'}//;
                   2682:     $file=~s:^/*res::;
                   2683:     if ( !( $file =~ m:^/:) ) {
                   2684:       $location = $dir. '/'.$file;
                   2685:     } else {
                   2686:       $location = '/home/httpd/html/res'.$file;
                   2687:     }
1.36      albertel 2688:   }
                   2689:   $location=~s://+:/:g; # remove duplicate /
1.46      www      2690:   while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..
                   2691:   return $location;
                   2692: }
1.36      albertel 2693: 
1.46      www      2694: sub hreflocation {
                   2695:     my ($dir,$file)=@_;
1.191     harris41 2696:     unless (($file=~/^http:\/\//i) || ($file=~/^\//)) {
1.46      www      2697:        my $finalpath=filelocation($dir,$file);
                   2698:        $finalpath=~s/^\/home\/httpd\/html//;
                   2699:        return $finalpath;
                   2700:     } else {
                   2701:        return $file;
                   2702:     }
1.31      www      2703: }
                   2704: 
                   2705: # ------------------------------------------------------------- Declutters URLs
                   2706: 
                   2707: sub declutter {
                   2708:     my $thisfn=shift;
                   2709:     $thisfn=~s/^$perlvar{'lonDocRoot'}//;
                   2710:     $thisfn=~s/^\///;
                   2711:     $thisfn=~s/^res\///;
                   2712:     return $thisfn;
1.12      www      2713: }
                   2714: 
                   2715: # -------------------------------------------------------- Escape Special Chars
                   2716: 
                   2717: sub escape {
                   2718:     my $str=shift;
                   2719:     $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
                   2720:     return $str;
                   2721: }
                   2722: 
                   2723: # ----------------------------------------------------- Un-Escape Special Chars
                   2724: 
                   2725: sub unescape {
                   2726:     my $str=shift;
                   2727:     $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
                   2728:     return $str;
                   2729: }
1.11      www      2730: 
1.1       albertel 2731: # ================================================================ Main Program
                   2732: 
1.184     www      2733: sub goodbye {
1.204     albertel 2734:    &logthis("Starting Shut down");
1.184     www      2735:    &flushcourselogs();
                   2736:    &logthis("Shutting down");
                   2737: }
                   2738: 
1.179     www      2739: BEGIN {
1.1       albertel 2740: # ------------------------------------------------------------ Read access.conf
1.195     www      2741:     unless ($readit) {
1.1       albertel 2742: {
                   2743:     my $config=Apache::File->new("/etc/httpd/conf/access.conf");
                   2744: 
                   2745:     while (my $configline=<$config>) {
                   2746:         if ($configline =~ /PerlSetVar/) {
                   2747: 	   my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
1.8       www      2748:            chomp($varvalue);
1.1       albertel 2749:            $perlvar{$varname}=$varvalue;
                   2750:         }
                   2751:     }
                   2752: }
                   2753: 
                   2754: # ------------------------------------------------------------- Read hosts file
                   2755: {
                   2756:     my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab");
                   2757: 
                   2758:     while (my $configline=<$config>) {
1.154     www      2759:        chomp($configline);
1.1       albertel 2760:        my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
                   2761:        $hostname{$id}=$name;
                   2762:        $hostdom{$id}=$domain;
1.150     www      2763:        $hostip{$id}=$ip;
1.1       albertel 2764:        if ($role eq 'library') { $libserv{$id}=$name; }
                   2765:     }
                   2766: }
                   2767: 
                   2768: # ------------------------------------------------------ Read spare server file
                   2769: {
                   2770:     my $config=Apache::File->new("$perlvar{'lonTabDir'}/spare.tab");
                   2771: 
                   2772:     while (my $configline=<$config>) {
                   2773:        chomp($configline);
                   2774:        if (($configline) && ($configline ne $perlvar{'lonHostID'})) {
                   2775:           $spareid{$configline}=1;
                   2776:        }
                   2777:     }
                   2778: }
1.11      www      2779: # ------------------------------------------------------------ Read permissions
                   2780: {
                   2781:     my $config=Apache::File->new("$perlvar{'lonTabDir'}/roles.tab");
                   2782: 
                   2783:     while (my $configline=<$config>) {
                   2784:        chomp($configline);
1.160     www      2785:       if ($configline) {
1.11      www      2786:        my ($role,$perm)=split(/ /,$configline);
                   2787:        if ($perm ne '') { $pr{$role}=$perm; }
1.160     www      2788:       }
1.11      www      2789:     }
                   2790: }
                   2791: 
                   2792: # -------------------------------------------- Read plain texts for permissions
                   2793: {
                   2794:     my $config=Apache::File->new("$perlvar{'lonTabDir'}/rolesplain.tab");
                   2795: 
                   2796:     while (my $configline=<$config>) {
                   2797:        chomp($configline);
1.160     www      2798:       if ($configline) {
1.11      www      2799:        my ($short,$plain)=split(/:/,$configline);
                   2800:        if ($plain ne '') { $prp{$short}=$plain; }
1.160     www      2801:       }
1.135     www      2802:     }
                   2803: }
                   2804: 
                   2805: # ---------------------------------------------------------- Read package table
                   2806: {
                   2807:     my $config=Apache::File->new("$perlvar{'lonTabDir'}/packages.tab");
                   2808: 
                   2809:     while (my $configline=<$config>) {
                   2810:        chomp($configline);
                   2811:        my ($short,$plain)=split(/:/,$configline);
1.143     www      2812:        my ($pack,$name)=split(/\&/,$short);
                   2813:        if ($plain ne '') {
                   2814:           $packagetab{$pack.'&'.$name.'&name'}=$name; 
                   2815:           $packagetab{$short}=$plain; 
1.25      www      2816:        }
1.11      www      2817:     }
                   2818: }
                   2819: 
1.71      www      2820: %metacache=();
1.185     www      2821: 
                   2822: $processmarker=$$.'_'.time.'_'.$perlvar{'lonHostID'};
1.186     www      2823: $dumpcount=0;
1.22      www      2824: 
1.163     harris41 2825: &logtouch();
1.12      www      2826: &logthis('<font color=yellow>INFO: Read configuration</font>');
1.195     www      2827: $readit=1;
                   2828: }
1.1       albertel 2829: }
1.179     www      2830: 
1.1       albertel 2831: 1;
1.191     harris41 2832: __END__
                   2833: 
                   2834: =head1 NAME
                   2835: 
                   2836: Apache::lonnet - TCP networking package
                   2837: 
                   2838: =head1 SYNOPSIS
                   2839: 
                   2840: Invoked by other LON-CAPA modules.
                   2841: 
                   2842:  &Apache::lonnet::SUBROUTINENAME(ARGUMENTS);
                   2843: 
                   2844: =head1 INTRODUCTION
                   2845: 
                   2846: This module provides subroutines which interact with the
                   2847: lonc/lond (TCP) network layer of LON-CAPA.
                   2848: 
                   2849: This is part of the LearningOnline Network with CAPA project
                   2850: described at http://www.lon-capa.org.
                   2851: 
                   2852: =head1 HANDLER SUBROUTINE
                   2853: 
                   2854: There is no handler routine for this module.
                   2855: 
                   2856: =head1 OTHER SUBROUTINES
                   2857: 
                   2858: =over 4
                   2859: 
                   2860: =item *
                   2861: 
                   2862: logtouch() : make sure the logfile, lonnet.log, exists
                   2863: 
                   2864: =item *
                   2865: 
                   2866: logthis() : append message to lonnet.log
                   2867: 
                   2868: =item *
                   2869: 
                   2870: logperm() : append a permanent message to lonnet.perm.log
                   2871: 
                   2872: =item *
                   2873: 
                   2874: subreply() : non-critical communication, called by &reply
                   2875: 
                   2876: =item *
                   2877: 
                   2878: reply() : makes two attempts to pass message; logs refusals and rejections
                   2879: 
                   2880: =item *
                   2881: 
                   2882: reconlonc() : tries to reconnect lonc client processes.
                   2883: 
                   2884: =item *
                   2885: 
                   2886: critical() : passes a critical message to another server; if cannot get
                   2887: through then place message in connection buffer
                   2888: 
                   2889: =item *
                   2890: 
                   2891: appenv(%hash) : read in current user environment, append new environment
                   2892: values to make new user environment
                   2893: 
                   2894: =item *
                   2895: 
                   2896: delenv($varname) : read in current user environment, remove all values
                   2897: beginning with $varname, write new user environment (note: flock is used
                   2898: to prevent conflicting shared read/writes with file)
                   2899: 
                   2900: =item *
                   2901: 
                   2902: spareserver() : find server with least workload from spare.tab
                   2903: 
                   2904: =item *
                   2905: 
                   2906: queryauthenticate($uname,$udom) : try to determine user's current
                   2907: authentication scheme
                   2908: 
                   2909: =item *
                   2910: 
                   2911: authenticate($uname,$upass,$udom) : try to authenticate user from domain's lib
                   2912: servers (first use the current one)
                   2913: 
                   2914: =item *
                   2915: 
                   2916: homeserver($uname,$udom) : find the homebase for a user from domain's lib
                   2917: servers
                   2918: 
                   2919: =item *
                   2920: 
                   2921: idget($udom,@ids) : find the usernames behind a list of IDs (returns hash:
                   2922: id=>name,id=>name)
                   2923: 
                   2924: =item *
                   2925: 
                   2926: idrget($udom,@unames) : find the IDs behind a list of usernames (returns hash:
                   2927: name=>id,name=>id)
                   2928: 
                   2929: =item *
                   2930: 
                   2931: idput($udom,%ids) : store away a list of names and associated IDs
                   2932: 
                   2933: =item *
                   2934: 
                   2935: usection($domain,$user,$courseid) : output of section name/number or '' for
                   2936: "not in course" and '-1' for "no section"
                   2937: 
                   2938: =item *
                   2939: 
                   2940: userenvironment($domain,$user,$what) : puts out any environment parameter 
                   2941: for a user
                   2942: 
                   2943: =item *
                   2944: 
                   2945: subscribe($fname) : subscribe to a resource, return URL if possible
                   2946: 
                   2947: =item *
                   2948: 
                   2949: repcopy($filename) : replicate file
                   2950: 
                   2951: =item *
                   2952: 
                   2953: ssi($url,%hash) : server side include, does a complete request cycle on url to
                   2954: localhost, posts hash
                   2955: 
                   2956: =item *
                   2957: 
                   2958: log($domain,$name,$home,$message) : write to permanent log for user; use
                   2959: critical subroutine
                   2960: 
                   2961: =item *
                   2962: 
                   2963: flushcourselogs() : flush (save) buffer logs and access logs
                   2964: 
                   2965: =item *
                   2966: 
                   2967: courselog($what) : save message for course in hash
                   2968: 
                   2969: =item *
                   2970: 
                   2971: courseacclog($what) : save message for course using &courselog().  Perform
                   2972: special processing for specific resource types (problems, exams, quizzes, etc).
                   2973: 
                   2974: =item *
                   2975: 
                   2976: countacc($url) : count the number of accesses to a given URL
                   2977: 
                   2978: =item *
                   2979: 
                   2980: sub checkout($symb,$tuname,$tudom,$tcrsid) : check out an item
                   2981: 
                   2982: =item *
                   2983: 
                   2984: sub checkin($token) : check in an item
                   2985: 
                   2986: =item *
                   2987: 
                   2988: sub expirespread($uname,$udom,$stype,$usymb) : set expire date for spreadsheet
                   2989: 
                   2990: =item *
                   2991: 
                   2992: devalidate($symb) : devalidate spreadsheets
                   2993: 
                   2994: =item *
                   2995: 
                   2996: hash2str(%hash) : convert a hash into a string complete with escaping and '='
1.204     albertel 2997: and '&' separators, supports elements that are arrayrefs and hashrefs
                   2998: 
                   2999: =item *
                   3000: 
                   3001: hashref2str($hashref) : convert a hashref into a string complete with
                   3002: escaping and '=' and '&' separators, supports elements that are
                   3003: arrayrefs and hashrefs
                   3004: 
                   3005: =item *
                   3006: 
                   3007: arrayref2str($arrayref) : convert an arrayref into a string complete
                   3008: with escaping and '&' separators, supports elements that are arrayrefs
                   3009: and hashrefs
                   3010: 
                   3011: =item *
                   3012: 
                   3013: str2hash($string) : convert string to hash using unescaping and
                   3014: splitting on '=' and '&', supports elements that are arrayrefs and
                   3015: hashrefs
1.191     harris41 3016: 
                   3017: =item *
                   3018: 
1.204     albertel 3019: str2array($string) : convert string to hash using unescaping and
                   3020: splitting on '&', supports elements that are arrayrefs and hashrefs
1.191     harris41 3021: 
                   3022: =item *
                   3023: 
                   3024: tmpreset($symb,$namespace,$domain,$stuname) : temporary storage
                   3025: 
                   3026: =item *
                   3027: 
                   3028: tmprestore($symb,$namespace,$domain,$stuname) : temporary restore
                   3029: 
                   3030: =item *
                   3031: 
                   3032: store($storehash,$symb,$namespace,$domain,$stuname) : stores hash permanently
                   3033: for this url; hashref needs to be given and should be a \%hashname; the
                   3034: remaining args aren't required and if they aren't passed or are '' they will
                   3035: be derived from the ENV
                   3036: 
                   3037: =item *
                   3038: 
                   3039: cstore($storehash,$symb,$namespace,$domain,$stuname) : same as store but
                   3040: uses critical subroutine
                   3041: 
                   3042: =item *
                   3043: 
                   3044: restore($symb,$namespace,$domain,$stuname) : returns hash for this symb;
                   3045: all args are optional
                   3046: 
                   3047: =item *
                   3048: 
                   3049: coursedescription($courseid) : course description
                   3050: 
                   3051: =item *
                   3052: 
                   3053: rolesinit($domain,$username,$authhost) : get user privileges
                   3054: 
                   3055: =item *
                   3056: 
                   3057: get($namespace,$storearr,$udomain,$uname) : returns hash with keys from array
                   3058: reference filled in from namesp ($udomain and $uname are optional)
                   3059: 
                   3060: =item *
                   3061: 
                   3062: del($namespace,$storearr,$udomain,$uname) : deletes keys out of array from
                   3063: namesp ($udomain and $uname are optional)
                   3064: 
                   3065: =item *
                   3066: 
1.193     www      3067: dump($namespace,$udomain,$uname,$regexp) : 
                   3068: dumps the complete (or key matching regexp) namespace into a hash
                   3069: ($udomain, $uname and $regexp are optional)
1.191     harris41 3070: 
                   3071: =item *
                   3072: 
                   3073: put($namespace,$storehash,$udomain,$uname) : stores hash in namesp
                   3074: ($udomain and $uname are optional)
                   3075: 
                   3076: =item *
                   3077: 
                   3078: cput($namespace,$storehash,$udomain,$uname) : critical put
                   3079: ($udomain and $uname are optional)
                   3080: 
                   3081: =item *
                   3082: 
                   3083: eget($namespace,$storearr,$udomain,$uname) : returns hash with keys from array
                   3084: reference filled in from namesp (encrypts the return communication)
                   3085: ($udomain and $uname are optional)
                   3086: 
                   3087: =item *
                   3088: 
                   3089: allowed($priv,$uri) : check for a user privilege; returns codes for allowed
                   3090: actions
                   3091:  F: full access
                   3092:  U,I,K: authentication modes (cxx only)
                   3093:  '': forbidden
                   3094:  1: user needs to choose course
                   3095:  2: browse allowed
                   3096: 
                   3097: =item *
                   3098: 
                   3099: definerole($rolename,$sysrole,$domrole,$courole) : define role; define a custom
                   3100: role rolename set privileges in format of lonTabs/roles.tab for system, domain,
                   3101: and course level
                   3102: 
                   3103: =item *
                   3104: 
                   3105: metadata_query($query,$custom,$customshow) : make a metadata query against the
                   3106: network of library servers; returns file handle of where SQL and regex results
                   3107: will be stored for query
                   3108: 
                   3109: =item *
                   3110: 
                   3111: plaintext($short) : return value in %prp hash (rolesplain.tab); plain text
                   3112: explanation of a user role term
                   3113: 
                   3114: =item *
                   3115: 
                   3116: assignrole($udom,$uname,$url,$role,$end,$start) : assign role; give a role to a
                   3117: user for the level given by URL.  Optional start and end dates (leave empty
                   3118: string or zero for "no date")
                   3119: 
                   3120: =item *
                   3121: 
                   3122: modifyuserauth($udom,$uname,$umode,$upass) : modify user authentication
                   3123: 
                   3124: =item *
                   3125: 
                   3126: modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene) : 
                   3127: modify user
                   3128: 
                   3129: =item *
                   3130: 
                   3131: modifystudent($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
                   3132: $end,$start) : modify student
                   3133: 
                   3134: =item *
                   3135: 
                   3136: writecoursepref($courseid,%prefs) : write preferences for a course
                   3137: 
                   3138: =item *
                   3139: 
                   3140: createcourse($udom,$description,$url) : make/modify course
                   3141: 
                   3142: =item *
                   3143: 
                   3144: assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start) : assign
                   3145: custom role; give a custom role to a user for the level given by URL.  Specify
                   3146: name and domain of role author, and role name
                   3147: 
                   3148: =item *
                   3149: 
                   3150: revokerole($udom,$uname,$url,$role) : revoke a role for url
                   3151: 
                   3152: =item *
                   3153: 
                   3154: revokecustomrole($udom,$uname,$url,$role) : revoke a custom role
                   3155: 
                   3156: =item *
                   3157: 
                   3158: dirlist($uri) : return directory list based on URI
                   3159: 
                   3160: =item *
                   3161: 
                   3162: directcondval($number) : get current value of a condition; reads from a state
                   3163: string
                   3164: 
                   3165: =item *
                   3166: 
                   3167: condval($condidx) : value of condition index based on state
                   3168: 
                   3169: =item *
                   3170: 
                   3171: EXT($varname,$symbparm) : value of a variable
                   3172: 
                   3173: =item *
                   3174: 
                   3175: metadata($uri,$what,$liburi,$prefix,$depthcount) : get metadata; returns the
                   3176: metadata entry for a file; entry='keys', returns a comma separated list of keys
                   3177: 
                   3178: =item *
                   3179: 
                   3180: symblist($mapname,%newhash) : update symbolic storage links
                   3181: 
                   3182: =item *
                   3183: 
                   3184: symbread($filename) : return symbolic list entry (filename argument optional);
                   3185: returns the data handle
                   3186: 
                   3187: =item *
                   3188: 
                   3189: numval($salt) : return random seed value (addend for rndseed)
                   3190: 
                   3191: =item *
                   3192: 
                   3193: rndseed($symb,$courseid,$domain,$username) : create a random sum; returns
                   3194: a random seed, all arguments are optional, if they aren't sent it uses the
                   3195: environment to derive them. Note: if symb isn't sent and it can't get one
                   3196: from &symbread it will use the current time as its return value
                   3197: 
                   3198: =item *
                   3199: 
                   3200: ireceipt($funame,$fudom,$fucourseid,$fusymb) : return unique,
                   3201: unfakeable, receipt
                   3202: 
                   3203: =item *
                   3204: 
                   3205: receipt() : API to ireceipt working off of ENV values; given out to users
                   3206: 
                   3207: =item *
                   3208: 
                   3209: getfile($file) : serves up a file, returns the contents of a file or -1;
                   3210: replicates and subscribes to the file
                   3211: 
                   3212: =item *
                   3213: 
                   3214: filelocation($dir,$file) : returns file system location of a file based on URI;
                   3215: meant to be "fairly clean" absolute reference
                   3216: 
                   3217: =item *
                   3218: 
                   3219: hreflocation($dir,$file) : returns file system location or a URL; same as
                   3220: filelocation except for hrefs
                   3221: 
                   3222: =item *
                   3223: 
                   3224: declutter() : declutters URLs (remove docroot, beginning slashes, 'res' etc)
                   3225: 
                   3226: =item *
                   3227: 
                   3228: escape() : unpack non-word characters into CGI-compatible hex codes
                   3229: 
                   3230: =item *
                   3231: 
                   3232: unescape() : pack CGI-compatible hex codes into actual non-word ASCII character
                   3233: 
                   3234: =item *
                   3235: 
                   3236: goodbye() : flush course logs and log shutting down; it is called in srm.conf
                   3237: as a PerlChildExitHandler
                   3238: 
                   3239: =back
                   3240: 
                   3241: =cut

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