[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.327 and 1.355

version 1.327, 2003/02/13 21:35:50 version 1.355, 2003/03/26 19:34:42
Line 74  use HTTP::Headers; Line 74  use HTTP::Headers;
 use vars   use vars 
 qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom   qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom 
    %libserv %pr %prp %metacache %packagetab %titlecache      %libserv %pr %prp %metacache %packagetab %titlecache 
    %courselogs %accesshash $processmarker $dumpcount      %courselogs %accesshash %userrolehash $processmarker $dumpcount 
    %coursedombuf %coursehombuf %courseresdatacache      %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache 
    %domaindescription %domain_auth_def %domain_auth_arg_def);     %domaindescription %domain_auth_def %domain_auth_arg_def $tmpdir);
 use IO::Socket;  use IO::Socket;
 use GDBM_File;  use GDBM_File;
 use Apache::Constants qw(:common :http);  use Apache::Constants qw(:common :http);
Line 588  sub idput { Line 588  sub idput {
     }      }
 }  }
   
   # --------------------------------------------------- Assign a key to a student
   
   sub assign_access_key {
       my ($ckey,$cdom,$cnum,$udom,$uname)=@_;
       $cdom=
      $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));
       $cnum=
      $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));
       $udom=$ENV{'user.name'} unless (defined($udom));
       $uname=$ENV{'user.domain'} unless (defined($uname));
       my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
       if (($existing{$ckey}=~/^\d+$/) || # has time - new key
           ($existing{$ckey} eq $uname.':'.$udom)) { # this should not happen,
                                                     # unless something went wrong
                                                     # the first time around
   # ready to assign
       } elsif (!$existing{$ckey}) {
           if (&put('accesskey',{$ckey=>$uname.':'.$udom},$cdom,$cnum) eq 'ok') {
   # key now belongs to user
       my $envkey='key.'.$cdom.'_'.$cnum;
               if (&put('environment',{$envkey => $ckey}) eq 'ok') {
                   &appenv('environment.'.$envkey => $ckey);
                   return 'ok';
               } else {
                   return 
     'error: Count not permanently assign key, will need to be re-entered later.';
       }
           } else {
               return 'error: Could not assign key, try again later.';
           }
   # the key does not exist
    return 'error: The key does not exist';
       } else {
   # the key is somebody else's
    return 'error: The key is already in use';
       }
   }
   
   # ------------------------------------------------------ Generate a set of keys
   
   sub generate_access_keys {
       my ($number,$cdom,$cnum)=@_;
       $cdom=
      $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));
       $cnum=
      $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));
       unless (&allowed('ccc',$cdom)) { return 0; }
       unless (($cdom) && ($cnum)) { return 0; }
       if ($number>10000) { return 0; }
       sleep(2); # make sure don't get same seed twice
       srand(time()^($$+($$<<15))); # from "Programming Perl"
       my $total=0;
       for (my $i=1;$i<=$number;$i++) {
          my $newkey=sprintf("%lx",int(100000*rand)).'-'.
                     sprintf("%lx",int(100000*rand)).'-'.
                     sprintf("%lx",int(100000*rand));
          $newkey=~s/1/g/g; # folks mix up 1 and l
          $newkey=~s/0/h/g; # and also 0 and O
          my %existing=&get('accesskeys',[$newkey],$cdom,$cnum);
          if ($existing{$newkey}) {
              $i--;
          } else {
     if (&put('accesskeys',{ $newkey => time() },$cdom,$cnum) eq 'ok') {
                 $total++;
     }
          }
       }
       &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.home'},
            'Generated '.$total.' keys for '.$cnum.' at '.$cdom);
       return $total;
   }
   
   # ------------------------------------------------------- Validate an accesskey
   
   sub validate_access_key {
       my ($ckey,$cdom,$cnum,$udom,$uname)=@_;
       $cdom=
      $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));
       $cnum=
      $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));
       $udom=$ENV{'user.name'} unless (defined($udom));
       $uname=$ENV{'user.domain'} unless (defined($uname));
       my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
       return ($existing{$ckey} eq $uname.':'.$udom);
   }
   
 # ------------------------------------- Find the section of student in a course  # ------------------------------------- Find the section of student in a course
   
 sub getsection {  sub getsection {
Line 729  sub subscribe { Line 815  sub subscribe {
     $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;      $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
     my ($udom,$uname)=split(/\//,$author);      my ($udom,$uname)=split(/\//,$author);
     my $home=homeserver($uname,$udom);      my $home=homeserver($uname,$udom);
     if ($home eq 'no_host') {       if ($home eq 'no_host') {
         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')) {      if (($answer eq 'con_lost') || ($answer eq 'rejected')) {
Line 804  sub repcopy { Line 890  sub repcopy {
     }      }
 }  }
   
   # ------------------------------------------------ Get server side include body
   sub ssi_body {
       my $filelink=shift;
       my $output=($filelink=~/^http\:/?&externalssi($filelink):
                                        &ssi($filelink));
       $output=~s/^.*\<body[^\>]*\>//si;
       $output=~s/\<\/body\s*\>.*$//si;
       $output=~
               s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs;
       return $output;
   }
   
 # --------------------------------------------------------- Server Side Include  # --------------------------------------------------------- Server Side Include
   
 sub ssi {  sub ssi {
Line 929  sub log { Line 1027  sub log {
 }  }
   
 # ------------------------------------------------------------------ Course Log  # ------------------------------------------------------------------ Course Log
   #
   # This routine flushes several buffers of non-mission-critical nature
   #
   
 sub flushcourselogs {  sub flushcourselogs {
     &logthis('Flushing course log buffers');      &logthis('Flushing log buffers');
   #
   # course logs
   # This is a log of all transactions in a course, which can be used
   # for data mining purposes
   #
   # It also collects the courseid database, which lists last transaction
   # times and course titles for all courseids
   #
       my %courseidbuffer=();
     foreach (keys %courselogs) {      foreach (keys %courselogs) {
         my $crsid=$_;          my $crsid=$_;
         if (&reply('log:'.$coursedombuf{$crsid}.':'.          if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$crsid}.':'.
           &escape($courselogs{$crsid}),            &escape($courselogs{$crsid}),
           $coursehombuf{$crsid}) eq 'ok') {            $coursehombuf{$crsid}) eq 'ok') {
     delete $courselogs{$crsid};      delete $courselogs{$crsid};
Line 945  sub flushcourselogs { Line 1055  sub flushcourselogs {
                         " exceeded maximum size, deleting.</font>");                          " exceeded maximum size, deleting.</font>");
                delete $courselogs{$crsid};                 delete $courselogs{$crsid};
             }              }
         }                  }
           if ($courseidbuffer{$coursehombuf{$crsid}}) {
              $courseidbuffer{$coursehombuf{$crsid}}.='&'.
    &escape($crsid).'='.&escape($coursedescrbuf{$crsid});
           } else {
              $courseidbuffer{$coursehombuf{$crsid}}=
    &escape($crsid).'='.&escape($coursedescrbuf{$crsid});
           }    
       }
   #
   # Write course id database (reverse lookup) to homeserver of courses 
   # Is used in pickcourse
   #
       foreach (keys %courseidbuffer) {
           &courseidput($hostdom{$_},$courseidbuffer{$_},$_);
     }      }
     &logthis('Flushing access logs');  #
   # File accesses
   # Writes to the dynamic metadata of resources to get hit counts, etc.
   #
     foreach (keys %accesshash) {      foreach (keys %accesshash) {
         my $entry=$_;          my $entry=$_;
         $entry=~/\_\_\_(\w+)\/(\w+)\/(.*)\_\_\_(\w+)$/;          $entry=~/\_\_\_(\w+)\/(\w+)\/(.*)\_\_\_(\w+)$/;
Line 956  sub flushcourselogs { Line 1083  sub flushcourselogs {
     delete $accesshash{$entry};      delete $accesshash{$entry};
         }          }
     }      }
   #
   # Roles
   # Reverse lookup of user roles for course faculty/staff and co-authorship
   #
       foreach (keys %userrolehash) {
           my $entry=$_;
           my ($role,$uname,$udom,$runame,$rudom,$rsec)=
       split(/\:/,$entry);
           if (&Apache::lonnet::put('nohist_userroles',
                { $role.':'.$uname.':'.$udom.':'.$rsec => $userrolehash{$entry} },
                   $rudom,$runame) eq 'ok') {
       delete $userrolehash{$entry};
           }
       }
     $dumpcount++;      $dumpcount++;
 }  }
   
Line 964  sub courselog { Line 1105  sub courselog {
     $what=time.':'.$what;      $what=time.':'.$what;
     unless ($ENV{'request.course.id'}) { return ''; }      unless ($ENV{'request.course.id'}) { return ''; }
     $coursedombuf{$ENV{'request.course.id'}}=      $coursedombuf{$ENV{'request.course.id'}}=
        $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.':'.         $ENV{'course.'.$ENV{'request.course.id'}.'.domain'};
       $coursenumbuf{$ENV{'request.course.id'}}=
        $ENV{'course.'.$ENV{'request.course.id'}.'.num'};         $ENV{'course.'.$ENV{'request.course.id'}.'.num'};
     $coursehombuf{$ENV{'request.course.id'}}=      $coursehombuf{$ENV{'request.course.id'}}=
        $ENV{'course.'.$ENV{'request.course.id'}.'.home'};         $ENV{'course.'.$ENV{'request.course.id'}.'.home'};
       $coursedescrbuf{$ENV{'request.course.id'}}=
          $ENV{'course.'.$ENV{'request.course.id'}.'.description'};
     if (defined $courselogs{$ENV{'request.course.id'}}) {      if (defined $courselogs{$ENV{'request.course.id'}}) {
  $courselogs{$ENV{'request.course.id'}}.='&'.$what;   $courselogs{$ENV{'request.course.id'}}.='&'.$what;
     } else {      } else {
Line 1004  sub countacc { Line 1148  sub countacc {
         $accesshash{$key}=1;          $accesshash{$key}=1;
     }      }
 }  }
       
   sub userrolelog {
       my ($trole,$username,$domain,$area,$tstart,$tend)=@_;
       if (($trole=~/^ca/) || ($trole=~/^in/) || 
           ($trole=~/^cc/) || ($trole=~/^ep/) ||
           ($trole=~/^cr/)) {
          my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
          $userrolehash
            {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
                       =$tend.':'.$tstart;
      }
   }
   
   sub get_course_adv_roles {
       my $cid=shift;
       $cid=$ENV{'request.course.id'} unless (defined($cid));
       my %coursehash=&coursedescription($cid);
       my %returnhash=();
       my %dumphash=
               &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});
       my $now=time;
       foreach (keys %dumphash) {
    my ($tend,$tstart)=split(/\:/,$dumphash{$_});
           if (($tstart) && ($tstart<0)) { next; }
           if (($tend) && ($tend<$now)) { next; }
           if (($tstart) && ($now<$tstart)) { next; }
           my ($role,$username,$domain,$section)=split(/\:/,$_);
           my $key=&plaintext($role);
           if ($section) { $key.=' (Sec/Grp '.$section.')'; }
           if ($returnhash{$key}) {
       $returnhash{$key}.=','.$username.':'.$domain;
           } else {
               $returnhash{$key}=$username.':'.$domain;
           }
       }
       return sort %returnhash;
   }
   
   # ---------------------------------------------------------- Course ID routines
   # Deal with domain's nohist_courseid.db files
   #
   
   sub courseidput {
       my ($domain,$what,$coursehome)=@_;
       return &reply('courseidput:'.$domain.':'.$what,$coursehome);
   }
   
   sub courseiddump {
       my ($domfilter,$descfilter,$sincefilter)=@_;
       my %returnhash=();
       unless ($domfilter) { $domfilter=''; }
       foreach my $tryserver (keys %libserv) {
    if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) {
       foreach (
                split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'.
          $sincefilter.':'.&escape($descfilter),
                                  $tryserver))) {
    my ($key,$value)=split(/\=/,$_);
                   if (($key) && ($value)) {
       $returnhash{&unescape($key)}=&unescape($value);
                   }
               }
   
           }
       }
       return %returnhash;
   }
   
   #
 # ----------------------------------------------------------- Check out an item  # ----------------------------------------------------------- Check out an item
   
 sub checkout {  sub checkout {
Line 1609  sub rolesinit { Line 1821  sub rolesinit {
             my ($trole,$tend,$tstart)=split(/_/,$role);              my ($trole,$tend,$tstart)=split(/_/,$role);
             $userroles.='user.role.'.$trole.'.'.$area.'='.              $userroles.='user.role.'.$trole.'.'.$area.'='.
                         $tstart.'.'.$tend."\n";                          $tstart.'.'.$tend."\n";
   # log the associated role with the area
               &userrolelog($trole,$username,$domain,$area,$tstart,$tend);
             if ($tend!=0) {              if ($tend!=0) {
         if ($tend<$now) {          if ($tend<$now) {
             $trole='';              $trole='';
Line 1620  sub rolesinit { Line 1834  sub rolesinit {
                 }                  }
             }              }
             if (($area ne '') && ($trole ne '')) {              if (($area ne '') && ($trole ne '')) {
        my $spec=$trole.'.'.$area;   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);
                    my $homsvr=homeserver($rauthor,$rdomain);      my $homsvr=homeserver($rauthor,$rdomain);
                    if ($hostname{$homsvr} ne '') {      if ($hostname{$homsvr} ne '') {
                       my $roledef=   my $roledef=
   reply("get:$rdomain:$rauthor:roles:rolesdef_$rrole",      reply("get:$rdomain:$rauthor:roles:rolesdef_$rrole",
                                 $homsvr);    $homsvr);
                       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{'cm./'}.=':'.$syspriv;      if (defined($syspriv)) {
                          $allroles{$spec.'./'}.=':'.$syspriv;   $allroles{'cm./'}.=':'.$syspriv;
                          if ($tdomain ne '') {   $allroles{$spec.'./'}.=':'.$syspriv;
                              $allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv;      }
                              $allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv;      if ($tdomain ne '') {
                              if ($trest ne '') {   if (defined($dompriv)) {
                 $allroles{'cm.'.$area}.=':'.$coursepriv;      $allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv;
                 $allroles{$spec.'.'.$area}.=':'.$coursepriv;      $allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv;
                              }   }
                  }   if ($trest ne '') {
                       }      if (defined($coursepriv)) {
                    }   $allroles{'cm.'.$area}.=':'.$coursepriv;
                } else {   $allroles{$spec.'.'.$area}.=':'.$coursepriv;
            $allroles{'cm./'}.=':'.$pr{$trole.':s'};      }
            $allroles{$spec.'./'}.=':'.$pr{$trole.':s'};   }
                    if ($tdomain ne '') {      }
                      $allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};   }
                      $allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};      }
                       if ($trest ne '') {   } else {
           $allroles{'cm.'.$area}.=':'.$pr{$trole.':c'};      if (defined($pr{$trole.':s'})) {
           $allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'};   $allroles{'cm./'}.=':'.$pr{$trole.':s'};
                       }   $allroles{$spec.'./'}.=':'.$pr{$trole.':s'};
            }      }
        }      if ($tdomain ne '') {
    if (defined($pr{$trole.':d'})) {
       $allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
       $allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
    }
    if ($trest ne '') {
       if (defined($pr{$trole.':c'})) {
    $allroles{'cm.'.$area}.=':'.$pr{$trole.':c'};
    $allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'};
       }
    }
       }
    }
             }              }
           }             } 
         }          }
