[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.56 and 1.87

version 1.56, 2000/10/31 19:28:11 version 1.87, 2001/01/05 20:45:09
Line 42 Line 42
 # directcondval(index) : reading condition value of single condition from   # directcondval(index) : reading condition value of single condition from 
 #                        state string  #                        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
 # symbread([filename]) : returns the data handle (filename optional)  # symbread([filename]) : returns the data handle (filename optional)
 # rndseed()          : returns a random seed    # rndseed()          : returns a random seed 
   # receipt()          : returns a receipt to be given out to users 
 # getfile(filename)  : returns the contents of filename, or a -1 if it can't  # 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
 # filelocation(dir,file) : returns a farily clean absolute reference to file   # filelocation(dir,file) : returns a farily clean absolute reference to file 
 #                          from the directory dir  #                          from the directory dir
 # hreflocation(dir,file) : same as filelocation, but for hrefs  # hreflocation(dir,file) : same as filelocation, but for hrefs
 # log(domain,user,home,msg) : write to permanent log for user  # log(domain,user,home,msg) : write to permanent log for user
   # usection(domain,user,courseid) : output of section name/number or '' for
   #                                  "not in course" and '-1' for "no section"
   # userenvironment(domain,user,what) : puts out any environment parameter 
   #                                     for a user
   # idput(domain,hash) : writes IDs for users from hash (name=>id,name=>id)
   # idget(domain,array): returns hash with usernames (id=>name,id=>name) for
   #                      an array of IDs
   # idrget(domain,array): returns hash with IDs for usernames (name=>id,...) for
   #                       an array of names
   # metadata(file,entry): returns the metadata entry for a file. entry='keys'
   #                       returns a comma separated list of keys
 #  #
 # 6/1/99,6/2,6/10,6/11,6/12,6/14,6/26,6/28,6/29,6/30,  # 6/1/99,6/2,6/10,6/11,6/12,6/14,6/26,6/28,6/29,6/30,
 # 7/1,7/2,7/9,7/10,7/12,7/14,7/15,7/19,  # 7/1,7/2,7/9,7/10,7/12,7/14,7/15,7/19,
Line 68 Line 79
 # 10/04 Gerd Kortemeyer  # 10/04 Gerd Kortemeyer
 # 10/04 Guy Albertelli  # 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/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 Gerd Kortemeyer  # 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 Gerd Kortemeyer
   
 package Apache::lonnet;  package Apache::lonnet;
   
Line 77  use Apache::File; Line 92  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 %spareid %hostdom %libserv %pr %prp %fe %fd $readit %metacache);
 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;
   
 # --------------------------------------------------------------------- Logging  # --------------------------------------------------------------------- Logging
   
Line 123  sub reply { Line 139  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 245  sub appenv { Line 260  sub appenv {
  return 'error';   return 'error';
      }       }
      my $newname;       my $newname;
        flock($fh,'LOCK_EX');
      foreach $newname (keys %newenv) {       foreach $newname (keys %newenv) {
  print $fh "$newname=$newenv{$newname}\n";   print $fh "$newname=$newenv{$newname}\n";
      }       }
        $fh->close();
     }      }
     return 'ok';      return 'ok';
 }  }
Line 274  sub delenv { Line 291  sub delenv {
      unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) {       unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) {
  return 'error';   return 'error';
      }       }
        flock($fh,'LOCK_EX');
      map {       map {
  unless ($_=~/^$delthis/) { print $fh $_; }   unless ($_=~/^$delthis/) { print $fh $_; }
      } @oldenv;       } @oldenv;
        $fh->close();
     }      }
     return 'ok';      return 'ok';
 }  }
