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

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

version 1.133, 2001/07/26 21:40:27 version 1.178, 2001/11/29 18:54:16
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 Gerd Kortemeyer
   #
   # $Id$
   #
   ###
   
 # Functions for use by content handlers:  # Functions for use by content handlers:
 #  #
 # metadata_query(sql-query-string,custom-metadata-regex) :   # metadata_query(sql-query-string,custom-metadata-regex) : 
Line 42 Line 106
 #                      current enviroment  #                      current enviroment
 #  #
 #  #
 # for the next 4 functions udom and uname are optional  # for the next 6 functions udom and uname are optional
 #         if supplied they use udom as the domain and uname  #         if supplied they use udom as the domain and uname
 #         as the username for the function (supply a courseid  #         as the username for the function (supply a courseid
 #         for the uname if you want a course database)  #         for the uname if you want a course database)
Line 57 Line 121
 #                      in from namesp  #                      in from namesp
 # dump(namesp,udom,uname) : dumps the complete namespace into a hash  # dump(namesp,udom,uname) : dumps the complete namespace into a hash
 # del(namesp,array,udom,uname)  : deletes keys out of array from namesp  # 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
 #  #
 #  #
 # put(namesp,hash)   : stores hash in namesp  
 # cput(namesp,hash)  : critical put  
 # ssi(url,hash)      : does a complete request cycle on url to localhost, posts  # ssi(url,hash)      : does a complete request cycle on url to localhost, posts
 #                      hash  #                      hash
 # coursedescription(id) : returns and caches course description for id  # coursedescription(id) : returns and caches course description for id
Line 72 Line 136
 # EXT(name)          : value of a variable  # EXT(name)          : value of a variable
 # symblist(map,hash) : Updates symbolic storage links  # symblist(map,hash) : Updates symbolic storage links
 # symbread([filename]) : returns the data handle (filename optional)  # symbread([filename]) : returns the data handle (filename optional)
 # rndseed()          : returns a random seed   # 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   # receipt()          : returns a receipt to be given out to users 
 # getfile(filename)  : returns the contents of filename, or a -1 if it can't  # getfile(filename)  : returns the contents of filename, or a -1 if it can't
 #                      be found, replicates and subscribes to the file  #                      be found, replicates and subscribes to the file
Line 92 Line 161
 # metadata(file,entry): returns the metadata entry for a file. entry='keys'  # metadata(file,entry): returns the metadata entry for a file. entry='keys'
 #                       returns a comma separated list of 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,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  
 # 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  
 #  
   
 package Apache::lonnet;  package Apache::lonnet;
   