Line 1755  sub dump { Line 1981  sub dump {
   
 # --------------------------------------------------------------- currentdump  # --------------------------------------------------------------- currentdump
 sub currentdump {  sub currentdump {
    my ($sname,$sdom,$courseid)=@_;     my ($courseid,$sdom,$sname)=@_;
    $courseid = $ENV{'request.course.id'} if (! defined($courseid));     $courseid = $ENV{'request.course.id'} if (! defined($courseid));
    $sdom     = $ENV{'user.domain'}       if (! defined($sdom));     $sdom     = $ENV{'user.domain'}       if (! defined($sdom));
    $sname    = $ENV{'user.name'}         if (! defined($sname));     $sname    = $ENV{'user.name'}         if (! defined($sname));
Line 1858  sub eget { Line 2084  sub eget {
    return %returnhash;     return %returnhash;
 }  }
   
   # ---------------------------------------------- Custom access rule evaluation
   
   sub customaccess {
       my ($priv,$uri)=@_;
       my ($urole,$urealm)=split(/\./,$ENV{'request.role'});
       $urealm=~s/^\W//;
       my ($udom,$ucrs,$usec)=split(/\//,$urealm);
       my $access=0;
       foreach (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) {
    my ($effect,$realm,$role)=split(/\:/,$_);
           if ($role) {
      if ($role ne $urole) { next; }
           }
           foreach (split(/\s*\,\s*/,$realm)) {
               my ($tdom,$tcrs,$tsec)=split(/\_/,$_);
               if ($tdom) {
    if ($tdom ne $udom) { next; }
               }
               if ($tcrs) {
    if ($tcrs ne $ucrs) { next; }
               }
               if ($tsec) {
    if ($tsec ne $usec) { next; }
               }
               $access=($effect eq 'allow');
               last;
           }
       }
       return $access;
   }
   
 # ------------------------------------------------- Check for a user privilege  # ------------------------------------------------- Check for a user privilege
   
 sub allowed {  sub allowed {
Line 1896  sub allowed { Line 2153  sub allowed {
             # Library role, so allow browsing of resources in this domain.              # Library role, so allow browsing of resources in this domain.
             return 'F';              return 'F';
         }          }
           if ($copyright eq 'custom') {
       unless (&customaccess($priv,$uri)) { return ''; }
           }
     }      }
     # Domain coordinator is trying to create a course      # Domain coordinator is trying to create a course
     if (($priv eq 'ccc') && ($ENV{'request.role'} =~ /^dc\./)) {      if (($priv eq 'ccc') && ($ENV{'request.role'} =~ /^dc\./)) {
Line 2113  sub allowed { Line 2373  sub allowed {
   
    if ($thisallowed=~/R/) {     if ($thisallowed=~/R/) {
        my $rolecode=(split(/\./,$ENV{'request.role'}))[0];         my $rolecode=(split(/\./,$ENV{'request.role'}))[0];
        my $filename=$perlvar{'lonDocRoot'}.'/res/'.$uri.'.meta';         if (&metadata($uri,'roledeny')=~/$rolecode/) {
        if (-e $filename) {    &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},
            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);                      'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
            return '';            return '';
   
            }  
        }         }
    }     }
   
Line 2157  sub is_on_map { Line 2407  sub is_on_map {
     my $filename=$uriparts[$#uriparts];      my $filename=$uriparts[$#uriparts];
     my $pathname=$uri;      my $pathname=$uri;
     $pathname=~s|/\Q$filename\E$||;      $pathname=~s|/\Q$filename\E$||;
       $pathname=~s/^adm\/wrapper\///;    
     #Trying to find the conditional for the file      #Trying to find the conditional for the file
     my $match=($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~      my $match=($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~
        /\&\Q$filename\E\:([\d\|]+)\&/);         /\&\Q$filename\E\:([\d\|]+)\&/);
Line 2330  sub assignrole { Line 2581  sub assignrole {
            $command.='_0_'.$start;             $command.='_0_'.$start;
         }          }
     }      }
     return &reply($command,&homeserver($uname,$udom));      my $answer=&reply($command,&homeserver($uname,$udom));
       if ($answer eq 'ok') {
    &userrolelog($mrole,$uname,$udom,$url,$start,$end);
       }
       return $answer;
 }  }
   
 # -------------------------------------------------- Modify user authentication  # -------------------------------------------------- Modify user authentication
Line 2818  sub EXT { Line 3073  sub EXT {
     my ($varname,$symbparm,$udom,$uname,)=@_;      my ($varname,$symbparm,$udom,$uname,)=@_;
   
     unless ($varname) { return ''; }      unless ($varname) { return ''; }
   
     #get real user name/domain, courseid and symb      #get real user name/domain, courseid and symb
     my $courseid;      my $courseid;
     if (!($uname && $udom)) {      if (!($uname && $udom)) {
Line 2842  sub EXT { Line 3096  sub EXT {
     if ($realm eq 'user') {      if ($realm eq 'user') {
 # --------------------------------------------------------------- user.resource  # --------------------------------------------------------------- user.resource
  if ($space eq 'resource') {   if ($space eq 'resource') {
     my %restored=&restore(undef,undef,$udom,$uname);      if (defined($Apache::lonhomework::parsing_a_problem)) {
             return $restored{$qualifierrest};   return $Apache::lonhomework::history{$qualifierrest};
       } else {
    my %restored=&restore($symbparm,$courseid,$udom,$uname);
    return $restored{$qualifierrest};
       }
 # ----------------------------------------------------------------- user.access  # ----------------------------------------------------------------- user.access
         } elsif ($space eq 'access') {          } elsif ($space eq 'access') {
     # FIXME - not supporting calls for a specific user      # FIXME - not supporting calls for a specific user
Line 2878  sub EXT { Line 3136  sub EXT {
             return $uname;              return $uname;
 # ---------------------------------------------------- Any other user namespace  # ---------------------------------------------------- Any other user namespace
         } else {          } else {
             my $item=($rest)?$qualifier.'.'.$rest:$qualifier;              my %reply=&get($space,[$qualifierrest],$udom,$uname);
             my %reply=&get($space,[$item]);              return $reply{$qualifierrest};
             return $reply{$item};  
         }          }
     } elsif ($realm eq 'query') {      } elsif ($realm eq 'query') {
 # ---------------------------------------------- pull stuff out of query string  # ---------------------------------------------- pull stuff out of query string
Line 2997  sub EXT { Line 3254  sub EXT {
   
 # ------------------------------------------------------------------ Cascade up  # ------------------------------------------------------------------ Cascade up
  unless ($space eq '0') {   unless ($space eq '0') {
     my ($part,$id)=split(/\_/,$space);      my @parts=split(/_/,$space);
     if ($id) {      my $id=pop(@parts);
  my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,      my $part=join('_',@parts);
      $symbparm,$udom,$uname);      if ($part eq '') { $part='0'; }
  if (defined($partgeneral)) { return $partgeneral; }      my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,
     } else {   $symbparm,$udom,$uname);
  my $resourcegeneral=&EXT('resource.0.'.$qualifierrest,      if (defined($partgeneral)) { return $partgeneral; }
  $symbparm,$udom,$uname);  
  if (defined($resourcegeneral)) { return $resourcegeneral; }  
     }  
  }   }
   
 # ---------------------------------------------------- Any other user namespace  # ---------------------------------------------------- Any other user namespace
Line 3028  sub EXT { Line 3282  sub EXT {
     return '';      return '';
 }  }
   
   sub add_prefix_and_part {
       my ($prefix,$part)=@_;
       my $keyroot;
       if (defined($prefix) && $prefix !~ /^__/) {
    # prefix that has a part already
    $keyroot=$prefix;
       } elsif (defined($prefix)) {
    # prefix that is missing a part
    if (defined($part)) { $keyroot='_'.$part.substr($prefix,1); }
       } else {
    # no prefix at all
    if (defined($part)) { $keyroot='_'.$part; }
       }
       return $keyroot;
   }
   
 # ---------------------------------------------------------------- Get metadata  # ---------------------------------------------------------------- Get metadata
   
 sub metadata {  sub metadata {
Line 3056  sub metadata { Line 3326  sub metadata {
         }          }
         my %metathesekeys=();          my %metathesekeys=();
         unless ($filename=~/\.meta$/) { $filename.='.meta'; }          unless ($filename=~/\.meta$/) { $filename.='.meta'; }
  my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename);   my $metastring=&getfile(&filelocation('',&clutter($filename)));
         my $parser=HTML::LCParser->new(\$metastring);          my $parser=HTML::LCParser->new(\$metastring);
         my $token;          my $token;
         undef %metathesekeys;          undef %metathesekeys;
         while ($token=$parser->get_token) {          while ($token=$parser->get_token) {
            if ($token->[0] eq 'S') {      if ($token->[0] eq 'S') {
      if (defined($token->[2]->{'package'})) {   if (defined($token->[2]->{'package'})) {
 #  #
 # This is a package - get package info  # This is a package - get package info
 #  #
       my $package=$token->[2]->{'package'};      my $package=$token->[2]->{'package'};
       my $keyroot='';      my $keyroot=&add_prefix_and_part($prefix,$token->[2]->{'part'});
               if ($prefix) {      if (defined($token->[2]->{'id'})) { 
   $keyroot.=$prefix;   $keyroot.='_'.$token->[2]->{'id'}; 
               } else {      }
                 if (defined($token->[2]->{'part'})) {       if ($metacache{$uri.':packages'}) {
                    $keyroot.='_'.$token->[2]->{'part'};    $metacache{$uri.':packages'}.=','.$package.$keyroot;
         }      } else {
       }   $metacache{$uri.':packages'}=$package.$keyroot;
               if (defined($token->[2]->{'id'})) {       }
                  $keyroot.='_'.$token->[2]->{'id'};       foreach (keys %packagetab) {
       }   if ($_=~/^$package\&/) {
               if ($metacache{$uri.':packages'}) {      my ($pack,$name,$subp)=split(/\&/,$_);
                  $metacache{$uri.':packages'}.=','.$package.$keyroot;      my $value=$packagetab{$_};
               } else {      my $part=$keyroot;
                  $metacache{$uri.':packages'}=$package.$keyroot;      $part=~s/^\_//;
       }      if ($subp eq 'display') {
               foreach (keys %packagetab) {   $value.=' [Part: '.$part.']';
   if ($_=~/^$package\&/) {      }
       my ($pack,$name,$subp)=split(/\&/,$_);      my $unikey='parameter'.$keyroot.'_'.$name;
                       my $value=$packagetab{$_};      if ($subp eq 'default') { $unikey='parameter_0_'.$name; }
       my $part=$keyroot;      $metathesekeys{$unikey}=1;
                       $part=~s/^\_//;      $metacache{$uri.':'.$unikey.'.part'}=$part;
                       if ($subp eq 'display') {      unless (defined($metacache{$uri.':'.$unikey.'.'.$subp})) {
   $value.=' [Part: '.$part.']';   $metacache{$uri.':'.$unikey.'.'.$subp}=$value;
                       }      }
                       my $unikey='parameter'.$keyroot.'_'.$name;      if (defined($metacache{$uri.':'.$unikey.'.default'})) {
                       $metathesekeys{$unikey}=1;   $metacache{$uri.':'.$unikey}=
                       $metacache{$uri.':'.$unikey.'.part'}=$part;      $metacache{$uri.':'.$unikey.'.default'}
                       unless (defined($metacache{$uri.':'.$unikey.'.'.$subp})) {   }
   $metacache{$uri.':'.$unikey.'.'.$subp}=$value;   }
       }      }
       if (defined($metacache{$uri.':'.$unikey.'.default'})) {   } else {
   $metacache{$uri.':'.$unikey}=  
      $metacache{$uri.':'.$unikey.'.default'}  
       }  
                   }  
               }  
              } else {  
 #  #
 # This is not a package - some other kind of start tag  # This is not a package - some other kind of start tag
 #   #
               my $entry=$token->[1];      my $entry=$token->[1];
               my $unikey;      my $unikey;
               if ($entry eq 'import') {      if ($entry eq 'import') {
                  $unikey='';   $unikey='';
               } else {      } else {
                  $unikey=$entry;   $unikey=$entry;
       }      }
               if ($prefix) {      $unikey.=&add_prefix_and_part($prefix,$token->[2]->{'part'});
   $unikey.=$prefix;  
               } else {      if (defined($token->[2]->{'id'})) { 
                 if (defined($token->[2]->{'part'})) {    $unikey.='_'.$token->[2]->{'id'}; 
                    $unikey.='_'.$token->[2]->{'part'};       }
         }  
       }  
               if (defined($token->[2]->{'id'})) {   
                  $unikey.='_'.$token->[2]->{'id'};   
       }  
   
              if ($entry eq 'import') {      if ($entry eq 'import') {
 #  #
 # Importing a library here  # Importing a library here
 #                  #
                  if ($depthcount<20) {   if ($depthcount<20) {
      my $location=$parser->get_text('/import');      my $location=$parser->get_text('/import');
      my $dir=$filename;      my $dir=$filename;
      $dir=~s|[^/]*$||;      $dir=~s|[^/]*$||;
      $location=&filelocation($dir,$location);      $location=&filelocation($dir,$location);
      foreach (sort(split(/\,/,&metadata($uri,'keys',      foreach (sort(split(/\,/,&metadata($uri,'keys',
  $location,$unikey,         $location,$unikey,
  $depthcount+1)))) {         $depthcount+1)))) {
                          $metathesekeys{$_}=1;   $metathesekeys{$_}=1;
      }      }
  }   }
              } else {       } else { 
   
               if (defined($token->[2]->{'name'})) {    if (defined($token->[2]->{'name'})) { 
                  $unikey.='_'.$token->[2]->{'name'};       $unikey.='_'.$token->[2]->{'name'}; 
       }   }
               $metathesekeys{$unikey}=1;   $metathesekeys{$unikey}=1;
               foreach (@{$token->[3]}) {   foreach (@{$token->[3]}) {
   $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};      $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};
               }   }
       my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));   my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));
       my $default=$metacache{$uri.':'.$unikey.'.default'};   my $default=$metacache{$uri.':'.$unikey.'.default'};
       if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) {   if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) {
   # only ws inside the tag, and not in default, so use default   # only ws inside the tag, and not in default, so use default
                   # as value   # as value
   $metacache{$uri.':'.$unikey}=$default;      $metacache{$uri.':'.$unikey}=$default;
       } else {   } else {
   # either something interesting inside the tag or default    # either something interesting inside the tag or default
                   # uninteresting                    # uninteresting
   $metacache{$uri.':'.$unikey}=$internaltext;      $metacache{$uri.':'.$unikey}=$internaltext;
       }   }
 # end of not-a-package not-a-library import  # end of not-a-package not-a-library import
    }      }
 # end of not-a-package start tag  # end of not-a-package start tag
   }   }
 # the next is the end of "start tag"  # the next is the end of "start tag"
  }      }
        }   }
        $metacache{$uri.':keys'}=join(',',keys %metathesekeys);  # are there custom rights to evaluate
    if ($metacache{$uri.':copyright'} eq 'custom') {
   
       #
       # Importing a rights file here
       #
       unless ($depthcount) {
    my $location=$metacache{$uri.':customdistributionfile'};
    my $dir=$filename;
    $dir=~s|[^/]*$||;
    $location=&filelocation($dir,$location);
    foreach (sort(split(/\,/,&metadata($uri,'keys',
      $location,'_rights',
      $depthcount+1)))) {
       $metathesekeys{$_}=1;
    }
       }
    }
    $metacache{$uri.':keys'}=join(',',keys %metathesekeys);
  &metadata_generate_part0(\%metathesekeys,\%metacache,$uri);   &metadata_generate_part0(\%metathesekeys,\%metacache,$uri);
        $metacache{$uri.':allpossiblekeys'}=join(',',keys %metathesekeys);   $metacache{$uri.':allpossiblekeys'}=join(',',keys %metathesekeys);
        $metacache{$uri.':cachedtimestamp'}=time;   $metacache{$uri.':cachedtimestamp'}=time;
 # this is the end of "was not already recently cached  # this is the end of "was not already recently cached
     }      }
     return $metacache{$uri.':'.$what};      return $metacache{$uri.':'.$what};
Line 3670  BEGIN { Line 3947  BEGIN {
     }      }
 }  }
   
   # ------------- set up temporary directory
   {
       $tmpdir = $perlvar{'lonDaemons'}.'/tmp/';
   
   }
   
 %metacache=();  %metacache=();
   
 $processmarker='_'.time.'_'.$perlvar{'lonHostID'};  $processmarker='_'.time.'_'.$perlvar{'lonHostID'};
Removed from v.1.327  
changed lines
  Added in v.1.355

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