Line 358  sub homeserver { Line 377  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 370  sub subscribe { Line 494  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 381  sub repcopy { Line 508  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 512  sub restore { Line 639  sub restore {
  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;
 }  }
   
Line 546  sub coursedescription { Line 676  sub coursedescription {
            $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'.             $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'.
        $ENV{'user.name'}.'_'.$cdomain.'_'.$cnum;         $ENV{'user.name'}.'_'.$cdomain.'_'.$cnum;
            $envhash{'course.'.$normalid.'.last_cache'}=time;             $envhash{'course.'.$normalid.'.last_cache'}=time;
              $envhash{'course.'.$normalid.'.home'}=$chome;
              $envhash{'course.'.$normalid.'.domain'}=$cdomain;
              $envhash{'course.'.$normalid.'.num'}=$cnum;
            &appenv(%envhash);             &appenv(%envhash);
            return %returnhash;             return %returnhash;
        }         }
Line 772  sub allowed { Line 905  sub allowed {
     }      }
   
 # Course: uri itself is a course  # Course: uri itself is a course
       my $courseuri=$uri;
       $courseuri=~s/\_(\d)/\/$1/;
       $courseuri=~s/^([^\/])/\/$1/;
   
     if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$uri}      if ($ENV{'user.priv.'.$ENV{'request.role'}.'.'.$courseuri}
        =~/$priv\&([^\:]*)/) {         =~/$priv\&([^\:]*)/) {
        $thisallowed.=$1;         $thisallowed.=$1;
     }      }
Line 815  sub allowed { Line 951  sub allowed {
                $checkreferer=0;                 $checkreferer=0;
            }             }
        }         }
          
        if (($ENV{'HTTP_REFERER'}) && ($checkreferer)) {         if (($ENV{'HTTP_REFERER'}) && ($checkreferer)) {
   my $refuri=$ENV{'HTTP_REFERER'};    my $refuri=$ENV{'HTTP_REFERER'};
           $refuri=~s/^http\:\/\/$ENV{'request.host'}//i;            $refuri=~s/^http\:\/\/$ENV{'request.host'}//i;
Line 885  sub allowed { Line 1021  sub allowed {
                if (($ENV{$prefix.'res.'.$uri.'.lock.sections'}=~/\,$csec\,/)                 if (($ENV{$prefix.'res.'.$uri.'.lock.sections'}=~/\,$csec\,/)
                 || ($ENV{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) {                  || ($ENV{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) {
    if ($ENV{$prefix.'res.'.$uri.'.lock.expire'}>time) {     if ($ENV{$prefix.'res.'.$uri.'.lock.expire'}>time) {
                        &log('Locked by res: '.$priv.' for '.$uri.' due to '.                         &log($ENV{'user.domain'},$ENV{'user.name'},
                               $ENV{'user.host'},
                               'Locked by res: '.$priv.' for '.$uri.' due to '.
                             $cdom.'/'.$cnum.'/'.$csec.' expire '.                              $cdom.'/'.$cnum.'/'.$csec.' expire '.
                             $ENV{$prefix.'priv.'.$priv.'.lock.expire'});                              $ENV{$prefix.'priv.'.$priv.'.lock.expire'});
        return '';         return '';
Line 894  sub allowed { Line 1032  sub allowed {
                if (($ENV{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,$csec\,/)                 if (($ENV{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,$csec\,/)
                 || ($ENV{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) {                  || ($ENV{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) {
    if ($ENV{'priv.'.$priv.'.lock.expire'}>time) {     if ($ENV{'priv.'.$priv.'.lock.expire'}>time) {
                        &log('Locked by priv: '.$priv.' for '.$uri.' due to '.                         &log($ENV{'user.domain'},$ENV{'user.name'},
                               $ENV{'user.host'},
                               'Locked by priv: '.$priv.' for '.$uri.' due to '.
                             $cdom.'/'.$cnum.'/'.$csec.' expire '.                              $cdom.'/'.$cnum.'/'.$csec.' expire '.
                             $ENV{$prefix.'priv.'.$priv.'.lock.expire'});                              $ENV{$prefix.'priv.'.$priv.'.lock.expire'});
        return '';         return '';
Line 923  sub allowed { Line 1063  sub allowed {
        my $rolecode=(split(/\./,$ENV{'request.role'}))[0];         my $rolecode=(split(/\./,$ENV{'request.role'}))[0];
        if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.roles.denied'}         if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.roles.denied'}
    =~/\,$rolecode\,/) {     =~/\,$rolecode\,/) {
            &log('Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.             &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},
                   'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
                 $ENV{'request.course.id'});                  $ENV{'request.course.id'});
            return '';             return '';
        }         }
Line 942  sub allowed { Line 1083  sub allowed {
    }     }
            if (join('',@content)=~             if (join('',@content)=~
                     /\<roledeny[^\>]*\>[^\<]*$rolecode[^\<]*\<\/roledeny\>/) {                      /\<roledeny[^\>]*\>[^\<]*$rolecode[^\<]*\<\/roledeny\>/) {
        &log('Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);         &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},
                       'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
            return '';             return '';
   
            }             }
Line 962  sub allowed { Line 1104  sub allowed {
    return 'F';     return 'F';
 }  }
   
 # ---------------------------------------------------------- Refresh State Info  
   
 sub refreshstate {  
 }  
   
 # ----------------------------------------------------------------- Define Role  # ----------------------------------------------------------------- Define Role
   
 sub definerole {  sub definerole {
Line 1025  sub fileembstyle { Line 1162  sub fileembstyle {
   
 # ------------------------------------------------------------ Description Text  # ------------------------------------------------------------ Description Text
   
 sub filedecription {  sub filedescription {
     my $ending=shift;      my $ending=shift;
     return $fd{$ending};      return $fd{$ending};
 }  }
Line 1035  sub filedecription { Line 1172  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)) { return 'refused'; }
  unless (allowed('ccr',$url)) { 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)) { 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 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=&reply('get:'.$udom.':'.$uname.
                        ':environment:firstname&middlename&lastname&generation',
                        $uhome);
       my ($efirst,$emiddle,$elast,$egene)=split(/\&/,$names);
       if ($first)  { $efirst  = &escape($first); }
       if ($middle) { $emiddle = &escape($middle); }
       if ($last)   { $elast   = &escape($last); }
       if ($gene)   { $egene   = &escape($gene); }
       my $reply=&reply('put:'.$udom.':'.$uname.
              ':environment:firstname='.$efirst.
                         '&middlename='.$emiddle.
                           '&lastname='.$elast.
                         '&generation='.$egene,$uhome);
       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
       my $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; }
       my $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 1186  sub condval { Line 1492  sub condval {
   
 # --------------------------------------------------------- Value of a Variable  # --------------------------------------------------------- Value of a Variable
   
 sub varval {  sub EXT {
     my $varname=shift;      my $varname=shift;
       unless ($varname) { return ''; }
     my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);      my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);
     my $rest;      my $rest;
     if ($therest[0]) {      if ($therest[0]) {
Line 1195  sub varval { Line 1502  sub varval {
     } else {      } else {
        $rest='';         $rest='';
     }      }
       my $qualifierrest=$qualifier;
       if ($rest) { $qualifierrest.='.'.$rest; }
       my $spacequalifierrest=$space;
       if ($qualifierrest) { $spacequalifierrest.='.'.$qualifierrest; }
     if ($realm eq 'user') {      if ($realm eq 'user') {
 # --------------------------------------------------------------- user.resource  # --------------------------------------------------------------- user.resource
  if ($space eq 'resource') {   if ($space eq 'resource') {
       my %restored=&restore;
               return $restored{$qualifierrest};
 # ----------------------------------------------------------------- user.access  # ----------------------------------------------------------------- user.access
         } elsif ($space eq 'access') {          } elsif ($space eq 'access') {
             return &allowed($qualifier,$rest);              return &allowed($qualifier,$rest);
 # ------------------------------------------ user.preferences, user.environment  # ------------------------------------------ user.preferences, user.environment
         } elsif (($space eq 'preferences') || ($space eq 'environment')) {          } elsif (($space eq 'preferences') || ($space eq 'environment')) {
             return $ENV{join('.',('environment',$qualifier,$rest))};              return $ENV{join('.',('environment',$qualifierrest))};
 # ----------------------------------------------------------------- user.course  # ----------------------------------------------------------------- user.course
         } elsif ($space eq 'course') {          } elsif ($space eq 'course') {
             return $ENV{join('.',('request.course',$qualifier))};              return $ENV{join('.',('request.course',$qualifier))};
Line 1231  sub varval { Line 1544  sub varval {
 # ------------------------------------------------------------- request.browser  # ------------------------------------------------------------- request.browser
         if ($space eq 'browser') {          if ($space eq 'browser') {
     return $ENV{'browser.'.$qualifier};      return $ENV{'browser.'.$qualifier};
         } elsif ($space eq 'filename') {  # ------------------------------------------------------------ request.filename
             return $ENV{'request.filename'};          } else {
               return $ENV{'request.'.$spacequalifierrest};
         }          }
     } elsif ($realm eq 'course') {      } elsif ($realm eq 'course') {
 # ---------------------------------------------------------- course.description  # ---------------------------------------------------------- course.description
         if ($space eq 'description') {          my $section='';
             my %reply=&coursedescription($ENV{'request.course.id'});          if ($ENV{'request.course.sec'}) {
             return $reply{'description'};      $section='_'.$ENV{'request.course.sec'};
 # ------------------------------------------------------------------- course.id          }
         } elsif ($space eq 'id') {          return $ENV{'course.'.$ENV{'request.course.id'}.$section.'.'.
             return $ENV{'request.course.id'};                                $spacequalifierrest};
 # -------------------------------------------------- Any other course namespace      } elsif ($realm eq 'resource') {
         } else {        if ($ENV{'request.course.id'}) {
     my ($cdom,$cnam)=split(/\_/,$ENV{'request.course.id'});  # ----------------------------------------------------- Cascading lookup scheme
     my $chome=&homeserver($cnam,$cdom);         my $symbp=&symbread();
             my $item=join('.',($qualifier,$rest));         my $mapp=(split(/\_\_\_/,$symbp))[0];
             return &unescape  
                    (&reply('get:'.$cdom.':'.$cnam.':'.&escape($space).':'.         my $symbparm=$symbp.'.'.$spacequalifierrest;
    &escape($item),$chome));         my $mapparm=$mapp.'___(all).'.$spacequalifierrest;
         }  
     } elsif ($realm eq 'userdata') {         my $seclevel=
         my $uhome=&homeserver($qualifier,$space);              $ENV{'request.course.id'}.'.['.
 # ----------------------------------------------- userdata.domain.name.resource   $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\:/) {
   
          if ($resourcedata{$courselevelr}) { 
             return $resourcedata{$courselevelr}; }
          if ($resourcedata{$courselevelm}) { 
             return $resourcedata{$courselevelm}; }
          if ($resourcedata{$courselevel}) { return $resourcedata{$courselevel}; }
   
         }
   # -------------------------------------------------------- second, check course
           my $section='';
           if ($ENV{'request.course.sec'}) {
       $section='_'.$ENV{'request.course.sec'};
           }
           my $reply=&reply('get:'.
                 $ENV{'course.'.$ENV{'request.course.id'}.$section.'.domain'}.':'.
                 $ENV{'course.'.$ENV{'request.course.id'}.$section.'.num'}.
         ':resourcedata:'.
      &escape($seclevelr).'&'.&escape($seclevelm).'&'.&escape($seclevel).'&'.
      &escape($courselevelr).'&'.&escape($courselevelm).'&'.&escape($courselevel),
      $ENV{'course.'.$ENV{'request.course.id'}.$section.'.home'});
         if ($reply!~/^error\:/) {
     map {
         if ($_) { return &unescape($_); }
             } split(/\&/,$reply);
         }
   
   # ------------------------------------------------------ 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; }
   
 # ---------------------------------------------------- Any other user namespace  # ---------------------------------------------------- Any other user namespace
     } elsif ($realm eq 'environment') {      } elsif ($realm eq 'environment') {
 # ----------------------------------------------------------------- environment  # ----------------------------------------------------------------- environment
         return $ENV{join('.',($space,$qualifier,$rest))};          return $ENV{$spacequalifierrest};
     } elsif ($realm eq 'system') {      } elsif ($realm eq 'system') {
 # ----------------------------------------------------------------- system.time  # ----------------------------------------------------------------- system.time
  if ($space eq 'time') {   if ($space eq 'time') {
Line 1267  sub varval { Line 1646  sub varval {
     return '';      return '';
 }  }
   
   # ---------------------------------------------------------------- Get metadata
   
   sub metadata {
       my ($uri,$what)=@_;
   
       $uri=&declutter($uri);
       my $filename=$uri;
       $uri=~s/\.meta$//;
       unless ($metacache{$uri.':keys'}) {
           unless ($filename=~/\.meta$/) { $filename.='.meta'; }
    my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename);
           my $parser=HTML::TokeParser->new(\$metastring);
           my $token;
           while ($token=$parser->get_token) {
              if ($token->[0] eq 'S') {
         my $entry=$token->[1];
                 my $unikey=$entry;
                 if (defined($token->[2]->{'part'})) { 
                    $unikey.='_'.$token->[2]->{'part'}; 
         }
                 if (defined($token->[2]->{'name'})) { 
                    $unikey.='_'.$token->[2]->{'name'}; 
         }
                 if ($metacache{$uri.':keys'}) {
                    $metacache{$uri.':keys'}.=','.$unikey;
                 } else {
                    $metacache{$uri.':keys'}=$unikey;
         }
                 map {
     $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};
                 } @{$token->[3]};
                 unless (
                    $metacache{$uri.':'.$unikey}=$parser->get_text('/'.$entry)
         ) { $metacache{$uri.':'.$unikey}=
         $metacache{$uri.':'.$unikey.'.default'};
         }
             }
          }
       }
       return $metacache{$uri.':'.$what};
   }
   
 # ------------------------------------------------- Update symbolic store links  # ------------------------------------------------- Update symbolic store links
   
 sub symblist {  sub symblist {
Line 1319  sub symbread { Line 1740  sub symbread {
                             &GDBM_READER,0640)) {                              &GDBM_READER,0640)) {
 # ---------------------------------------------- Get ID(s) for current resource  # ---------------------------------------------- Get ID(s) for current resource
               my $ids=$bighash{'ids_/res/'.$thisfn};                my $ids=$bighash{'ids_/res/'.$thisfn};
                 unless ($ids) { 
                    $ids=$bighash{'ids_/'.$thisfn};
                 }
               if ($ids) {                if ($ids) {
 # ------------------------------------------------------------------- Has ID(s)  # ------------------------------------------------------------------- Has ID(s)
                  my @possibilities=split(/\,/,$ids);                   my @possibilities=split(/\,/,$ids);
Line 1346  sub symbread { Line 1770  sub symbread {
               untie(%bighash)                untie(%bighash)
            }              } 
         }          }
         if ($syval) { return $syval.'___'.$thisfn; }          if ($syval) {
              return $syval.'___'.$thisfn; 
           }
     }      }
     &appenv('request.ambiguous' => $thisfn);      &appenv('request.ambiguous' => $thisfn);
     return '';      return '';
Line 1381  sub rndseed { Line 1807  sub rndseed {
                .$symbchck);                 .$symbchck);
 }  }
   
   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  # ------------------------------------------------------------ Serves up a file
 # returns either the contents of the file or a -1  # returns either the contents of the file or a -1
 sub getfile {  sub getfile {
Line 1397  sub filelocation { Line 1844  sub filelocation {
   my ($dir,$file) = @_;    my ($dir,$file) = @_;
   my $location;    my $location;
   $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces    $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces
   $file=~s/^$perlvar{'lonDocRoot'}//;    if ($file=~m:^/~:) { # is a contruction space reference
   $file=~s:^/*res::;      $location = $file;
   if ( !( $file =~ m:^/:) ) {      $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;
     $location = $dir. '/'.$file;  
   } else {    } else {
     $location = '/home/httpd/html/res'.$file;      $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 /    $location=~s://+:/:g; # remove duplicate /
   while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..    while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..
Line 1522  if ($readit ne 'done') { Line 1974  if ($readit ne 'done') {
     }      }
 }  }
   
   %metacache=();
   
 $readit='done';  $readit='done';
 &logthis('<font color=yellow>INFO: Read configuration</font>');  &logthis('<font color=yellow>INFO: Read configuration</font>');
Removed from v.1.56  
changed lines
  Added in v.1.87

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