[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.32 and 1.179

version 1.32, 2000/09/26 20:07:24 version 1.179, 2001/11/29 21:54:56
Line 1 Line 1
 # The LearningOnline Network  # The LearningOnline Network
 # TCP networking package  # TCP networking package
 #  #
   # $Id$
   #
   # Copyright Michigan State University Board of Trustees
   #
   # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
   #
   # LON-CAPA is free software; you can redistribute it and/or modify
   # it under the terms of the GNU General Public License as published by
   # the Free Software Foundation; either version 2 of the License, or
   # (at your option) any later version.
   #
   # LON-CAPA is distributed in the hope that it will be useful,
   # but WITHOUT ANY WARRANTY; without even the implied warranty of
   # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   # GNU General Public License for more details.
   #
   # You should have received a copy of the GNU General Public License
   # along with LON-CAPA; if not, write to the Free Software
   # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
   #
   # /home/httpd/html/adm/gpl.txt
   #
   # http://www.lon-capa.org/
   #
   # 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,
   # 11/8,11/16,11/18,11/22,11/23,12/22,
   # 01/06,01/13,02/24,02/28,02/29,
   # 03/01,03/02,03/06,03/07,03/13,
   # 04/05,05/29,05/31,06/01,
   # 06/05,06/26 Gerd Kortemeyer
   # 06/26 Ben Tyszka
   # 06/30,07/15,07/17,07/18,07/20,07/21,07/22,07/25 Gerd Kortemeyer
   # 08/14 Ben Tyszka
   # 08/22,08/28,08/31,09/01,09/02,09/04,09/05,09/25,09/28,09/30 Gerd Kortemeyer
   # 10/04 Gerd Kortemeyer
   # 10/04 Guy Albertelli
   # 10/06,10/09,10/10,10/11,10/14,10/20,10/23,10/25,10/26,10/27,10/28,10/29, 
   # 10/30,10/31,
   # 11/2,11/14,11/15,11/16,11/20,11/21,11/22,11/25,11/27,
   # 12/02,12/12,12/13,12/14,12/28,12/29 Gerd Kortemeyer
   # 05/01/01 Guy Albertelli
   # 05/01,06/01,09/01 Gerd Kortemeyer
   # 09/01 Guy Albertelli
   # 09/01,10/01,11/01 Gerd Kortemeyer
   # YEAR=2001
   # 02/27/01 Scott Harrison
   # 3/2 Gerd Kortemeyer
   # 3/15,3/19 Scott Harrison
   # 3/19,3/20 Gerd Kortemeyer
   # 3/22,3/27,4/2,4/16,4/17 Scott Harrison
   # 5/26,5/28 Gerd Kortemeyer
   # 5/30 H. K. Ng
   # 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
   #
   # $Id$
   #
   ###
   
 # Functions for use by content handlers:  # Functions for use by content handlers:
 #  #
   # metadata_query(sql-query-string,custom-metadata-regex) : 
   #                                    returns file handle of where sql and
   #                                    regex results will be stored for query
 # plaintext(short)   : plain text explanation of short term  # plaintext(short)   : plain text explanation of short term
 # fileembstyle(ext)  : embed style in page for file extension  # fileembstyle(ext)  : embed style in page for file extension
 # filedescription(ext) : descriptor text for file extension  # filedescription(ext) : descriptor text for file extension
Line 13 Line 80
 #                      1: user needs to choose course  #                      1: user needs to choose course
 #                      2: browse allowed  #                      2: browse allowed
 # definerole(rolename,sys,dom,cou) : define a custom role rolename  # definerole(rolename,sys,dom,cou) : define a custom role rolename
 #                      set priviledges in format of lonTabs/roles.tab for  #                      set privileges in format of lonTabs/roles.tab for
 #                      system, domain and course level,   #                      system, domain and course level, 
 # assignrole(udom,uname,url,role,end,start) : give a role to a user for the  # assignrole(udom,uname,url,role,end,start) : give a role to a user for the
 #                      level given by url. Optional start and end dates  #                      level given by url. Optional start and end dates
Line 24 Line 91
 # revokerole (udom,uname,url,role) : Revoke a role for url  # revokerole (udom,uname,url,role) : Revoke a role for url
 # revokecustomrole (udom,uname,url,rdom,rnam,rolename) : Revoke a custom role  # revokecustomrole (udom,uname,url,rdom,rnam,rolename) : Revoke a custom role
 # appenv(hash)       : adds hash to session environment  # appenv(hash)       : adds hash to session environment
 # store(hash)        : stores hash permanently for this url  # delenv(varname)    : deletes all environment entries starting with varname
 # restore            : returns hash for this url  # store(hashref,symb,courseid,udom,uname)
 # eget(namesp,array) : returns hash with keys from array filled in from namesp  #                    : stores hash permanently for this url
 # get(namesp,array)  : returns hash with keys from array filled in from namesp  #                      hashref needs to be given, and should be a \%hashname
 # del(namesp,array)  : deletes keys out of arry from namesp  #                      the remaining args aren't required and if they aren't
 # put(namesp,hash)   : stores hash in namesp  #                      passed or are '' they will be derived from the ENV
 # dump(namesp)       : dumps the complete namespace into a hash  # 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 6 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,udom,uname)   : stores hash in namesp
   # cput(namesp,hash,udom,uname)  : critical put
   #
   #
 # ssi(url,hash)      : does a complete request cycle on url to localhost, posts  # ssi(url,hash)      : does a complete request cycle on url to localhost, posts
 #                      hash  #                      hash
   # coursedescription(id) : returns and caches course description for id
 # repcopy(filename)  : replicate file  # repcopy(filename)  : replicate file
 # dirlist(url)       : gets a directory listing  # 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  # condval(index)     : value of condition index based on state
 # varval(name)       : value of a variable  # EXT(name)          : value of a variable
 # refreshstate()     : refresh the state information string  
 # symblist(map,hash) : Updates symbolic storage links  # symblist(map,hash) : Updates symbolic storage links
 # rndseed()          : returns a random seed    # symbread([filename]) : returns the data handle (filename optional)
   # rndseed([symb,courseid,domain,uname])
   #                    : returns a random seed, all arguments are optional,
   #                      if they aren't sent it use 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 it's return
   # 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,  
 # 7/1,7/2,7/9,7/10,7/12,7/14,7/15,7/19,  
 # 11/8,11/16,11/18,11/22,11/23,12/22,  
 # 01/06,01/13,02/24,02/28,02/29,  
 # 03/01,03/02,03/06,03/07,03/13,  
 # 04/05,05/29,05/31,06/01,  
 # 06/05,06/26 Gerd Kortemeyer  
 # 06/26 Ben Tyszka  
 # 06/30,07/15,07/17,07/18,07/20,07/21,07/22,07/25 Gerd Kortemeyer  
 # 08/14 Ben Tyszka  
 # 08/22,08/28,08/31,09/01,09/02,09/04,09/05,09/25 Gerd Kortemeyer  
   
 package Apache::lonnet;  package Apache::lonnet;
   
Line 60  use Apache::File; Line 169  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);  qw(%perlvar %hostname %homecache %hostip %spareid %hostdom %libserv %pr %prp %fe %fd $readit %metacache %packagetab %courselogs);
 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 Fcntl qw(:flock);
   
 # --------------------------------------------------------------------- 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 106  sub reply { Line 227  sub reply {
     my ($cmd,$server)=@_;      my ($cmd,$server)=@_;
     my $answer=subreply($cmd,$server);      my $answer=subreply($cmd,$server);
     if ($answer eq 'con_lost') { $answer=subreply($cmd,$server); }      if ($answer eq 'con_lost') { $answer=subreply($cmd,$server); }
     if (($answer=~/^error:/) || ($answer=~/^refused/) ||       if (($answer=~/^refused/) || ($answer=~/^rejected/)) {
         ($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 147  sub reconlonc { Line 267  sub reconlonc {
   
 sub critical {  sub critical {
     my ($cmd,$server)=@_;      my ($cmd,$server)=@_;
       unless ($hostname{$server}) {
           &logthis("<font color=blue>WARNING:".
                  " Critical message to unknown server ($server)</font>");
           return 'no_such_host';
       }
     my $answer=reply($cmd,$server);      my $answer=reply($cmd,$server);
     if ($answer eq 'con_lost') {      if ($answer eq 'con_lost') {
         my $pingreply=reply('ping',$server);          my $pingreply=reply('ping',$server);
Line 196  sub critical { Line 321  sub critical {
   
 sub appenv {  sub appenv {
     my %newenv=@_;      my %newenv=@_;
       map {
    if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) {
               &logthis("<font color=blue>WARNING: ".
                   "Attempt to modify environment ".$_." to ".$newenv{$_}
                   .'</font>');
       delete($newenv{$_});
           } else {
               $ENV{$_}=$newenv{$_};
           }
       } keys %newenv;
   
       my $lockfh;
       unless ($lockfh=Apache::File->new("$ENV{'user.environment'}")) {
          return 'error: '.$!;
       }
       unless (flock($lockfh,LOCK_EX)) {
            &logthis("<font color=blue>WARNING: ".
                     'Could not obtain exclusive lock in appenv: '.$!);
            $lockfh->close();
            return 'error: '.$!;
       }
   
     my @oldenv;      my @oldenv;
     {      {
      my $fh;       my $fh;
      unless ($fh=Apache::File->new("$ENV{'user.environment'}")) {       unless ($fh=Apache::File->new("$ENV{'user.environment'}")) {
  return 'error';   return 'error: '.$!;
      }       }
      @oldenv=<$fh>;       @oldenv=<$fh>;
        $fh->close();
     }      }
     for (my $i=0; $i<=$#oldenv; $i++) {      for (my $i=0; $i<=$#oldenv; $i++) {
         chomp($oldenv[$i]);          chomp($oldenv[$i]);
Line 222  sub appenv { Line 370  sub appenv {
      foreach $newname (keys %newenv) {       foreach $newname (keys %newenv) {
  print $fh "$newname=$newenv{$newname}\n";   print $fh "$newname=$newenv{$newname}\n";
      }       }
        $fh->close();
       }
   
       $lockfh->close();
       return 'ok';
   }
   # ----------------------------------------------------- Delete from Environment
   
   sub delenv {
       my $delthis=shift;
       my %newenv=();
       if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {
           &logthis("<font color=blue>WARNING: ".
                   "Attempt to delete from environment ".$delthis);
           return 'error';
       }
       my @oldenv;
       {
        my $fh;
        unless ($fh=Apache::File->new("$ENV{'user.environment'}")) {
    return 'error';
        }
        unless (flock($fh,LOCK_SH)) {
            &logthis("<font color=blue>WARNING: ".
                     'Could not obtain shared lock in delenv: '.$!);
            $fh->close();
            return 'error: '.$!;
        }
        @oldenv=<$fh>;
        $fh->close();
       }
       {
        my $fh;
        unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) {
    return 'error';
        }
        unless (flock($fh,LOCK_EX)) {
            &logthis("<font color=blue>WARNING: ".
                     'Could not obtain exclusive lock in delenv: '.$!);
            $fh->close();
            return 'error: '.$!;
        }
        map {
    unless ($_=~/^$delthis/) { print $fh $_; }
        } @oldenv;
        $fh->close();
     }      }
     return 'ok';      return 'ok';
 }  }
Line 242  sub spareserver { Line 436  sub spareserver {
     return $spareserver;      return $spareserver;
 }  }
   
   # ----------------------- 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 {
Line 303  sub homeserver { Line 535  sub homeserver {
     return 'no_host';      return 'no_host';
 }  }
   
   # ------------------------------------- Find the usernames behind a list of IDs
   
   sub idget {
       my ($udom,@ids)=@_;
       my %returnhash=();
       
       my $tryserver;
       foreach $tryserver (keys %libserv) {
          if ($hostdom{$tryserver} eq $udom) {
     my $idlist=join('&',@ids);
             $idlist=~tr/A-Z/a-z/; 
     my $reply=&reply("idget:$udom:".$idlist,$tryserver);
             my @answer=();
             if (($reply ne 'con_lost') && ($reply!~/^error\:/)) {
         @answer=split(/\&/,$reply);
             }                    ;
             my $i;
             for ($i=0;$i<=$#ids;$i++) {
                 if ($answer[$i]) {
     $returnhash{$ids[$i]}=$answer[$i];
                 } 
             }
          }
       }    
       return %returnhash;
   }
   
   # ------------------------------------- Find the IDs behind a list of usernames
   
   sub idrget {
       my ($udom,@unames)=@_;
       my %returnhash=();
       map {
           $returnhash{$_}=(&userenvironment($udom,$_,'id'))[1];
       } @unames;
       return %returnhash;
   }
   
   # ------------------------------- Store away a list of names and associated IDs
   
   sub idput {
       my ($udom,%ids)=@_;
       my %servers=();
       map {
           my $uhom=&homeserver($_,$udom);
           if ($uhom ne 'no_host') {
               my $id=&escape($ids{$_});
               $id=~tr/A-Z/a-z/;
               my $unam=&escape($_);
       if ($servers{$uhom}) {
    $servers{$uhom}.='&'.$id.'='.$unam;
               } else {
                   $servers{$uhom}=$id.'='.$unam;
               }
               &critical('put:'.$udom.':'.$unam.':environment:id='.$id,$uhom);
           }
       } keys %ids;
       map {
           &critical('idput:'.$udom.':'.$servers{$_},$_);
       } keys %servers;
   }
   
   # ------------------------------------- Find the section of student in a course
   
   sub usection {
       my ($udom,$unam,$courseid)=@_;
       $courseid=~s/\_/\//g;
       $courseid=~s/^(\w)/\/$1/;
       map {
           my ($key,$value)=split(/\=/,$_);
           $key=&unescape($key);
           if ($key=~/^$courseid(?:\/)*(\w+)*\_st$/) {
               my $section=$1;
               if ($key eq $courseid.'_st') { $section=''; }
       my ($dummy,$end,$start)=split(/\_/,&unescape($value));
               my $now=time;
               my $notactive=0;
               if ($start) {
    if ($now<$start) { $notactive=1; }
               }
               if ($end) {
                   if ($now>$end) { $notactive=1; }
               } 
               unless ($notactive) { return $section; }
           }
       } split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',
                           &homeserver($unam,$udom)));
       return '-1';
   }
   
   # ------------------------------------- Read an entry from a user's environment
   
   sub userenvironment {
       my ($udom,$unam,@what)=@_;
       my %returnhash=();
       my @answer=split(/\&/,
                   &reply('get:'.$udom.':'.$unam.':environment:'.join('&',@what),
                         &homeserver($unam,$udom)));
       my $i;
       for ($i=0;$i<=$#what;$i++) {
    $returnhash{$what[$i]}=&unescape($answer[$i]);
       }
       return %returnhash;
   }
   
 # ----------------------------- Subscribe to a resource, return URL if possible  # ----------------------------- Subscribe to a resource, return URL if possible
   
 sub subscribe {  sub subscribe {
Line 315  sub subscribe { Line 652  sub subscribe {
         return 'not_found';           return 'not_found'; 
     }      }
     my $answer=reply("sub:$fname",$home);      my $answer=reply("sub:$fname",$home);
       if (($answer eq 'con_lost') || ($answer eq 'rejected')) {
    $answer.=' by '.$home;
       }
     return $answer;      return $answer;
 }  }
           
Line 326  sub repcopy { Line 666  sub repcopy {
     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);
     if ($remoteurl eq 'con_lost') {      if ($remoteurl =~ /^con_lost by/) {
    &logthis("Subscribe returned con_lost: $filename");     &logthis("Subscribe returned $remoteurl: $filename");
            return HTTP_SERVICE_UNAVAILABLE;             return HTTP_SERVICE_UNAVAILABLE;
     } elsif ($remoteurl eq 'not_found') {      } elsif ($remoteurl eq 'not_found') {
    &logthis("Subscribe returned not_found: $filename");     &logthis("Subscribe returned not_found: $filename");
    return HTTP_NOT_FOUND;     return HTTP_NOT_FOUND;
     } elsif ($remoteurl eq 'rejected') {      } elsif ($remoteurl =~ /^rejected by/) {
    &logthis("Subscribe returned rejected: $filename");     &logthis("Subscribe returned $remoteurl: $filename");
            return FORBIDDEN;             return FORBIDDEN;
     } elsif ($remoteurl eq 'directory') {      } elsif ($remoteurl eq 'directory') {
            return OK;             return OK;
Line 403  sub ssi { Line 743  sub ssi {
   
 sub log {  sub log {
     my ($dom,$nam,$hom,$what)=@_;      my ($dom,$nam,$hom,$what)=@_;
     return reply("log:$dom:$nam:$what",$hom);      return critical("log:$dom:$nam:$what",$hom);
   }
   
   # ------------------------------------------------------------------ Course Log
   
   sub flushcourselogs {
       &logthis('Flushing course log buffers');
       map {
           my $crsid=$_;
           if (&reply('log:'.$ENV{'course.'.$crsid.'.domain'}.':'.
             $ENV{'course.'.$crsid.'.num'}.':'.
              &escape($courselogs{$crsid}),
             $ENV{'course.'.$crsid.'.home'}) 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};
               }
           }        
       } keys %courselogs;
   }
   
   sub courselog {
       my $what=shift;
       $what=time.':'.$what;
       unless ($ENV{'request.course.id'}) { return ''; }
       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 ($what=~/(problem|exam|quiz|assess|survey|form)$/) {
    map {
               if ($_=~/^form\.(.*)/) {
    $what.=':'.$1.'='.$ENV{$_};
               }
           } keys %ENV;
       }
       &courselog($what);
   }
   
   # ----------------------------------------------------------- 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
   
   sub expirespread {
       my ($uname,$udom,$stype,$usymb)=@_;
       my $cid=$ENV{'request.course.id'}; 
       if ($cid) {
          my $now=time;
          my $key=$uname.':'.$udom.':'.$stype.':'.$usymb;
          return &reply('put:'.$ENV{'course.'.$cid.'.domain'}.':'.
                               $ENV{'course.'.$cid.'.num'}.
               ':nohist_expirationdates:'.
                               &escape($key).'='.$now,
                               $ENV{'course.'.$cid.'.home'})
       }
       return 'ok';
   }
   
   # ----------------------------------------------------- Devalidate Spreadsheets
   
   sub devalidate {
       my $symb=shift;
       my $cid=$ENV{'request.course.id'}; 
       if ($cid) {
    my $key=$ENV{'user.name'}.':'.$ENV{'user.domain'}.':';
           my $status=
       &del('nohist_calculatedsheet',
    [$key.'studentcalc'],
    $ENV{'course.'.$cid.'.domain'},
    $ENV{'course.'.$cid.'.num'})
    .' '.
       &del('nohist_calculatedsheets_'.$cid,
    [$key.'assesscalc:'.$symb]);
           unless ($status eq 'ok ok') {
              &logthis('Could not devalidate spreadsheet '.
                       $ENV{'user.name'}.' at '.$ENV{'user.domain'}.' for '.
       $symb.': '.$status);
           }
       }
   }
   
   sub hash2str {
     my (%hash)=@_;
     my $result='';
     map { $result.=escape($_).'='.escape($hash{$_}).'&'; } keys %hash;
     $result=~s/\&$//;
     return $result;
   }
   
   sub str2hash {
     my ($string) = @_;
     my %returnhash;
     map {
       my ($name,$value)=split(/\=/,$_);
       $returnhash{&unescape($name)}=&unescape($value);
     } split(/\&/,$string);
     return %returnhash;
   }
   
   # -------------------------------------------------------------------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=@_;      my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
     my $symb;      my $home='';
     unless ($symb=escape(&symbread())) { return ''; }  
     my $namespace;      if ($stuname) { $home=&homeserver($stuname,$domain); }
     unless ($namespace=$ENV{'request.course.uri'}) { return ''; }  
     $namespace=~s/\//\_\_/g;      if (!$symb) { unless ($symb=&symbread()) { return ''; } }
     $namespace=~s/\./\_/g;  
     $namespace=escape($namespace);      &devalidate($symb);
   
       $symb=escape($symb);
       if (!$namespace) { unless ($namespace=$ENV{'request.course.id'}) { return ''; } }
       if (!$domain) { $domain=$ENV{'user.domain'}; }
       if (!$stuname) { $stuname=$ENV{'user.name'}; }
       if (!$home) { $home=$ENV{'user.home'}; }
       my $namevalue='';
       map {
           $namevalue.=escape($_).'='.escape($$storehash{$_}).'&';
       } keys %$storehash;
       $namevalue=~s/\&$//;
       return reply("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");
   }
   
   # -------------------------------------------------------------- Critical Store
   
   sub cstore {
       my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
       my $home='';
   
       if ($stuname) { $home=&homeserver($stuname,$domain); }
   
       if (!$symb) { unless ($symb=&symbread()) { return ''; } }
   
       &devalidate($symb);
   
       $symb=escape($symb);
       if (!$namespace) { unless ($namespace=$ENV{'request.course.id'}) { return ''; } }
       if (!$domain) { $domain=$ENV{'user.domain'}; }
       if (!$stuname) { $stuname=$ENV{'user.name'}; }
       if (!$home) { $home=$ENV{'user.home'}; }
   
     my $namevalue='';      my $namevalue='';
     map {      map {
         $namevalue.=escape($_).'='.escape($storehash{$_}).'&';          $namevalue.=escape($_).'='.escape($$storehash{$_}).'&';
     } keys %storehash;      } keys %$storehash;
     $namevalue=~s/\&$//;      $namevalue=~s/\&$//;
     return reply(      return critical("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");
      "store:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$symb:$namevalue",  
  "$ENV{'user.home'}");  
 }  }
   
 # --------------------------------------------------------------------- Restore  # --------------------------------------------------------------------- Restore
   
 sub restore {  sub restore {
     my $symb;      my ($symb,$namespace,$domain,$stuname) = @_;
     unless ($symb=escape(&symbread())) { return ''; }      my $home='';
     my $namespace;  
     unless ($namespace=$ENV{'request.course.uri'}) { return ''; }      if ($stuname) { $home=&homeserver($stuname,$domain); }
     $namespace=~s/\//\_\_/g;  
     $namespace=~s/\./\_/g;      if (!$symb) {
     $namespace=escape($namespace);        unless ($symb=escape(&symbread())) { return ''; }
     my $answer=reply(      } else {
               "restore:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$symb",        $symb=&escape($symb);
               "$ENV{'user.home'}");      }
       if (!$namespace) { unless ($namespace=$ENV{'request.course.id'}) { return ''; } }
       if (!$domain) { $domain=$ENV{'user.domain'}; }
       if (!$stuname) { $stuname=$ENV{'user.name'}; }
       if (!$home) { $home=$ENV{'user.home'}; }
       my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home");
   
     my %returnhash=();      my %returnhash=();
     map {      map {
  my ($name,$value)=split(/\=/,$_);   my ($name,$value)=split(/\=/,$_);
         $returnhash{&unescape($name)}=&unescape($value);          $returnhash{&unescape($name)}=&unescape($value);
     } split(/\&/,$answer);      } split(/\&/,$answer);
     map {      my $version;
         $returnhash{$_}=$returnhash{$returnhash{'version'}.':'.$_};      for ($version=1;$version<=$returnhash{'version'};$version++) {
     } split(/\:/,$returnhash{$returnhash{'version'}.':keys'});         map {
             $returnhash{$_}=$returnhash{$version.':'.$_};
          } split(/\:/,$returnhash{$version.':keys'});
       }
     return %returnhash;      return %returnhash;
 }  }
   
 # -------------------------------------------------------- Get user priviledges  # ---------------------------------------------------------- Course Description
   
   sub coursedescription {
       my $courseid=shift;
       $courseid=~s/^\///;
       $courseid=~s/\_/\//g;
       my ($cdomain,$cnum)=split(/\//,$courseid);
       my $chome=&homeserver($cnum,$cdomain);
       if ($chome ne 'no_host') {
          my %returnhash=&dump('environment',$cdomain,$cnum);
          if (!exists($returnhash{'con_lost'})) {
              my $normalid=$cdomain.'_'.$cnum;
              my %envhash=();
              $returnhash{'home'}= $chome;
      $returnhash{'domain'} = $cdomain;
      $returnhash{'num'} = $cnum;
              while (my ($name,$value) = each %returnhash) {
                  $envhash{'course.'.$normalid.'.'.$name}=$value;
              }
              $returnhash{'url'}='/res/'.declutter($returnhash{'url'});
              $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'.
          $ENV{'user.name'}.'_'.$cdomain.'_'.$cnum;
              $envhash{'course.'.$normalid.'.last_cache'}=time;
              $envhash{'course.'.$normalid.'.home'}=$chome;
              $envhash{'course.'.$normalid.'.domain'}=$cdomain;
              $envhash{'course.'.$normalid.'.num'}=$cnum;
              &appenv(%envhash);
              return %returnhash;
          }
       }
       return ();
   }
   
   # -------------------------------------------------------- Get user privileges
   
 sub rolesinit {  sub rolesinit {
     my ($domain,$username,$authhost)=@_;      my ($domain,$username,$authhost)=@_;
Line 482  sub rolesinit { Line 1212  sub rolesinit {
                 }                  }
             }              }
             if (($area ne '') && ($trole ne '')) {              if (($area ne '') && ($trole ne '')) {
          my $spec=$trole.'.'.$area;
                my ($tdummy,$tdomain,$trest)=split(/\//,$area);                 my ($tdummy,$tdomain,$trest)=split(/\//,$area);
                if ($trole =~ /^cr\//) {                 if ($trole =~ /^cr\//) {
    my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);     my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
Line 493  sub rolesinit { Line 1224  sub rolesinit {
                       if (($roledef ne 'con_lost') && ($roledef ne '')) {                        if (($roledef ne 'con_lost') && ($roledef ne '')) {
                          my ($syspriv,$dompriv,$coursepriv)=                           my ($syspriv,$dompriv,$coursepriv)=
      split(/\_/,unescape($roledef));       split(/\_/,unescape($roledef));
                   $allroles{'/'}.=':'.$syspriv;                    $allroles{'cm./'}.=':'.$syspriv;
                            $allroles{$spec.'./'}.=':'.$syspriv;
                          if ($tdomain ne '') {                           if ($tdomain ne '') {
                              $allroles{'/'.$tdomain.'/'}.=':'.$dompriv;                               $allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv;
                                $allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv;
                              if ($trest ne '') {                               if ($trest ne '') {
                 $allroles{$area}.=':'.$coursepriv;                  $allroles{'cm.'.$area}.=':'.$coursepriv;
                   $allroles{$spec.'.'.$area}.=':'.$coursepriv;
                              }                               }
                  }                   }
                       }                        }
                    }                     }
                } else {                 } else {
            $allroles{'/'}.=':'.$pr{$trole.':s'};             $allroles{'cm./'}.=':'.$pr{$trole.':s'};
              $allroles{$spec.'./'}.=':'.$pr{$trole.':s'};
                    if ($tdomain ne '') {                     if ($tdomain ne '') {
                       $allroles{'/'.$tdomain.'/'}.=':'.$pr{$trole.':d'};                       $allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
                        $allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
                       if ($trest ne '') {                        if ($trest ne '') {
           $allroles{$area}.=':'.$pr{$trole.':c'};            $allroles{'cm.'.$area}.=':'.$pr{$trole.':c'};
             $allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'};
                       }                        }
            }             }
        }         }
             }              }
           }             } 
         } split(/&/,$rolesdump);          } split(/&/,$rolesdump);
           my $adv=0;
           my $author=0;
         map {          map {
             %thesepriv=();              %thesepriv=();
               if (($_!~/^st/) && ($_!~/^ta/) && ($_!~/^cm/)) { $adv=1; }
               if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; }
             map {              map {
                 if ($_ ne '') {                  if ($_ ne '') {
     my ($priviledge,$restrictions)=split(/&/,$_);      my ($privilege,$restrictions)=split(/&/,$_);
                     if ($restrictions eq '') {                      if ($restrictions eq '') {
  $thesepriv{$priviledge}='F';   $thesepriv{$privilege}='F';
                     } else {                      } else {
                         if ($thesepriv{$priviledge} ne 'F') {                          if ($thesepriv{$privilege} ne 'F') {
     $thesepriv{$priviledge}.=$restrictions;      $thesepriv{$privilege}.=$restrictions;
                         }                          }
                     }                      }
                 }                  }
Line 532  sub rolesinit { Line 1273  sub rolesinit {
             map { $thesestr.=':'.$_.'&'.$thesepriv{$_}; } keys %thesepriv;              map { $thesestr.=':'.$_.'&'.$thesepriv{$_}; } keys %thesepriv;
             $userroles.='user.priv.'.$_.'='.$thesestr."\n";              $userroles.='user.priv.'.$_.'='.$thesestr."\n";
         } keys %allroles;                      } keys %allroles;            
           $userroles.='user.adv='.$adv."\n".
               'user.author='.$author."\n";
           $ENV{'user.adv'}=$adv;
     }      }
     return $userroles;        return $userroles;  
 }  }
Line 539  sub rolesinit { Line 1283  sub rolesinit {
 # --------------------------------------------------------------- get interface  # --------------------------------------------------------------- get interface
   
 sub get {  sub get {
    my ($namespace,@storearr)=@_;     my ($namespace,$storearr,$udomain,$uname)=@_;
    my $items='';     my $items='';
    map {     map {
        $items.=escape($_).'&';         $items.=escape($_).'&';
    } @storearr;     } @$storearr;
    $items=~s/\&$//;     $items=~s/\&$//;
  my $rep=reply("get:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",     if (!$udomain) { $udomain=$ENV{'user.domain'}; }
                  $ENV{'user.home'});     if (!$uname) { $uname=$ENV{'user.name'}; }
      my $uhome=&homeserver($uname,$udomain);
   
      my $rep=&reply("get:$udomain:$uname:$namespace:$items",$uhome);
    my @pairs=split(/\&/,$rep);     my @pairs=split(/\&/,$rep);
    my %returnhash=();     my %returnhash=();
      my $i=0;
    map {     map {
       my ($key,$value)=split(/=/,$_);        $returnhash{$_}=unescape($pairs[$i]);
       $returnhash{unescape($key)}=unescape($value);        $i++;
    } @pairs;     } @$storearr;
    return %returnhash;     return %returnhash;
 }  }
   
 # --------------------------------------------------------------- del interface  # --------------------------------------------------------------- del interface
   
 sub del {  sub del {
    my ($namespace,@storearr)=@_;     my ($namespace,$storearr,$udomain,$uname)=@_;
    my $items='';     my $items='';
    map {     map {
        $items.=escape($_).'&';         $items.=escape($_).'&';
    } @storearr;     } @$storearr;
    $items=~s/\&$//;     $items=~s/\&$//;
    return reply("del:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",     if (!$udomain) { $udomain=$ENV{'user.domain'}; }
                  $ENV{'user.home'});     if (!$uname) { $uname=$ENV{'user.name'}; }
      my $uhome=&homeserver($uname,$udomain);
   
      return &reply("del:$udomain:$uname:$namespace:$items",$uhome);
 }  }
   
 # -------------------------------------------------------------- dump interface  # -------------------------------------------------------------- dump interface
   
 sub dump {  sub dump {
    my $namespace=shift;     my ($namespace,$udomain,$uname)=@_;
    my $rep=reply("dump:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace",     if (!$udomain) { $udomain=$ENV{'user.domain'}; }
                 $ENV{'user.home'});     if (!$uname) { $uname=$ENV{'user.name'}; }
      my $uhome=&homeserver($uname,$udomain);
      my $rep=reply("dump:$udomain:$uname:$namespace",$uhome);
    my @pairs=split(/\&/,$rep);     my @pairs=split(/\&/,$rep);
    my %returnhash=();     my %returnhash=();
    map {     map {
Line 587  sub dump { Line 1340  sub dump {
 # --------------------------------------------------------------- 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 {     map {
        $items.=escape($_).'='.escape($storehash{$_}).'&';         $items.=&escape($_).'='.&escape($$storehash{$_}).'&';
    } keys %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
   
   sub cput {
      my ($namespace,$storehash,$udomain,$uname)=@_;
      if (!$udomain) { $udomain=$ENV{'user.domain'}; }
      if (!$uname) { $uname=$ENV{'user.name'}; }
      my $uhome=&homeserver($uname,$udomain);
      my $items='';
      map {
          $items.=escape($_).'='.escape($$storehash{$_}).'&';
      } keys %$storehash;
      $items=~s/\&$//;
      return &critical("put:$udomain:$uname:$namespace:$items",$uhome);
 }  }
   
 # -------------------------------------------------------------- eget interface  # -------------------------------------------------------------- eget interface
   
 sub eget {  sub eget {
    my ($namespace,@storearr)=@_;     my ($namespace,$storearr,$udomain,$uname)=@_;
    my $items='';     my $items='';
    map {     map {
        $items.=escape($_).'&';         $items.=escape($_).'&';
    } @storearr;     } @$storearr;
    $items=~s/\&$//;     $items=~s/\&$//;
  my $rep=reply("eget:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",     if (!$udomain) { $udomain=$ENV{'user.domain'}; }
                  $ENV{'user.home'});     if (!$uname) { $uname=$ENV{'user.name'}; }
      my $uhome=&homeserver($uname,$udomain);
      my $rep=&reply("eget:$udomain:$uname:$namespace:$items",$uhome);
    my @pairs=split(/\&/,$rep);     my @pairs=split(/\&/,$rep);
    my %returnhash=();     my %returnhash=();
      my $i=0;
    map {     map {
       my ($key,$value)=split(/=/,$_);        $returnhash{$_}=unescape($pairs[$i]);
       $returnhash{unescape($key)}=unescape($value);        $i++;
    } @pairs;     } @$storearr;
    return %returnhash;     return %returnhash;
 }  }
   
 # ------------------------------------------------- Check for a user priviledge  # ------------------------------------------------- Check for a user privilege
   
 sub allowed {  sub allowed {
     my ($priv,$uri)=@_;      my ($priv,$uri)=@_;
     $uri=~s/^\/res//;  
     $uri=~s/^\///;  
   
 # Free bre access to adm resources      my $orguri=$uri;
       $uri=&declutter($uri);
   
     if (($uri=~/^adm\//) && ($priv eq 'bre')) {  # Free bre access to adm and meta resources
   
       if ((($uri=~/^adm\//) || ($uri=~/\.meta$/)) && ($priv eq 'bre')) {
  return 'F';   return 'F';
     }      }
   
 # Gather priviledges over system and domain  # Free bre to public access
   
       if ($priv eq 'bre') {
    if (&metadata($uri,'copyright') eq 'public') { return 'F'; }
       }
   
     my $thisallowed='';      my $thisallowed='';
     if ($ENV{'user.priv./'}=~/$priv\&([^\:]*)/) {      my $statecond=0;
       my $courseprivid='';
   
   # Course
   
       if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'}=~/$priv\&([^\:]*)/) {
        $thisallowed.=$1;         $thisallowed.=$1;
     }      }
     if ($ENV{'user.priv./'.(split(/\//,$uri))[0].'/'}=~/$priv\&([^\:]*)/) {  
   # Domain
   
       if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.(split(/\//,$uri))[0].'/'}
          =~/$priv\&([^\:]*)/) {
          $thisallowed.=$1;
       }
   
   # Course: uri itself is a course
       my $courseuri=$uri;
       $courseuri=~s/\_(\d)/\/$1/;
       $courseuri=~s/^([^\/])/\/$1/;
   
       if ($ENV{'user.priv.'.$ENV{'request.role'}.'.'.$courseuri}
          =~/$priv\&([^\:]*)/) {
        $thisallowed.=$1;         $thisallowed.=$1;
     }      }
   
 # Full access at system or domain level? Exit.  # Full access at system, domain or course-wide level? Exit.
   
     if ($thisallowed=~/F/) {      if ($thisallowed=~/F/) {
  return 'F';   return 'F';
     }      }
   
 # The user does not have full access at system or domain level  # If this is generating or modifying users, exit with special codes
 # Course level access control  
   
 # uri itself refering to a course?      if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:'=~/\:$priv\:/) {
        return $thisallowed;
     if ($uri=~/\.course$/) {      }
        if ($ENV{'user.priv./'.$uri}=~/$priv\&([^\:]*)/) {  #
           $thisallowed.=$1;  # Gathered so far: system, domain and course wide privileges
   #
   # Course: See if uri or referer is an individual resource that is part of 
   # the course
   
       if ($ENV{'request.course.id'}) {
          $courseprivid=$ENV{'request.course.id'};
          if ($ENV{'request.course.sec'}) {
             $courseprivid.='/'.$ENV{'request.course.sec'};
        }         }
 # Full access on course level? Exit.         $courseprivid=~s/\_/\//;
        if ($thisallowed=~/F/) {         my $checkreferer=1;
   return 'F';         my @uriparts=split(/\//,$uri);
          my $filename=$uriparts[$#uriparts];
          my $pathname=$uri;
          $pathname=~s/\/$filename$//;
          if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~
              /\&$filename\:([\d\|]+)\&/) {
              $statecond=$1;
              if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid}
                  =~/$priv\&([^\:]*)/) {
                  $thisallowed.=$1;
                  $checkreferer=0;
              }
        }         }
          
          if ($checkreferer) {
     my $refuri=$ENV{'httpref.'.$orguri};
   
 # uri is refering to an individual resource; user needs to be in a course              unless ($refuri) {
                   map {
       if ($_=~/^httpref\..*\*/) {
    my $pattern=$_;
                           $pattern=~s/^httpref\.\/res\///;
                           $pattern=~s/\*/\[\^\/\]\+/g;
                           $pattern=~s/\//\\\//g;
                           if ($orguri=~/$pattern/) {
       $refuri=$ENV{$_};
                           }
                       }
                   } keys %ENV;
               }
            if ($refuri) { 
     $refuri=&declutter($refuri);
             my @uriparts=split(/\//,$refuri);
             my $filename=$uriparts[$#uriparts];
             my $pathname=$refuri;
             $pathname=~s/\/$filename$//;
               if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~
                 /\&$filename\:([\d\|]+)\&/) {
                 my $refstatecond=$1;
                 if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid}
                     =~/$priv\&([^\:]*)/) {
                     $thisallowed.=$1;
                     $uri=$refuri;
                     $statecond=$refstatecond;
                 }
             }
           }
          }
      }
   
    } else {  #
   # Gathered now: all privileges that could apply, and condition number
   # 
   #
   # Full or no access?
   #
   
        unless(defined($ENV{'request.course.uri'})) {      if ($thisallowed=~/F/) {
    return '1';   return 'F';
        }      }
   
 # Get access priviledges for course      unless ($thisallowed) {
           return '';
       }
   
        if ($ENV{'user.priv./'.$ENV{'request.course.uri'}}=~/$priv\&([^\:]*)/) {  # Restrictions exist, deal with them
           $thisallowed.=$1;  #
        }  #   C:according to course preferences
   #   R:according to resource settings
   #   L:unless locked
   #   X:according to user session state
   #
   
 # See if resource or referer is part of this course  # Possibly locked functionality, check all courses
             # Locks might take effect only after 10 minutes cache expiration for other
        my @uriparts=split(/\//,$uri);  # courses, and 2 minutes for current course
        my $urifile=$uriparts[$#uriparts];  
        $urifile=~/\.(\w+)$/;      my $envkey;
        my $uritype=$1;      if ($thisallowed=~/L/) {
        $#uriparts--;          foreach $envkey (keys %ENV) {
        my $uripath=join('/',@uriparts);             if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) {
        my $uricond=-1;                 my $courseid=$2;
        if ($ENV{'acc.res.'.$ENV{'request.course'}.'.'.$uripath}=~                 my $roleid=$1.'.'.$2;
    /\&$urifile\:(\d+)\&/) {                 $courseid=~s/^\///;
    $uricond=$1;                 my $expiretime=600;
        } elsif (($fe{$uritype} eq 'emb') || ($fe{$uritype} eq 'img')) {                 if ($ENV{'request.role'} eq $roleid) {
   my $refuri=$ENV{'HTTP_REFERER'};    $expiretime=120;
           $refuri=~s/^\/res//;                 }
           $refuri=~s/^\///;         my ($cdom,$cnum,$csec)=split(/\//,$courseid);
           @uriparts=split(/\//,$refuri);                 my $prefix='course.'.$cdom.'_'.$cnum.'.';
           $urifile=$uriparts[$#uriparts];                 if ((time-$ENV{$prefix.'last_cache'})>$expiretime) {
           $#uriparts--;     &coursedescription($courseid);
           $uripath=join('/',@uriparts);                 }
           if ($ENV{'acc.res.'.$ENV{'request.course'}.'.'.$uripath}=~                 if (($ENV{$prefix.'res.'.$uri.'.lock.sections'}=~/\,$csec\,/)
      /\&$urifile\:(\d+)\&/) {                  || ($ENV{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) {
      $uricond=$1;     if ($ENV{$prefix.'res.'.$uri.'.lock.expire'}>time) {
   }                         &log($ENV{'user.domain'},$ENV{'user.name'},
                               $ENV{'user.host'},
                               'Locked by res: '.$priv.' for '.$uri.' due to '.
                               $cdom.'/'.$cnum.'/'.$csec.' expire '.
                               $ENV{$prefix.'priv.'.$priv.'.lock.expire'});
          return '';
                      }
                  }
                  if (($ENV{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,$csec\,/)
                   || ($ENV{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) {
      if ($ENV{'priv.'.$priv.'.lock.expire'}>time) {
                          &log($ENV{'user.domain'},$ENV{'user.name'},
                               $ENV{'user.host'},
                               'Locked by priv: '.$priv.' for '.$uri.' due to '.
                               $cdom.'/'.$cnum.'/'.$csec.' expire '.
                               $ENV{$prefix.'priv.'.$priv.'.lock.expire'});
          return '';
                      }
                  }
      }
        }         }
       }
      
   #
   # Rest of the restrictions depend on selected course
   #
   
        if ($uricond>=0) {      unless ($ENV{'request.course.id'}) {
          return '1';
       }
   
 # The resource is part of the course  #
 # If user had full access on course level, go ahead  # Now user is definitely in a course
   #
   
            if ($thisallowed=~/F/) {  
        return 'F';  
            }  
   
 # Restricted by state?  # Course preferences
   
            if ($thisallowed=~/X/) {     if ($thisallowed=~/C/) {
       if (&condval($uricond)>1) {         my $rolecode=(split(/\./,$ENV{'request.role'}))[0];
          return '2';         if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.roles.denied'}
               } else {     =~/\,$rolecode\,/) {
                  return '';             &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},
               }                  'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
                   $ENV{'request.course.id'});
              return '';
          }
      }
   
   # Resource preferences
   
      if ($thisallowed=~/R/) {
          my $rolecode=(split(/\./,$ENV{'request.role'}))[0];
          my $filename=$perlvar{'lonDocRoot'}.'/res/'.$uri.'.meta';
          if (-e $filename) {
              my @content;
              {
        my $fh=Apache::File->new($filename);
                @content=<$fh>;
    }     }
              if (join('',@content)=~
                       /\<roledeny[^\>]*\>[^\<]*$rolecode[^\<]*\<\/roledeny\>/) {
          &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},
                       'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
              return '';
   
              }
        }         }
     }     }
     return $thisallowed;  
 }  
   
 # ---------------------------------------------------------- Refresh State Info  # Restricted by state?
   
 sub refreshstate {     if ($thisallowed=~/X/) {
         if (&condval($statecond)) {
    return '2';
         } else {
            return '';
         }
      }
   
      return 'F';
 }  }
   
 # ----------------------------------------------------------------- Define Role  # ----------------------------------------------------------------- Define Role
Line 770  sub definerole { Line 1682  sub definerole {
   }    }
 }  }
   
   # ---------------- Make a metadata query against the network of library servers
   
   sub metadata_query {
       my ($query,$custom,$customshow)=@_;
       my %rhash;
       for my $server (keys %libserv) {
    unless ($custom or $customshow) {
       my $reply=&reply("querysend:".&escape($query),$server);
       $rhash{$server}=$reply;
    }
    else {
       my $reply=&reply("querysend:".&escape($query).':'.
        &escape($custom).':'.&escape($customshow),
        $server);
       $rhash{$server}=$reply;
    }
       }
       return \%rhash;
   }
   
 # ------------------------------------------------------------------ Plain Text  # ------------------------------------------------------------------ Plain Text
   
 sub plaintext {  sub plaintext {
Line 786  sub fileembstyle { Line 1718  sub fileembstyle {
   
 # ------------------------------------------------------------ Description Text  # ------------------------------------------------------------ Description Text
   
 sub filedecription {  sub filedescription {
     my $ending=shift;      my $ending=shift;
     return $fd{$ending};      return $fd{$ending};
 }  }
Line 796  sub filedecription { Line 1728  sub filedecription {
 sub assignrole {  sub assignrole {
     my ($udom,$uname,$url,$role,$end,$start)=@_;      my ($udom,$uname,$url,$role,$end,$start)=@_;
     my $mrole;      my $mrole;
     $url=declutter($url);  
     if ($role =~ /^cr\//) {      if ($role =~ /^cr\//) {
         unless ($url=~/\.course$/) { return 'invalid'; }   unless (&allowed('ccr',$url)) {
  unless (allowed('ccr',$url)) { return 'refused'; }             &logthis('Refused custom assignrole: '.
                $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
       $ENV{'user.name'}.' at '.$ENV{'user.domain'});
              return 'refused'; 
           }
         $mrole='cr';          $mrole='cr';
     } else {      } else {
         unless (($url=~/\.course$/) || ($url=~/\/$/)) { return 'invalid'; }          my $cwosec=$url;
         unless (allowed('c'+$role)) { return 'refused'; }          $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;
           unless (&allowed('c'.$role,$cwosec)) { 
              &logthis('Refused assignrole: '.
                $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
       $ENV{'user.name'}.' at '.$ENV{'user.domain'});
              return 'refused'; 
           }
         $mrole=$role;          $mrole=$role;
     }      }
     my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:".      my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:".
                 "$udom:$uname:$url".'_'."$mrole=$role";                  "$udom:$uname:$url".'_'."$mrole=$role";
     if ($end) { $command.='_$end'; }      if ($end) { $command.='_'.$end; }
     if ($start) {      if ($start) {
  if ($end) {    if ($end) { 
            $command.='_$start';              $command.='_'.$start; 
         } else {          } else {
            $command.='_0_$start';             $command.='_0_'.$start;
         }          }
     }      }
     return &reply($command,&homeserver($uname,$udom));      return &reply($command,&homeserver($uname,$udom));
 }  }
   
   # -------------------------------------------------- Modify user authentication
   sub modifyuserauth {
       my ($udom,$uname,$umode,$upass)=@_;
       my $uhome=&homeserver($uname,$udom);
       &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);
       unless ($reply eq 'ok') {
    return 'error: '.$reply;
       }   
       return 'ok';
   }
   
   # --------------------------------------------------------------- Modify a user
   
   
   sub modifyuser {
       my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene)=@_;
       &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
                $umode.', '.$first.', '.$middle.', '.
        $last.', '.$gene.' by '.
                $ENV{'user.name'}.' at '.$ENV{'user.domain'});  
       my $uhome=&homeserver($uname,$udom);
   # ----------------------------------------------------------------- Create User
       if (($uhome eq 'no_host') && ($umode) && ($upass)) {
           my $unhome='';
    if ($ENV{'course.'.$ENV{'request.course.id'}.'.domain'} eq $udom) {
       $unhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'};
           } else {
               my $tryserver;
               my $loadm=10000000;
               foreach $tryserver (keys %libserv) {
          if ($hostdom{$tryserver} eq $udom) {
                     my $answer=reply('load',$tryserver);
                     if (($answer=~/\d+/) && ($answer<$loadm)) {
         $loadm=$answer;
                         $unhome=$tryserver;
                     }
          }
       }
           }
           if (($unhome eq '') || ($unhome eq 'no_host')) {
       return 'error: find home';
           }
           my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':'.$umode.':'.
                            &escape($upass),$unhome);
    unless ($reply eq 'ok') {
               return 'error: '.$reply;
           }   
           $uhome=&homeserver($uname,$udom);
           if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) {
       return 'error: verify home';
           }
       }
   # ---------------------------------------------------------------------- Add ID
       if ($uid) {
          $uid=~tr/A-Z/a-z/;
          my %uidhash=&idrget($udom,$uname);
          if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/)) {
     unless ($uid eq $uidhash{$uname}) {
         return 'error: mismatch '.$uidhash{$uname}.' versus '.$uid;
             }
          } else {
     &idput($udom,($uname => $uid));
          }
       }
   # -------------------------------------------------------------- Add names, etc
       my %names=&get('environment',
      ['firstname','middlename','lastname','generation'],
      $udom,$uname);
       if ($first)  { $names{'firstname'}  = $first; }
       if ($middle) { $names{'middlename'} = $middle; }
       if ($last)   { $names{'lastname'}   = $last; }
       if ($gene)   { $names{'generation'} = $gene; }
       my $reply = &put('environment', \%names, $udom,$uname);
       if ($reply ne 'ok') { return 'error: '.$reply; }
       &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
                $umode.', '.$first.', '.$middle.', '.
        $last.', '.$gene.' by '.
                $ENV{'user.name'}.' at '.$ENV{'user.domain'});
       return 'ok';
   }
   
   # -------------------------------------------------------------- Modify student
   
   sub modifystudent {
       my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
           $end,$start)=@_;
       my $cid='';
       unless ($cid=$ENV{'request.course.id'}) {
    return 'not_in_class';
       }
   # --------------------------------------------------------------- Make the user
       my $reply=&modifyuser
    ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene);
       unless ($reply eq 'ok') { return $reply; }
       my $uhome=&homeserver($uname,$udom);
       if (($uhome eq '') || ($uhome eq 'no_host')) { 
    return 'error: no such user';
       }
   # -------------------------------------------------- Add student to course list
       $reply=critical('put:'.$ENV{'course.'.$cid.'.domain'}.':'.
                 $ENV{'course.'.$cid.'.num'}.':classlist:'.
                         &escape($uname.':'.$udom).'='.
                         &escape($end.':'.$start),
                 $ENV{'course.'.$cid.'.home'});
       unless (($reply eq 'ok') || ($reply eq 'delayed')) {
    return 'error: '.$reply;
       }
   # ---------------------------------------------------- Add student role to user
       my $uurl='/'.$cid;
       $uurl=~s/\_/\//g;
       if ($usec) {
    $uurl.='/'.$usec;
       }
       return &assignrole($udom,$uname,$uurl,'st',$end,$start);
   }
   
   # ------------------------------------------------- Write to course preferences
   
   sub writecoursepref {
       my ($courseid,%prefs)=@_;
       $courseid=~s/^\///;
       $courseid=~s/\_/\//g;
       my ($cdomain,$cnum)=split(/\//,$courseid);
       my $chome=homeserver($cnum,$cdomain);
       if (($chome eq '') || ($chome eq 'no_host')) { 
    return 'error: no such course';
       }
       my $cstring='';
       map {
    $cstring.=escape($_).'='.escape($prefs{$_}).'&';
       } keys %prefs;
       $cstring=~s/\&$//;
       return reply('put:'.$cdomain.':'.$cnum.':environment:'.$cstring,$chome);
   }
   
   # ---------------------------------------------------------- Make/modify course
   
   sub createcourse {
       my ($udom,$description,$url)=@_;
       $url=&declutter($url);
       my $cid='';
       unless (&allowed('ccc',$ENV{'user.domain'})) {
           return 'refused';
       }
       unless ($udom eq $ENV{'user.domain'}) {
           return 'refused';
       }
   # ------------------------------------------------------------------- Create ID
      my $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).
          unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
   # ----------------------------------------------- Make sure that does not exist
      my $uhome=&homeserver($uname,$udom);
      unless (($uhome eq '') || ($uhome eq 'no_host')) {
          $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).
           unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
          $uhome=&homeserver($uname,$udom);       
          unless (($uhome eq '') || ($uhome eq 'no_host')) {
              return 'error: unable to generate unique course-ID';
          } 
      }
   # ------------------------------------------------------------- Make the course
       my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',
                         $ENV{'user.home'});
       unless ($reply eq 'ok') { return 'error: '.$reply; }
       $uhome=&homeserver($uname,$udom);
       if (($uhome eq '') || ($uhome eq 'no_host')) { 
    return 'error: no such course';
       }
       &writecoursepref($udom.'_'.$uname,
                        ('description' => $description,
                         'url'         => $url));
       return '/'.$udom.'/'.$uname;
   }
   
 # ---------------------------------------------------------- Assign Custom Role  # ---------------------------------------------------------- Assign Custom Role
   
 sub assigncustomrole {  sub assigncustomrole {
Line 895  sub dirlist { Line 2013  sub dirlist {
   
 # -------------------------------------------------------- Value of a Condition  # -------------------------------------------------------- Value of a Condition
   
   sub directcondval {
       my $number=shift;
       if ($ENV{'user.state.'.$ENV{'request.course.id'}}) {
          return substr($ENV{'user.state.'.$ENV{'request.course.id'}},$number,1);
       } else {
          return 2;
       }
   }
   
 sub condval {  sub condval {
     my $condidx=shift;      my $condidx=shift;
     my $result=0;      my $result=0;
     if ($ENV{'request.course'}) {      my $allpathcond='';
        if (defined($ENV{'acc.cond.'.$ENV{'request.course'}.'.'.$condidx})) {      map {
          if (defined($ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_})) {
      $allpathcond.=
                  '('.$ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_}.')|';
          }
       } split(/\|/,$condidx);
       $allpathcond=~s/\|$//;
       if ($ENV{'request.course.id'}) {
          if ($allpathcond) {
           my $operand='|';            my $operand='|';
   my @stack;    my @stack;
           map {            map {
Line 915  sub condval { Line 2050  sub condval {
               } elsif (($_ eq '&') || ($_ eq '|')) {                } elsif (($_ eq '&') || ($_ eq '|')) {
                   $operand=$_;                    $operand=$_;
               } else {                } else {
                   my $new=                    my $new=directcondval($_);
                        substr($ENV{'user.state.'.$ENV{'request.course'}},$_,1);  
                   if ($operand eq '&') {                    if ($operand eq '&') {
                      $result=$result>$new?$new:$result;                       $result=$result>$new?$new:$result;
                   } else {                    } else {
                      $result=$result>$new?$result:$new;                       $result=$result>$new?$result:$new;
                   }                                      }                  
               }                }
           } ($ENV{'acc.cond.'.$ENV{'request.course'}.'.'.$condidx}=~            } ($allpathcond=~/(\d+|\(|\)|\&|\|)/g);
              /(\d+|\(|\)|\&|\|)/g);  
        }         }
     }      }
     return $result;      return $result;
Line 932  sub condval { Line 2065  sub condval {
   
 # --------------------------------------------------------- Value of a Variable  # --------------------------------------------------------- Value of a Variable
   
 sub varval {  sub EXT {
     my ($realm,$space,@components)=split(/\./,shift);      my ($varname,$symbparm)=@_;
     my $value='';      unless ($varname) { return ''; }
       my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);
       my $rest;
       if ($therest[0]) {
          $rest=join('.',@therest);
       } else {
          $rest='';
       }
       my $qualifierrest=$qualifier;
       if ($rest) { $qualifierrest.='.'.$rest; }
       my $spacequalifierrest=$space;
       if ($qualifierrest) { $spacequalifierrest.='.'.$qualifierrest; }
     if ($realm eq 'user') {      if ($realm eq 'user') {
  if ($space=~/^resource/) {  # --------------------------------------------------------------- user.resource
     $space=~s/^resource\[//;   if ($space eq 'resource') {
             $space=~s/\]$//;      my %restored=&restore();
               return $restored{$qualifierrest};
   # ----------------------------------------------------------------- user.access
           } elsif ($space eq 'access') {
               return &allowed($qualifier,$rest);
   # ------------------------------------------ user.preferences, user.environment
           } elsif (($space eq 'preferences') || ($space eq 'environment')) {
               return $ENV{join('.',('environment',$qualifierrest))};
   # ----------------------------------------------------------------- user.course
           } elsif ($space eq 'course') {
               return $ENV{join('.',('request.course',$qualifier))};
   # ------------------------------------------------------------------- user.role
           } elsif ($space eq 'role') {
               my ($role,$where)=split(/\./,$ENV{'request.role'});
               if ($qualifier eq 'value') {
    return $role;
               } elsif ($qualifier eq 'extent') {
                   return $where;
               }
   # ----------------------------------------------------------------- user.domain
           } elsif ($space eq 'domain') {
               return $ENV{'user.domain'};
   # ------------------------------------------------------------------- user.name
           } elsif ($space eq 'name') {
               return $ENV{'user.name'};
   # ---------------------------------------------------- Any other user namespace
           } else {
               my $item=($rest)?$qualifier.'.'.$rest:$qualifier;
               my %reply=&get($space,[$item]);
               return $reply{$item};
           }
       } elsif ($realm eq 'request') {
   # ------------------------------------------------------------- request.browser
           if ($space eq 'browser') {
       return $ENV{'browser.'.$qualifier};
   # ------------------------------------------------------------ request.filename
         } else {          } else {
               return $ENV{'request.'.$spacequalifierrest};
         }          }
     } elsif ($realm eq 'course') {      } elsif ($realm eq 'course') {
     } elsif ($realm eq 'session') {  # ---------------------------------------------------------- course.description
           return $ENV{'course.'.$ENV{'request.course.id'}.'.'.
                                 $spacequalifierrest};
       } elsif ($realm eq 'resource') {
          if ($ENV{'request.course.id'}) {
   
   #   print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;
   
   
   # ----------------------------------------------------- Cascading lookup scheme
            my $symbp;
            if ($symbparm) {
               $symbp=$symbparm;
    } else {
               $symbp=&symbread();
            }            
            my $mapp=(split(/\_\_\_/,$symbp))[0];
   
            my $symbparm=$symbp.'.'.$spacequalifierrest;
            my $mapparm=$mapp.'___(all).'.$spacequalifierrest;
   
            my $seclevel=
               $ENV{'request.course.id'}.'.['.
    $ENV{'request.course.sec'}.'].'.$spacequalifierrest;
            my $seclevelr=
               $ENV{'request.course.id'}.'.['.
    $ENV{'request.course.sec'}.'].'.$symbparm;
            my $seclevelm=
               $ENV{'request.course.id'}.'.['.
    $ENV{'request.course.sec'}.'].'.$mapparm;
   
            my $courselevel=
               $ENV{'request.course.id'}.'.'.$spacequalifierrest;
            my $courselevelr=
               $ENV{'request.course.id'}.'.'.$symbparm;
            my $courselevelm=
               $ENV{'request.course.id'}.'.'.$mapparm;
   
   # ----------------------------------------------------------- first, check user
            my %resourcedata=get('resourcedata',
                              [$courselevelr,$courselevelm,$courselevel]);
            if (($resourcedata{$courselevelr}!~/^error\:/) &&
                ($resourcedata{$courselevelr}!~/^con_lost/)) {
   
            if ($resourcedata{$courselevelr}) { 
               return $resourcedata{$courselevelr}; }
            if ($resourcedata{$courselevelm}) { 
               return $resourcedata{$courselevelm}; }
            if ($resourcedata{$courselevel}) { return $resourcedata{$courselevel}; }
   
         } else {
     if ($resourcedata{$courselevelr}!~/No such file/) {
       &logthis("<font color=blue>WARNING:".
      " Trying to get resource data for ".$ENV{'user.name'}." at "
                      .$ENV{'user.domain'}.": ".$resourcedata{$courselevelr}.
                    "</font>");
     }
         }
   
   # -------------------------------------------------------- second, check course
   
           my $reply=&reply('get:'.
                 $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.':'.
                 $ENV{'course.'.$ENV{'request.course.id'}.'.num'}.
         ':resourcedata:'.
      &escape($seclevelr).'&'.&escape($seclevelm).'&'.&escape($seclevel).'&'.
      &escape($courselevelr).'&'.&escape($courselevelm).'&'.&escape($courselevel),
      $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
          my %parmhash=();
          my $thisparm='';       
          if (tie(%parmhash,'GDBM_File',
             $ENV{'request.course.fn'}.'_parms.db',&GDBM_READER,0640)) {
              $thisparm=$parmhash{$symbparm};
      untie(%parmhash);
          }
          if ($thisparm) { return $thisparm; }
        }
        
   # --------------------------------------------- last, look in resource metadata
   
         $spacequalifierrest=~s/\./\_/;
         my $metadata=&metadata($ENV{'request.filename'},$spacequalifierrest);
         if ($metadata) { return $metadata; }
         $metadata=&metadata($ENV{'request.filename'},
                                            'parameter_'.$spacequalifierrest);
         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
       } elsif ($realm eq 'environment') {
   # ----------------------------------------------------------------- environment
           return $ENV{'environment.'.$spacequalifierrest};
     } elsif ($realm eq 'system') {      } elsif ($realm eq 'system') {
   # ----------------------------------------------------------------- system.time
    if ($space eq 'time') {
       return time;
           }
       }
       return '';
   }
   
   # ---------------------------------------------------------------- Get metadata
   
   sub metadata {
       my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
   
       $uri=&declutter($uri);
       my $filename=$uri;
       $uri=~s/\.meta$//;
   #
   # 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'; }
    my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename);
           my $parser=HTML::TokeParser->new(\$metastring);
           my $token;
           undef %metathesekeys;
           while ($token=$parser->get_token) {
              if ($token->[0] eq 'S') {
        if (defined($token->[2]->{'package'})) {
   #
   # This is a package - get package info
   #
         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]->{'id'})) { 
                    $keyroot.='_'.$token->[2]->{'id'}; 
         }
                 if ($metacache{$uri.':packages'}) {
                    $metacache{$uri.':packages'}.=','.$package.$keyroot;
                 } else {
                    $metacache{$uri.':packages'}=$package.$keyroot;
         }
                 map {
     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;
         }
                     }
                 } keys %packagetab;
                } 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) {
        map {
                            $metathesekeys{$_}=1;
        } split(/\,/,&metadata($uri,'keys',
                                     $parser->get_text('/import'),$unikey,
                                     $depthcount));
    }
                } else { 
   
                 if (defined($token->[2]->{'name'})) { 
                    $unikey.='_'.$token->[2]->{'name'}; 
         }
                 $metathesekeys{$unikey}=1;
                 map {
     $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};
                 } @{$token->[3]};
                 unless (
                    $metacache{$uri.':'.$unikey}=$parser->get_text('/'.$entry)
         ) { $metacache{$uri.':'.$unikey}=
         $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 $value;      return $metacache{$uri.':'.$what};
 }  }
   
 # ------------------------------------------------- Update symbolic store links  # ------------------------------------------------- Update symbolic store links
Line 972  sub symblist { Line 2407  sub symblist {
 # ------------------------------------------------------ Return symb list entry  # ------------------------------------------------------ Return symb list entry
   
 sub symbread {  sub symbread {
       my $thisfn=shift;
       unless ($thisfn) {
           if ($ENV{'request.symb'}) { return $ENV{'request.symb'}; }
    $thisfn=$ENV{'request.filename'};
       }
       $thisfn=declutter($thisfn);
     my %hash;      my %hash;
     my $syval;      my %bighash;
     if (($ENV{'request.course.fn'}) && ($ENV{'request.filename'})) {      my $syval='';
       if (($ENV{'request.course.fn'}) && ($thisfn)) {
         if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',          if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',
                       &GDBM_READER,0640)) {                        &GDBM_READER,0640)) {
             my $thisfn=declutter($ENV{'request.filename'});  
     $syval=$hash{$thisfn};      $syval=$hash{$thisfn};
             if (untie(%hash)) {              untie(%hash);
                 unless ($syval=~/\_\d+$/) {          }
    unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) {  # ---------------------------------------------------------- There was an entry
                       return '';          if ($syval) {
                    }                 unless ($syval=~/\_\d+$/) {
                    $syval.=$1;         unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) {
         }                    &appenv('request.ambiguous' => $thisfn);
                 $syval.='___'.$thisfn;                    return '';
  return $syval;                 }    
             }                 $syval.=$1;
      }
           } else {
   # ------------------------------------------------------- Was not in symb table
              if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
                               &GDBM_READER,0640)) {
   # ---------------------------------------------- Get ID(s) for current resource
                 my $ids=$bighash{'ids_/res/'.$thisfn};
                 unless ($ids) { 
                    $ids=$bighash{'ids_/'.$thisfn};
                 }
                 if ($ids) {
   # ------------------------------------------------------------------- Has ID(s)
                    my @possibilities=split(/\,/,$ids);
                    if ($#possibilities==0) {
   # ----------------------------------------------- There is only one possibility
        my ($mapid,$resid)=split(/\./,$ids);
                        $syval=declutter($bighash{'map_id_'.$mapid}).'___'.$resid;
                    } else {
   # ------------------------------------------ There is more than one possibility
                        my $realpossible=0;
                        map {
    my $file=$bighash{'src_'.$_};
                            if (&allowed('bre',$file)) {
                my ($mapid,$resid)=split(/\./,$_);
                               if ($bighash{'map_type_'.$mapid} ne 'page') {
    $realpossible++;
                                   $syval=declutter($bighash{'map_id_'.$mapid}).
                                          '___'.$resid;
                               }
    }
                        } @possibilities;
        if ($realpossible!=1) { $syval=''; }
                    }
         }
                 untie(%bighash)
              } 
           }
           if ($syval) {
              return $syval.'___'.$thisfn; 
         }          }
     }      }
       &appenv('request.ambiguous' => $thisfn);
     return '';      return '';
 }  }
   
Line 1009  sub numval { Line 2490  sub numval {
 }      }    
   
 sub rndseed {  sub rndseed {
     my $symb;      my ($symb,$courseid,$domain,$username)=@_;
     unless ($symb=&symbread()) { return ''; }      if (!$symb) {
     my $symbchck=unpack("%32C*",$symb);        unless ($symb=&symbread()) { return time; }
     my $symbseed=numval($symb)%$symbchck;      }
     my $namechck=unpack("%32C*",$ENV{'user.name'});      if (!$courseid) { $courseid=$ENV{'request.course.id'};}
     my $nameseed=numval($ENV{'user.name'})%$namechck;      if (!$domain) {$domain=$ENV{'user.domain'};}
     return int( $symbseed      if (!$username) {$username=$ENV{'user.name'};}
        .$nameseed      {
                .unpack("%32C*",$ENV{'user.domain'})        use integer;
                .unpack("%32C*",$ENV{'request.course.uri'})        my $symbchck=unpack("%32C*",$symb) << 27;
                .$namechck        my $symbseed=numval($symb) << 22;
                .$symbchck);        my $namechck=unpack("%32C*",$username) << 17;
         my $nameseed=numval($username) << 12;
         my $domainseed=unpack("%32C*",$domain) << 7;
         my $courseseed=unpack("%32C*",$courseid);
         my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;
         #uncommenting these lines can break things!
         #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
         #&Apache::lonxml::debug("rndseed :$num:$symb");
         return $num;
       }
   }
   
   sub ireceipt {
       my ($funame,$fudom,$fucourseid,$fusymb)=@_;
       my $cuname=unpack("%32C*",$funame);
       my $cudom=unpack("%32C*",$fudom);
       my $cucourseid=unpack("%32C*",$fucourseid);
       my $cusymb=unpack("%32C*",$fusymb);
       my $cunique=unpack("%32C*",$perlvar{'lonReceipt'});
       return unpack("%32C*",$perlvar{'lonHostID'}).'-'.
              ($cunique%$cuname+
               $cunique%$cudom+
               $cusymb%$cuname+
               $cusymb%$cudom+
               $cucourseid%$cuname+
               $cucourseid%$cudom);
   }
   
   sub receipt {
       return &ireceipt($ENV{'user.name'},$ENV{'user.domain'},
                        $ENV{'request.course.id'},&symbread());
   }
     
   # ------------------------------------------------------------ Serves up a file
   # returns either the contents of the file or a -1
   sub getfile {
     my $file=shift;
     &repcopy($file);
     if (! -e $file ) { return -1; };
     my $fh=Apache::File->new($file);
     my $a='';
     while (<$fh>) { $a .=$_; }
     return $a
   }
   
   sub filelocation {
     my ($dir,$file) = @_;
     my $location;
     $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces
     if ($file=~m:^/~:) { # is a contruction space reference
       $location = $file;
       $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;
     } else {
       $file=~s/^$perlvar{'lonDocRoot'}//;
       $file=~s:^/*res::;
       if ( !( $file =~ m:^/:) ) {
         $location = $dir. '/'.$file;
       } else {
         $location = '/home/httpd/html/res'.$file;
       }
     }
     $location=~s://+:/:g; # remove duplicate /
     while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..
     return $location;
   }
   
   sub hreflocation {
       my ($dir,$file)=@_;
       unless (($_=~/^http:\/\//i) || ($_=~/^\//)) {
          my $finalpath=filelocation($dir,$file);
          $finalpath=~s/^\/home\/httpd\/html//;
          return $finalpath;
       } else {
          return $file;
       }
 }  }
   
 # ------------------------------------------------------------- Declutters URLs  # ------------------------------------------------------------- Declutters URLs
Line 1051  sub unescape { Line 2606  sub unescape {
   
 # ================================================================ Main Program  # ================================================================ Main Program
   
 sub BEGIN {  BEGIN {
 if ($readit ne 'done') {  
 # ------------------------------------------------------------ Read access.conf  # ------------------------------------------------------------ Read access.conf
 {  {
     my $config=Apache::File->new("/etc/httpd/conf/access.conf");      my $config=Apache::File->new("/etc/httpd/conf/access.conf");
Line 1071  if ($readit ne 'done') { Line 2625  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 1095  if ($readit ne 'done') { Line 2651  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 1106  if ($readit ne 'done') { Line 2664  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 package table
   {
       my $config=Apache::File->new("$perlvar{'lonTabDir'}/packages.tab");
   
       while (my $configline=<$config>) {
          chomp($configline);
          my ($short,$plain)=split(/:/,$configline);
          my ($pack,$name)=split(/\&/,$short);
          if ($plain ne '') {
             $packagetab{$pack.'&'.$name.'&name'}=$name; 
             $packagetab{$short}=$plain; 
          }
     }      }
 }  }
   
Line 1125  if ($readit ne 'done') { Line 2700  if ($readit ne 'done') {
     }      }
 }  }
   
   %metacache=();
   
 $readit='done';  $readit='done';
   &logtouch();
 &logthis('<font color=yellow>INFO: Read configuration</font>');  &logthis('<font color=yellow>INFO: Read configuration</font>');
 }  }
 }  
 1;  1;
Removed from v.1.32  
changed lines
  Added in v.1.179

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