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

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

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