[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.48 and 1.68

version 1.48, 2000/10/25 10:55:46 version 1.68, 2000/11/22 12:14:56
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 66 Line 66
 # 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 Gerd Kortemeyer  # 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 Gerd Kortemeyer
   
 package Apache::lonnet;  package Apache::lonnet;
   
Line 121  sub reply { Line 122  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 249  sub appenv { Line 249  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 339  sub subscribe { Line 368  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 350  sub repcopy { Line 382  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 492  sub restore { Line 524  sub restore {
 sub coursedescription {  sub coursedescription {
     my $courseid=shift;      my $courseid=shift;
     $courseid=~s/^\///;      $courseid=~s/^\///;
       $courseid=~s/\_/\//g;
     my ($cdomain,$cnum)=split(/\//,$courseid);      my ($cdomain,$cnum)=split(/\//,$courseid);
     my $chome=homeserver($cnum,$cdomain);      my $chome=homeserver($cnum,$cdomain);
     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 506  sub coursedescription { Line 541  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 ('coursedescriptions',%cachehash);             $envhash{'course.'.$normalid.'.last_cache'}=time;
              $envhash{'course.'.$normalid.'.home'}=$chome;
              $envhash{'course.'.$normalid.'.domain'}=$cdomain;
              $envhash{'course.'.$normalid.'.num'}=$cnum;
              &appenv(%envhash);
            return %returnhash;             return %returnhash;
        }         }
     }      }
Line 551  sub rolesinit { Line 588  sub rolesinit {
                 }                  }
             }              }
             if (($area ne '') && ($trole ne '')) {              if (($area ne '') && ($trole ne '')) {
          my $spec=$trole.'.'.$area;
                my ($tdummy,$tdomain,$trest)=split(/\//,$area);                 my ($tdummy,$tdomain,$trest)=split(/\//,$area);
                if ($trole =~ /^cr\//) {                 if ($trole =~ /^cr\//) {
    my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);     my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
Line 562  sub rolesinit { Line 600  sub rolesinit {
                       if (($roledef ne 'con_lost') && ($roledef ne '')) {                        if (($roledef ne 'con_lost') && ($roledef ne '')) {
                          my ($syspriv,$dompriv,$coursepriv)=                           my ($syspriv,$dompriv,$coursepriv)=
      split(/\_/,unescape($roledef));       split(/\_/,unescape($roledef));
                   $allroles{'/'}.=':'.$syspriv;                    $allroles{'cm./'}.=':'.$syspriv;
                            $allroles{$spec.'./'}.=':'.$syspriv;
                          if ($tdomain ne '') {                           if ($tdomain ne '') {
                              $allroles{'/'.$tdomain.'/'}.=':'.$dompriv;                               $allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv;
                                $allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv;
                              if ($trest ne '') {                               if ($trest ne '') {
                 $allroles{$area}.=':'.$coursepriv;                  $allroles{'cm.'.$area}.=':'.$coursepriv;
                   $allroles{$spec.'.'.$area}.=':'.$coursepriv;
                              }                               }
                  }                   }
                       }                        }
                    }                     }
                } else {                 } else {
            $allroles{'/'}.=':'.$pr{$trole.':s'};             $allroles{'cm./'}.=':'.$pr{$trole.':s'};
              $allroles{$spec.'./'}.=':'.$pr{$trole.':s'};
                    if ($tdomain ne '') {                     if ($tdomain ne '') {
                       $allroles{'/'.$tdomain.'/'}.=':'.$pr{$trole.':d'};                       $allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
                        $allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
                       if ($trest ne '') {                        if ($trest ne '') {
           $allroles{$area}.=':'.$pr{$trole.':c'};            $allroles{'cm.'.$area}.=':'.$pr{$trole.':c'};
             $allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'};
                       }                        }
            }             }
        }         }
Line 706  sub eget { Line 750  sub eget {
   
 sub allowed {  sub allowed {
     my ($priv,$uri)=@_;      my ($priv,$uri)=@_;
     $uri=~s/^\/res//;      $uri=&declutter($uri);
     $uri=~s/^\///;  
   
 # 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';
     }      }
   
 # Gather priviledges over system and domain  
   
     my $thisallowed='';      my $thisallowed='';
     if ($ENV{'user.priv./'}=~/$priv\&([^\:]*)/) {      my $statecond=0;
       my $courseprivid='';
   
   # Course
   
       if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'}=~/$priv\&([^\:]*)/) {
        $thisallowed.=$1;         $thisallowed.=$1;
     }      }
     if ($ENV{'user.priv./'.(split(/\//,$uri))[0].'/'}=~/$priv\&([^\:]*)/) {  
   # Domain
   
       if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.(split(/\//,$uri))[0].'/'}
          =~/$priv\&([^\:]*)/) {
        $thisallowed.=$1;         $thisallowed.=$1;
     }      }
   
 # Full access at system or domain level? Exit.  # Course: uri itself is a course
       my $courseuri=$uri;
       $courseuri=~s/\_(\d)/\/$1/;
       if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseuri}
          =~/$priv\&([^\:]*)/) {
          $thisallowed.=$1;
       }
   
   # Full access at system, domain or course-wide level? Exit.
   
     if ($thisallowed=~/F/) {      if ($thisallowed=~/F/) {
  return 'F';   return 'F';
     }      }
   
 # The user does not have full access at system or domain level  # If this is generating or modifying users, exit with special codes
 # Course level access control  
   
 # uri itself refering to a course?      if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:'=~/\:$priv\:/) {
        return $thisallowed;
     if ($uri=~/\.course$/) {      }
        if ($ENV{'user.priv./'.$uri}=~/$priv\&([^\:]*)/) {  #
           $thisallowed.=$1;  # Gathered so far: system, domain and course wide priviledges
   #
   # Course: See if uri or referer is an individual resource that is part of 
   # the course
   
       if ($ENV{'request.course.id'}) {
          $courseprivid=$ENV{'request.course.id'};
          if ($ENV{'request.course.sec'}) {
             $courseprivid.='/'.$ENV{'request.course.sec'};
        }         }
 # Full access on course level? Exit.         $courseprivid=~s/\_/\//;
        if ($thisallowed=~/F/) {         my $checkreferer=1;
   return 'F';         my @uriparts=split(/\//,$uri);
          my $filename=$uriparts[$#uriparts];
          my $pathname=$uri;
          $pathname=~s/\/$filename$//;
          if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~
              /\&$filename\:([\d\|]+)\&/) {
              $statecond=$1;
              if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid}
                  =~/$priv\&([^\:]*)/) {
                  $thisallowed.=$1;
                  $checkreferer=0;
              }
        }         }
   
 # uri is refering to an individual resource; user needs to be in a course         if (($ENV{'HTTP_REFERER'}) && ($checkreferer)) {
     my $refuri=$ENV{'HTTP_REFERER'};
             $refuri=~s/^http\:\/\/$ENV{'request.host'}//i;
             $refuri=&declutter($refuri);
             my @uriparts=split(/\//,$refuri);
             my $filename=$uriparts[$#uriparts];
             my $pathname=$refuri;
             $pathname=~s/\/$filename$//;
             my @filenameparts=split(/\./,$uri);
             if (&fileembstyle($filenameparts[$#filenameparts]) ne 'ssi') {
               if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~
                 /\&$filename\:([\d\|]+)\&/) {
                 my $refstatecond=$1;
                 if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid}
                     =~/$priv\&([^\:]*)/) {
                     $thisallowed.=$1;
                     $uri=$refuri;
                     $statecond=$refstatecond;
                 }
               }
             }
          }
      }
   
    } else {  #
   # Gathered now: all priviledges that could apply, and condition number
   # 
   #
   # Full or no access?
   #
   
        unless(defined($ENV{'request.course.id'})) {      if ($thisallowed=~/F/) {
    return '1';   return 'F';
        }      }
   
       unless ($thisallowed) {
           return '';
       }
   
 # Get access priviledges for course  # Restrictions exist, deal with them
   #
   #   C:according to course preferences
   #   R:according to resource settings
   #   L:unless locked
   #   X:according to user session state
   #
   
        if ($ENV{'user.priv./'.$ENV{'request.course.id'}}=~/$priv\&([^\:]*)/) {  # Possibly locked functionality, check all courses
           $thisallowed.=$1;  # Locks might take effect only after 10 minutes cache expiration for other
   # courses, and 2 minutes for current course
   
       my $envkey;
       if ($thisallowed=~/L/) {
           foreach $envkey (keys %ENV) {
              if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) {
                  my $courseid=$2;
                  my $roleid=$1.'.'.$2;
                  my $expiretime=600;
                  if ($ENV{'request.role'} eq $roleid) {
     $expiretime=120;
                  }
          my ($cdom,$cnum,$csec)=split(/\//,$courseid);
                  my $prefix='course.'.$cdom.'_'.$cnum.'.';
                  if ((time-$ENV{$prefix.'last_cache'})>$expiretime) {
      &coursedescription($courseid);
                  }
                  if (($ENV{$prefix.'res.'.$uri.'.lock.sections'}=~/\,$csec\,/)
                   || ($ENV{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) {
      if ($ENV{$prefix.'res.'.$uri.'.lock.expire'}>time) {
                          &log($ENV{'user.domain'},$ENV{'user.name'},
                               $ENV{'user.host'},
                               'Locked by res: '.$priv.' for '.$uri.' due to '.
                               $cdom.'/'.$cnum.'/'.$csec.' expire '.
                               $ENV{$prefix.'priv.'.$priv.'.lock.expire'});
          return '';
                      }
                  }
                  if (($ENV{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,$csec\,/)
                   || ($ENV{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) {
      if ($ENV{'priv.'.$priv.'.lock.expire'}>time) {
                          &log($ENV{'user.domain'},$ENV{'user.name'},
                               $ENV{'user.host'},
                               'Locked by priv: '.$priv.' for '.$uri.' due to '.
                               $cdom.'/'.$cnum.'/'.$csec.' expire '.
                               $ENV{$prefix.'priv.'.$priv.'.lock.expire'});
          return '';
                      }
                  }
      }
        }         }
       }
      
   #
   # Rest of the restrictions depend on selected course
   #
   
 # See if resource or referer is part of this course      unless ($ENV{'request.course.id'}) {
                    return '1';
        my @uriparts=split(/\//,$uri);      }
        my $urifile=$uriparts[$#uriparts];  
        $urifile=~/\.(\w+)$/;  
        my $uritype=$1;  
        $#uriparts--;  
        my $uripath=join('/',@uriparts);  
        my $uricond=-1;  
        if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$uripath}=~  
    /\&$urifile\:(\d+)\&/) {  
    $uricond=$1;  
        } elsif (($fe{$uritype} eq 'emb') || ($fe{$uritype} eq 'img')) {  
   my $refuri=$ENV{'HTTP_REFERER'};  
           $refuri=~s/^\/res//;  
           $refuri=~s/^\///;  
           @uriparts=split(/\//,$refuri);  
           $urifile=$uriparts[$#uriparts];  
           $#uriparts--;  
           $uripath=join('/',@uriparts);  
           if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$uripath}=~  
      /\&$urifile\:(\d+)\&/) {  
      $uricond=$1;  
   }  
        }  
   
        if ($uricond>=0) {  #
   # Now user is definitely in a course
   #
   
 # The resource is part of the course  
 # If user had full access on course level, go ahead  
   
            if ($thisallowed=~/F/) {  # Course preferences
        return 'F';  
            }  
   
 # Restricted by state?     if ($thisallowed=~/C/) {
          my $rolecode=(split(/\./,$ENV{'request.role'}))[0];
          if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.roles.denied'}
      =~/\,$rolecode\,/) {
              &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},
                   'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
                   $ENV{'request.course.id'});
              return '';
          }
      }
   
            if ($thisallowed=~/X/) {  # Resource preferences
       if (&condval($uricond)) {  
          return '2';     if ($thisallowed=~/R/) {
               } else {         my $rolecode=(split(/\./,$ENV{'request.role'}))[0];
                  return '';         my $filename=$perlvar{'lonDocRoot'}.'/res/'.$uri.'.meta';
               }         if (-e $filename) {
              my @content;
              {
        my $fh=Apache::File->new($filename);
                @content=<$fh>;
    }     }
              if (join('',@content)=~
                       /\<roledeny[^\>]*\>[^\<]*$rolecode[^\<]*\<\/roledeny\>/) {
          &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},
                       'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
              return '';
   
              }
        }         }
     }     }
     return $thisallowed;  
 }  
   
 # ---------------------------------------------------------- Refresh State Info  # Restricted by state?
   
 sub refreshstate {     if ($thisallowed=~/X/) {
         if (&condval($statecond)) {
    return '2';
         } else {
            return '';
         }
      }
   
      return 'F';
 }  }
   
 # ----------------------------------------------------------------- Define Role  # ----------------------------------------------------------------- Define Role
Line 992  sub directcondval { Line 1152  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 1016  sub condval { Line 1184  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;
Line 1025  sub condval { Line 1192  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 1034  sub varval { Line 1202  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 1070  sub varval { Line 1244  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='';
     return &coursedescription($ENV{'request.course.id'});          if ($ENV{'request.course.sec'}) {
 # ------------------------------------------------------------------- course.id      $section='_'.$ENV{'request.course.sec'};
         } elsif ($space eq 'id') {          }
             return $ENV{'request.course.id'};          return $ENV{'course.'.$ENV{'request.course.id'}.$section.'.'.
 # -------------------------------------------------- Any other course namespace                                $spacequalifierrest};
         } else {      } elsif ($realm eq 'resource') {
     my ($cdom,$cnam)=split(/\_/,$ENV{'request.course.id'});        if ($ENV{'request.course.id'}) {
     my $chome=&homeserver($cnam,$cdom);  # ----------------------------------------------------- Cascading lookup scheme
             my $item=join('.',($qualifier,$rest));         my $symbparm=&symbread().'.'.$spacequalifierrest;
             return &unescape         my $reslevel=
                    (&reply('get:'.$cdom.':'.$cnam.':'.&escape($space).':'.      $ENV{'request.course.id'}.'.'.$symbparm;
    &escape($item),$chome));         my $seclevel=
               $ENV{'request.course.id'}.'.'.
    $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}!~/^error\:/) {
          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'});
         if ($reply!~/^error\:/) {
           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
          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
    my $uri=&declutter($ENV{'request.filename'});
           my $filename=$perlvar{'lonDocRoot'}.'/res/'.$uri.'.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 1157  sub symbread { Line 1386  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 1184  sub symbread { Line 1416  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 1235  sub filelocation { Line 1469  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.48  
changed lines
  Added in v.1.68

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