[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.54 and 1.62

version 1.54, 2000/10/30 16:32:06 version 1.62, 2000/11/14 15:58:39
Line 24 Line 24
 # 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
   # delenv(varname)    : deletes all environment entries starting with varname
 # store(hash)        : stores hash permanently for this url  # store(hash)        : stores hash permanently for this url
 # cstore(hash)       : critical store  # cstore(hash)       : critical store
 # restore            : returns hash for this url  # restore            : returns hash for this url
Line 41 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  
Line 67 Line 67
 # 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 Gerd Kortemeyer  # 10/30,10/31,11/2,11/14 Gerd Kortemeyer
   
 package Apache::lonnet;  package Apache::lonnet;
   
Line 250  sub appenv { Line 250  sub appenv {
     }      }
     return 'ok';      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';
        }
        @oldenv=<$fh>;
       }
       {
        my $fh;
        unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) {
    return 'error';
        }
        map {
    unless ($_=~/^$delthis/) { print $fh $_; }
        } @oldenv;
       }
       return 'ok';
   }
   
 # ------------------------------ Find server with least workload from spare.tab  # ------------------------------ Find server with least workload from spare.tab
   
Line 516  sub coursedescription { Line 545  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 785  sub allowed { Line 817  sub allowed {
                $checkreferer=0;                 $checkreferer=0;
            }             }
        }         }
   
        if (($ENV{'HTTP_REFERER'}) && ($checkreferer)) {         if (($ENV{'HTTP_REFERER'}) && ($checkreferer)) {
   my $refuri=&declutter($ENV{'HTTP_REFERER'});    my $refuri=$ENV{'HTTP_REFERER'};
             $refuri=~s/^http\:\/\/$ENV{'request.host'}//i;
             $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(/\./,$filename);            my @filenameparts=split(/\./,$uri);
           if (&fileembstyle($filenameparts[$#filenameparts]) ne 'ssi') {            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\|]+)\&/) {
Line 852  sub allowed { Line 887  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 861  sub allowed { Line 898  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 890  sub allowed { Line 929  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 909  sub allowed { Line 949  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 929  sub allowed { Line 970  sub allowed {
    return 'F';     return 'F';
 }  }
   
 # ---------------------------------------------------------- Refresh State Info  
   
 sub refreshstate {  
 }  
   
 # ----------------------------------------------------------------- Define Role  # ----------------------------------------------------------------- Define Role
   
 sub definerole {  sub definerole {
Line 1153  sub condval { Line 1189  sub condval {
   
 # --------------------------------------------------------- Value of a Variable  # --------------------------------------------------------- Value of a Variable
   
 sub varval {  sub EXT {
     my $varname=shift;      my $varname=shift;
     my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);      my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);
     my $rest;      my $rest;
Line 1162  sub varval { Line 1198  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 1198  sub varval { Line 1240  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 $reslevel=
             my $item=join('.',($qualifier,$rest));      $ENV{'request.course.id'}.'.'.&symbread().'.'.$spacequalifierrest;
             return &unescape         my $seclevel=
                    (&reply('get:'.$cdom.':'.$cnam.':'.&escape($space).':'.              $ENV{'request.course.id'}.'.'.
    &escape($item),$chome));   $ENV{'request.course.sec'}.'.'.$spacequalifierrest;
          my $courselevel=
               $ENV{'request.course.id'}.'.'.$spacequalifierrest;
   
   # ----------------------------------------------------------- first, check user
          my %resourcedata=get('resourcedata',($reslevel,$seclevel,$courselevel));
          if ($resourcedata{$reslevel}) { return $resourcedata{$reslevel}; }
          if ($resourcedata{$seclevel}) { return $resourcedata{$seclevel}; }
          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($reslevel).':'.escape($seclevel).':'.escape($courselevel),
      $ENV{'course.'.$ENV{'request.course.id'}.$section.'.home'});
           map {
              my ($name,$value)=split(/\=/,$_);
              $resourcedata{unescape($name)}=unescape($value);  
           } split(/\&/,$reply);
          if ($resourcedata{$reslevel}) { return $resourcedata{$reslevel}; }
          if ($resourcedata{$seclevel}) { return $resourcedata{$seclevel}; }
          if ($resourcedata{$courselevel}) { return $resourcedata{$courselevel}; }
   
   # ------------------------------------------------------ third, check map parms
          
          if ($ENV{'resource.parms.'.$reslevel}) {
      return $ENV{'resource.parms.'.$reslevel};
          }
        }
        
   # --------------------------------------------- last, look in resource metadata
    my $uri=&declutter($ENV{'request.filename'});
           my $filename=$perlvar{'lonDocRoot'}.'/res/'.$ENV.'.meta';
           if (-e $filename) {
               my @content;
               {
                my $fh=Apache::File->new($filename);
                @content=<$fh>;
               }
               if (join('',@content)=~
                    /\<$space[^\>]*\>([^\<]*)\<\/$space\>/) {
           return $1;
        }
         }          }
     } elsif ($realm eq 'userdata') {  
         my $uhome=&homeserver($qualifier,$space);  
 # ----------------------------------------------- userdata.domain.name.resource  
 # ---------------------------------------------------- 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 1234  sub varval { Line 1322  sub varval {
     return '';      return '';
 }  }
   
   # ---------------------------------------- Append resource parms to environment
   
   sub appendparms {
       my ($symb,$parms)=@_;
       my %storehash=();
       my $prefix='resource.parms.'.$ENV{'request.course.id'}.'.'.$symb;
       map {
    my ($typename,$value)=split(/\=/,$_);
           my ($type,$name)=split(/\:/,$typename);
           $storehash{$prefix.'.'.unescape($name)}=unescape($value);
    $storehash{$prefix.'.'.unescape($name).'.type'}=unescape($type);
       } split(/\&/,$parms);
       &appenv(%storehash);
   }
   
 # ------------------------------------------------- Update symbolic store links  # ------------------------------------------------- Update symbolic store links
   
 sub symblist {  sub symblist {
Line 1265  sub symbread { Line 1368  sub symbread {
     my %hash;      my %hash;
     my %bighash;      my %bighash;
     my $syval='';      my $syval='';
       my $parms='';
     if (($ENV{'request.course.fn'}) && ($thisfn)) {      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)) {
Line 1292  sub symbread { Line 1396  sub symbread {
                  if ($#possibilities==0) {                   if ($#possibilities==0) {
 # ----------------------------------------------- There is only one possibility  # ----------------------------------------------- There is only one possibility
      my ($mapid,$resid)=split(/\./,$ids);       my ($mapid,$resid)=split(/\./,$ids);
                        $parms=$bighash{'param_'.$ids};
                      $syval=declutter($bighash{'map_id_'.$mapid}).'___'.$resid;                       $syval=declutter($bighash{'map_id_'.$mapid}).'___'.$resid;
                  } else {                   } else {
 # ------------------------------------------ There is more than one possibility  # ------------------------------------------ There is more than one possibility
Line 1302  sub symbread { Line 1407  sub symbread {
              my ($mapid,$resid)=split(/\./,$_);               my ($mapid,$resid)=split(/\./,$_);
                             if ($bighash{'map_type_'.$mapid} ne 'page') {                              if ($bighash{'map_type_'.$mapid} ne 'page') {
  $realpossible++;   $realpossible++;
                                   $parms=$bighash{'param_'.$_};
                                 $syval=declutter($bighash{'map_id_'.$mapid}).                                  $syval=declutter($bighash{'map_id_'.$mapid}).
                                        '___'.$resid;                                         '___'.$resid;
                             }                              }
Line 1313  sub symbread { Line 1419  sub symbread {
               untie(%bighash)                untie(%bighash)
            }              } 
         }          }
         if ($syval) { return $syval.'___'.$thisfn; }          if ($syval) {
              if ($parms) {
          &appendparms($syval.'___'.$thisfn,$parms);
              }
              return $syval.'___'.$thisfn; 
           }
     }      }
     &appenv('request.ambiguous' => $thisfn);      &appenv('request.ambiguous' => $thisfn);
     return '';      return '';
Line 1364  sub filelocation { Line 1475  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/..
Removed from v.1.54  
changed lines
  Added in v.1.62

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