[BACK]Return to lonnet.pm CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom / lonnet / perl

Diff for /loncom/lonnet/perl/lonnet.pm between versions 1.133 and 1.217

version 1.133, 2001/07/26 21:40:27 version 1.217, 2002/05/11 20:42:00
Line 1 Line 1
 # The LearningOnline Network  # The LearningOnline Network
 # TCP networking package  # TCP networking package
 #  #
 # Functions for use by content handlers:  # $Id$
 #  #
 # metadata_query(sql-query-string,custom-metadata-regex) :   # Copyright Michigan State University Board of Trustees
 #                                    returns file handle of where sql and  #
 #                                    regex results will be stored for query  # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
 # plaintext(short)   : plain text explanation of short term  #
 # fileembstyle(ext)  : embed style in page for file extension  # LON-CAPA is free software; you can redistribute it and/or modify
 # filedescription(ext) : descriptor text for file extension  # it under the terms of the GNU General Public License as published by
 # allowed(short,url) : returns codes for allowed actions   # the Free Software Foundation; either version 2 of the License, or
 #                      F: full access  # (at your option) any later version.
 #                      U,I,K: authentication modes (cxx only)  #
 #                      '': forbidden  # LON-CAPA is distributed in the hope that it will be useful,
 #                      1: user needs to choose course  # but WITHOUT ANY WARRANTY; without even the implied warranty of
 #                      2: browse allowed  # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 # definerole(rolename,sys,dom,cou) : define a custom role rolename  # GNU General Public License for more details.
 #                      set privileges in format of lonTabs/roles.tab for  #
 #                      system, domain and course level,   # You should have received a copy of the GNU General Public License
 # assignrole(udom,uname,url,role,end,start) : give a role to a user for the  # along with LON-CAPA; if not, write to the Free Software
 #                      level given by url. Optional start and end dates  # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 #                      (leave empty string or zero for "no date")   #
 # assigncustomrole (udom,uname,url,rdom,rnam,rolename,end,start) : give a  # /home/httpd/html/adm/gpl.txt
 #                      custom role to a user for the level given by url.  #
 #                      Specify name and domain of role author, and role name  # http://www.lon-capa.org/
 # revokerole (udom,uname,url,role) : Revoke a role for url  
 # revokecustomrole (udom,uname,url,rdom,rnam,rolename) : Revoke a custom role  
 # appenv(hash)       : adds hash to session environment  
 # delenv(varname)    : deletes all environment entries starting with varname  
 # store(hashref,symb,courseid,udom,uname)  
 #                    : stores hash permanently for this url  
 #                      hashref needs to be given, and should be a \%hashname  
 #                      the remaining args aren't required and if they aren't  
 #                      passed or are '' they will be derived from the ENV  
 # cstore(hashref,symb,courseid,udom,uname)  
 #                    : same as store but uses the critical interface to   
 #                      guarentee a store  
 # restore(symb,courseid,udom,uname)  
 #                    : returns hash for this symb, all args are optional  
 #                      if they aren't given they will be derived from the   
 #                      current enviroment  
 #  
 #  
 # for the next 4 functions udom and uname are optional  
 #         if supplied they use udom as the domain and uname  
 #         as the username for the function (supply a courseid  
 #         for the uname if you want a course database)  
 #         if not supplied it uses %ENV and looks at   
 #         user. attribute for the values  
 #  
 # eget(namesp,arrayref,udom,uname)  
 #                    : returns hash with keys from array  reference filled  
 #                      in from namesp (encrypts the return communication)  
 # get(namesp,arrayref,udom,uname)  
 #                    : returns hash with keys from array  reference filled  
 #                      in from namesp  
 # dump(namesp,udom,uname) : dumps the complete namespace into a hash  
 # del(namesp,array,udom,uname)  : deletes keys out of array from namesp  
 #  
 #  
 # put(namesp,hash)   : stores hash in namesp  
 # cput(namesp,hash)  : critical put  
 # ssi(url,hash)      : does a complete request cycle on url to localhost, posts  
 #                      hash  
 # coursedescription(id) : returns and caches course description for id  
 # repcopy(filename)  : replicate file  
 # dirlist(url)       : gets a directory listing  
 # directcondval(index) : reading condition value of single condition from   
 #                        state string  
 # condval(index)     : value of condition index based on state  
 # EXT(name)          : value of a variable  
 # symblist(map,hash) : Updates symbolic storage links  
 # symbread([filename]) : returns the data handle (filename optional)  
 # rndseed()          : returns a random seed   
 # receipt()          : returns a receipt to be given out to users   
 # getfile(filename)  : returns the contents of filename, or a -1 if it can't  
 #                      be found, replicates and subscribes to the file  
 # filelocation(dir,file) : returns a fairly clean absolute reference to file   
 #                          from the directory dir  
 # hreflocation(dir,file) : same as filelocation, but for hrefs  
 # log(domain,user,home,msg) : write to permanent log for user  
 # usection(domain,user,courseid) : output of section name/number or '' for  
 #                                  "not in course" and '-1' for "no section"  
 # userenvironment(domain,user,what) : puts out any environment parameter   
 #                                     for a user  
 # idput(domain,hash) : writes IDs for users from hash (name=>id,name=>id)  
 # idget(domain,array): returns hash with usernames (id=>name,id=>name) for  
 #                      an array of IDs  
 # idrget(domain,array): returns hash with IDs for usernames (name=>id,...) for  
 #                       an array of names  
 # metadata(file,entry): returns the metadata entry for a file. entry='keys'  
 #                       returns a comma separated list of keys  
 #  #
 # 6/1/99,6/2,6/10,6/11,6/12,6/14,6/26,6/28,6/29,6/30,  # 6/1/99,6/2,6/10,6/11,6/12,6/14,6/26,6/28,6/29,6/30,
 # 7/1,7/2,7/9,7/10,7/12,7/14,7/15,7/19,  # 7/1,7/2,7/9,7/10,7/12,7/14,7/15,7/19,
Line 113 Line 46
 # 05/01,06/01,09/01 Gerd Kortemeyer  # 05/01,06/01,09/01 Gerd Kortemeyer
 # 09/01 Guy Albertelli  # 09/01 Guy Albertelli
 # 09/01,10/01,11/01 Gerd Kortemeyer  # 09/01,10/01,11/01 Gerd Kortemeyer
   # YEAR=2001
 # 02/27/01 Scott Harrison  # 02/27/01 Scott Harrison
 # 3/2 Gerd Kortemeyer  # 3/2 Gerd Kortemeyer
 # 3/15,3/19 Scott Harrison  # 3/15,3/19 Scott Harrison
Line 121 Line 55
 # 5/26,5/28 Gerd Kortemeyer  # 5/26,5/28 Gerd Kortemeyer
 # 5/30 H. K. Ng  # 5/30 H. K. Ng
 # 6/1 Gerd Kortemeyer  # 6/1 Gerd Kortemeyer
   # July Guy Albertelli
   # 8/4,8/7,8/8,8/9,8/11,8/16,8/17,8/18,8/20,8/23,9/20,9/21,9/26,
   # 10/2 Gerd Kortemeyer
   # 10/5,10/10,11/13,11/15 Scott Harrison
   # 11/17,11/20,11/22,11/29 Gerd Kortemeyer
   # 12/5 Matthew Hall
   # 12/5 Guy Albertelli
   # 12/6,12/7,12/12 Gerd Kortemeyer
   # 12/18 Scott Harrison
   # 12/21,12/22,12/27,12/28 Gerd Kortemeyer
   # YEAR=2002
   # 1/4,2/4,2/7 Gerd Kortemeyer
 #  #
   ###
   
 package Apache::lonnet;  package Apache::lonnet;
   