Line 130  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 %metacache);  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);
Line 139  use Fcntl qw(:flock); Line 178  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 275  sub appenv { Line 324  sub appenv {
     map {      map {
  if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) {   if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) {
             &logthis("<font color=blue>WARNING: ".              &logthis("<font color=blue>WARNING: ".
                 "Attempt to modify environment ".$_." to ".$newenv{$_});                  "Attempt to modify environment ".$_." to ".$newenv{$_}
                   .'</font>');
     delete($newenv{$_});      delete($newenv{$_});
         } else {          } else {
             $ENV{$_}=$newenv{$_};              $ENV{$_}=$newenv{$_};
Line 386  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 658  sub log { Line 746  sub log {
     return critical("log:$dom:$nam:$what",$hom);      return critical("log:$dom:$nam:$what",$hom);
 }  }
   
   # ------------------------------------------------------------------ Course Log
   
   sub flushcourselogs {
       &logthis('Flushing course log buffers');
       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  # --------------------------------------------- Set Expire Date for Spreadsheet
   
 sub expirespread {  sub expirespread {
Line 698  sub devalidate { Line 922  sub devalidate {
     }      }
 }  }
   
   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,$symb,$namespace,$domain,$stuname) = @_;      my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
     my $home='';      my $home='';
   
     if ($stuname) {      if ($stuname) { $home=&homeserver($stuname,$domain); }
  $home=&homeserver($stuname,$domain);  
     }  
   
     if (!$symb) { unless ($symb=&symbread()) { return ''; } }      if (!$symb) { unless ($symb=&symbread()) { return ''; } }
   
Line 731  sub cstore { Line 1095  sub cstore {
     my ($storehash,$symb,$namespace,$domain,$stuname) = @_;      my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
     my $home='';      my $home='';
   
     if ($stuname) {      if ($stuname) { $home=&homeserver($stuname,$domain); }
  $home=&homeserver($stuname,$domain);  
     }  
   
     if (!$symb) { unless ($symb=&symbread()) { return ''; } }      if (!$symb) { unless ($symb=&symbread()) { return ''; } }
   
Line 759  sub restore { Line 1121  sub restore {
     my ($symb,$namespace,$domain,$stuname) = @_;      my ($symb,$namespace,$domain,$stuname) = @_;
     my $home='';      my $home='';
   
     if ($stuname) {      if ($stuname) { $home=&homeserver($stuname,$domain); }
  $home=&homeserver($stuname,$domain);  
     }  
   
     if (!$symb) {      if (!$symb) {
       unless ($symb=escape(&symbread())) { return ''; }        unless ($symb=escape(&symbread())) { return ''; }
Line 895  sub rolesinit { Line 1255  sub rolesinit {
         my $author=0;          my $author=0;
         map {          map {
             %thesepriv=();              %thesepriv=();
             if ($_!~/^st/) { $adv=1; }              if (($_!~/^st/) && ($_!~/^ta/) && ($_!~/^cm/)) { $adv=1; }
             if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; }              if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; }
             map {              map {
                 if ($_ ne '') {                  if ($_ ne '') {
Line 980  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  # ------------------------------------------------------ critical put interface
   
 sub cput {  sub cput {
    my ($namespace,%storehash)=@_;     my ($namespace,$storehash,$udomain,$uname)=@_;
      if (!$udomain) { $udomain=$ENV{'user.domain'}; }
      if (!$uname) { $uname=$ENV{'user.name'}; }
      my $uhome=&homeserver($uname,$udomain);
    my $items='';     my $items='';
    map {     map {
        $items.=escape($_).'='.escape($storehash{$_}).'&';         $items.=escape($_).'='.escape($$storehash{$_}).'&';
    } keys %storehash;     } keys %$storehash;
    $items=~s/\&$//;     $items=~s/\&$//;
    return critical     return &critical("put:$udomain:$uname:$namespace:$items",$uhome);
            ("put:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",  
                  $ENV{'user.home'});  
 }  }
   
 # -------------------------------------------------------------- eget interface  # -------------------------------------------------------------- eget interface
Line 1031  sub eget { Line 1394  sub eget {
   
 sub allowed {  sub allowed {
     my ($priv,$uri)=@_;      my ($priv,$uri)=@_;
   
       my $orguri=$uri;
     $uri=&declutter($uri);      $uri=&declutter($uri);
   
 # Free bre access to adm and meta resources  # Free bre access to adm and meta resources
Line 1039  sub allowed { Line 1404  sub allowed {
  return 'F';   return 'F';
     }      }
   
   # Free bre to public access
   
       if ($priv eq 'bre') {
    if (&metadata($uri,'copyright') eq 'public') { return 'F'; }
       }
   
     my $thisallowed='';      my $thisallowed='';
     my $statecond=0;      my $statecond=0;
     my $courseprivid='';      my $courseprivid='';
Line 1074  sub allowed { Line 1445  sub allowed {
   
 # If this is generating or modifying users, exit with special codes  # If this is generating or modifying users, exit with special codes
   
     if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:'=~/\:$priv\:/) {      if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:'=~/\:$priv\:/) {
  return $thisallowed;   return $thisallowed;
     }      }
 #  #
Line 1104  sub allowed { Line 1475  sub allowed {
            }             }
        }         }
                 
        if (($ENV{'HTTP_REFERER'}) && ($checkreferer)) {         if ($checkreferer) {
   my $refuri=$ENV{'HTTP_REFERER'};    my $refuri=$ENV{'httpref.'.$orguri};
           $refuri=~s/^http\:\/\/$ENV{'request.host'}//i;  
           $refuri=&declutter($refuri);              unless ($refuri) {
                   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 @uriparts=split(/\//,$refuri);
           my $filename=$uriparts[$#uriparts];            my $filename=$uriparts[$#uriparts];
           my $pathname=$refuri;            my $pathname=$refuri;
           $pathname=~s/\/$filename$//;            $pathname=~s/\/$filename$//;
           my @filenameparts=split(/\./,$uri);  
           if (&fileembstyle($filenameparts[$#filenameparts]) ne 'ssi') {  
             if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~              if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~
               /\&$filename\:([\d\|]+)\&/) {                /\&$filename\:([\d\|]+)\&/) {
               my $refstatecond=$1;                my $refstatecond=$1;
Line 1123  sub allowed { Line 1506  sub allowed {
                   $uri=$refuri;                    $uri=$refuri;
                   $statecond=$refstatecond;                    $statecond=$refstatecond;
               }                }
             }  
           }            }
           }
        }         }
    }     }
   
Line 1303  sub definerole { Line 1686  sub definerole {
   
 sub metadata_query {  sub metadata_query {
     my ($query,$custom,$customshow)=@_;      my ($query,$custom,$customshow)=@_;
     # need to put in a library server loop here and return a hash  
     my %rhash;      my %rhash;
     for my $server (keys %libserv) {      for my $server (keys %libserv) {
  unless ($custom or $customshow) {   unless ($custom or $customshow) {
Line 1378  sub assignrole { Line 1760  sub assignrole {
     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  # --------------------------------------------------------------- Modify a user
   
   
Line 1432  sub modifyuser { Line 1828  sub modifyuser {
        }         }
     }      }
 # -------------------------------------------------------------- Add names, etc  # -------------------------------------------------------------- Add names, etc
     my $names=&reply('get:'.$udom.':'.$uname.      my %names=&get('environment',
                      ':environment:firstname&middlename&lastname&generation',     ['firstname','middlename','lastname','generation'],
                      $uhome);     $udom,$uname);
     my ($efirst,$emiddle,$elast,$egene)=split(/\&/,$names);      if ($first)  { $names{'firstname'}  = $first; }
     if ($first)  { $efirst  = &escape($first); }      if ($middle) { $names{'middlename'} = $middle; }
     if ($middle) { $emiddle = &escape($middle); }      if ($last)   { $names{'lastname'}   = $last; }
     if ($last)   { $elast   = &escape($last); }      if ($gene)   { $names{'generation'} = $gene; }
     if ($gene)   { $egene   = &escape($gene); }      my $reply = &put('environment', \%names, $udom,$uname);
     my $reply=&reply('put:'.$udom.':'.$uname.      if ($reply ne 'ok') { return 'error: '.$reply; }
            ':environment:firstname='.$efirst.  
                       '&middlename='.$emiddle.  
                         '&lastname='.$elast.  
                       '&generation='.$egene,$uhome);  
     if ($reply ne 'ok') {  
  return 'error: '.$reply;  
     }  
     &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.      &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
              $umode.', '.$first.', '.$middle.', '.               $umode.', '.$first.', '.$middle.', '.
      $last.', '.$gene.' by '.       $last.', '.$gene.' by '.
              $ENV{'user.name'}.' at '.$ENV{'user.domain'});               $ENV{'user.name'}.' at '.$ENV{'user.domain'});
     return 'ok';       return 'ok';
 }  }
   
 # -------------------------------------------------------------- Modify student  # -------------------------------------------------------------- Modify student
Line 1473  sub modifystudent { Line 1862  sub modifystudent {
  return 'error: no such user';   return 'error: no such user';
     }      }
 # -------------------------------------------------- Add student to course list  # -------------------------------------------------- Add student to course list
     my $reply=critical('put:'.$ENV{'course.'.$cid.'.domain'}.':'.      $reply=critical('put:'.$ENV{'course.'.$cid.'.domain'}.':'.
               $ENV{'course.'.$cid.'.num'}.':classlist:'.                $ENV{'course.'.$cid.'.num'}.':classlist:'.
                       &escape($uname.':'.$udom).'='.                        &escape($uname.':'.$udom).'='.
                       &escape($end.':'.$start),                        &escape($end.':'.$start),
Line 1538  sub createcourse { Line 1927  sub createcourse {
     my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',      my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',
                       $ENV{'user.home'});                        $ENV{'user.home'});
     unless ($reply eq 'ok') { return 'error: '.$reply; }      unless ($reply eq 'ok') { return 'error: '.$reply; }
     my $uhome=&homeserver($uname,$udom);      $uhome=&homeserver($uname,$udom);
     if (($uhome eq '') || ($uhome eq 'no_host')) {       if (($uhome eq '') || ($uhome eq 'no_host')) { 
  return 'error: no such course';   return 'error: no such course';
     }      }
Line 1677  sub condval { Line 2066  sub condval {
 # --------------------------------------------------------- Value of a Variable  # --------------------------------------------------------- Value of a Variable
   
 sub EXT {  sub EXT {
     my $varname=shift;      my ($varname,$symbparm)=@_;
     unless ($varname) { return ''; }      unless ($varname) { return ''; }
     my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);      my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);
     my $rest;      my $rest;
Line 1738  sub EXT { Line 2127  sub EXT {
                               $spacequalifierrest};                                $spacequalifierrest};
     } elsif ($realm eq 'resource') {      } elsif ($realm eq 'resource') {
        if ($ENV{'request.course.id'}) {         if ($ENV{'request.course.id'}) {
   
   #   print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;
   
   
 # ----------------------------------------------------- Cascading lookup scheme  # ----------------------------------------------------- Cascading lookup scheme
          my $symbp=&symbread();           my $symbp;
            if ($symbparm) {
               $symbp=$symbparm;
    } else {
               $symbp=&symbread();
            }            
          my $mapp=(split(/\_\_\_/,$symbp))[0];           my $mapp=(split(/\_\_\_/,$symbp))[0];
   
          my $symbparm=$symbp.'.'.$spacequalifierrest;           my $symbparm=$symbp.'.'.$spacequalifierrest;
Line 1827  sub EXT { Line 2225  sub EXT {
                                          'parameter_'.$spacequalifierrest);                                           'parameter_'.$spacequalifierrest);
       if ($metadata) { return $metadata; }        if ($metadata) { return $metadata; }
   
   # ------------------------------------------------------------------ Cascade up
   
         unless ($space eq '0') {
             my ($part,$id)=split(/\_/,$space);
             if ($id) {
         my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,
                                      $symbparm);
                 if ($partgeneral) { return $partgeneral; }
             } else {
                 my $resourcegeneral=&EXT('resource.0.'.$qualifierrest,
                                          $symbparm);
                 if ($resourcegeneral) { return $resourcegeneral; }
             }
         }
   
 # ---------------------------------------------------- Any other user namespace  # ---------------------------------------------------- Any other user namespace
     } elsif ($realm eq 'environment') {      } elsif ($realm eq 'environment') {
 # ----------------------------------------------------------------- environment  # ----------------------------------------------------------------- environment
Line 1843  sub EXT { Line 2256  sub EXT {
 # ---------------------------------------------------------------- Get metadata  # ---------------------------------------------------------------- Get metadata
   
 sub metadata {  sub metadata {
     my ($uri,$what)=@_;      my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
   
     $uri=&declutter($uri);      $uri=&declutter($uri);
     my $filename=$uri;      my $filename=$uri;
     $uri=~s/\.meta$//;      $uri=~s/\.meta$//;
     unless ($metacache{$uri.':keys'}) {  #
   # Is the metadata already cached?
   # Look at timestamp of caching
   # Everything is cached by the main uri, libraries are never directly cached
   #
       unless (abs($metacache{$uri.':cachedtimestamp'}-time)<600) {
   #
   # Is this a recursive call for a library?
   #
           if ($liburi) {
       $liburi=&declutter($liburi);
               $filename=$liburi;
           }
           my %metathesekeys=();
         unless ($filename=~/\.meta$/) { $filename.='.meta'; }          unless ($filename=~/\.meta$/) { $filename.='.meta'; }
  my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename);   my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename);
         my $parser=HTML::TokeParser->new(\$metastring);          my $parser=HTML::TokeParser->new(\$metastring);
         my $token;          my $token;
           undef %metathesekeys;
         while ($token=$parser->get_token) {          while ($token=$parser->get_token) {
            if ($token->[0] eq 'S') {             if ($token->[0] eq 'S') {
       my $entry=$token->[1];       if (defined($token->[2]->{'package'})) {
               my $unikey=$entry;  #
               if (defined($token->[2]->{'part'})) {   # This is a package - get package info
                  $unikey.='_'.$token->[2]->{'part'};   #
         my $package=$token->[2]->{'package'};
         my $keyroot='';
                 if ($prefix) {
     $keyroot.='_'.$prefix;
                 } else {
                   if (defined($token->[2]->{'part'})) { 
                      $keyroot.='_'.$token->[2]->{'part'}; 
           }
       }        }
               if (defined($token->[2]->{'name'})) {                 if (defined($token->[2]->{'id'})) { 
                  $unikey.='_'.$token->[2]->{'name'};                    $keyroot.='_'.$token->[2]->{'id'}; 
       }        }
               if ($metacache{$uri.':keys'}) {                if ($metacache{$uri.':packages'}) {
                  $metacache{$uri.':keys'}.=','.$unikey;                   $metacache{$uri.':packages'}.=','.$package.$keyroot;
               } else {                } else {
                  $metacache{$uri.':keys'}=$unikey;                   $metacache{$uri.':packages'}=$package.$keyroot;
       }        }
               map {                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]->{$_};    $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};
               } @{$token->[3]};                } @{$token->[3]};
               unless (                unless (
Line 1876  sub metadata { Line 2370  sub metadata {
       ) { $metacache{$uri.':'.$unikey}=        ) { $metacache{$uri.':'.$unikey}=
       $metacache{$uri.':'.$unikey.'.default'};        $metacache{$uri.':'.$unikey.'.default'};
       }        }
           }  # end of not-a-package not-a-library import
      }
   # end of not-a-package start tag
     }
   # the next is the end of "start tag"
    }
        }         }
          $metacache{$uri.':keys'}=join(',',keys %metathesekeys);
          $metacache{$uri.':cachedtimestamp'}=time;
   # this is the end of "was not already recently cached
     }      }
     return $metacache{$uri.':'.$what};      return $metacache{$uri.':'.$what};
 }  }
Line 1987  sub numval { Line 2489  sub numval {
 }      }    
   
 sub rndseed {  sub rndseed {
     my $symb;      my ($symb,$courseid,$domain,$username)=@_;
     unless ($symb=&symbread()) { return time; }      if (!$symb) {
     {         unless ($symb=&symbread()) { return time; }
       }
       if (!$courseid) { $courseid=$ENV{'request.course.id'};}
       if (!$domain) {$domain=$ENV{'user.domain'};}
       if (!$username) {$username=$ENV{'user.name'};}
       {
       use integer;        use integer;
       my $symbchck=unpack("%32C*",$symb) << 27;        my $symbchck=unpack("%32C*",$symb) << 27;
       my $symbseed=numval($symb) << 22;        my $symbseed=numval($symb) << 22;
       my $namechck=unpack("%32C*",$ENV{'user.name'}) << 17;        my $namechck=unpack("%32C*",$username) << 17;
       my $nameseed=numval($ENV{'user.name'}) << 12;        my $nameseed=numval($username) << 12;
       my $domainseed=unpack("%32C*",$ENV{'user.domain'}) << 7;        my $domainseed=unpack("%32C*",$domain) << 7;
       my $courseseed=unpack("%32C*",$ENV{'request.course.id'});        my $courseseed=unpack("%32C*",$courseid);
       my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;        my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;
       #uncommenting these lines can break things!        #uncommenting these lines can break things!
       #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");        #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
Line 2099  sub unescape { Line 2606  sub unescape {
 # ================================================================ Main Program  # ================================================================ Main Program
   
 sub BEGIN {  sub BEGIN {
 if ($readit ne 'done') {  unless ($readit) {
 # ------------------------------------------------------------ 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 2118  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 2142  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 2153  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 2175  if ($readit ne 'done') { Line 2703  if ($readit ne 'done') {
 %metacache=();  %metacache=();
   
 $readit='done';  $readit='done';
   &logtouch();
 &logthis('<font color=yellow>INFO: Read configuration</font>');  &logthis('<font color=yellow>INFO: Read configuration</font>');
 }  }
 }  }
Removed from v.1.133  
changed lines
  Added in v.1.178

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