File:  [LON-CAPA] / loncom / lonnet / perl / lonnet.pm
Revision 1.52: download - view: text, annotated - select for diffs
Sat Oct 28 17:26:35 2000 UTC (23 years, 9 months ago) by www
Branches: MAIN
CVS tags: HEAD
Work on "allowed"

    1: # The LearningOnline Network
    2: # TCP networking package
    3: #
    4: # Functions for use by content handlers:
    5: #
    6: # plaintext(short)   : plain text explanation of short term
    7: # fileembstyle(ext)  : embed style in page for file extension
    8: # filedescription(ext) : descriptor text for file extension
    9: # allowed(short,url) : returns codes for allowed actions 
   10: #                      F: full access
   11: #                      U,I,K: authentication modes (cxx only)
   12: #                      '': forbidden
   13: #                      1: user needs to choose course
   14: #                      2: browse allowed
   15: # definerole(rolename,sys,dom,cou) : define a custom role rolename
   16: #                      set priviledges in format of lonTabs/roles.tab for
   17: #                      system, domain and course level, 
   18: # assignrole(udom,uname,url,role,end,start) : give a role to a user for the
   19: #                      level given by url. Optional start and end dates
   20: #                      (leave empty string or zero for "no date") 
   21: # assigncustomrole (udom,uname,url,rdom,rnam,rolename,end,start) : give a
   22: #                      custom role to a user for the level given by url.
   23: #                      Specify name and domain of role author, and role name
   24: # revokerole (udom,uname,url,role) : Revoke a role for url
   25: # revokecustomrole (udom,uname,url,rdom,rnam,rolename) : Revoke a custom role
   26: # appenv(hash)       : adds hash to session environment
   27: # store(hash)        : stores hash permanently for this url
   28: # cstore(hash)       : critical store
   29: # restore            : returns hash for this url
   30: # eget(namesp,array) : returns hash with keys from array filled in from namesp
   31: # get(namesp,array)  : returns hash with keys from array filled in from namesp
   32: # del(namesp,array)  : deletes keys out of array from namesp
   33: # put(namesp,hash)   : stores hash in namesp
   34: # cput(namesp,hash)  : critical put
   35: # dump(namesp)       : dumps the complete namespace into a hash
   36: # ssi(url,hash)      : does a complete request cycle on url to localhost, posts
   37: #                      hash
   38: # coursedescription(id) : returns and caches course description for id
   39: # repcopy(filename)  : replicate file
   40: # dirlist(url)       : gets a directory listing
   41: # directcondval(index) : reading condition value of single condition from 
   42: #                        state string
   43: # condval(index)     : value of condition index based on state
   44: # varval(name)       : value of a variable
   45: # refreshstate()     : refresh the state information string
   46: # symblist(map,hash) : Updates symbolic storage links
   47: # symbread([filename]) : returns the data handle (filename optional)
   48: # rndseed()          : returns a random seed  
   49: # getfile(filename)  : returns the contents of filename, or a -1 if it can't
   50: #                      be found, replicates and subscribes to the file
   51: # filelocation(dir,file) : returns a farily clean absolute reference to file 
   52: #                          from the directory dir
   53: # hreflocation(dir,file) : same as filelocation, but for hrefs
   54: # log(domain,user,home,msg) : write to permanent log for user
   55: #
   56: # 6/1/99,6/2,6/10,6/11,6/12,6/14,6/26,6/28,6/29,6/30,
   57: # 7/1,7/2,7/9,7/10,7/12,7/14,7/15,7/19,
   58: # 11/8,11/16,11/18,11/22,11/23,12/22,
   59: # 01/06,01/13,02/24,02/28,02/29,
   60: # 03/01,03/02,03/06,03/07,03/13,
   61: # 04/05,05/29,05/31,06/01,
   62: # 06/05,06/26 Gerd Kortemeyer
   63: # 06/26 Ben Tyszka
   64: # 06/30,07/15,07/17,07/18,07/20,07/21,07/22,07/25 Gerd Kortemeyer
   65: # 08/14 Ben Tyszka
   66: # 08/22,08/28,08/31,09/01,09/02,09/04,09/05,09/25,09/28,09/30 Gerd Kortemeyer
   67: # 10/04 Gerd Kortemeyer
   68: # 10/04 Guy Albertelli
   69: # 10/06,10/09,10/10,10/11,10/14,10/20,10/23,10/25,10/26,10/27,10/28 
   70: # Gerd Kortemeyer
   71: 
   72: package Apache::lonnet;
   73: 
   74: use strict;
   75: use Apache::File;
   76: use LWP::UserAgent();
   77: use HTTP::Headers;
   78: use vars 
   79: qw(%perlvar %hostname %homecache %spareid %hostdom %libserv %pr %prp %fe %fd $readit);
   80: use IO::Socket;
   81: use GDBM_File;
   82: use Apache::Constants qw(:common :http);
   83: 
   84: # --------------------------------------------------------------------- Logging
   85: 
   86: sub logthis {
   87:     my $message=shift;
   88:     my $execdir=$perlvar{'lonDaemons'};
   89:     my $now=time;
   90:     my $local=localtime($now);
   91:     my $fh=Apache::File->new(">>$execdir/logs/lonnet.log");
   92:     print $fh "$local ($$): $message\n";
   93:     return 1;
   94: }
   95: 
   96: sub logperm {
   97:     my $message=shift;
   98:     my $execdir=$perlvar{'lonDaemons'};
   99:     my $now=time;
  100:     my $local=localtime($now);
  101:     my $fh=Apache::File->new(">>$execdir/logs/lonnet.perm.log");
  102:     print $fh "$now:$message:$local\n";
  103:     return 1;
  104: }
  105: 
  106: # -------------------------------------------------- Non-critical communication
  107: sub subreply {
  108:     my ($cmd,$server)=@_;
  109:     my $peerfile="$perlvar{'lonSockDir'}/$server";
  110:     my $client=IO::Socket::UNIX->new(Peer    =>"$peerfile",
  111:                                      Type    => SOCK_STREAM,
  112:                                      Timeout => 10)
  113:        or return "con_lost";
  114:     print $client "$cmd\n";
  115:     my $answer=<$client>;
  116:     if (!$answer) { $answer="con_lost"; }
  117:     chomp($answer);
  118:     return $answer;
  119: }
  120: 
  121: sub reply {
  122:     my ($cmd,$server)=@_;
  123:     my $answer=subreply($cmd,$server);
  124:     if ($answer eq 'con_lost') { $answer=subreply($cmd,$server); }
  125:     if (($answer=~/^error:/) || ($answer=~/^refused/) || 
  126:         ($answer=~/^rejected/)) {
  127:        &logthis("<font color=blue>WARNING:".
  128:                 " $cmd to $server returned $answer</font>");
  129:     }
  130:     return $answer;
  131: }
  132: 
  133: # ----------------------------------------------------------- Send USR1 to lonc
  134: 
  135: sub reconlonc {
  136:     my $peerfile=shift;
  137:     &logthis("Trying to reconnect for $peerfile");
  138:     my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
  139:     if (my $fh=Apache::File->new("$loncfile")) {
  140: 	my $loncpid=<$fh>;
  141:         chomp($loncpid);
  142:         if (kill 0 => $loncpid) {
  143: 	    &logthis("lonc at pid $loncpid responding, sending USR1");
  144:             kill USR1 => $loncpid;
  145:             sleep 1;
  146:             if (-e "$peerfile") { return; }
  147:             &logthis("$peerfile still not there, give it another try");
  148:             sleep 5;
  149:             if (-e "$peerfile") { return; }
  150:             &logthis(
  151:   "<font color=blue>WARNING: $peerfile still not there, giving up</font>");
  152:         } else {
  153: 	    &logthis(
  154:                "<font color=blue>WARNING:".
  155:                " lonc at pid $loncpid not responding, giving up</font>");
  156:         }
  157:     } else {
  158:      &logthis('<font color=blue>WARNING: lonc not running, giving up</font>');
  159:     }
  160: }
  161: 
  162: # ------------------------------------------------------ Critical communication
  163: 
  164: sub critical {
  165:     my ($cmd,$server)=@_;
  166:     my $answer=reply($cmd,$server);
  167:     if ($answer eq 'con_lost') {
  168:         my $pingreply=reply('ping',$server);
  169: 	&reconlonc("$perlvar{'lonSockDir'}/$server");
  170:         my $pongreply=reply('pong',$server);
  171:         &logthis("Ping/Pong for $server: $pingreply/$pongreply");
  172:         $answer=reply($cmd,$server);
  173:         if ($answer eq 'con_lost') {
  174:             my $now=time;
  175:             my $middlename=$cmd;
  176:             $middlename=substr($middlename,0,16);
  177:             $middlename=~s/\W//g;
  178:             my $dfilename=
  179:              "$perlvar{'lonSockDir'}/delayed/$now.$middlename.$server";
  180:             {
  181:              my $dfh;
  182:              if ($dfh=Apache::File->new(">$dfilename")) {
  183:                 print $dfh "$cmd\n";
  184: 	     }
  185:             }
  186:             sleep 2;
  187:             my $wcmd='';
  188:             {
  189: 	     my $dfh;
  190:              if ($dfh=Apache::File->new("$dfilename")) {
  191:                 $wcmd=<$dfh>;
  192: 	     }
  193:             }
  194:             chomp($wcmd);
  195:             if ($wcmd eq $cmd) {
  196: 		&logthis("<font color=blue>WARNING: ".
  197:                          "Connection buffer $dfilename: $cmd</font>");
  198:                 &logperm("D:$server:$cmd");
  199: 	        return 'con_delayed';
  200:             } else {
  201:                 &logthis("<font color=red>CRITICAL:"
  202:                         ." Critical connection failed: $server $cmd</font>");
  203:                 &logperm("F:$server:$cmd");
  204:                 return 'con_failed';
  205:             }
  206:         }
  207:     }
  208:     return $answer;
  209: }
  210: 
  211: # ---------------------------------------------------------- Append Environment
  212: 
  213: sub appenv {
  214:     my %newenv=@_;
  215:     map {
  216: 	if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) {
  217:             &logthis("<font color=blue>WARNING: ".
  218:                 "Attempt to modify environment ".$_." to ".$newenv{$_});
  219: 	    delete($newenv{$_});
  220:         } else {
  221:             $ENV{$_}=$newenv{$_};
  222:         }
  223:     } keys %newenv;
  224:     my @oldenv;
  225:     {
  226:      my $fh;
  227:      unless ($fh=Apache::File->new("$ENV{'user.environment'}")) {
  228: 	return 'error';
  229:      }
  230:      @oldenv=<$fh>;
  231:     }
  232:     for (my $i=0; $i<=$#oldenv; $i++) {
  233:         chomp($oldenv[$i]);
  234:         if ($oldenv[$i] ne '') {
  235:            my ($name,$value)=split(/=/,$oldenv[$i]);
  236:            unless (defined($newenv{$name})) {
  237: 	      $newenv{$name}=$value;
  238: 	   }
  239:         }
  240:     }
  241:     {
  242:      my $fh;
  243:      unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) {
  244: 	return 'error';
  245:      }
  246:      my $newname;
  247:      foreach $newname (keys %newenv) {
  248: 	 print $fh "$newname=$newenv{$newname}\n";
  249:      }
  250:     }
  251:     return 'ok';
  252: }
  253: 
  254: # ------------------------------ Find server with least workload from spare.tab
  255: 
  256: sub spareserver {
  257:     my $tryserver;
  258:     my $spareserver='';
  259:     my $lowestserver=100;
  260:     foreach $tryserver (keys %spareid) {
  261:        my $answer=reply('load',$tryserver);
  262:        if (($answer =~ /\d/) && ($answer<$lowestserver)) {
  263: 	   $spareserver="http://$hostname{$tryserver}";
  264:            $lowestserver=$answer;
  265:        }
  266:     }    
  267:     return $spareserver;
  268: }
  269: 
  270: # --------- Try to authenticate user from domain's lib servers (first this one)
  271: 
  272: sub authenticate {
  273:     my ($uname,$upass,$udom)=@_;
  274:     $upass=escape($upass);
  275:     if (($perlvar{'lonRole'} eq 'library') && 
  276:         ($udom eq $perlvar{'lonDefDomain'})) {
  277:     my $answer=reply("encrypt:auth:$udom:$uname:$upass",$perlvar{'lonHostID'});
  278:         if ($answer =~ /authorized/) {
  279:               if ($answer eq 'authorized') {
  280:                  &logthis("User $uname at $udom authorized by local server"); 
  281:                  return $perlvar{'lonHostID'}; 
  282:               }
  283:               if ($answer eq 'non_authorized') {
  284:                  &logthis("User $uname at $udom rejected by local server"); 
  285:                  return 'no_host'; 
  286:               }
  287: 	}
  288:     }
  289: 
  290:     my $tryserver;
  291:     foreach $tryserver (keys %libserv) {
  292: 	if ($hostdom{$tryserver} eq $udom) {
  293:            my $answer=reply("encrypt:auth:$udom:$uname:$upass",$tryserver);
  294:            if ($answer =~ /authorized/) {
  295:               if ($answer eq 'authorized') {
  296:                  &logthis("User $uname at $udom authorized by $tryserver"); 
  297:                  return $tryserver; 
  298:               }
  299:               if ($answer eq 'non_authorized') {
  300:                  &logthis("User $uname at $udom rejected by $tryserver");
  301:                  return 'no_host';
  302:               } 
  303: 	   }
  304:        }
  305:     }
  306:     &logthis("User $uname at $udom could not be authenticated");    
  307:     return 'no_host';
  308: }
  309: 
  310: # ---------------------- Find the homebase for a user from domain's lib servers
  311: 
  312: sub homeserver {
  313:     my ($uname,$udom)=@_;
  314: 
  315:     my $index="$uname:$udom";
  316:     if ($homecache{$index}) { return "$homecache{$index}"; }
  317: 
  318:     my $tryserver;
  319:     foreach $tryserver (keys %libserv) {
  320: 	if ($hostdom{$tryserver} eq $udom) {
  321:            my $answer=reply("home:$udom:$uname",$tryserver);
  322:            if ($answer eq 'found') { 
  323: 	      $homecache{$index}=$tryserver;
  324:               return $tryserver; 
  325: 	   }
  326:        }
  327:     }    
  328:     return 'no_host';
  329: }
  330: 
  331: # ----------------------------- Subscribe to a resource, return URL if possible
  332: 
  333: sub subscribe {
  334:     my $fname=shift;
  335:     my $author=$fname;
  336:     $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
  337:     my ($udom,$uname)=split(/\//,$author);
  338:     my $home=homeserver($uname,$udom);
  339:     if (($home eq 'no_host') || ($home eq $perlvar{'lonHostID'})) { 
  340:         return 'not_found'; 
  341:     }
  342:     my $answer=reply("sub:$fname",$home);
  343:     return $answer;
  344: }
  345:     
  346: # -------------------------------------------------------------- Replicate file
  347: 
  348: sub repcopy {
  349:     my $filename=shift;
  350:     $filename=~s/\/+/\//g;
  351:     my $transname="$filename.in.transfer";
  352:     if ((-e $filename) || (-e $transname)) { return OK; }
  353:     my $remoteurl=subscribe($filename);
  354:     if ($remoteurl eq 'con_lost') {
  355: 	   &logthis("Subscribe returned con_lost: $filename");
  356:            return HTTP_SERVICE_UNAVAILABLE;
  357:     } elsif ($remoteurl eq 'not_found') {
  358: 	   &logthis("Subscribe returned not_found: $filename");
  359: 	   return HTTP_NOT_FOUND;
  360:     } elsif ($remoteurl eq 'rejected') {
  361: 	   &logthis("Subscribe returned rejected: $filename");
  362:            return FORBIDDEN;
  363:     } elsif ($remoteurl eq 'directory') {
  364:            return OK;
  365:     } else {
  366:            my @parts=split(/\//,$filename);
  367:            my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";
  368:            if ($path ne "$perlvar{'lonDocRoot'}/res") {
  369:                &logthis("Malconfiguration for replication: $filename");
  370: 	       return HTTP_BAD_REQUEST;
  371:            }
  372:            my $count;
  373:            for ($count=5;$count<$#parts;$count++) {
  374:                $path.="/$parts[$count]";
  375:                if ((-e $path)!=1) {
  376: 		   mkdir($path,0777);
  377:                }
  378:            }
  379:            my $ua=new LWP::UserAgent;
  380:            my $request=new HTTP::Request('GET',"$remoteurl");
  381:            my $response=$ua->request($request,$transname);
  382:            if ($response->is_error()) {
  383: 	       unlink($transname);
  384:                my $message=$response->status_line;
  385:                &logthis("<font color=blue>WARNING:"
  386:                        ." LWP get: $message: $filename</font>");
  387:                return HTTP_SERVICE_UNAVAILABLE;
  388:            } else {
  389: 	       if ($remoteurl!~/\.meta$/) {
  390:                   my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');
  391:                   my $mresponse=$ua->request($mrequest,$filename.'.meta');
  392:                   if ($mresponse->is_error()) {
  393: 		      unlink($filename.'.meta');
  394:                       &logthis(
  395:                      "<font color=yellow>INFO: No metadata: $filename</font>");
  396:                   }
  397: 	       }
  398:                rename($transname,$filename);
  399:                return OK;
  400:            }
  401:     }
  402: }
  403: 
  404: # --------------------------------------------------------- Server Side Include
  405: 
  406: sub ssi {
  407: 
  408:     my ($fn,%form)=@_;
  409: 
  410:     my $ua=new LWP::UserAgent;
  411:     
  412:     my $request;
  413:     
  414:     if (%form) {
  415:       $request=new HTTP::Request('POST',"http://".$ENV{'HTTP_HOST'}.$fn);
  416:       $request->content(join '&', map { "$_=$form{$_}" } keys %form);
  417:     } else {
  418:       $request=new HTTP::Request('GET',"http://".$ENV{'HTTP_HOST'}.$fn);
  419:     }
  420: 
  421:     $request->header(Cookie => $ENV{'HTTP_COOKIE'});
  422:     my $response=$ua->request($request);
  423: 
  424:     return $response->content;
  425: }
  426: 
  427: # ------------------------------------------------------------------------- Log
  428: 
  429: sub log {
  430:     my ($dom,$nam,$hom,$what)=@_;
  431:     return critical("log:$dom:$nam:$what",$hom);
  432: }
  433: 
  434: # ----------------------------------------------------------------------- Store
  435: 
  436: sub store {
  437:     my %storehash=@_;
  438:     my $symb;
  439:     unless ($symb=escape(&symbread())) { return ''; }
  440:     my $namespace;
  441:     unless ($namespace=$ENV{'request.course.id'}) { return ''; }
  442:     my $namevalue='';
  443:     map {
  444:         $namevalue.=escape($_).'='.escape($storehash{$_}).'&';
  445:     } keys %storehash;
  446:     $namevalue=~s/\&$//;
  447:     return reply(
  448:      "store:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$symb:$namevalue",
  449: 		 "$ENV{'user.home'}");
  450: }
  451: 
  452: # -------------------------------------------------------------- Critical Store
  453: 
  454: sub cstore {
  455:     my %storehash=@_;
  456:     my $symb;
  457:     unless ($symb=escape(&symbread())) { return ''; }
  458:     my $namespace;
  459:     unless ($namespace=$ENV{'request.course.id'}) { return ''; }
  460:     my $namevalue='';
  461:     map {
  462:         $namevalue.=escape($_).'='.escape($storehash{$_}).'&';
  463:     } keys %storehash;
  464:     $namevalue=~s/\&$//;
  465:     return critical(
  466:      "store:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$symb:$namevalue",
  467: 		 "$ENV{'user.home'}");
  468: }
  469: 
  470: # --------------------------------------------------------------------- Restore
  471: 
  472: sub restore {
  473:     my $symb;
  474:     unless ($symb=escape(&symbread())) { return ''; }
  475:     my $namespace;
  476:     unless ($namespace=$ENV{'request.course.id'}) { return ''; }
  477:     my $answer=reply(
  478:               "restore:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$symb",
  479:               "$ENV{'user.home'}");
  480:     my %returnhash=();
  481:     map {
  482: 	my ($name,$value)=split(/\=/,$_);
  483:         $returnhash{&unescape($name)}=&unescape($value);
  484:     } split(/\&/,$answer);
  485:     map {
  486:         $returnhash{$_}=$returnhash{$returnhash{'version'}.':'.$_};
  487:     } split(/\:/,$returnhash{$returnhash{'version'}.':keys'});
  488:     return %returnhash;
  489: }
  490: 
  491: # ---------------------------------------------------------- Course Description
  492: 
  493: sub coursedescription {
  494:     my $courseid=shift;
  495:     $courseid=~s/^\///;
  496:     $courseid=~s/\_/\//g;
  497:     my ($cdomain,$cnum)=split(/\//,$courseid);
  498:     my $chome=homeserver($cnum,$cdomain);
  499:     if ($chome ne 'no_host') {
  500:        my $rep=reply("dump:$cdomain:$cnum:environment",$chome);
  501:        if ($rep ne 'con_lost') {
  502: 	   my %cachehash=();
  503:            my %returnhash=('home'   => $chome, 
  504:                            'domain' => $cdomain,
  505:                            'num'    => $cnum);
  506:            map {
  507:                my ($name,$value)=split(/\=/,$_);
  508:                $name=&unescape($name);
  509:                $value=&unescape($value);
  510:                $returnhash{$name}=$value;
  511:                if ($name eq 'description') {
  512: 		   $cachehash{$courseid}=$value;
  513:                }
  514:            } split(/\&/,$rep);
  515:            $returnhash{'url'}='/res/'.declutter($returnhash{'url'});
  516:            $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'.
  517: 	       $ENV{'user.name'}.'_'.$cdomain.'_'.$cnum;
  518: 	   put ('nohist_coursedescriptions',%cachehash);
  519:            return %returnhash;
  520:        }
  521:     }
  522:     return ();
  523: }
  524: 
  525: # -------------------------------------------------------- Get user priviledges
  526: 
  527: sub rolesinit {
  528:     my ($domain,$username,$authhost)=@_;
  529:     my $rolesdump=reply("dump:$domain:$username:roles",$authhost);
  530:     if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; }
  531:     my %allroles=();
  532:     my %thesepriv=();
  533:     my $now=time;
  534:     my $userroles="user.login.time=$now\n";
  535:     my $thesestr;
  536: 
  537:     if ($rolesdump ne '') {
  538:         map {
  539: 	  if ($_!~/^rolesdef\&/) {
  540:             my ($area,$role)=split(/=/,$_);
  541:             $area=~s/\_\w\w$//;
  542:             my ($trole,$tend,$tstart)=split(/_/,$role);
  543:             $userroles.='user.role.'.$trole.'.'.$area.'='.
  544:                         $tstart.'.'.$tend."\n";
  545:             if ($tend!=0) {
  546: 	        if ($tend<$now) {
  547: 	            $trole='';
  548:                 } 
  549:             }
  550:             if ($tstart!=0) {
  551:                 if ($tstart>$now) {
  552:                    $trole='';        
  553:                 }
  554:             }
  555:             if (($area ne '') && ($trole ne '')) {
  556: 	       my $spec=$trole.'.'.$area;
  557:                my ($tdummy,$tdomain,$trest)=split(/\//,$area);
  558:                if ($trole =~ /^cr\//) {
  559: 		   my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
  560:                    my $homsvr=homeserver($rauthor,$rdomain);
  561:                    if ($hostname{$homsvr} ne '') {
  562:                       my $roledef=
  563: 			  reply("get:$rdomain:$rauthor:roles:rolesdef_$rrole",
  564:                                 $homsvr);
  565:                       if (($roledef ne 'con_lost') && ($roledef ne '')) {
  566:                          my ($syspriv,$dompriv,$coursepriv)=
  567: 			     split(/\_/,unescape($roledef));
  568:  	                 $allroles{'cm./'}.=':'.$syspriv;
  569:                          $allroles{$spec.'./'}.=':'.$syspriv;
  570:                          if ($tdomain ne '') {
  571:                              $allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv;
  572:                              $allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv;
  573:                              if ($trest ne '') {
  574: 		                $allroles{'cm.'.$area}.=':'.$coursepriv;
  575: 		                $allroles{$spec.'.'.$area}.=':'.$coursepriv;
  576:                              }
  577: 	                 }
  578:                       }
  579:                    }
  580:                } else {
  581: 	           $allroles{'cm./'}.=':'.$pr{$trole.':s'};
  582: 	           $allroles{$spec.'./'}.=':'.$pr{$trole.':s'};
  583:                    if ($tdomain ne '') {
  584:                      $allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
  585:                      $allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
  586:                       if ($trest ne '') {
  587: 		          $allroles{'cm.'.$area}.=':'.$pr{$trole.':c'};
  588: 		          $allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'};
  589:                       }
  590: 	           }
  591: 	       }
  592:             }
  593:           } 
  594:         } split(/&/,$rolesdump);
  595:         map {
  596:             %thesepriv=();
  597:             map {
  598:                 if ($_ ne '') {
  599: 		    my ($priviledge,$restrictions)=split(/&/,$_);
  600:                     if ($restrictions eq '') {
  601: 			$thesepriv{$priviledge}='F';
  602:                     } else {
  603:                         if ($thesepriv{$priviledge} ne 'F') {
  604: 			    $thesepriv{$priviledge}.=$restrictions;
  605:                         }
  606:                     }
  607:                 }
  608:             } split(/:/,$allroles{$_});
  609:             $thesestr='';
  610:             map { $thesestr.=':'.$_.'&'.$thesepriv{$_}; } keys %thesepriv;
  611:             $userroles.='user.priv.'.$_.'='.$thesestr."\n";
  612:         } keys %allroles;            
  613:     }
  614:     return $userroles;  
  615: }
  616: 
  617: # --------------------------------------------------------------- get interface
  618: 
  619: sub get {
  620:    my ($namespace,@storearr)=@_;
  621:    my $items='';
  622:    map {
  623:        $items.=escape($_).'&';
  624:    } @storearr;
  625:    $items=~s/\&$//;
  626:  my $rep=reply("get:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
  627:                  $ENV{'user.home'});
  628:    my @pairs=split(/\&/,$rep);
  629:    my %returnhash=();
  630:    my $i=0;
  631:    map {
  632:       $returnhash{$_}=unescape($pairs[$i]);
  633:       $i++;
  634:    } @storearr;
  635:    return %returnhash;
  636: }
  637: 
  638: # --------------------------------------------------------------- del interface
  639: 
  640: sub del {
  641:    my ($namespace,@storearr)=@_;
  642:    my $items='';
  643:    map {
  644:        $items.=escape($_).'&';
  645:    } @storearr;
  646:    $items=~s/\&$//;
  647:    return reply("del:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
  648:                  $ENV{'user.home'});
  649: }
  650: 
  651: # -------------------------------------------------------------- dump interface
  652: 
  653: sub dump {
  654:    my $namespace=shift;
  655:    my $rep=reply("dump:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace",
  656:                 $ENV{'user.home'});
  657:    my @pairs=split(/\&/,$rep);
  658:    my %returnhash=();
  659:    map {
  660:       my ($key,$value)=split(/=/,$_);
  661:       $returnhash{unescape($key)}=unescape($value);
  662:    } @pairs;
  663:    return %returnhash;
  664: }
  665: 
  666: # --------------------------------------------------------------- put interface
  667: 
  668: sub put {
  669:    my ($namespace,%storehash)=@_;
  670:    my $items='';
  671:    map {
  672:        $items.=escape($_).'='.escape($storehash{$_}).'&';
  673:    } keys %storehash;
  674:    $items=~s/\&$//;
  675:    return reply("put:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
  676:                  $ENV{'user.home'});
  677: }
  678: 
  679: # ------------------------------------------------------ critical put interface
  680: 
  681: sub cput {
  682:    my ($namespace,%storehash)=@_;
  683:    my $items='';
  684:    map {
  685:        $items.=escape($_).'='.escape($storehash{$_}).'&';
  686:    } keys %storehash;
  687:    $items=~s/\&$//;
  688:    return critical
  689:            ("put:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
  690:                  $ENV{'user.home'});
  691: }
  692: 
  693: # -------------------------------------------------------------- eget interface
  694: 
  695: sub eget {
  696:    my ($namespace,@storearr)=@_;
  697:    my $items='';
  698:    map {
  699:        $items.=escape($_).'&';
  700:    } @storearr;
  701:    $items=~s/\&$//;
  702:  my $rep=reply("eget:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
  703:                  $ENV{'user.home'});
  704:    my @pairs=split(/\&/,$rep);
  705:    my %returnhash=();
  706:    my $i=0;
  707:    map {
  708:       $returnhash{$_}=unescape($pairs[$i]);
  709:       $i++;
  710:    } @storearr;
  711:    return %returnhash;
  712: }
  713: 
  714: # ------------------------------------------------- Check for a user priviledge
  715: 
  716: sub allowed {
  717:     my ($priv,$uri)=@_;
  718:     $uri=&declutter($uri);
  719: 
  720: # Free bre access to adm resources
  721: 
  722:     if (($uri=~/^adm\//) && ($priv eq 'bre')) {
  723: 	return 'F';
  724:     }
  725: 
  726:     my $thisallowed='';
  727:     my $statecond=0;
  728:     my $courseprivid='';
  729: 
  730: # Course
  731: 
  732:     if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'}=~/$priv\&([^\:]*)/) {
  733:        $thisallowed.=$1;
  734:     }
  735: 
  736: # Domain
  737: 
  738:     if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.(split(/\//,$uri))[0].'/'}
  739:        =~/$priv\&([^\:]*)/) {
  740:        $thisallowed.=$1;
  741:     }
  742: 
  743: # Course: uri itself is a course
  744: 
  745:     if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$uri}
  746:        =~/$priv\&([^\:]*)/) {
  747:        $thisallowed.=$1;
  748:     }
  749: 
  750: # Full access at system, domain or course-wide level? Exit.
  751: 
  752:     if ($thisallowed=~/F/) {
  753: 	return 'F';
  754:     }
  755: 
  756: # If this is generating or modifying users, exit with special codes
  757: 
  758:     if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:'=~/\:$priv\:/) {
  759: 	return $thisallowed;
  760:     }
  761: #
  762: # Gathered so far: system, domain and course wide priviledges
  763: #
  764: # Course: See if uri or referer is an individual resource that is part of 
  765: # the course
  766: 
  767:     if ($ENV{'request.course.id'}) {
  768:        $courseprivid=$ENV{'request.course.id'};
  769:        if ($ENV{'request.course.sec'}) {
  770:           $courseprivid.='/'.$ENV{'request.course.sec'};
  771:        }
  772:        $courseprivid=~s/\_/\//;
  773:        my $checkreferer=1;
  774:        my @uriparts=split(/\//,$uri);
  775:        my $filename=$uriparts[$#uriparts];
  776:        my $pathname=$uri;
  777:        $pathname=~s/\/$filename$//;
  778:        if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~
  779:            /\&$filename\:(\d+)\&/) {
  780:            $statecond=$1;
  781:            if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid}
  782:                =~/$priv\&([^\:]*)/) {
  783:                $thisallowed.=$1;
  784:                $checkreferer=0;
  785:            }
  786:        }
  787:        if (($ENV{'HTTP_REFERER'}) && ($checkreferer)) {
  788:           my @uriparts=split(/\//,&declutter($ENV{'HTTP_REFERER'}));
  789:           my $filename=$uriparts[$#uriparts];
  790:           my $pathname=$uri;
  791:           $pathname=~s/\/$filename$//;
  792:           if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~
  793:               /\&$filename\:(\d+)\&/) {
  794:               $statecond=$1;
  795:               if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid}
  796:                   =~/$priv\&([^\:]*)/) {
  797:                   $thisallowed.=$1;
  798:               }
  799:           }
  800:        }
  801:    }
  802: 
  803: #
  804: # Gathered now: all priviledges that could apply, and condition number
  805: # 
  806: #
  807: # Full or no access?
  808: #
  809: 
  810:     if ($thisallowed=~/F/) {
  811: 	return 'F';
  812:     }
  813: 
  814:     unless ($thisallowed) {
  815:         return '';
  816:     }
  817: 
  818: # Restrictions exist, deal with them
  819: #
  820: #   C:according to course preferences
  821: #   R:according to resource settings
  822: #   L:unless locked
  823: #   X:according to user session state
  824: #
  825: 
  826: # Possibly locked functionality, check all courses
  827: 
  828:     my $envkey;
  829:     if ($thisallowed=~/L/) {
  830:         foreach $envkey (keys %ENV) {
  831:            if ($envkey=~/^user\.role\.st\.([^\.]*)/) {
  832: 	       my ($cdom,$cnum,$csec)=split(/\//,$1);
  833:                my %locks=();
  834:                map {
  835:                    my ($name,$value)=split(/\=/,$_);
  836:                    $locks{&unescape($name)}=&unescape($value);
  837:                } split(/\&/,&reply('get:'.$cdom.':'.$cnum.
  838:                  ':environment:'.&escape('priv.'.$priv.'.lock.sections').
  839:                              ':'.&escape('priv.'.$priv.'.lock.expire').
  840:                              ':'.&escape('res.'.$uri.'.lock.sections').
  841: 			     ':'.&escape('res.'.$uri.'.lock.expire'),
  842:                   &homeserver($cnum,$cdom)));
  843:                if (($locks{'res.'.$uri.'.lock.sections'}=~/\,$csec\,/) ||
  844:                    ($locks{'res.'.$uri.'.lock.sections'} eq 'all')) {
  845: 		   if ($locks{'res.'.$uri.'.lock.expire'}>time) {
  846:                        &log('Locked by res: '.$priv.' for '.$uri.' due to '.
  847:                             $cdom.'/'.$cnum.'/'.$csec.' expire '.
  848:                             $locks{'priv.'.$priv.'.lock.expire'});
  849: 		       return '';
  850:                    }
  851:                }
  852:                if (($locks{'priv.'.$priv.'.lock.sections'}=~/\,$csec\,/) ||
  853:                    ($locks{'priv.'.$priv.'.lock.sections'} eq 'all')) {
  854: 		   if ($locks{'priv.'.$priv.'.lock.expire'}>time) {
  855:                        &log('Locked by priv: '.$priv.' for '.$uri.' due to '.
  856:                             $cdom.'/'.$cnum.'/'.$csec.' expire '.
  857:                             $locks{'priv.'.$priv.'.lock.expire'});
  858: 		       return '';
  859:                    }
  860:                }
  861: 	   }
  862:        }
  863:     }
  864:    
  865: #
  866: # Rest of the restrictions depend on selected course
  867: #
  868: 
  869:     unless ($ENV{'request.course.id'}) {
  870:        return '1';
  871:     }
  872: 
  873: #
  874: # Now user is definitely in a course
  875: #
  876: 
  877: # Restricted by state?
  878: 
  879:    if ($thisallowed=~/X/) {
  880:       if (&condval($statecond)) {
  881: 	 return '2';
  882:       } else {
  883:          return '';
  884:       }
  885:    }
  886: 
  887:    return 'F';
  888: }
  889: 
  890: # ---------------------------------------------------------- Refresh State Info
  891: 
  892: sub refreshstate {
  893: }
  894: 
  895: # ----------------------------------------------------------------- Define Role
  896: 
  897: sub definerole {
  898:   if (allowed('mcr','/')) {
  899:     my ($rolename,$sysrole,$domrole,$courole)=@_;
  900:     map {
  901: 	my ($crole,$cqual)=split(/\&/,$_);
  902:         if ($pr{'cr:s'}!~/$crole/) { return "refused:s:$crole"; }
  903:         if ($pr{'cr:s'}=~/$crole\&/) {
  904: 	    if ($pr{'cr:s'}!~/$crole\&\w*$cqual/) { 
  905:                return "refused:s:$crole&$cqual"; 
  906:             }
  907:         }
  908:     } split('/',$sysrole);
  909:     map {
  910: 	my ($crole,$cqual)=split(/\&/,$_);
  911:         if ($pr{'cr:d'}!~/$crole/) { return "refused:d:$crole"; }
  912:         if ($pr{'cr:d'}=~/$crole\&/) {
  913: 	    if ($pr{'cr:d'}!~/$crole\&\w*$cqual/) { 
  914:                return "refused:d:$crole&$cqual"; 
  915:             }
  916:         }
  917:     } split('/',$domrole);
  918:     map {
  919: 	my ($crole,$cqual)=split(/\&/,$_);
  920:         if ($pr{'cr:c'}!~/$crole/) { return "refused:c:$crole"; }
  921:         if ($pr{'cr:c'}=~/$crole\&/) {
  922: 	    if ($pr{'cr:c'}!~/$crole\&\w*$cqual/) { 
  923:                return "refused:c:$crole&$cqual"; 
  924:             }
  925:         }
  926:     } split('/',$courole);
  927:     my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:".
  928:                 "$ENV{'user.domain'}:$ENV{'user.name'}:".
  929: 	        "rolesdef_$rolename=".
  930:                 escape($sysrole.'_'.$domrole.'_'.$courole);
  931:     return reply($command,$ENV{'user.home'});
  932:   } else {
  933:     return 'refused';
  934:   }
  935: }
  936: 
  937: # ------------------------------------------------------------------ Plain Text
  938: 
  939: sub plaintext {
  940:     my $short=shift;
  941:     return $prp{$short};
  942: }
  943: 
  944: # ------------------------------------------------------------------ Plain Text
  945: 
  946: sub fileembstyle {
  947:     my $ending=shift;
  948:     return $fe{$ending};
  949: }
  950: 
  951: # ------------------------------------------------------------ Description Text
  952: 
  953: sub filedecription {
  954:     my $ending=shift;
  955:     return $fd{$ending};
  956: }
  957: 
  958: # ----------------------------------------------------------------- Assign Role
  959: 
  960: sub assignrole {
  961:     my ($udom,$uname,$url,$role,$end,$start)=@_;
  962:     my $mrole;
  963:     $url=declutter($url);
  964:     if ($role =~ /^cr\//) {
  965:         unless ($url=~/\.course$/) { return 'invalid'; }
  966: 	unless (allowed('ccr',$url)) { return 'refused'; }
  967:         $mrole='cr';
  968:     } else {
  969:         unless (($url=~/\.course$/) || ($url=~/\/$/)) { return 'invalid'; }
  970:         unless (allowed('c'+$role)) { return 'refused'; }
  971:         $mrole=$role;
  972:     }
  973:     my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:".
  974:                 "$udom:$uname:$url".'_'."$mrole=$role";
  975:     if ($end) { $command.='_$end'; }
  976:     if ($start) {
  977: 	if ($end) { 
  978:            $command.='_$start'; 
  979:         } else {
  980:            $command.='_0_$start';
  981:         }
  982:     }
  983:     return &reply($command,&homeserver($uname,$udom));
  984: }
  985: 
  986: # ---------------------------------------------------------- Assign Custom Role
  987: 
  988: sub assigncustomrole {
  989:     my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start)=@_;
  990:     return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename,
  991:                        $end,$start);
  992: }
  993: 
  994: # ----------------------------------------------------------------- Revoke Role
  995: 
  996: sub revokerole {
  997:     my ($udom,$uname,$url,$role)=@_;
  998:     my $now=time;
  999:     return &assignrole($udom,$uname,$url,$role,$now);
 1000: }
 1001: 
 1002: # ---------------------------------------------------------- Revoke Custom Role
 1003: 
 1004: sub revokecustomrole {
 1005:     my ($udom,$uname,$url,$rdom,$rnam,$rolename)=@_;
 1006:     my $now=time;
 1007:     return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now);
 1008: }
 1009: 
 1010: # ------------------------------------------------------------ Directory lister
 1011: 
 1012: sub dirlist {
 1013:     my $uri=shift;
 1014:     $uri=~s/^\///;
 1015:     $uri=~s/\/$//;
 1016:     my ($res,$udom,$uname,@rest)=split(/\//,$uri);
 1017:     if ($udom) {
 1018:      if ($uname) {
 1019:        my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/'.$uri,
 1020:                       homeserver($uname,$udom));
 1021:        return split(/:/,$listing);
 1022:      } else {
 1023:        my $tryserver;
 1024:        my %allusers=();
 1025:        foreach $tryserver (keys %libserv) {
 1026: 	  if ($hostdom{$tryserver} eq $udom) {
 1027:              my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.$udom,
 1028: 			       $tryserver);
 1029:              if (($listing ne 'no_such_dir') && ($listing ne 'empty')
 1030:               && ($listing ne 'con_lost')) {
 1031:                 map {
 1032:                   my ($entry,@stat)=split(/&/,$_);
 1033:                   $allusers{$entry}=1;
 1034:                 } split(/:/,$listing);
 1035:              }
 1036: 	  }
 1037:        }
 1038:        my $alluserstr='';
 1039:        map {
 1040:            $alluserstr.=$_.'&user:';
 1041:        } sort keys %allusers;
 1042:        $alluserstr=~s/:$//;
 1043:        return split(/:/,$alluserstr);
 1044:      } 
 1045:    } else {
 1046:        my $tryserver;
 1047:        my %alldom=();
 1048:        foreach $tryserver (keys %libserv) {
 1049: 	   $alldom{$hostdom{$tryserver}}=1;
 1050:        }
 1051:        my $alldomstr='';
 1052:        map {
 1053:           $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'&domain:';
 1054:        } sort keys %alldom;
 1055:        $alldomstr=~s/:$//;
 1056:        return split(/:/,$alldomstr);       
 1057:    }
 1058: }
 1059: 
 1060: # -------------------------------------------------------- Value of a Condition
 1061: 
 1062: sub directcondval {
 1063:     my $number=shift;
 1064:     if ($ENV{'user.state.'.$ENV{'request.course.id'}}) {
 1065:        return substr($ENV{'user.state.'.$ENV{'request.course.id'}},$number,1);
 1066:     } else {
 1067:        return 2;
 1068:     }
 1069: }
 1070: 
 1071: sub condval {
 1072:     my $condidx=shift;
 1073:     my $result=0;
 1074:     if ($ENV{'request.course.id'}) {
 1075:        if (defined($ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$condidx})) {
 1076:           my $operand='|';
 1077: 	  my @stack;
 1078:           map {
 1079:               if ($_ eq '(') {
 1080:                  push @stack,($operand,$result)
 1081:               } elsif ($_ eq ')') {
 1082:                   my $before=pop @stack;
 1083: 		  if (pop @stack eq '&') {
 1084: 		      $result=$result>$before?$before:$result;
 1085:                   } else {
 1086:                       $result=$result>$before?$result:$before;
 1087:                   }
 1088:               } elsif (($_ eq '&') || ($_ eq '|')) {
 1089:                   $operand=$_;
 1090:               } else {
 1091:                   my $new=directcondval($_);
 1092:                   if ($operand eq '&') {
 1093:                      $result=$result>$new?$new:$result;
 1094:                   } else {
 1095:                      $result=$result>$new?$result:$new;
 1096:                   }                  
 1097:               }
 1098:           } ($ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$condidx}=~
 1099:              /(\d+|\(|\)|\&|\|)/g);
 1100:        }
 1101:     }
 1102:     return $result;
 1103: }
 1104: 
 1105: # --------------------------------------------------------- Value of a Variable
 1106: 
 1107: sub varval {
 1108:     my $varname=shift;
 1109:     my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);
 1110:     my $rest;
 1111:     if ($therest[0]) {
 1112:        $rest=join('.',@therest);
 1113:     } else {
 1114:        $rest='';
 1115:     }
 1116:     if ($realm eq 'user') {
 1117: # --------------------------------------------------------------- user.resource
 1118: 	if ($space eq 'resource') {
 1119: # ----------------------------------------------------------------- user.access
 1120:         } elsif ($space eq 'access') {
 1121:             return &allowed($qualifier,$rest);
 1122: # ------------------------------------------ user.preferences, user.environment
 1123:         } elsif (($space eq 'preferences') || ($space eq 'environment')) {
 1124:             return $ENV{join('.',('environment',$qualifier,$rest))};
 1125: # ----------------------------------------------------------------- user.course
 1126:         } elsif ($space eq 'course') {
 1127:             return $ENV{join('.',('request.course',$qualifier))};
 1128: # ------------------------------------------------------------------- user.role
 1129:         } elsif ($space eq 'role') {
 1130:             my ($role,$where)=split(/\./,$ENV{'request.role'});
 1131:             if ($qualifier eq 'value') {
 1132: 		return $role;
 1133:             } elsif ($qualifier eq 'extent') {
 1134:                 return $where;
 1135:             }
 1136: # ----------------------------------------------------------------- user.domain
 1137:         } elsif ($space eq 'domain') {
 1138:             return $ENV{'user.domain'};
 1139: # ------------------------------------------------------------------- user.name
 1140:         } elsif ($space eq 'name') {
 1141:             return $ENV{'user.name'};
 1142: # ---------------------------------------------------- Any other user namespace
 1143:         } else {
 1144:             my $item=($rest)?$qualifier.'.'.$rest:$qualifier;
 1145:             my %reply=&get($space,$item);
 1146:             return $reply{$item};
 1147:         }
 1148:     } elsif ($realm eq 'request') {
 1149: # ------------------------------------------------------------- request.browser
 1150:         if ($space eq 'browser') {
 1151: 	    return $ENV{'browser.'.$qualifier};
 1152:         } elsif ($space eq 'filename') {
 1153:             return $ENV{'request.filename'};
 1154:         }
 1155:     } elsif ($realm eq 'course') {
 1156: # ---------------------------------------------------------- course.description
 1157:         if ($space eq 'description') {
 1158:             my %reply=&coursedescription($ENV{'request.course.id'});
 1159:             return $reply{'description'};
 1160: # ------------------------------------------------------------------- course.id
 1161:         } elsif ($space eq 'id') {
 1162:             return $ENV{'request.course.id'};
 1163: # -------------------------------------------------- Any other course namespace
 1164:         } else {
 1165: 	    my ($cdom,$cnam)=split(/\_/,$ENV{'request.course.id'});
 1166: 	    my $chome=&homeserver($cnam,$cdom);
 1167:             my $item=join('.',($qualifier,$rest));
 1168:             return &unescape
 1169:                    (&reply('get:'.$cdom.':'.$cnam.':'.&escape($space).':'.
 1170: 			   &escape($item),$chome));
 1171:         }
 1172:     } elsif ($realm eq 'userdata') {
 1173:         my $uhome=&homeserver($qualifier,$space);
 1174: # ----------------------------------------------- userdata.domain.name.resource
 1175: # ---------------------------------------------------- Any other user namespace
 1176:     } elsif ($realm eq 'environment') {
 1177: # ----------------------------------------------------------------- environment
 1178:         return $ENV{join('.',($space,$qualifier,$rest))};
 1179:     } elsif ($realm eq 'system') {
 1180: # ----------------------------------------------------------------- system.time
 1181: 	if ($space eq 'time') {
 1182: 	    return time;
 1183:         }
 1184:     }
 1185:     return '';
 1186: }
 1187: 
 1188: # ------------------------------------------------- Update symbolic store links
 1189: 
 1190: sub symblist {
 1191:     my ($mapname,%newhash)=@_;
 1192:     $mapname=declutter($mapname);
 1193:     my %hash;
 1194:     if (($ENV{'request.course.fn'}) && (%newhash)) {
 1195:         if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',
 1196:                       &GDBM_WRCREAT,0640)) {
 1197: 	    map {
 1198:                 $hash{declutter($_)}=$mapname.'___'.$newhash{$_};
 1199:             } keys %newhash;
 1200:             if (untie(%hash)) {
 1201: 		return 'ok';
 1202:             }
 1203:         }
 1204:     }
 1205:     return 'error';
 1206: }
 1207: 
 1208: # ------------------------------------------------------ Return symb list entry
 1209: 
 1210: sub symbread {
 1211:     my $thisfn=shift;
 1212:     unless ($thisfn) {
 1213: 	$thisfn=$ENV{'request.filename'};
 1214:     }
 1215:     $thisfn=declutter($thisfn);
 1216:     my %hash;
 1217:     my %bighash;
 1218:     my $syval='';
 1219:     if (($ENV{'request.course.fn'}) && ($thisfn)) {
 1220:         if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',
 1221:                       &GDBM_READER,0640)) {
 1222: 	    $syval=$hash{$thisfn};
 1223:             untie(%hash);
 1224:         }
 1225: # ---------------------------------------------------------- There was an entry
 1226:         if ($syval) {
 1227:            unless ($syval=~/\_\d+$/) {
 1228: 	       unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) {
 1229:                   &appenv('request.ambiguous' => $thisfn);
 1230:                   return '';
 1231:                }    
 1232:                $syval.=$1;
 1233: 	   }
 1234:         } else {
 1235: # ------------------------------------------------------- Was not in symb table
 1236:            if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
 1237:                             &GDBM_READER,0640)) {
 1238: # ---------------------------------------------- Get ID(s) for current resource
 1239:               my $ids=$bighash{'ids_/res/'.$thisfn};
 1240:               if ($ids) {
 1241: # ------------------------------------------------------------------- Has ID(s)
 1242:                  my @possibilities=split(/\,/,$ids);
 1243:                  if ($#possibilities==0) {
 1244: # ----------------------------------------------- There is only one possibility
 1245: 		     my ($mapid,$resid)=split(/\./,$ids);
 1246:                      $syval=declutter($bighash{'map_id_'.$mapid}).'___'.$resid;
 1247:                  } else {
 1248: # ------------------------------------------ There is more than one possibility
 1249:                      my $realpossible=0;
 1250:                      map {
 1251: 			 my $file=$bighash{'src_'.$_};
 1252:                          if (&allowed('bre',$file)) {
 1253:          		    my ($mapid,$resid)=split(/\./,$_);
 1254:                             if ($bighash{'map_type_'.$mapid} ne 'page') {
 1255: 				$realpossible++;
 1256:                                 $syval=declutter($bighash{'map_id_'.$mapid}).
 1257:                                        '___'.$resid;
 1258:                             }
 1259: 			 }
 1260:                      } @possibilities;
 1261: 		     if ($realpossible!=1) { $syval=''; }
 1262:                  }
 1263: 	      }
 1264:               untie(%bighash)
 1265:            } 
 1266:         }
 1267:         if ($syval) { return $syval.'___'.$thisfn; }
 1268:     }
 1269:     &appenv('request.ambiguous' => $thisfn);
 1270:     return '';
 1271: }
 1272: 
 1273: # ---------------------------------------------------------- Return random seed
 1274: 
 1275: sub numval {
 1276:     my $txt=shift;
 1277:     $txt=~tr/A-J/0-9/;
 1278:     $txt=~tr/a-j/0-9/;
 1279:     $txt=~tr/K-T/0-9/;
 1280:     $txt=~tr/k-t/0-9/;
 1281:     $txt=~tr/U-Z/0-5/;
 1282:     $txt=~tr/u-z/0-5/;
 1283:     $txt=~s/\D//g;
 1284:     return int($txt);
 1285: }    
 1286: 
 1287: sub rndseed {
 1288:     my $symb;
 1289:     unless ($symb=&symbread()) { return time; }
 1290:     my $symbchck=unpack("%32C*",$symb);
 1291:     my $symbseed=numval($symb)%$symbchck;
 1292:     my $namechck=unpack("%32C*",$ENV{'user.name'});
 1293:     my $nameseed=numval($ENV{'user.name'})%$namechck;
 1294:     return int( $symbseed
 1295: 	       .$nameseed
 1296:                .unpack("%32C*",$ENV{'user.domain'})
 1297:                .unpack("%32C*",$ENV{'request.course.id'})
 1298:                .$namechck
 1299:                .$symbchck);
 1300: }
 1301: 
 1302: # ------------------------------------------------------------ Serves up a file
 1303: # returns either the contents of the file or a -1
 1304: sub getfile {
 1305:   my $file=shift;
 1306:   &repcopy($file);
 1307:   if (! -e $file ) { return -1; };
 1308:   my $fh=Apache::File->new($file);
 1309:   my $a='';
 1310:   while (<$fh>) { $a .=$_; }
 1311:   return $a
 1312: }
 1313: 
 1314: sub filelocation {
 1315:   my ($dir,$file) = @_;
 1316:   my $location;
 1317:   $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces
 1318:   $file=~s/^$perlvar{'lonDocRoot'}//;
 1319:   $file=~s:^/*res::;
 1320:   if ( !( $file =~ m:^/:) ) {
 1321:     $location = $dir. '/'.$file;
 1322:   } else {
 1323:     $location = '/home/httpd/html/res'.$file;
 1324:   }
 1325:   $location=~s://+:/:g; # remove duplicate /
 1326:   while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..
 1327:   return $location;
 1328: }
 1329: 
 1330: sub hreflocation {
 1331:     my ($dir,$file)=@_;
 1332:     unless (($_=~/^http:\/\//i) || ($_=~/^\//)) {
 1333:        my $finalpath=filelocation($dir,$file);
 1334:        $finalpath=~s/^\/home\/httpd\/html//;
 1335:        return $finalpath;
 1336:     } else {
 1337:        return $file;
 1338:     }
 1339: }
 1340: 
 1341: # ------------------------------------------------------------- Declutters URLs
 1342: 
 1343: sub declutter {
 1344:     my $thisfn=shift;
 1345:     $thisfn=~s/^$perlvar{'lonDocRoot'}//;
 1346:     $thisfn=~s/^\///;
 1347:     $thisfn=~s/^res\///;
 1348:     return $thisfn;
 1349: }
 1350: 
 1351: # -------------------------------------------------------- Escape Special Chars
 1352: 
 1353: sub escape {
 1354:     my $str=shift;
 1355:     $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
 1356:     return $str;
 1357: }
 1358: 
 1359: # ----------------------------------------------------- Un-Escape Special Chars
 1360: 
 1361: sub unescape {
 1362:     my $str=shift;
 1363:     $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
 1364:     return $str;
 1365: }
 1366: 
 1367: # ================================================================ Main Program
 1368: 
 1369: sub BEGIN {
 1370: if ($readit ne 'done') {
 1371: # ------------------------------------------------------------ Read access.conf
 1372: {
 1373:     my $config=Apache::File->new("/etc/httpd/conf/access.conf");
 1374: 
 1375:     while (my $configline=<$config>) {
 1376:         if ($configline =~ /PerlSetVar/) {
 1377: 	   my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
 1378:            chomp($varvalue);
 1379:            $perlvar{$varname}=$varvalue;
 1380:         }
 1381:     }
 1382: }
 1383: 
 1384: # ------------------------------------------------------------- Read hosts file
 1385: {
 1386:     my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab");
 1387: 
 1388:     while (my $configline=<$config>) {
 1389:        my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
 1390:        $hostname{$id}=$name;
 1391:        $hostdom{$id}=$domain;
 1392:        if ($role eq 'library') { $libserv{$id}=$name; }
 1393:     }
 1394: }
 1395: 
 1396: # ------------------------------------------------------ Read spare server file
 1397: {
 1398:     my $config=Apache::File->new("$perlvar{'lonTabDir'}/spare.tab");
 1399: 
 1400:     while (my $configline=<$config>) {
 1401:        chomp($configline);
 1402:        if (($configline) && ($configline ne $perlvar{'lonHostID'})) {
 1403:           $spareid{$configline}=1;
 1404:        }
 1405:     }
 1406: }
 1407: # ------------------------------------------------------------ Read permissions
 1408: {
 1409:     my $config=Apache::File->new("$perlvar{'lonTabDir'}/roles.tab");
 1410: 
 1411:     while (my $configline=<$config>) {
 1412:        chomp($configline);
 1413:        my ($role,$perm)=split(/ /,$configline);
 1414:        if ($perm ne '') { $pr{$role}=$perm; }
 1415:     }
 1416: }
 1417: 
 1418: # -------------------------------------------- Read plain texts for permissions
 1419: {
 1420:     my $config=Apache::File->new("$perlvar{'lonTabDir'}/rolesplain.tab");
 1421: 
 1422:     while (my $configline=<$config>) {
 1423:        chomp($configline);
 1424:        my ($short,$plain)=split(/:/,$configline);
 1425:        if ($plain ne '') { $prp{$short}=$plain; }
 1426:     }
 1427: }
 1428: 
 1429: # ------------------------------------------------------------- Read file types
 1430: {
 1431:     my $config=Apache::File->new("$perlvar{'lonTabDir'}/filetypes.tab");
 1432: 
 1433:     while (my $configline=<$config>) {
 1434:        chomp($configline);
 1435:        my ($ending,$emb,@descr)=split(/\s+/,$configline);
 1436:        if ($descr[0] ne '') { 
 1437:          $fe{$ending}=$emb;
 1438:          $fd{$ending}=join(' ',@descr);
 1439:        }
 1440:     }
 1441: }
 1442: 
 1443: 
 1444: $readit='done';
 1445: &logthis('<font color=yellow>INFO: Read configuration</font>');
 1446: }
 1447: }
 1448: 1;

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