Line 130  use Apache::File; Line 77  use Apache::File;
 use LWP::UserAgent();  use LWP::UserAgent();
 use HTTP::Headers;  use HTTP::Headers;
 use vars   use vars 
 qw(%perlvar %hostname %homecache %spareid %hostdom %libserv %pr %prp %fe %fd $readit %metacache);  qw(%perlvar %hostname %homecache %hostip %spareid %hostdom 
      %libserv %pr %prp %metacache %packagetab 
      %courselogs %accesshash $processmarker $dumpcount 
      %coursedombuf %coursehombuf %courseresdatacache);
 use IO::Socket;  use IO::Socket;
 use GDBM_File;  use GDBM_File;
 use Apache::Constants qw(:common :http);  use Apache::Constants qw(:common :http);
 use HTML::TokeParser;  use HTML::LCParser;
 use Fcntl qw(:flock);  use Fcntl qw(:flock);
   my $readit;
   
 # --------------------------------------------------------------------- Logging  # --------------------------------------------------------------------- Logging
   
   sub logtouch {
       my $execdir=$perlvar{'lonDaemons'};
       unless (-e "$execdir/logs/lonnet.log") {
    my $fh=Apache::File->new(">>$execdir/logs/lonnet.log");
    close $fh;
       }
       my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3];
       chown($wwwuid,$wwwgid,$execdir.'/logs/lonnet.log');
   }
   
 sub logthis {  sub logthis {
     my $message=shift;      my $message=shift;
     my $execdir=$perlvar{'lonDaemons'};      my $execdir=$perlvar{'lonDaemons'};
Line 176  sub subreply { Line 137  sub subreply {
   
 sub reply {  sub reply {
     my ($cmd,$server)=@_;      my ($cmd,$server)=@_;
       unless (defined($hostname{$server})) { return 'no_such_host'; }
     my $answer=subreply($cmd,$server);      my $answer=subreply($cmd,$server);
     if ($answer eq 'con_lost') { $answer=subreply($cmd,$server); }      if ($answer eq 'con_lost') {
          sleep 5; 
          $answer=subreply($cmd,$server);
          if ($answer eq 'con_lost') {
      &logthis("Second attempt con_lost on $server");
              my $peerfile="$perlvar{'lonSockDir'}/$server";
              my $client=IO::Socket::UNIX->new(Peer    =>"$peerfile",
                                               Type    => SOCK_STREAM,
                                               Timeout => 10)
                         or return "con_lost";
              &logthis("Killing socket");
              print $client "close_connection_exit\n";
              sleep 5;
              $answer=subreply($cmd,$server);       
          }   
       }
     if (($answer=~/^refused/) || ($answer=~/^rejected/)) {      if (($answer=~/^refused/) || ($answer=~/^rejected/)) {
        &logthis("<font color=blue>WARNING:".         &logthis("<font color=blue>WARNING:".
                 " $cmd to $server returned $answer</font>");                  " $cmd to $server returned $answer</font>");
Line 272  sub critical { Line 249  sub critical {
   
 sub appenv {  sub appenv {
     my %newenv=@_;      my %newenv=@_;
     map {      foreach (keys %newenv) {
  if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) {   if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) {
             &logthis("<font color=blue>WARNING: ".              &logthis("<font color=blue>WARNING: ".
                 "Attempt to modify environment ".$_." to ".$newenv{$_});                  "Attempt to modify environment ".$_." to ".$newenv{$_}
                   .'</font>');
     delete($newenv{$_});      delete($newenv{$_});
         } else {          } else {
             $ENV{$_}=$newenv{$_};              $ENV{$_}=$newenv{$_};
         }          }
     } keys %newenv;      }
   
     my $lockfh;      my $lockfh;
     unless ($lockfh=Apache::File->new("$ENV{'user.environment'}")) {      unless ($lockfh=Apache::File->new("$ENV{'user.environment'}")) {
Line 362  sub delenv { Line 340  sub delenv {
          $fh->close();           $fh->close();
          return 'error: '.$!;           return 'error: '.$!;
      }       }
      map {       foreach (@oldenv) {
  unless ($_=~/^$delthis/) { print $fh $_; }   unless ($_=~/^$delthis/) { print $fh $_; }
      } @oldenv;       }
      $fh->close();       $fh->close();
     }      }
     return 'ok';      return 'ok';
Line 386  sub spareserver { Line 364  sub spareserver {
     return $spareserver;      return $spareserver;
 }  }
   
   # --------------------------------------------- Try to change a user's password
   
   sub changepass {
       my ($uname,$udom,$currentpass,$newpass,$server)=@_;
       $currentpass = &escape($currentpass);
       $newpass     = &escape($newpass);
       my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass",
          $server);
       if (! $answer) {
    &logthis("No reply on password change request to $server ".
    "by $uname in domain $udom.");
       } elsif ($answer =~ "^ok") {
           &logthis("$uname in $udom successfully changed their password ".
    "on $server.");
       } elsif ($answer =~ "^pwchange_failure") {
    &logthis("$uname in $udom was unable to change their password ".
    "on $server.  The action was blocked by either lcpasswd ".
    "or pwchange");
       } elsif ($answer =~ "^non_authorized") {
           &logthis("$uname in $udom did not get their password correct when ".
    "attempting to change it on $server.");
       } elsif ($answer =~ "^auth_mode_error") {
           &logthis("$uname in $udom attempted to change their password despite ".
    "not being locally or internally authenticated on $server.");
       } elsif ($answer =~ "^unknown_user") {
           &logthis("$uname in $udom attempted to change their password ".
    "on $server but were unable to because $server is not ".
    "their home server.");
       } elsif ($answer =~ "^refused") {
    &logthis("$server refused to change $uname in $udom password because ".
    "it was sent an unencrypted request to change the password.");
       }
       return $answer;
   }
   
   # ----------------------- Try to determine user's current authentication scheme
   
   sub queryauthenticate {
       my ($uname,$udom)=@_;
       if (($perlvar{'lonRole'} eq 'library') && 
           ($udom eq $perlvar{'lonDefDomain'})) {
    my $answer=reply("encrypt:currentauth:$udom:$uname",
    $perlvar{'lonHostID'});
    unless ($answer eq 'unknown_user' or $answer eq 'refused') {
       if (length($answer)) {
    return $answer;
       }
       else {
    &logthis("User $uname at $udom lacks an authentication mechanism");
    return 'no_host';
       }
    }
       }
   
       my $tryserver;
       foreach $tryserver (keys %libserv) {
    if ($hostdom{$tryserver} eq $udom) {
              my $answer=reply("encrypt:currentauth:$udom:$uname",$tryserver);
      unless ($answer eq 'unknown_user' or $answer eq 'refused') {
          if (length($answer)) {
      return $answer;
          }
          else {
      &logthis("User $uname at $udom lacks an authentication mechanism");
      return 'no_host';
          }
      }
          }
       }
       &logthis("User $uname at $udom lacks an authentication mechanism");    
       return 'no_host';
   }
   
 # --------- Try to authenticate user from domain's lib servers (first this one)  # --------- Try to authenticate user from domain's lib servers (first this one)
   
 sub authenticate {  sub authenticate {
     my ($uname,$upass,$udom)=@_;      my ($uname,$upass,$udom)=@_;
     $upass=escape($upass);      $upass=escape($upass);
       $uname=~s/\W//g;
     if (($perlvar{'lonRole'} eq 'library') &&       if (($perlvar{'lonRole'} eq 'library') && 
         ($udom eq $perlvar{'lonDefDomain'})) {          ($udom eq $perlvar{'lonDefDomain'})) {
     my $answer=reply("encrypt:auth:$udom:$uname:$upass",$perlvar{'lonHostID'});      my $answer=reply("encrypt:auth:$udom:$uname:$upass",$perlvar{'lonHostID'});
Line 479  sub idget { Line 531  sub idget {
 sub idrget {  sub idrget {
     my ($udom,@unames)=@_;      my ($udom,@unames)=@_;
     my %returnhash=();      my %returnhash=();
     map {      foreach (@unames) {
         $returnhash{$_}=(&userenvironment($udom,$_,'id'))[1];          $returnhash{$_}=(&userenvironment($udom,$_,'id'))[1];
     } @unames;      }
     return %returnhash;      return %returnhash;
 }  }
   
Line 490  sub idrget { Line 542  sub idrget {
 sub idput {  sub idput {
     my ($udom,%ids)=@_;      my ($udom,%ids)=@_;
     my %servers=();      my %servers=();
     map {      foreach (keys %ids) {
         my $uhom=&homeserver($_,$udom);          my $uhom=&homeserver($_,$udom);
         if ($uhom ne 'no_host') {          if ($uhom ne 'no_host') {
             my $id=&escape($ids{$_});              my $id=&escape($ids{$_});
Line 503  sub idput { Line 555  sub idput {
             }              }
             &critical('put:'.$udom.':'.$unam.':environment:id='.$id,$uhom);              &critical('put:'.$udom.':'.$unam.':environment:id='.$id,$uhom);
         }          }
     } keys %ids;      }
     map {      foreach (keys %servers) {
         &critical('idput:'.$udom.':'.$servers{$_},$_);          &critical('idput:'.$udom.':'.$servers{$_},$_);
     } keys %servers;      }
 }  }
   
 # ------------------------------------- Find the section of student in a course  # ------------------------------------- Find the section of student in a course
Line 515  sub usection { Line 567  sub usection {
     my ($udom,$unam,$courseid)=@_;      my ($udom,$unam,$courseid)=@_;
     $courseid=~s/\_/\//g;      $courseid=~s/\_/\//g;
     $courseid=~s/^(\w)/\/$1/;      $courseid=~s/^(\w)/\/$1/;
     map {      foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',
                           &homeserver($unam,$udom)))) {
         my ($key,$value)=split(/\=/,$_);          my ($key,$value)=split(/\=/,$_);
         $key=&unescape($key);          $key=&unescape($key);
         if ($key=~/^$courseid(?:\/)*(\w+)*\_st$/) {          if ($key=~/^$courseid(?:\/)*(\w+)*\_st$/) {
Line 532  sub usection { Line 585  sub usection {
             }               } 
             unless ($notactive) { return $section; }              unless ($notactive) { return $section; }
         }          }
     } split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',      }
                         &homeserver($unam,$udom)));  
     return '-1';      return '-1';
 }  }
   
Line 575  sub subscribe { Line 627  sub subscribe {
 sub repcopy {  sub repcopy {
     my $filename=shift;      my $filename=shift;
     $filename=~s/\/+/\//g;      $filename=~s/\/+/\//g;
       if ($filename=~/^\/home\/httpd\/html\/adm\//) { return OK; }
     my $transname="$filename.in.transfer";      my $transname="$filename.in.transfer";
     if ((-e $filename) || (-e $transname)) { return OK; }      if ((-e $filename) || (-e $transname)) { return OK; }
     my $remoteurl=subscribe($filename);      my $remoteurl=subscribe($filename);
Line 640  sub ssi { Line 693  sub ssi {
           
     if (%form) {      if (%form) {
       $request=new HTTP::Request('POST',"http://".$ENV{'HTTP_HOST'}.$fn);        $request=new HTTP::Request('POST',"http://".$ENV{'HTTP_HOST'}.$fn);
       $request->content(join '&', map { "$_=$form{$_}" } keys %form);        $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form));
     } else {      } else {
       $request=new HTTP::Request('GET',"http://".$ENV{'HTTP_HOST'}.$fn);        $request=new HTTP::Request('GET',"http://".$ENV{'HTTP_HOST'}.$fn);
     }      }
Line 658  sub log { Line 711  sub log {
     return critical("log:$dom:$nam:$what",$hom);      return critical("log:$dom:$nam:$what",$hom);
 }  }
   
   # ------------------------------------------------------------------ Course Log
   
   sub flushcourselogs {
       &logthis('Flushing course log buffers');
       foreach (keys %courselogs) {
           my $crsid=$_;
           if (&reply('log:'.$coursedombuf{$crsid}.':'.
             &escape($courselogs{$crsid}),
             $coursehombuf{$crsid}) eq 'ok') {
       delete $courselogs{$crsid};
           } else {
               &logthis('Failed to flush log buffer for '.$crsid);
               if (length($courselogs{$crsid})>40000) {
                  &logthis("<font color=blue>WARNING: Buffer for ".$crsid.
                           " exceeded maximum size, deleting.</font>");
                  delete $courselogs{$crsid};
               }
           }        
       }
       &logthis('Flushing access logs');
       foreach (keys %accesshash) {
           my $entry=$_;
           $entry=~/\_\_\_(\w+)\/(\w+)\/(.*)\_\_\_(\w+)$/;
           my %temphash=($entry => $accesshash{$entry});
           if (&Apache::lonnet::put('resevaldata',\%temphash,$1,$2) eq 'ok') {
       delete $accesshash{$entry};
           }
       }
       $dumpcount++;
   }
   
   sub courselog {
       my $what=shift;
       $what=time.':'.$what;
       unless ($ENV{'request.course.id'}) { return ''; }
       $coursedombuf{$ENV{'request.course.id'}}=
          $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.':'.
          $ENV{'course.'.$ENV{'request.course.id'}.'.num'};
       $coursehombuf{$ENV{'request.course.id'}}=
          $ENV{'course.'.$ENV{'request.course.id'}.'.home'};
       if (defined $courselogs{$ENV{'request.course.id'}}) {
    $courselogs{$ENV{'request.course.id'}}.='&'.$what;
       } else {
    $courselogs{$ENV{'request.course.id'}}.=$what;
       }
       if (length($courselogs{$ENV{'request.course.id'}})>4048) {
    &flushcourselogs();
       }
   }
   
   sub courseacclog {
       my $fnsymb=shift;
       unless ($ENV{'request.course.id'}) { return ''; }
       my $what=$fnsymb.':'.$ENV{'user.name'}.':'.$ENV{'user.domain'};
       if ($fnsymb=~/(problem|exam|quiz|assess|survey|form)$/) {
           $what.=':POST';
    foreach (keys %ENV) {
               if ($_=~/^form\.(.*)/) {
    $what.=':'.$1.'='.$ENV{$_};
               }
           }
       }
       &courselog($what);
   }
   
   sub countacc {
       my $url=&declutter(shift);
       unless ($ENV{'request.course.id'}) { return ''; }
       $accesshash{$ENV{'request.course.id'}.'___'.$url.'___course'}=1;
       my $key=$processmarker.'_'.$dumpcount.'___'.$url.'___count';
       if (defined($accesshash{$key})) {
    $accesshash{$key}++;
       } else {
           $accesshash{$key}=1;
       }
   }
       
   # ----------------------------------------------------------- Check out an item
   
   sub checkout {
       my ($symb,$tuname,$tudom,$tcrsid)=@_;
       my $now=time;
       my $lonhost=$perlvar{'lonHostID'};
       my $infostr=&escape(
                    $tuname.'&'.
                    $tudom.'&'.
                    $tcrsid.'&'.
                    $symb.'&'.
    $now.'&'.$ENV{'REMOTE_ADDR'});
       my $token=&reply('tmpput:'.$infostr,$lonhost);
       if ($token=~/^error\:/) { 
           &logthis("<font color=blue>WARNING: ".
                   "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.
                    "</font>");
           return ''; 
       }
   
       $token=~s/^(\d+)\_.*\_(\d+)$/$1\*$2\*$lonhost/;
       $token=~tr/a-z/A-Z/;
   
       my %infohash=('resource.0.outtoken' => $token,
                     'resource.0.checkouttime' => $now,
                     'resource.0.outremote' => $ENV{'REMOTE_ADDR'});
   
       unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
          return '';
       } else {
           &logthis("<font color=blue>WARNING: ".
                   "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.
                    "</font>");
       }    
   
       if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
                            &escape('Checkout '.$infostr.' - '.
                                                    $token)) ne 'ok') {
    return '';
       } else {
           &logthis("<font color=blue>WARNING: ".
                   "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.
                    "</font>");
       }
       return $token;
   }
   
   # ------------------------------------------------------------ Check in an item
   
   sub checkin {
       my $token=shift;
       my $now=time;
       my ($ta,$tb,$lonhost)=split(/\*/,$token);
       $lonhost=~tr/A-Z/a-z/;
       my $dtoken=$ta.'_'.$hostip{$lonhost}.'_'.$tb;
       $dtoken=~s/\W/\_/g;
       my ($tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
                    split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));
   
       unless (($tuname) && ($tudom)) {
           &logthis('Check in '.$token.' ('.$dtoken.') failed');
           return '';
       }
       
       unless (&allowed('mgr',$tcrsid)) {
           &logthis('Check in '.$token.' ('.$dtoken.') unauthorized: '.
                    $ENV{'user.name'}.' - '.$ENV{'user.domain'});
           return '';
       }
   
       my %infohash=('resource.0.intoken' => $token,
                     'resource.0.checkintime' => $now,
                     'resource.0.inremote' => $ENV{'REMOTE_ADDR'});
   
       unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
          return '';
       }    
   
       if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
                            &escape('Checkin - '.$token)) ne 'ok') {
    return '';
       }
   
       return ($symb,$tuname,$tudom,$tcrsid);    
   }
   
 # --------------------------------------------- Set Expire Date for Spreadsheet  # --------------------------------------------- Set Expire Date for Spreadsheet
   
 sub expirespread {  sub expirespread {
Line 698  sub devalidate { Line 914  sub devalidate {
     }      }
 }  }
   
   sub arrayref2str {
     my ($arrayref) = @_;
     my $result='_ARRAY_REF__';
     foreach my $elem (@$arrayref) {
       if (ref($elem) eq 'ARRAY') {
         $result.=&escape(&arrayref2str($elem)).'&';
       } elsif (ref($elem) eq 'HASH') {
         $result.=&escape(&hashref2str($elem)).'&';
       } elsif (ref($elem)) {
         &logthis("Got a ref of ".(ref($elem))." skipping.");
       } else {
         $result.=&escape($elem).'&';
       }
     }
     $result=~s/\&$//;
     return $result;
   }
   
   sub hash2str {
     my (%hash) = @_;
     my $result=&hashref2str(\%hash);
     $result=~s/^_HASH_REF__//;
     return $result;
   }
   
   sub hashref2str {
     my ($hashref)=@_;
     my $result='_HASH_REF__';
     foreach (keys(%$hashref)) {
       if (ref($_) eq 'ARRAY') {
         $result.=&escape(&arrayref2str($_)).'=';
       } elsif (ref($_) eq 'HASH') {
         $result.=&escape(&hashref2str($_)).'=';
       } elsif (ref($_)) {
         &logthis("Got a ref of ".(ref($_))." skipping.");
       } else {
         $result.=&escape($_).'=';
       }
   
       if (ref($$hashref{$_}) eq 'ARRAY') {
         $result.=&escape(&arrayref2str($$hashref{$_})).'&';
       } elsif (ref($$hashref{$_}) eq 'HASH') {
         $result.=&escape(&hashref2str($$hashref{$_})).'&';
       } elsif (ref($$hashref{$_})) {
         &logthis("Got a ref of ".(ref($$hashref{$_}))." skipping.");
       } else {
         $result.=&escape($$hashref{$_}).'&';
       }
     }
     $result=~s/\&$//;
     return $result;
   }
   
   sub str2hash {
     my ($string) = @_;
     my %returnhash;
     foreach (split(/\&/,$string)) {
       my ($name,$value)=split(/\=/,$_);
       $name=&unescape($name);
       $value=&unescape($value);
       if ($value =~ /^_HASH_REF__/) {
         $value =~ s/^_HASH_REF__//;
         my %hash=&str2hash($value);
         $value=\%hash;
       } elsif ($value =~ /^_ARRAY_REF__/) {
         $value =~ s/^_ARRAY_REF__//;
         my @array=&str2array($value);
         $value=\@array;
       }
       $returnhash{$name}=$value;
     }
     return (%returnhash);
   }
   
   sub str2array {
     my ($string) = @_;
     my @returnarray;
     foreach my $value (split(/\&/,$string)) {
       $value=&unescape($value);
       if ($value =~ /^_HASH_REF__/) {
         $value =~ s/^_HASH_REF__//;
         my %hash=&str2hash($value);
         $value=\%hash;
       } elsif ($value =~ /^_ARRAY_REF__/) {
         $value =~ s/^_ARRAY_REF__//;
         my @array=&str2array($value);
         $value=\@array;
       }
       push(@returnarray,$value);
     }
     return (@returnarray);
   }
   
   # -------------------------------------------------------------------Temp Store
   
   sub tmpreset {
     my ($symb,$namespace,$domain,$stuname) = @_;
     if (!$symb) {
       $symb=&symbread();
       if (!$symb) { $symb= $ENV{'REQUEST_URI'}; }
     }
     $symb=escape($symb);
   
     if (!$namespace) { $namespace=$ENV{'request.state'}; }
     $namespace=~s/\//\_/g;
     $namespace=~s/\W//g;
   
     #FIXME needs to do something for /pub resources
     if (!$domain) { $domain=$ENV{'user.domain'}; }
     if (!$stuname) { $stuname=$ENV{'user.name'}; }
     my $path=$perlvar{'lonDaemons'}.'/tmp';
     my %hash;
     if (tie(%hash,'GDBM_File',
     $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
     &GDBM_WRCREAT,0640)) {
       foreach my $key (keys %hash) {
         if ($key=~ /:$symb/) {
    delete($hash{$key});
         }
       }
     }
   }
   
   sub tmpstore {
     my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
   
     if (!$symb) {
       $symb=&symbread();
       if (!$symb) { $symb= $ENV{'request.url'}; }
     }
     $symb=escape($symb);
   
     if (!$namespace) {
       # I don't think we would ever want to store this for a course.
       # it seems this will only be used if we don't have a course.
       #$namespace=$ENV{'request.course.id'};
       #if (!$namespace) {
         $namespace=$ENV{'request.state'};
       #}
     }
     $namespace=~s/\//\_/g;
     $namespace=~s/\W//g;
   #FIXME needs to do something for /pub resources
     if (!$domain) { $domain=$ENV{'user.domain'}; }
     if (!$stuname) { $stuname=$ENV{'user.name'}; }
     my $now=time;
     my %hash;
     my $path=$perlvar{'lonDaemons'}.'/tmp';
     if (tie(%hash,'GDBM_File',
     $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
     &GDBM_WRCREAT,0640)) {
       $hash{"version:$symb"}++;
       my $version=$hash{"version:$symb"};
       my $allkeys=''; 
       foreach my $key (keys(%$storehash)) {
         $allkeys.=$key.':';
         $hash{"$version:$symb:$key"}=$$storehash{$key};
       }
       $hash{"$version:$symb:timestamp"}=$now;
       $allkeys.='timestamp';
       $hash{"$version:keys:$symb"}=$allkeys;
       if (untie(%hash)) {
         return 'ok';
       } else {
         return "error:$!";
       }
     } else {
       return "error:$!";
     }
   }
   
   # -----------------------------------------------------------------Temp Restore
   
   sub tmprestore {
     my ($symb,$namespace,$domain,$stuname) = @_;
   
     if (!$symb) {
       $symb=&symbread();
       if (!$symb) { $symb= $ENV{'request.url'}; }
     }
     $symb=escape($symb);
   
     if (!$namespace) { $namespace=$ENV{'request.state'}; }
     #FIXME needs to do something for /pub resources
     if (!$domain) { $domain=$ENV{'user.domain'}; }
     if (!$stuname) { $stuname=$ENV{'user.name'}; }
   
     my %returnhash;
     $namespace=~s/\//\_/g;
     $namespace=~s/\W//g;
     my %hash;
     my $path=$perlvar{'lonDaemons'}.'/tmp';
     if (tie(%hash,'GDBM_File',
     $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
     &GDBM_READER,0640)) {
       my $version=$hash{"version:$symb"};
       $returnhash{'version'}=$version;
       my $scope;
       for ($scope=1;$scope<=$version;$scope++) {
         my $vkeys=$hash{"$scope:keys:$symb"};
         my @keys=split(/:/,$vkeys);
         my $key;
         $returnhash{"$scope:keys"}=$vkeys;
         foreach $key (@keys) {
    $returnhash{"$scope:$key"}=$hash{"$scope:$symb:$key"};
    $returnhash{"$key"}=$hash{"$scope:$symb:$key"};
         }
       }
       if (!(untie(%hash))) {
         return "error:$!";
       }
     } else {
       return "error:$!";
     }
     return %returnhash;
   }
   
 # ----------------------------------------------------------------------- Store  # ----------------------------------------------------------------------- Store
   
 sub store {  sub store {
     my ($storehash,$symb,$namespace,$domain,$stuname) = @_;      my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
     my $home='';      my $home='';
   
     if ($stuname) {      if ($stuname) { $home=&homeserver($stuname,$domain); }
  $home=&homeserver($stuname,$domain);  
     }  
   
       $symb=&symbclean($symb);
     if (!$symb) { unless ($symb=&symbread()) { return ''; } }      if (!$symb) { unless ($symb=&symbread()) { return ''; } }
   
     &devalidate($symb);      &devalidate($symb);
   
     $symb=escape($symb);      $symb=escape($symb);
     if (!$namespace) { unless ($namespace=$ENV{'request.course.id'}) { return ''; } }      if (!$namespace) { 
          unless ($namespace=$ENV{'request.course.id'}) { 
             return ''; 
          } 
       }
     if (!$domain) { $domain=$ENV{'user.domain'}; }      if (!$domain) { $domain=$ENV{'user.domain'}; }
     if (!$stuname) { $stuname=$ENV{'user.name'}; }      if (!$stuname) { $stuname=$ENV{'user.name'}; }
     if (!$home) { $home=$ENV{'user.home'}; }      if (!$home) { $home=$ENV{'user.home'}; }
     my $namevalue='';      my $namevalue='';
     map {      foreach (keys %$storehash) {
         $namevalue.=escape($_).'='.escape($$storehash{$_}).'&';          $namevalue.=escape($_).'='.escape($$storehash{$_}).'&';
     } keys %$storehash;      }
     $namevalue=~s/\&$//;      $namevalue=~s/\&$//;
       &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue);
     return reply("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");      return reply("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");
 }  }
   
Line 731  sub cstore { Line 1168  sub cstore {
     my ($storehash,$symb,$namespace,$domain,$stuname) = @_;      my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
     my $home='';      my $home='';
   
     if ($stuname) {      if ($stuname) { $home=&homeserver($stuname,$domain); }
  $home=&homeserver($stuname,$domain);  
     }  
   
       $symb=&symbclean($symb);
     if (!$symb) { unless ($symb=&symbread()) { return ''; } }      if (!$symb) { unless ($symb=&symbread()) { return ''; } }
   
     &devalidate($symb);      &devalidate($symb);
   
     $symb=escape($symb);      $symb=escape($symb);
     if (!$namespace) { unless ($namespace=$ENV{'request.course.id'}) { return ''; } }      if (!$namespace) { 
          unless ($namespace=$ENV{'request.course.id'}) { 
             return ''; 
          } 
       }
     if (!$domain) { $domain=$ENV{'user.domain'}; }      if (!$domain) { $domain=$ENV{'user.domain'}; }
     if (!$stuname) { $stuname=$ENV{'user.name'}; }      if (!$stuname) { $stuname=$ENV{'user.name'}; }
     if (!$home) { $home=$ENV{'user.home'}; }      if (!$home) { $home=$ENV{'user.home'}; }
   
     my $namevalue='';      my $namevalue='';
     map {      foreach (keys %$storehash) {
         $namevalue.=escape($_).'='.escape($$storehash{$_}).'&';          $namevalue.=escape($_).'='.escape($$storehash{$_}).'&';
     } keys %$storehash;      }
     $namevalue=~s/\&$//;      $namevalue=~s/\&$//;
     return critical("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");      &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue);
       return critical
                   ("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");
 }  }
   
 # --------------------------------------------------------------------- Restore  # --------------------------------------------------------------------- Restore
Line 759  sub restore { Line 1201  sub restore {
     my ($symb,$namespace,$domain,$stuname) = @_;      my ($symb,$namespace,$domain,$stuname) = @_;
     my $home='';      my $home='';
   
     if ($stuname) {      if ($stuname) { $home=&homeserver($stuname,$domain); }
  $home=&homeserver($stuname,$domain);  
     }  
   
     if (!$symb) {      if (!$symb) {
       unless ($symb=escape(&symbread())) { return ''; }        unless ($symb=escape(&symbread())) { return ''; }
     } else {      } else {
       $symb=&escape($symb);        $symb=&escape(&symbclean($symb));
       }
       if (!$namespace) { 
          unless ($namespace=$ENV{'request.course.id'}) { 
             return ''; 
          } 
     }      }
     if (!$namespace) { unless ($namespace=$ENV{'request.course.id'}) { return ''; } }  
     if (!$domain) { $domain=$ENV{'user.domain'}; }      if (!$domain) { $domain=$ENV{'user.domain'}; }
     if (!$stuname) { $stuname=$ENV{'user.name'}; }      if (!$stuname) { $stuname=$ENV{'user.name'}; }
     if (!$home) { $home=$ENV{'user.home'}; }      if (!$home) { $home=$ENV{'user.home'}; }
     my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home");      my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home");
   
     my %returnhash=();      my %returnhash=();
     map {      foreach (split(/\&/,$answer)) {
  my ($name,$value)=split(/\=/,$_);   my ($name,$value)=split(/\=/,$_);
         $returnhash{&unescape($name)}=&unescape($value);          $returnhash{&unescape($name)}=&unescape($value);
     } split(/\&/,$answer);      }
     my $version;      my $version;
     for ($version=1;$version<=$returnhash{'version'};$version++) {      for ($version=1;$version<=$returnhash{'version'};$version++) {
        map {         foreach (split(/\:/,$returnhash{$version.':keys'})) {
           $returnhash{$_}=$returnhash{$version.':'.$_};            $returnhash{$_}=$returnhash{$version.':'.$_};
        } split(/\:/,$returnhash{$version.':keys'});         }
     }      }
     return %returnhash;      return %returnhash;
 }  }
Line 834  sub rolesinit { Line 1278  sub rolesinit {
     my $thesestr;      my $thesestr;
   
     if ($rolesdump ne '') {      if ($rolesdump ne '') {
         map {          foreach (split(/&/,$rolesdump)) {
   if ($_!~/^rolesdef\&/) {    if ($_!~/^rolesdef\&/) {
             my ($area,$role)=split(/=/,$_);              my ($area,$role)=split(/=/,$_);
             $area=~s/\_\w\w$//;              $area=~s/\_\w\w$//;
Line 890  sub rolesinit { Line 1334  sub rolesinit {
        }         }
             }              }
           }             } 
         } split(/&/,$rolesdump);          }
         my $adv=0;          my $adv=0;
         my $author=0;          my $author=0;
         map {          foreach (keys %allroles) {
             %thesepriv=();              %thesepriv=();
             if ($_!~/^st/) { $adv=1; }              if (($_!~/^st/) && ($_!~/^ta/) && ($_!~/^cm/)) { $adv=1; }
             if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; }              if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; }
             map {              foreach (split(/:/,$allroles{$_})) {
                 if ($_ ne '') {                  if ($_ ne '') {
     my ($privilege,$restrictions)=split(/&/,$_);      my ($privilege,$restrictions)=split(/&/,$_);
                     if ($restrictions eq '') {                      if ($restrictions eq '') {
Line 908  sub rolesinit { Line 1352  sub rolesinit {
                         }                          }
                     }                      }
                 }                  }
             } split(/:/,$allroles{$_});              }
             $thesestr='';              $thesestr='';
             map { $thesestr.=':'.$_.'&'.$thesepriv{$_}; } keys %thesepriv;              foreach (keys %thesepriv) { $thesestr.=':'.$_.'&'.$thesepriv{$_}; }
             $userroles.='user.priv.'.$_.'='.$thesestr."\n";              $userroles.='user.priv.'.$_.'='.$thesestr."\n";
         } keys %allroles;                      }
         $userroles.='user.adv='.$adv."\n".          $userroles.='user.adv='.$adv."\n".
             'user.author='.$author."\n";              'user.author='.$author."\n";
         $ENV{'user.adv'}=$adv;          $ENV{'user.adv'}=$adv;
Line 925  sub rolesinit { Line 1369  sub rolesinit {
 sub get {  sub get {
    my ($namespace,$storearr,$udomain,$uname)=@_;     my ($namespace,$storearr,$udomain,$uname)=@_;
    my $items='';     my $items='';
    map {     foreach (@$storearr) {
        $items.=escape($_).'&';         $items.=escape($_).'&';
    } @$storearr;     }
    $items=~s/\&$//;     $items=~s/\&$//;
    if (!$udomain) { $udomain=$ENV{'user.domain'}; }     if (!$udomain) { $udomain=$ENV{'user.domain'}; }
    if (!$uname) { $uname=$ENV{'user.name'}; }     if (!$uname) { $uname=$ENV{'user.name'}; }
Line 937  sub get { Line 1381  sub get {
    my @pairs=split(/\&/,$rep);     my @pairs=split(/\&/,$rep);
    my %returnhash=();     my %returnhash=();
    my $i=0;     my $i=0;
    map {     foreach (@$storearr) {
       $returnhash{$_}=unescape($pairs[$i]);        $returnhash{$_}=unescape($pairs[$i]);
       $i++;        $i++;
    } @$storearr;     }
    return %returnhash;     return %returnhash;
 }  }
   
Line 949  sub get { Line 1393  sub get {
 sub del {  sub del {
    my ($namespace,$storearr,$udomain,$uname)=@_;     my ($namespace,$storearr,$udomain,$uname)=@_;
    my $items='';     my $items='';
    map {     foreach (@$storearr) {
        $items.=escape($_).'&';         $items.=escape($_).'&';
    } @$storearr;     }
    $items=~s/\&$//;     $items=~s/\&$//;
    if (!$udomain) { $udomain=$ENV{'user.domain'}; }     if (!$udomain) { $udomain=$ENV{'user.domain'}; }
    if (!$uname) { $uname=$ENV{'user.name'}; }     if (!$uname) { $uname=$ENV{'user.name'}; }
Line 963  sub del { Line 1407  sub del {
 # -------------------------------------------------------------- dump interface  # -------------------------------------------------------------- dump interface
   
 sub dump {  sub dump {
    my ($namespace,$udomain,$uname)=@_;     my ($namespace,$udomain,$uname,$regexp)=@_;
    if (!$udomain) { $udomain=$ENV{'user.domain'}; }     if (!$udomain) { $udomain=$ENV{'user.domain'}; }
    if (!$uname) { $uname=$ENV{'user.name'}; }     if (!$uname) { $uname=$ENV{'user.name'}; }
    my $uhome=&homeserver($uname,$udomain);     my $uhome=&homeserver($uname,$udomain);
    my $rep=reply("dump:$udomain:$uname:$namespace",$uhome);     if ($regexp) {
          $regexp=&escape($regexp);
      } else {
          $regexp='.';
      }
      my $rep=reply("dump:$udomain:$uname:$namespace:$regexp",$uhome);
    my @pairs=split(/\&/,$rep);     my @pairs=split(/\&/,$rep);
    my %returnhash=();     my %returnhash=();
    map {     foreach (@pairs) {
       my ($key,$value)=split(/=/,$_);        my ($key,$value)=split(/=/,$_);
       $returnhash{unescape($key)}=unescape($value);        $returnhash{unescape($key)}=unescape($value);
    } @pairs;     }
    return %returnhash;     return %returnhash;
 }  }
   
 # --------------------------------------------------------------- put interface  # --------------------------------------------------------------- put interface
   
 sub put {  sub put {
    my ($namespace,%storehash)=@_;     my ($namespace,$storehash,$udomain,$uname)=@_;
      if (!$udomain) { $udomain=$ENV{'user.domain'}; }
      if (!$uname) { $uname=$ENV{'user.name'}; }
      my $uhome=&homeserver($uname,$udomain);
    my $items='';     my $items='';
    map {     foreach (keys %$storehash) {
        $items.=escape($_).'='.escape($storehash{$_}).'&';         $items.=&escape($_).'='.&escape($$storehash{$_}).'&';
    } keys %storehash;     }
    $items=~s/\&$//;     $items=~s/\&$//;
    return reply("put:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",     return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
                  $ENV{'user.home'});  
 }  }
   
 # ------------------------------------------------------ critical put interface  # ------------------------------------------------------ critical put interface
   
 sub cput {  sub cput {
    my ($namespace,%storehash)=@_;     my ($namespace,$storehash,$udomain,$uname)=@_;
      if (!$udomain) { $udomain=$ENV{'user.domain'}; }
      if (!$uname) { $uname=$ENV{'user.name'}; }
      my $uhome=&homeserver($uname,$udomain);
    my $items='';     my $items='';
    map {     foreach (keys %$storehash) {
        $items.=escape($_).'='.escape($storehash{$_}).'&';         $items.=escape($_).'='.escape($$storehash{$_}).'&';
    } keys %storehash;     }
    $items=~s/\&$//;     $items=~s/\&$//;
    return critical     return &critical("put:$udomain:$uname:$namespace:$items",$uhome);
            ("put:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",  
                  $ENV{'user.home'});  
 }  }
   
 # -------------------------------------------------------------- eget interface  # -------------------------------------------------------------- eget interface
Line 1009  sub cput { Line 1461  sub cput {
 sub eget {  sub eget {
    my ($namespace,$storearr,$udomain,$uname)=@_;     my ($namespace,$storearr,$udomain,$uname)=@_;
    my $items='';     my $items='';
    map {     foreach (@$storearr) {
        $items.=escape($_).'&';         $items.=escape($_).'&';
    } @$storearr;     }
    $items=~s/\&$//;     $items=~s/\&$//;
    if (!$udomain) { $udomain=$ENV{'user.domain'}; }     if (!$udomain) { $udomain=$ENV{'user.domain'}; }
    if (!$uname) { $uname=$ENV{'user.name'}; }     if (!$uname) { $uname=$ENV{'user.name'}; }
Line 1020  sub eget { Line 1472  sub eget {
    my @pairs=split(/\&/,$rep);     my @pairs=split(/\&/,$rep);
    my %returnhash=();     my %returnhash=();
    my $i=0;     my $i=0;
    map {     foreach (@$storearr) {
       $returnhash{$_}=unescape($pairs[$i]);        $returnhash{$_}=unescape($pairs[$i]);
       $i++;        $i++;
    } @$storearr;     }
    return %returnhash;     return %returnhash;
 }  }
   
Line 1031  sub eget { Line 1483  sub eget {
   
 sub allowed {  sub allowed {
     my ($priv,$uri)=@_;      my ($priv,$uri)=@_;
   
       my $orguri=$uri;
     $uri=&declutter($uri);      $uri=&declutter($uri);
   
 # Free bre access to adm and meta resources  # Free bre access to adm and meta resources
Line 1039  sub allowed { Line 1493  sub allowed {
  return 'F';   return 'F';
     }      }
   
   # Free bre to public access
   
       if ($priv eq 'bre') {
    if (&metadata($uri,'copyright') eq 'public') { return 'F'; }
       }
   
     my $thisallowed='';      my $thisallowed='';
     my $statecond=0;      my $statecond=0;
     my $courseprivid='';      my $courseprivid='';
Line 1074  sub allowed { Line 1534  sub allowed {
   
 # If this is generating or modifying users, exit with special codes  # If this is generating or modifying users, exit with special codes
   
     if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:'=~/\:$priv\:/) {      if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:'=~/\:$priv\:/) {
  return $thisallowed;   return $thisallowed;
     }      }
 #  #
Line 1104  sub allowed { Line 1564  sub allowed {
            }             }
        }         }
                 
        if (($ENV{'HTTP_REFERER'}) && ($checkreferer)) {         if ($checkreferer) {
   my $refuri=$ENV{'HTTP_REFERER'};    my $refuri=$ENV{'httpref.'.$orguri};
           $refuri=~s/^http\:\/\/$ENV{'request.host'}//i;  
           $refuri=&declutter($refuri);              unless ($refuri) {
                   foreach (keys %ENV) {
       if ($_=~/^httpref\..*\*/) {
    my $pattern=$_;
                           $pattern=~s/^httpref\.\/res\///;
                           $pattern=~s/\*/\[\^\/\]\+/g;
                           $pattern=~s/\//\\\//g;
                           if ($orguri=~/$pattern/) {
       $refuri=$ENV{$_};
                           }
                       }
                   }
               }
            if ($refuri) { 
     $refuri=&declutter($refuri);
           my @uriparts=split(/\//,$refuri);            my @uriparts=split(/\//,$refuri);
           my $filename=$uriparts[$#uriparts];            my $filename=$uriparts[$#uriparts];
           my $pathname=$refuri;            my $pathname=$refuri;
           $pathname=~s/\/$filename$//;            $pathname=~s/\/$filename$//;
           my @filenameparts=split(/\./,$uri);  
           if (&fileembstyle($filenameparts[$#filenameparts]) ne 'ssi') {  
             if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~              if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~
               /\&$filename\:([\d\|]+)\&/) {                /\&$filename\:([\d\|]+)\&/) {
               my $refstatecond=$1;                my $refstatecond=$1;
Line 1123  sub allowed { Line 1595  sub allowed {
                   $uri=$refuri;                    $uri=$refuri;
                   $statecond=$refstatecond;                    $statecond=$refstatecond;
               }                }
             }  
           }            }
           }
        }         }
    }     }
   
Line 1215  sub allowed { Line 1687  sub allowed {
    if ($thisallowed=~/C/) {     if ($thisallowed=~/C/) {
        my $rolecode=(split(/\./,$ENV{'request.role'}))[0];         my $rolecode=(split(/\./,$ENV{'request.role'}))[0];
        if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.roles.denied'}         if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.roles.denied'}
    =~/\,$rolecode\,/) {     =~/$rolecode/) {
            &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},             &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},
                 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.                  'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
                 $ENV{'request.course.id'});                  $ENV{'request.course.id'});
Line 1262  sub allowed { Line 1734  sub allowed {
 sub definerole {  sub definerole {
   if (allowed('mcr','/')) {    if (allowed('mcr','/')) {
     my ($rolename,$sysrole,$domrole,$courole)=@_;      my ($rolename,$sysrole,$domrole,$courole)=@_;
     map {      foreach (split('/',$sysrole)) {
  my ($crole,$cqual)=split(/\&/,$_);   my ($crole,$cqual)=split(/\&/,$_);
         if ($pr{'cr:s'}!~/$crole/) { return "refused:s:$crole"; }          if ($pr{'cr:s'}!~/$crole/) { return "refused:s:$crole"; }
         if ($pr{'cr:s'}=~/$crole\&/) {          if ($pr{'cr:s'}=~/$crole\&/) {
Line 1270  sub definerole { Line 1742  sub definerole {
                return "refused:s:$crole&$cqual";                  return "refused:s:$crole&$cqual"; 
             }              }
         }          }
     } split('/',$sysrole);      }
     map {      foreach (split('/',$domrole)) {
  my ($crole,$cqual)=split(/\&/,$_);   my ($crole,$cqual)=split(/\&/,$_);
         if ($pr{'cr:d'}!~/$crole/) { return "refused:d:$crole"; }          if ($pr{'cr:d'}!~/$crole/) { return "refused:d:$crole"; }
         if ($pr{'cr:d'}=~/$crole\&/) {          if ($pr{'cr:d'}=~/$crole\&/) {
Line 1279  sub definerole { Line 1751  sub definerole {
                return "refused:d:$crole&$cqual";                  return "refused:d:$crole&$cqual"; 
             }              }
         }          }
     } split('/',$domrole);      }
     map {      foreach (split('/',$courole)) {
  my ($crole,$cqual)=split(/\&/,$_);   my ($crole,$cqual)=split(/\&/,$_);
         if ($pr{'cr:c'}!~/$crole/) { return "refused:c:$crole"; }          if ($pr{'cr:c'}!~/$crole/) { return "refused:c:$crole"; }
         if ($pr{'cr:c'}=~/$crole\&/) {          if ($pr{'cr:c'}=~/$crole\&/) {
Line 1288  sub definerole { Line 1760  sub definerole {
                return "refused:c:$crole&$cqual";                  return "refused:c:$crole&$cqual"; 
             }              }
         }          }
     } split('/',$courole);      }
     my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:".      my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:".
                 "$ENV{'user.domain'}:$ENV{'user.name'}:".                  "$ENV{'user.domain'}:$ENV{'user.name'}:".
         "rolesdef_$rolename=".          "rolesdef_$rolename=".
Line 1303  sub definerole { Line 1775  sub definerole {
   
 sub metadata_query {  sub metadata_query {
     my ($query,$custom,$customshow)=@_;      my ($query,$custom,$customshow)=@_;
     # need to put in a library server loop here and return a hash  
     my %rhash;      my %rhash;
     for my $server (keys %libserv) {      for my $server (keys %libserv) {
  unless ($custom or $customshow) {   unless ($custom or $customshow) {
Line 1327  sub plaintext { Line 1798  sub plaintext {
     return $prp{$short};      return $prp{$short};
 }  }
   
 # ------------------------------------------------------------------ Plain Text  
   
 sub fileembstyle {  
     my $ending=shift;  
     return $fe{$ending};  
 }  
   
 # ------------------------------------------------------------ Description Text  
   
 sub filedescription {  
     my $ending=shift;  
     return $fd{$ending};  
 }  
   
 # ----------------------------------------------------------------- Assign Role  # ----------------------------------------------------------------- Assign Role
   
 sub assignrole {  sub assignrole {
Line 1378  sub assignrole { Line 1835  sub assignrole {
     return &reply($command,&homeserver($uname,$udom));      return &reply($command,&homeserver($uname,$udom));
 }  }
   
 # --------------------------------------------------------------- Modify a user  # -------------------------------------------------- Modify user authentication
   # Overrides without validation
   
   sub modifyuserauth {
       my ($udom,$uname,$umode,$upass)=@_;
       my $uhome=&homeserver($uname,$udom);
       unless (&allowed('mau',$udom)) { return 'refused'; }
       &logthis('Call to modify user authentication '.$udom.', '.$uname.', '.
                $umode.' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'});  
       my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'.
        &escape($upass),$uhome);
       &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.home'},
           'Authentication changed for '.$udom.', '.$uname.', '.$umode.
            '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply);
       &log($udom,,$uname,$uhome,
           'Authentication changed by '.$ENV{'user.domain'}.', '.
                                        $ENV{'user.name'}.', '.$umode.
            '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply);
       unless ($reply eq 'ok') {
           &logthis('Authentication mode error: '.$reply);
    return 'error: '.$reply;
       }   
       return 'ok';
   }
   
   # --------------------------------------------------------------- Modify a user
   
 sub modifyuser {  sub modifyuser {
     my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene)=@_;      my ($udom,    $uname, $uid,
           $umode,   $upass, $first,
           $middle,  $last,  $gene,
           $forceid, $desiredhome)=@_;
       $udom=~s/\W//g;
       $uname=~s/\W//g;
     &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.      &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
              $umode.', '.$first.', '.$middle.', '.               $umode.', '.$first.', '.$middle.', '.
      $last.', '.$gene.' by '.       $last.', '.$gene.'(forceid: '.$forceid.')'.
              $ENV{'user.name'}.' at '.$ENV{'user.domain'});                 (defined($desiredhome) ? ' desiredhome = '.$desiredhome :
                                        ' desiredhome not specified'). 
                ' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'});
     my $uhome=&homeserver($uname,$udom);      my $uhome=&homeserver($uname,$udom);
 # ----------------------------------------------------------------- Create User  # ----------------------------------------------------------------- Create User
     if (($uhome eq 'no_host') && ($umode) && ($upass)) {      if (($uhome eq 'no_host') && ($umode) && ($upass)) {
         my $unhome='';          my $unhome='';
  if ($ENV{'course.'.$ENV{'request.course.id'}.'.domain'} eq $udom) {          if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) { 
               $unhome = $desiredhome;
    } elsif($ENV{'course.'.$ENV{'request.course.id'}.'.domain'} eq $udom) {
     $unhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'};      $unhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'};
         } else {          } else { # load balancing routine for determining $unhome
             my $tryserver;              my $tryserver;
             my $loadm=10000000;              my $loadm=10000000;
             foreach $tryserver (keys %libserv) {              foreach $tryserver (keys %libserv) {
Line 1407  sub modifyuser { Line 1897  sub modifyuser {
     }      }
         }          }
         if (($unhome eq '') || ($unhome eq 'no_host')) {          if (($unhome eq '') || ($unhome eq 'no_host')) {
     return 'error: find home';      return 'error: unable to find a home server for '.$uname.
                      ' in domain '.$udom;
         }          }
         my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':'.$umode.':'.          my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':'.$umode.':'.
                          &escape($upass),$unhome);                           &escape($upass),$unhome);
Line 1418  sub modifyuser { Line 1909  sub modifyuser {
         if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) {          if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) {
     return 'error: verify home';      return 'error: verify home';
         }          }
     }      }   # End of creation of new user
 # ---------------------------------------------------------------------- Add ID  # ---------------------------------------------------------------------- Add ID
     if ($uid) {      if ($uid) {
        $uid=~tr/A-Z/a-z/;         $uid=~tr/A-Z/a-z/;
        my %uidhash=&idrget($udom,$uname);         my %uidhash=&idrget($udom,$uname);
        if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/)) {         if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/) 
            && (!$forceid)) {
   unless ($uid eq $uidhash{$uname}) {    unless ($uid eq $uidhash{$uname}) {
       return 'error: mismatch '.$uidhash{$uname}.' versus '.$uid;        return 'error: mismatch '.$uidhash{$uname}.' versus '.$uid;
           }            }
Line 1432  sub modifyuser { Line 1924  sub modifyuser {
        }         }
     }      }
 # -------------------------------------------------------------- Add names, etc  # -------------------------------------------------------------- Add names, etc
     my $names=&reply('get:'.$udom.':'.$uname.      my %names=&get('environment',
                      ':environment:firstname&middlename&lastname&generation',     ['firstname','middlename','lastname','generation'],
                      $uhome);     $udom,$uname);
     my ($efirst,$emiddle,$elast,$egene)=split(/\&/,$names);      if ($names{'firstname'} =~ m/^error:.*/) { %names=(); }
     if ($first)  { $efirst  = &escape($first); }      if ($first)  { $names{'firstname'}  = $first; }
     if ($middle) { $emiddle = &escape($middle); }      if ($middle) { $names{'middlename'} = $middle; }
     if ($last)   { $elast   = &escape($last); }      if ($last)   { $names{'lastname'}   = $last; }
     if ($gene)   { $egene   = &escape($gene); }      if ($gene)   { $names{'generation'} = $gene; }
     my $reply=&reply('put:'.$udom.':'.$uname.      my $reply = &put('environment', \%names, $udom,$uname);
            ':environment:firstname='.$efirst.      if ($reply ne 'ok') { return 'error: '.$reply; }
                       '&middlename='.$emiddle.  
                         '&lastname='.$elast.  
                       '&generation='.$egene,$uhome);  
     if ($reply ne 'ok') {  
  return 'error: '.$reply;  
     }  
     &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.      &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
              $umode.', '.$first.', '.$middle.', '.               $umode.', '.$first.', '.$middle.', '.
      $last.', '.$gene.' by '.       $last.', '.$gene.' by '.
              $ENV{'user.name'}.' at '.$ENV{'user.domain'});               $ENV{'user.name'}.' at '.$ENV{'user.domain'});
     return 'ok';       return 'ok';
 }  }
   
 # -------------------------------------------------------------- Modify student  # -------------------------------------------------------------- Modify student
   
 sub modifystudent {  sub modifystudent {
     my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,      my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
         $end,$start)=@_;          $end,$start,$forceid,$desiredhome)=@_;
     my $cid='';      my $cid='';
     unless ($cid=$ENV{'request.course.id'}) {      unless ($cid=$ENV{'request.course.id'}) {
  return 'not_in_class';   return 'not_in_class';
     }      }
 # --------------------------------------------------------------- Make the user  # --------------------------------------------------------------- Make the user
     my $reply=&modifyuser      my $reply=&modifyuser
  ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene);   ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid,
            $desiredhome);
     unless ($reply eq 'ok') { return $reply; }      unless ($reply eq 'ok') { return $reply; }
     my $uhome=&homeserver($uname,$udom);      my $uhome=&homeserver($uname,$udom);
     if (($uhome eq '') || ($uhome eq 'no_host')) {       if (($uhome eq '') || ($uhome eq 'no_host')) { 
  return 'error: no such user';   return 'error: no such user';
     }      }
 # -------------------------------------------------- Add student to course list  # -------------------------------------------------- Add student to course list
     my $reply=critical('put:'.$ENV{'course.'.$cid.'.domain'}.':'.      $reply=critical('put:'.$ENV{'course.'.$cid.'.domain'}.':'.
               $ENV{'course.'.$cid.'.num'}.':classlist:'.                $ENV{'course.'.$cid.'.num'}.':classlist:'.
                       &escape($uname.':'.$udom).'='.                        &escape($uname.':'.$udom).'='.
                       &escape($end.':'.$start),                        &escape($end.':'.$start),
Line 1502  sub writecoursepref { Line 1989  sub writecoursepref {
  return 'error: no such course';   return 'error: no such course';
     }      }
     my $cstring='';      my $cstring='';
     map {      foreach (keys %prefs) {
  $cstring.=escape($_).'='.escape($prefs{$_}).'&';   $cstring.=escape($_).'='.escape($prefs{$_}).'&';
     } keys %prefs;      }
     $cstring=~s/\&$//;      $cstring=~s/\&$//;
     return reply('put:'.$cdomain.':'.$cnum.':environment:'.$cstring,$chome);      return reply('put:'.$cdomain.':'.$cnum.':environment:'.$cstring,$chome);
 }  }
Line 1538  sub createcourse { Line 2025  sub createcourse {
     my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',      my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',
                       $ENV{'user.home'});                        $ENV{'user.home'});
     unless ($reply eq 'ok') { return 'error: '.$reply; }      unless ($reply eq 'ok') { return 'error: '.$reply; }
     my $uhome=&homeserver($uname,$udom);      $uhome=&homeserver($uname,$udom);
     if (($uhome eq '') || ($uhome eq 'no_host')) {       if (($uhome eq '') || ($uhome eq 'no_host')) { 
  return 'error: no such course';   return 'error: no such course';
     }      }
Line 1593  sub dirlist { Line 2080  sub dirlist {
        $tryserver);         $tryserver);
              if (($listing ne 'no_such_dir') && ($listing ne 'empty')               if (($listing ne 'no_such_dir') && ($listing ne 'empty')
               && ($listing ne 'con_lost')) {                && ($listing ne 'con_lost')) {
                 map {                  foreach (split(/:/,$listing)) {
                   my ($entry,@stat)=split(/&/,$_);                    my ($entry,@stat)=split(/&/,$_);
                   $allusers{$entry}=1;                    $allusers{$entry}=1;
                 } split(/:/,$listing);                  }
              }               }
   }    }
        }         }
        my $alluserstr='';         my $alluserstr='';
        map {         foreach (sort keys %allusers) {
            $alluserstr.=$_.'&user:';             $alluserstr.=$_.'&user:';
        } sort keys %allusers;         }
        $alluserstr=~s/:$//;         $alluserstr=~s/:$//;
        return split(/:/,$alluserstr);         return split(/:/,$alluserstr);
      }        } 
Line 1614  sub dirlist { Line 2101  sub dirlist {
    $alldom{$hostdom{$tryserver}}=1;     $alldom{$hostdom{$tryserver}}=1;
        }         }
        my $alldomstr='';         my $alldomstr='';
        map {         foreach (sort keys %alldom) {
           $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'&domain:';            $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'&domain:';
        } sort keys %alldom;         }
        $alldomstr=~s/:$//;         $alldomstr=~s/:$//;
        return split(/:/,$alldomstr);                return split(/:/,$alldomstr);       
    }     }
Line 1637  sub condval { Line 2124  sub condval {
     my $condidx=shift;      my $condidx=shift;
     my $result=0;      my $result=0;
     my $allpathcond='';      my $allpathcond='';
     map {      foreach (split(/\|/,$condidx)) {
        if (defined($ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_})) {         if (defined($ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_})) {
    $allpathcond.=     $allpathcond.=
                '('.$ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_}.')|';                 '('.$ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_}.')|';
        }         }
     } split(/\|/,$condidx);      }
     $allpathcond=~s/\|$//;      $allpathcond=~s/\|$//;
     if ($ENV{'request.course.id'}) {      if ($ENV{'request.course.id'}) {
        if ($allpathcond) {         if ($allpathcond) {
           my $operand='|';            my $operand='|';
   my @stack;    my @stack;
           map {             foreach ($allpathcond=~/(\d+|\(|\)|\&|\|)/g) {
               if ($_ eq '(') {                if ($_ eq '(') {
                  push @stack,($operand,$result)                   push @stack,($operand,$result)
               } elsif ($_ eq ')') {                } elsif ($_ eq ')') {
Line 1666  sub condval { Line 2153  sub condval {
                      $result=$result>$new?$new:$result;                       $result=$result>$new?$new:$result;
                   } else {                    } else {
                      $result=$result>$new?$result:$new;                       $result=$result>$new?$result:$new;
                   }                                      }
               }                }
           } ($allpathcond=~/(\d+|\(|\)|\&|\|)/g);            }
        }         }
     }      }
     return $result;      return $result;
 }  }
   
   # --------------------------------------------------- Course Resourcedata Query
   
   sub courseresdata {
       my ($coursenum,$coursedomain,@which)=@_;
       my $coursehom=&homeserver($coursenum,$coursedomain);
       my $hashid=$coursenum.':'.$coursedomain;
       unless (defined($courseresdatacache{$hashid.'.time'})) {
    unless (time-$courseresdatacache{$hashid.'.time'}<300) {
              my $coursehom=&homeserver($coursenum,$coursedomain);
              if ($coursehom) {
                 my $dumpreply=&reply('dump:'.$coursedomain.':'.$coursenum.
        ':resourcedata:.',$coursehom);
         unless ($dumpreply=~/^error\:/) {
            $courseresdatacache{$hashid.'.time'}=time;
                    $courseresdatacache{$hashid}=$dumpreply;
        }
     }
          }
       }
      my @pairs=split(/\&/,$courseresdatacache{$hashid});
      my %returnhash=();
      foreach (@pairs) {
         my ($key,$value)=split(/=/,$_);
         $returnhash{unescape($key)}=unescape($value);
      }
       my $item;
      foreach $item (@which) {
          if ($returnhash{$item}) { return $returnhash{$item}; }
      }
      return '';
   }
   
 # --------------------------------------------------------- Value of a Variable  # --------------------------------------------------------- Value of a Variable
   
 sub EXT {  sub EXT {
     my $varname=shift;      my ($varname,$symbparm)=@_;
     unless ($varname) { return ''; }      unless ($varname) { return ''; }
     my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);      my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);
     my $rest;      my $rest;
Line 1738  sub EXT { Line 2257  sub EXT {
                               $spacequalifierrest};                                $spacequalifierrest};
     } elsif ($realm eq 'resource') {      } elsif ($realm eq 'resource') {
        if ($ENV{'request.course.id'}) {         if ($ENV{'request.course.id'}) {
   
   #   print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;
   
   
 # ----------------------------------------------------- Cascading lookup scheme  # ----------------------------------------------------- Cascading lookup scheme
          my $symbp=&symbread();           my $symbp;
            if ($symbparm) {
               $symbp=$symbparm;
    } else {
               $symbp=&symbread();
            }            
          my $mapp=(split(/\_\_\_/,$symbp))[0];           my $mapp=(split(/\_\_\_/,$symbp))[0];
   
          my $symbparm=$symbp.'.'.$spacequalifierrest;           my $symbparm=$symbp.'.'.$spacequalifierrest;
Line 1785  sub EXT { Line 2313  sub EXT {
   
 # -------------------------------------------------------- second, check course  # -------------------------------------------------------- second, check course
   
         my $reply=&reply('get:'.          my $coursereply=&courseresdata(
               $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.':'.                          $ENV{'course.'.$ENV{'request.course.id'}.'.num'},
               $ENV{'course.'.$ENV{'request.course.id'}.'.num'}.                          $ENV{'course.'.$ENV{'request.course.id'}.'.domain'},
       ':resourcedata:'.                          ($seclevelr,$seclevelm,$seclevel,
    &escape($seclevelr).'&'.&escape($seclevelm).'&'.&escape($seclevel).'&'.                           $courselevelr,$courselevelm,$courselevel));
    &escape($courselevelr).'&'.&escape($courselevelm).'&'.&escape($courselevel),          if ($coursereply) { return $coursereply; }
    $ENV{'course.'.$ENV{'request.course.id'}.'.home'});  
       if ($reply!~/^error\:/) {  
   map {  
       if ($_) { return &unescape($_); }  
           } split(/\&/,$reply);  
       }  
       if (($reply=~/^con_lost/) || ($reply=~/^error\:/)) {  
   &logthis("<font color=blue>WARNING:".  
                 " Getting ".$reply." asking for ".$varname." for ".  
                 $ENV{'course.'.$ENV{'request.course.id'}.'.num'}.  
                 ' at '.  
                 $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.  
                 ' from '.  
                 $ENV{'course.'.$ENV{'request.course.id'}.'.home'}.  
                  "</font>");  
       }  
 # ------------------------------------------------------ third, check map parms  # ------------------------------------------------------ third, check map parms
        my %parmhash=();         my %parmhash=();
        my $thisparm='';                my $thisparm='';       
Line 1827  sub EXT { Line 2340  sub EXT {
                                          'parameter_'.$spacequalifierrest);                                           'parameter_'.$spacequalifierrest);
       if ($metadata) { return $metadata; }        if ($metadata) { return $metadata; }
   
   # ------------------------------------------------------------------ Cascade up
   
         unless ($space eq '0') {
             my ($part,$id)=split(/\_/,$space);
             if ($id) {
         my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,
                                      $symbparm);
                 if ($partgeneral) { return $partgeneral; }
             } else {
                 my $resourcegeneral=&EXT('resource.0.'.$qualifierrest,
                                          $symbparm);
                 if ($resourcegeneral) { return $resourcegeneral; }
             }
         }
   
 # ---------------------------------------------------- Any other user namespace  # ---------------------------------------------------- Any other user namespace
     } elsif ($realm eq 'environment') {      } elsif ($realm eq 'environment') {
 # ----------------------------------------------------------------- environment  # ----------------------------------------------------------------- environment
Line 1843  sub EXT { Line 2371  sub EXT {
 # ---------------------------------------------------------------- Get metadata  # ---------------------------------------------------------------- Get metadata
   
 sub metadata {  sub metadata {
     my ($uri,$what)=@_;      my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
   
     $uri=&declutter($uri);      $uri=&declutter($uri);
     my $filename=$uri;      my $filename=$uri;
     $uri=~s/\.meta$//;      $uri=~s/\.meta$//;
     unless ($metacache{$uri.':keys'}) {  #
   # Is the metadata already cached?
   # Look at timestamp of caching
   # Everything is cached by the main uri, libraries are never directly cached
   #
       unless (abs($metacache{$uri.':cachedtimestamp'}-time)<600) {
   #
   # Is this a recursive call for a library?
   #
           if ($liburi) {
       $liburi=&declutter($liburi);
               $filename=$liburi;
           }
           my %metathesekeys=();
         unless ($filename=~/\.meta$/) { $filename.='.meta'; }          unless ($filename=~/\.meta$/) { $filename.='.meta'; }
  my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename);   my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename);
         my $parser=HTML::TokeParser->new(\$metastring);          my $parser=HTML::LCParser->new(\$metastring);
         my $token;          my $token;
           undef %metathesekeys;
         while ($token=$parser->get_token) {          while ($token=$parser->get_token) {
            if ($token->[0] eq 'S') {             if ($token->[0] eq 'S') {
       my $entry=$token->[1];       if (defined($token->[2]->{'package'})) {
               my $unikey=$entry;  #
               if (defined($token->[2]->{'part'})) {   # This is a package - get package info
                  $unikey.='_'.$token->[2]->{'part'};   #
         my $package=$token->[2]->{'package'};
         my $keyroot='';
                 if ($prefix) {
     $keyroot.='_'.$prefix;
                 } else {
                   if (defined($token->[2]->{'part'})) { 
                      $keyroot.='_'.$token->[2]->{'part'}; 
           }
       }        }
               if (defined($token->[2]->{'name'})) {                 if (defined($token->[2]->{'id'})) { 
                  $unikey.='_'.$token->[2]->{'name'};                    $keyroot.='_'.$token->[2]->{'id'}; 
       }        }
               if ($metacache{$uri.':keys'}) {                if ($metacache{$uri.':packages'}) {
                  $metacache{$uri.':keys'}.=','.$unikey;                   $metacache{$uri.':packages'}.=','.$package.$keyroot;
               } else {                } else {
                  $metacache{$uri.':keys'}=$unikey;                   $metacache{$uri.':packages'}=$package.$keyroot;
       }        }
               map {                foreach (keys %packagetab) {
     if ($_=~/^$package\&/) {
         my ($pack,$name,$subp)=split(/\&/,$_);
                         my $value=$packagetab{$_};
         my $part=$keyroot;
                         $part=~s/^\_//;
                         if ($subp eq 'display') {
     $value.=' [Part: '.$part.']';
                         }
                         my $unikey='parameter'.$keyroot.'_'.$name;
                         $metathesekeys{$unikey}=1;
                         $metacache{$uri.':'.$unikey.'.part'}=$part;
                         unless 
                          (defined($metacache{$uri.':'.$unikey.'.'.$subp})) {
                            $metacache{$uri.':'.$unikey.'.'.$subp}=$value;
         }
                     }
                 }
                } else {
   #
   # This is not a package - some other kind of start tag
   # 
                 my $entry=$token->[1];
                 my $unikey;
                 if ($entry eq 'import') {
                    $unikey='';
                 } else {
                    $unikey=$entry;
         }
                 if ($prefix) {
     $unikey.=$prefix;
                 } else {
                   if (defined($token->[2]->{'part'})) { 
                      $unikey.='_'.$token->[2]->{'part'}; 
           }
         }
                 if (defined($token->[2]->{'id'})) { 
                    $unikey.='_'.$token->[2]->{'id'}; 
         }
   
                if ($entry eq 'import') {
   #
   # Importing a library here
   #                
    if (defined($depthcount)) { $depthcount++; } else 
                                              { $depthcount=0; }
                    if ($depthcount<20) {
        foreach (split(/\,/,&metadata($uri,'keys',
                                     $parser->get_text('/import'),$unikey,
                                     $depthcount))) {
                            $metathesekeys{$_}=1;
        }
    }
                } else { 
   
                 if (defined($token->[2]->{'name'})) { 
                    $unikey.='_'.$token->[2]->{'name'}; 
         }
                 $metathesekeys{$unikey}=1;
                 foreach (@{$token->[3]}) {
   $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};    $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};
               } @{$token->[3]};                }
               unless (                unless (
                  $metacache{$uri.':'.$unikey}=$parser->get_text('/'.$entry)                   $metacache{$uri.':'.$unikey}=&HTML::Entities::decode($parser->get_text('/'.$entry))
       ) { $metacache{$uri.':'.$unikey}=        ) { $metacache{$uri.':'.$unikey}=
       $metacache{$uri.':'.$unikey.'.default'};        $metacache{$uri.':'.$unikey.'.default'};
       }        }
           }  # end of not-a-package not-a-library import
      }
   # end of not-a-package start tag
     }
   # the next is the end of "start tag"
    }
        }         }
          $metacache{$uri.':keys'}=join(',',keys %metathesekeys);
          $metacache{$uri.':cachedtimestamp'}=time;
   # this is the end of "was not already recently cached
     }      }
     return $metacache{$uri.':'.$what};      return $metacache{$uri.':'.$what};
 }  }
Line 1891  sub symblist { Line 2508  sub symblist {
     if (($ENV{'request.course.fn'}) && (%newhash)) {      if (($ENV{'request.course.fn'}) && (%newhash)) {
         if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',          if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',
                       &GDBM_WRCREAT,0640)) {                        &GDBM_WRCREAT,0640)) {
     map {      foreach (keys %newhash) {
                 $hash{declutter($_)}=$mapname.'___'.$newhash{$_};                  $hash{declutter($_)}=$mapname.'___'.$newhash{$_};
             } keys %newhash;              }
             if (untie(%hash)) {              if (untie(%hash)) {
  return 'ok';   return 'ok';
             }              }
Line 1902  sub symblist { Line 2519  sub symblist {
     return 'error';      return 'error';
 }  }
   
   # --------------------------------------------------------------- Verify a symb
   
   sub symbverify {
       my ($symb,$thisfn)=@_;
       $thisfn=&declutter($thisfn);
   # direct jump to resource in page or to a sequence - will construct own symbs
       if ($thisfn=~/\.(page|sequence)$/) { return 1; }
   # check URL part
       my ($map,$resid,$url)=split(/\_\_\_/,$symb);
       unless (&symbclean($url) eq &symbclean($thisfn)) { return 0; }
   
       $symb=&symbclean($symb);
   
       my %bighash;
       my $okay=0;
       if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
                               &GDBM_READER,0640)) {
           my $ids=$bighash{'ids_/res/'.$thisfn};
           unless ($ids) { 
              $ids=$bighash{'ids_/'.$thisfn};
           }
           if ($ids) {
   # ------------------------------------------------------------------- Has ID(s)
       foreach (split(/\,/,$ids)) {
                  my ($mapid,$resid)=split(/\./,$_);
                  if (
     &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)
      eq $symb) { 
                     $okay=1; 
                  }
      }
           }
    untie(%bighash);
       }
       return $okay;
   }
   
   # --------------------------------------------------------------- Clean-up symb
   
   sub symbclean {
       my $symb=shift;
   
   # remove version from map
       $symb=~s/\.(\d+)\.(\w+)\_\_\_/\.$2\_\_\_/;
   
   # remove version from URL
       $symb=~s/\.(\d+)\.(\w+)$/\.$2/;
   
       return $symb;
   }
   
 # ------------------------------------------------------ Return symb list entry  # ------------------------------------------------------ Return symb list entry
   
 sub symbread {  sub symbread {
     my $thisfn=shift;      my $thisfn=shift;
     unless ($thisfn) {      unless ($thisfn) {
           if ($ENV{'request.symb'}) { return &symbclean($ENV{'request.symb'}); }
  $thisfn=$ENV{'request.filename'};   $thisfn=$ENV{'request.filename'};
     }      }
     $thisfn=declutter($thisfn);      $thisfn=declutter($thisfn);
Line 1947  sub symbread { Line 2616  sub symbread {
                  } else {                   } else {
 # ------------------------------------------ There is more than one possibility  # ------------------------------------------ There is more than one possibility
                      my $realpossible=0;                       my $realpossible=0;
                      map {                       foreach (@possibilities) {
  my $file=$bighash{'src_'.$_};   my $file=$bighash{'src_'.$_};
                          if (&allowed('bre',$file)) {                           if (&allowed('bre',$file)) {
              my ($mapid,$resid)=split(/\./,$_);               my ($mapid,$resid)=split(/\./,$_);
Line 1957  sub symbread { Line 2626  sub symbread {
                                        '___'.$resid;                                         '___'.$resid;
                             }                              }
  }   }
                      } @possibilities;                       }
      if ($realpossible!=1) { $syval=''; }       if ($realpossible!=1) { $syval=''; }
                  }                   }
       }        }
Line 1965  sub symbread { Line 2634  sub symbread {
            }              } 
         }          }
         if ($syval) {          if ($syval) {
            return $syval.'___'.$thisfn;              return &symbclean($syval.'___'.$thisfn); 
         }          }
     }      }
     &appenv('request.ambiguous' => $thisfn);      &appenv('request.ambiguous' => $thisfn);
Line 1987  sub numval { Line 2656  sub numval {
 }      }    
   
 sub rndseed {  sub rndseed {
     my $symb;      my ($symb,$courseid,$domain,$username)=@_;
     unless ($symb=&symbread()) { return time; }      if (!$symb) {
     {         unless ($symb=&symbread()) { return time; }
       }
       if (!$courseid) { $courseid=$ENV{'request.course.id'};}
       if (!$domain) {$domain=$ENV{'user.domain'};}
       if (!$username) {$username=$ENV{'user.name'};}
       {
       use integer;        use integer;
       my $symbchck=unpack("%32C*",$symb) << 27;        my $symbchck=unpack("%32C*",$symb) << 27;
       my $symbseed=numval($symb) << 22;        my $symbseed=numval($symb) << 22;
       my $namechck=unpack("%32C*",$ENV{'user.name'}) << 17;        my $namechck=unpack("%32C*",$username) << 17;
       my $nameseed=numval($ENV{'user.name'}) << 12;        my $nameseed=numval($username) << 12;
       my $domainseed=unpack("%32C*",$ENV{'user.domain'}) << 7;        my $domainseed=unpack("%32C*",$domain) << 7;
       my $courseseed=unpack("%32C*",$ENV{'request.course.id'});        my $courseseed=unpack("%32C*",$courseid);
       my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;        my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;
       #uncommenting these lines can break things!        #uncommenting these lines can break things!
       #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");        #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
Line 2061  sub filelocation { Line 2735  sub filelocation {
   
 sub hreflocation {  sub hreflocation {
     my ($dir,$file)=@_;      my ($dir,$file)=@_;
     unless (($_=~/^http:\/\//i) || ($_=~/^\//)) {      unless (($file=~/^http:\/\//i) || ($file=~/^\//)) {
        my $finalpath=filelocation($dir,$file);         my $finalpath=filelocation($dir,$file);
        $finalpath=~s/^\/home\/httpd\/html//;         $finalpath=~s/^\/home\/httpd\/html//;
        return $finalpath;         return $finalpath;
Line 2098  sub unescape { Line 2772  sub unescape {
   
 # ================================================================ Main Program  # ================================================================ Main Program
   
 sub BEGIN {  sub goodbye {
 if ($readit ne 'done') {     &logthis("Starting Shut down");
 # ------------------------------------------------------------ Read access.conf     &flushcourselogs();
      &logthis("Shutting down");
   }
   
   BEGIN {
   # ------------------------------------------- Read access.conf and loncapa.conf
   # (eventually access.conf will become deprecated)
       unless ($readit) {
   
 {  {
     my $config=Apache::File->new("/etc/httpd/conf/access.conf");      my $config=Apache::File->new("/etc/httpd/conf/access.conf");
   
     while (my $configline=<$config>) {      while (my $configline=<$config>) {
         if ($configline =~ /PerlSetVar/) {          if ($configline =~ /^[^\#]*PerlSetVar/) {
      my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
              chomp($varvalue);
              $perlvar{$varname}=$varvalue;
           }
       }
   }
   {
       my $config=Apache::File->new("/etc/httpd/conf/loncapa.conf");
   
       while (my $configline=<$config>) {
           if ($configline =~ /^[^\#]*PerlSetVar/) {
    my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);     my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
            chomp($varvalue);             chomp($varvalue);
            $perlvar{$varname}=$varvalue;             $perlvar{$varname}=$varvalue;
Line 2118  if ($readit ne 'done') { Line 2811  if ($readit ne 'done') {
     my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab");      my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab");
   
     while (my $configline=<$config>) {      while (my $configline=<$config>) {
          chomp($configline);
        my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);         my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
        $hostname{$id}=$name;         $hostname{$id}=$name;
        $hostdom{$id}=$domain;         $hostdom{$id}=$domain;
          $hostip{$id}=$ip;
        if ($role eq 'library') { $libserv{$id}=$name; }         if ($role eq 'library') { $libserv{$id}=$name; }
     }      }
 }  }
Line 2142  if ($readit ne 'done') { Line 2837  if ($readit ne 'done') {
   
     while (my $configline=<$config>) {      while (my $configline=<$config>) {
        chomp($configline);         chomp($configline);
         if ($configline) {
        my ($role,$perm)=split(/ /,$configline);         my ($role,$perm)=split(/ /,$configline);
        if ($perm ne '') { $pr{$role}=$perm; }         if ($perm ne '') { $pr{$role}=$perm; }
         }
     }      }
 }  }
   
Line 2153  if ($readit ne 'done') { Line 2850  if ($readit ne 'done') {
   
     while (my $configline=<$config>) {      while (my $configline=<$config>) {
        chomp($configline);         chomp($configline);
         if ($configline) {
        my ($short,$plain)=split(/:/,$configline);         my ($short,$plain)=split(/:/,$configline);
        if ($plain ne '') { $prp{$short}=$plain; }         if ($plain ne '') { $prp{$short}=$plain; }
         }
     }      }
 }  }
   
 # ------------------------------------------------------------- Read file types  # ---------------------------------------------------------- Read package table
 {  {
     my $config=Apache::File->new("$perlvar{'lonTabDir'}/filetypes.tab");      my $config=Apache::File->new("$perlvar{'lonTabDir'}/packages.tab");
   
     while (my $configline=<$config>) {      while (my $configline=<$config>) {
        chomp($configline);         chomp($configline);
        my ($ending,$emb,@descr)=split(/\s+/,$configline);         my ($short,$plain)=split(/:/,$configline);
        if ($descr[0] ne '') {          my ($pack,$name)=split(/\&/,$short);
          $fe{$ending}=$emb;         if ($plain ne '') {
          $fd{$ending}=join(' ',@descr);            $packagetab{$pack.'&'.$name.'&name'}=$name; 
             $packagetab{$short}=$plain; 
        }         }
     }      }
 }  }
   
 %metacache=();  %metacache=();
   
 $readit='done';  $processmarker=$$.'_'.time.'_'.$perlvar{'lonHostID'};
   $dumpcount=0;
   
   &logtouch();
 &logthis('<font color=yellow>INFO: Read configuration</font>');  &logthis('<font color=yellow>INFO: Read configuration</font>');
   $readit=1;
 }  }
 }  }
   
 1;  1;
   __END__
   
   =head1 NAME
   
   Apache::lonnet - TCP networking package
   
   =head1 SYNOPSIS
   
   Invoked by other LON-CAPA modules.
   
    &Apache::lonnet::SUBROUTINENAME(ARGUMENTS);
   
   =head1 INTRODUCTION
   
   This module provides subroutines which interact with the
   lonc/lond (TCP) network layer of LON-CAPA.
   
   This is part of the LearningOnline Network with CAPA project
   described at http://www.lon-capa.org.
   
   =head1 HANDLER SUBROUTINE
   
   There is no handler routine for this module.
   
   =head1 OTHER SUBROUTINES
   
   =over 4
   
   =item *
   
   logtouch() : make sure the logfile, lonnet.log, exists
   
   =item *
   
   logthis() : append message to lonnet.log
   
   =item *
   
   logperm() : append a permanent message to lonnet.perm.log
   
   =item *
   
   subreply() : non-critical communication, called by &reply
   
   =item *
   
   reply() : makes two attempts to pass message; logs refusals and rejections
   
   =item *
   
   reconlonc() : tries to reconnect lonc client processes.
   
   =item *
   
   critical() : passes a critical message to another server; if cannot get
   through then place message in connection buffer
   
   =item *
   
   appenv(%hash) : read in current user environment, append new environment
   values to make new user environment
   
   =item *
   
   delenv($varname) : read in current user environment, remove all values
   beginning with $varname, write new user environment (note: flock is used
   to prevent conflicting shared read/writes with file)
   
   =item *
   
   spareserver() : find server with least workload from spare.tab
   
   =item *
   
   queryauthenticate($uname,$udom) : try to determine user's current
   authentication scheme
   
   =item *
   
   authenticate($uname,$upass,$udom) : try to authenticate user from domain's lib
   servers (first use the current one)
   
   =item *
   
   homeserver($uname,$udom) : find the homebase for a user from domain's lib
   servers
   
   =item *
   
   idget($udom,@ids) : find the usernames behind a list of IDs (returns hash:
   id=>name,id=>name)
   
   =item *
   
   idrget($udom,@unames) : find the IDs behind a list of usernames (returns hash:
   name=>id,name=>id)
   
   =item *
   
   idput($udom,%ids) : store away a list of names and associated IDs
   
   =item *
   
   usection($domain,$user,$courseid) : output of section name/number or '' for
   "not in course" and '-1' for "no section"
   
   =item *
   
   userenvironment($domain,$user,$what) : puts out any environment parameter 
   for a user
   
   =item *
   
   subscribe($fname) : subscribe to a resource, return URL if possible
   
   =item *
   
   repcopy($filename) : replicate file
   
   =item *
   
   ssi($url,%hash) : server side include, does a complete request cycle on url to
   localhost, posts hash
   
   =item *
   
   log($domain,$name,$home,$message) : write to permanent log for user; use
   critical subroutine
   
   =item *
   
   flushcourselogs() : flush (save) buffer logs and access logs
   
   =item *
   
   courselog($what) : save message for course in hash
   
   =item *
   
   courseacclog($what) : save message for course using &courselog().  Perform
   special processing for specific resource types (problems, exams, quizzes, etc).
   
   =item *
   
   countacc($url) : count the number of accesses to a given URL
   
   =item *
   
   sub checkout($symb,$tuname,$tudom,$tcrsid) : check out an item
   
   =item *
   
   sub checkin($token) : check in an item
   
   =item *
   
   sub expirespread($uname,$udom,$stype,$usymb) : set expire date for spreadsheet
   
   =item *
   
   devalidate($symb) : devalidate spreadsheets
   
   =item *
   
   hash2str(%hash) : convert a hash into a string complete with escaping and '='
   and '&' separators, supports elements that are arrayrefs and hashrefs
   
   =item *
   
   hashref2str($hashref) : convert a hashref into a string complete with
   escaping and '=' and '&' separators, supports elements that are
   arrayrefs and hashrefs
   
   =item *
   
   arrayref2str($arrayref) : convert an arrayref into a string complete
   with escaping and '&' separators, supports elements that are arrayrefs
   and hashrefs
   
   =item *
   
   str2hash($string) : convert string to hash using unescaping and
   splitting on '=' and '&', supports elements that are arrayrefs and
   hashrefs
   
   =item *
   
   str2array($string) : convert string to hash using unescaping and
   splitting on '&', supports elements that are arrayrefs and hashrefs
   
   =item *
   
   tmpreset($symb,$namespace,$domain,$stuname) : temporary storage
   
   =item *
   
   tmprestore($symb,$namespace,$domain,$stuname) : temporary restore
   
   =item *
   
   store($storehash,$symb,$namespace,$domain,$stuname) : stores hash permanently
   for this url; hashref needs to be given and should be a \%hashname; the
   remaining args aren't required and if they aren't passed or are '' they will
   be derived from the ENV
   
   =item *
   
   cstore($storehash,$symb,$namespace,$domain,$stuname) : same as store but
   uses critical subroutine
   
   =item *
   
   restore($symb,$namespace,$domain,$stuname) : returns hash for this symb;
   all args are optional
   
   =item *
   
   coursedescription($courseid) : course description
   
   =item *
   
   rolesinit($domain,$username,$authhost) : get user privileges
   
   =item *
   
   get($namespace,$storearr,$udomain,$uname) : returns hash with keys from array
   reference filled in from namesp ($udomain and $uname are optional)
   
   =item *
   
   del($namespace,$storearr,$udomain,$uname) : deletes keys out of array from
   namesp ($udomain and $uname are optional)
   
   =item *
   
   dump($namespace,$udomain,$uname,$regexp) : 
   dumps the complete (or key matching regexp) namespace into a hash
   ($udomain, $uname and $regexp are optional)
   
   =item *
   
   put($namespace,$storehash,$udomain,$uname) : stores hash in namesp
   ($udomain and $uname are optional)
   
   =item *
   
   cput($namespace,$storehash,$udomain,$uname) : critical put
   ($udomain and $uname are optional)
   
   =item *
   
   eget($namespace,$storearr,$udomain,$uname) : returns hash with keys from array
   reference filled in from namesp (encrypts the return communication)
   ($udomain and $uname are optional)
   
   =item *
   
   allowed($priv,$uri) : check for a user privilege; returns codes for allowed
   actions
    F: full access
    U,I,K: authentication modes (cxx only)
    '': forbidden
    1: user needs to choose course
    2: browse allowed
   
   =item *
   
   definerole($rolename,$sysrole,$domrole,$courole) : define role; define a custom
   role rolename set privileges in format of lonTabs/roles.tab for system, domain,
   and course level
   
   =item *
   
   metadata_query($query,$custom,$customshow) : make a metadata query against the
   network of library servers; returns file handle of where SQL and regex results
   will be stored for query
   
   =item *
   
   plaintext($short) : return value in %prp hash (rolesplain.tab); plain text
   explanation of a user role term
   
   =item *
   
   assignrole($udom,$uname,$url,$role,$end,$start) : assign role; give a role to a
   user for the level given by URL.  Optional start and end dates (leave empty
   string or zero for "no date")
   
   =item *
   
   modifyuserauth($udom,$uname,$umode,$upass) : modify user authentication
   
   =item *
   
   modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene) : 
   modify user
   
   =item *
   
   modifystudent($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
   $end,$start) : modify student
   
   =item *
   
   writecoursepref($courseid,%prefs) : write preferences for a course
   
   =item *
   
   createcourse($udom,$description,$url) : make/modify course
   
   =item *
   
   assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start) : assign
   custom role; give a custom role to a user for the level given by URL.  Specify
   name and domain of role author, and role name
   
   =item *
   
   revokerole($udom,$uname,$url,$role) : revoke a role for url
   
   =item *
   
   revokecustomrole($udom,$uname,$url,$role) : revoke a custom role
   
   =item *
   
   dirlist($uri) : return directory list based on URI
   
   =item *
   
   directcondval($number) : get current value of a condition; reads from a state
   string
   
   =item *
   
   condval($condidx) : value of condition index based on state
   
   =item *
   
   EXT($varname,$symbparm) : value of a variable
   
   =item *
   
   metadata($uri,$what,$liburi,$prefix,$depthcount) : get metadata; returns the
   metadata entry for a file; entry='keys', returns a comma separated list of keys
   
   =item *
   
   symblist($mapname,%newhash) : update symbolic storage links
   
   =item *
   
   symbread($filename) : return symbolic list entry (filename argument optional);
   returns the data handle
   
   =item *
   
   numval($salt) : return random seed value (addend for rndseed)
   
   =item *
   
   rndseed($symb,$courseid,$domain,$username) : create a random sum; returns
   a random seed, all arguments are optional, if they aren't sent it uses the
   environment to derive them. Note: if symb isn't sent and it can't get one
   from &symbread it will use the current time as its return value
   
   =item *
   
   ireceipt($funame,$fudom,$fucourseid,$fusymb) : return unique,
   unfakeable, receipt
   
   =item *
   
   receipt() : API to ireceipt working off of ENV values; given out to users
   
   =item *
   
   getfile($file) : serves up a file, returns the contents of a file or -1;
   replicates and subscribes to the file
   
   =item *
   
   filelocation($dir,$file) : returns file system location of a file based on URI;
   meant to be "fairly clean" absolute reference
   
   =item *
   
   hreflocation($dir,$file) : returns file system location or a URL; same as
   filelocation except for hrefs
   
   =item *
   
   declutter() : declutters URLs (remove docroot, beginning slashes, 'res' etc)
   
   =item *
   
   escape() : unpack non-word characters into CGI-compatible hex codes
   
   =item *
   
   unescape() : pack CGI-compatible hex codes into actual non-word ASCII character
   
   =item *
   
   goodbye() : flush course logs and log shutting down; it is called in srm.conf
   as a PerlChildExitHandler
   
   =back
   
   =cut
Removed from v.1.133  
changed lines
  Added in v.1.217

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