[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.52 and 1.56

version 1.52, 2000/10/28 17:26:35 version 1.56, 2000/10/31 19:28:11
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 66 Line 67
 # 08/22,08/28,08/31,09/01,09/02,09/04,09/05,09/25,09/28,09/30 Gerd Kortemeyer  # 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 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/06,10/09,10/10,10/11,10/14,10/20,10/23,10/25,10/26,10/27,10/28,10/29, 
 # Gerd Kortemeyer  # 10/30,10/31 Gerd Kortemeyer
   
 package Apache::lonnet;  package Apache::lonnet;
   
Line 250  sub appenv { Line 251  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 499  sub coursedescription { Line 529  sub coursedescription {
     if ($chome ne 'no_host') {      if ($chome ne 'no_host') {
        my $rep=reply("dump:$cdomain:$cnum:environment",$chome);         my $rep=reply("dump:$cdomain:$cnum:environment",$chome);
        if ($rep ne 'con_lost') {         if ($rep ne 'con_lost') {
    my %cachehash=();             my $normalid=$courseid;
              $normalid=~s/\//\_/g;
              my %envhash=();
            my %returnhash=('home'   => $chome,              my %returnhash=('home'   => $chome, 
                            'domain' => $cdomain,                             'domain' => $cdomain,
                            'num'    => $cnum);                             'num'    => $cnum);
Line 508  sub coursedescription { Line 540  sub coursedescription {
                $name=&unescape($name);                 $name=&unescape($name);
                $value=&unescape($value);                 $value=&unescape($value);
                $returnhash{$name}=$value;                 $returnhash{$name}=$value;
                if ($name eq 'description') {                 $envhash{'course.'.$normalid.'.'.$name}=$value;
    $cachehash{$courseid}=$value;  
                }  
            } split(/\&/,$rep);             } split(/\&/,$rep);
            $returnhash{'url'}='/res/'.declutter($returnhash{'url'});             $returnhash{'url'}='/res/'.declutter($returnhash{'url'});
            $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'.             $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'.
        $ENV{'user.name'}.'_'.$cdomain.'_'.$cnum;         $ENV{'user.name'}.'_'.$cdomain.'_'.$cnum;
    put ('nohist_coursedescriptions',%cachehash);             $envhash{'course.'.$normalid.'.last_cache'}=time;
              &appenv(%envhash);
            return %returnhash;             return %returnhash;
        }         }
     }      }
Line 717  sub allowed { Line 748  sub allowed {
     my ($priv,$uri)=@_;      my ($priv,$uri)=@_;
     $uri=&declutter($uri);      $uri=&declutter($uri);
   
 # Free bre access to adm resources  # Free bre access to adm and meta resources
   
     if (($uri=~/^adm\//) && ($priv eq 'bre')) {      if ((($uri=~/^adm\//) || ($uri=~/\.meta$/)) && ($priv eq 'bre')) {
  return 'F';   return 'F';
     }      }
   
Line 776  sub allowed { Line 807  sub allowed {
        my $pathname=$uri;         my $pathname=$uri;
        $pathname=~s/\/$filename$//;         $pathname=~s/\/$filename$//;
        if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~         if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~
            /\&$filename\:(\d+)\&/) {             /\&$filename\:([\d\|]+)\&/) {
            $statecond=$1;             $statecond=$1;
            if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid}             if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid}
                =~/$priv\&([^\:]*)/) {                 =~/$priv\&([^\:]*)/) {
Line 784  sub allowed { Line 815  sub allowed {
                $checkreferer=0;                 $checkreferer=0;
            }             }
        }         }
   
        if (($ENV{'HTTP_REFERER'}) && ($checkreferer)) {         if (($ENV{'HTTP_REFERER'}) && ($checkreferer)) {
           my @uriparts=split(/\//,&declutter($ENV{'HTTP_REFERER'}));    my $refuri=$ENV{'HTTP_REFERER'};
             $refuri=~s/^http\:\/\/$ENV{'request.host'}//i;
             $refuri=&declutter($refuri);
             my @uriparts=split(/\//,$refuri);
           my $filename=$uriparts[$#uriparts];            my $filename=$uriparts[$#uriparts];
           my $pathname=$uri;            my $pathname=$refuri;
           $pathname=~s/\/$filename$//;            $pathname=~s/\/$filename$//;
           if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~            my @filenameparts=split(/\./,$uri);
               /\&$filename\:(\d+)\&/) {            if (&fileembstyle($filenameparts[$#filenameparts]) ne 'ssi') {
               $statecond=$1;              if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~
                 /\&$filename\:([\d\|]+)\&/) {
                 my $refstatecond=$1;
               if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid}                if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid}
                   =~/$priv\&([^\:]*)/) {                    =~/$priv\&([^\:]*)/) {
                   $thisallowed.=$1;                    $thisallowed.=$1;
                     $uri=$refuri;
                     $statecond=$refstatecond;
               }                }
               }
           }            }
        }         }
    }     }
Line 824  sub allowed { Line 864  sub allowed {
 #  #
   
 # Possibly locked functionality, check all courses  # Possibly locked functionality, check all courses
   # Locks might take effect only after 10 minutes cache expiration for other
   # courses, and 2 minutes for current course
   
     my $envkey;      my $envkey;
     if ($thisallowed=~/L/) {      if ($thisallowed=~/L/) {
         foreach $envkey (keys %ENV) {          foreach $envkey (keys %ENV) {
            if ($envkey=~/^user\.role\.st\.([^\.]*)/) {             if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) {
        my ($cdom,$cnum,$csec)=split(/\//,$1);                 my $courseid=$2;
                my %locks=();                 my $roleid=$1.'.'.$2;
                map {                 my $expiretime=600;
                    my ($name,$value)=split(/\=/,$_);                 if ($ENV{'request.role'} eq $roleid) {
                    $locks{&unescape($name)}=&unescape($value);    $expiretime=120;
                } split(/\&/,&reply('get:'.$cdom.':'.$cnum.                 }
                  ':environment:'.&escape('priv.'.$priv.'.lock.sections').         my ($cdom,$cnum,$csec)=split(/\//,$courseid);
                              ':'.&escape('priv.'.$priv.'.lock.expire').                 my $prefix='course.'.$cdom.'_'.$cnum.'.';
                              ':'.&escape('res.'.$uri.'.lock.sections').                 if ((time-$ENV{$prefix.'last_cache'})>$expiretime) {
      ':'.&escape('res.'.$uri.'.lock.expire'),     &coursedescription($courseid);
                   &homeserver($cnum,$cdom)));                 }
                if (($locks{'res.'.$uri.'.lock.sections'}=~/\,$csec\,/) ||                 if (($ENV{$prefix.'res.'.$uri.'.lock.sections'}=~/\,$csec\,/)
                    ($locks{'res.'.$uri.'.lock.sections'} eq 'all')) {                  || ($ENV{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) {
    if ($locks{'res.'.$uri.'.lock.expire'}>time) {     if ($ENV{$prefix.'res.'.$uri.'.lock.expire'}>time) {
                        &log('Locked by res: '.$priv.' for '.$uri.' due to '.                         &log('Locked by res: '.$priv.' for '.$uri.' due to '.
                             $cdom.'/'.$cnum.'/'.$csec.' expire '.                              $cdom.'/'.$cnum.'/'.$csec.' expire '.
                             $locks{'priv.'.$priv.'.lock.expire'});                              $ENV{$prefix.'priv.'.$priv.'.lock.expire'});
        return '';         return '';
                    }                     }
                }                 }
                if (($locks{'priv.'.$priv.'.lock.sections'}=~/\,$csec\,/) ||                 if (($ENV{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,$csec\,/)
                    ($locks{'priv.'.$priv.'.lock.sections'} eq 'all')) {                  || ($ENV{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) {
    if ($locks{'priv.'.$priv.'.lock.expire'}>time) {     if ($ENV{'priv.'.$priv.'.lock.expire'}>time) {
                        &log('Locked by priv: '.$priv.' for '.$uri.' due to '.                         &log('Locked by priv: '.$priv.' for '.$uri.' due to '.
                             $cdom.'/'.$cnum.'/'.$csec.' expire '.                              $cdom.'/'.$cnum.'/'.$csec.' expire '.
                             $locks{'priv.'.$priv.'.lock.expire'});                              $ENV{$prefix.'priv.'.$priv.'.lock.expire'});
        return '';         return '';
                    }                     }
                }                 }
Line 874  sub allowed { Line 916  sub allowed {
 # Now user is definitely in a course  # Now user is definitely in a course
 #  #
   
   
   # Course preferences
   
      if ($thisallowed=~/C/) {
          my $rolecode=(split(/\./,$ENV{'request.role'}))[0];
          if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.roles.denied'}
      =~/\,$rolecode\,/) {
              &log('Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
                   $ENV{'request.course.id'});
              return '';
          }
      }
   
   # Resource preferences
   
      if ($thisallowed=~/R/) {
          my $rolecode=(split(/\./,$ENV{'request.role'}))[0];
          my $filename=$perlvar{'lonDocRoot'}.'/res/'.$uri.'.meta';
          if (-e $filename) {
              my @content;
              {
        my $fh=Apache::File->new($filename);
                @content=<$fh>;
      }
              if (join('',@content)=~
                       /\<roledeny[^\>]*\>[^\<]*$rolecode[^\<]*\<\/roledeny\>/) {
          &log('Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
              return '';
   
              }
          }
      }
   
 # Restricted by state?  # Restricted by state?
   
    if ($thisallowed=~/X/) {     if ($thisallowed=~/X/) {
Line 1071  sub directcondval { Line 1146  sub directcondval {
 sub condval {  sub condval {
     my $condidx=shift;      my $condidx=shift;
     my $result=0;      my $result=0;
       my $allpathcond='';
       map {
          if (defined($ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_})) {
      $allpathcond.=
                  '('.$ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_}.')|';
          }
       } split(/\|/,$condidx);
       $allpathcond=~s/\|$//;
     if ($ENV{'request.course.id'}) {      if ($ENV{'request.course.id'}) {
        if (defined($ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$condidx})) {         if ($allpathcond) {
           my $operand='|';            my $operand='|';
   my @stack;    my @stack;
           map {            map {
Line 1095  sub condval { Line 1178  sub condval {
                      $result=$result>$new?$result:$new;                       $result=$result>$new?$result:$new;
                   }                                      }                  
               }                }
           } ($ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$condidx}=~            } ($allpathcond=~/(\d+|\(|\)|\&|\|)/g);
              /(\d+|\(|\)|\&|\|)/g);  
        }         }
     }      }
     return $result;      return $result;
Removed from v.1.52  
changed lines
  Added in v.1.56

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