[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.62 and 1.74

version 1.62, 2000/11/14 15:58:39 version 1.74, 2000/11/29 12:27:49
Line 52 Line 52
 #                          from the directory dir  #                          from the directory dir
 # hreflocation(dir,file) : same as filelocation, but for hrefs  # hreflocation(dir,file) : same as filelocation, but for hrefs
 # log(domain,user,home,msg) : write to permanent log for user  # log(domain,user,home,msg) : write to permanent log for user
   # usection(domain,user,courseid) : output of section name/number or '' for
   #                                  "not in course" and '-1' for "no section"
   # userenvironment(domain,user,what) : puts out any environment parameter 
   #                                     for a user
   # idput(domain,hash) : writes IDs for users from hash (name=>id,name=>id)
   # idget(domain,array): returns hash with usernames (id=>name,id=>name) for
   #                      an array of IDs
   # idrget(domain,array): returns hash with IDs for usernames (name=>id,...) for
   #                       an array of names
   # metadata(file,entry): returns the metadata entry for a file. entry='keys'
   #                       returns a comma separated list of keys
 #  #
 # 6/1/99,6/2,6/10,6/11,6/12,6/14,6/26,6/28,6/29,6/30,  # 6/1/99,6/2,6/10,6/11,6/12,6/14,6/26,6/28,6/29,6/30,
 # 7/1,7/2,7/9,7/10,7/12,7/14,7/15,7/19,  # 7/1,7/2,7/9,7/10,7/12,7/14,7/15,7/19,
Line 67 Line 78
 # 10/04 Gerd Kortemeyer  # 10/04 Gerd Kortemeyer
 # 10/04 Guy Albertelli  # 10/04 Guy Albertelli
 # 10/06,10/09,10/10,10/11,10/14,10/20,10/23,10/25,10/26,10/27,10/28,10/29,   # 10/06,10/09,10/10,10/11,10/14,10/20,10/23,10/25,10/26,10/27,10/28,10/29, 
 # 10/30,10/31,11/2,11/14 Gerd Kortemeyer  # 10/30,10/31,
   # 11/2,11/14,11/15,11/16,11/20,11/21,11/22,11/25,11/27 Gerd Kortemeyer
   
 package Apache::lonnet;  package Apache::lonnet;
   
Line 76  use Apache::File; Line 88  use Apache::File;
 use LWP::UserAgent();  use LWP::UserAgent();
 use HTTP::Headers;  use HTTP::Headers;
 use vars   use vars 
 qw(%perlvar %hostname %homecache %spareid %hostdom %libserv %pr %prp %fe %fd $readit);  qw(%perlvar %hostname %homecache %spareid %hostdom %libserv %pr %prp %fe %fd $readit %metacache);
 use IO::Socket;  use IO::Socket;
 use GDBM_File;  use GDBM_File;
 use Apache::Constants qw(:common :http);  use Apache::Constants qw(:common :http);
   use HTML::TokeParser;
   
 # --------------------------------------------------------------------- Logging  # --------------------------------------------------------------------- Logging
   
Line 122  sub reply { Line 135  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 357  sub homeserver { Line 369  sub homeserver {
     return 'no_host';      return 'no_host';
 }  }
   
   # ------------------------------------- Find the usernames behind a list of IDs
   
   sub idget {
       my ($udom,@ids)=@_;
       my %returnhash=();
       
       my $tryserver;
       foreach $tryserver (keys %libserv) {
          if ($hostdom{$tryserver} eq $udom) {
     my $idlist=join('&',@ids);
             $idlist=~tr/A-Z/a-z/; 
     my $reply=&reply("idget:$udom:".$idlist,$tryserver);
             my @answer=();
             if ($reply ne 'con_lost') {
         @answer=split(/\&/,$reply);
             }                    ;
             my $i;
             for ($i=0;$i<=$#ids;$i++) {
                 if ($answer[$i]) {
     $returnhash{$ids[$i]}=$answer[$i];
                 } 
             }
          }
       }    
       return %returnhash;
   }
   
   # ------------------------------------- Find the IDs behind a list of usernames
   
   sub idrget {
       my ($udom,@unames)=@_;
       my %returnhash=();
       map {
           $returnhash{$_}=(&userenvironment($udom,$_,'id'))[1];
       } @unames;
       return %returnhash;
   }
   
   # ------------------------------- Store away a list of names and associated IDs
   
   sub idput {
       my ($udom,%ids)=@_;
       my %servers=();
       map {
           my $uhom=&homeserver($_,$udom);
           if ($uhom ne 'no_host') {
               my $id=&escape($ids{$_});
               $id=~tr/A-Z/a-z/;
               my $unam=&escape($_);
       if ($servers{$uhom}) {
    $servers{$uhom}.='&'.$id.'='.$unam;
               } else {
                   $servers{$uhom}=$id.'='.$unam;
               }
               &critical('put:'.$udom.':'.$unam.':environment:id='.$id,$uhom);
           }
       } keys %ids;
       map {
           &critical('idput:'.$udom.':'.$servers{$_},$_);
       } keys %servers;
   }
   
   # ------------------------------------- Find the section of student in a course
   
   sub usection {
       my ($udom,$unam,$courseid)=@_;
       $courseid=~s/\_/\//g;
       $courseid=~s/^(\w)/\/$1/;
       map {
           my ($key,$value)=split(/\=/,$_);
           $key=&unescape($key);
           if ($key=~/^$courseid(?:\/)*(\w+)*\_st$/) {
               my $section=$1;
               if ($key eq $courseid.'_st') { $section=''; }
       my ($dummy,$end,$start)=split(/\_/,&unescape($value));
               my $now=time;
               my $notactive=0;
               if ($start) {
    if ($now<$start) { $notactive=1; }
               }
               if ($end) {
                   if ($now>$end) { $notactive=1; }
               } 
               unless ($notactive) { return $section; }
           }
       } split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',
                           &homeserver($unam,$udom)));
       return '-1';
   }
   
   # ------------------------------------- Read an entry from a user's environment
   
   sub userenvironment {
       my ($udom,$unam,@what)=@_;
       my %returnhash=();
       my @answer=split(/\&/,
                   &reply('get:'.$udom.':'.$unam.':environment:'.join('&',@what),
                         &homeserver($unam,$udom)));
       my $i;
       for ($i=0;$i<=$#what;$i++) {
    $returnhash{$what[$i]}=&unescape($answer[$i]);
       }
       return %returnhash;
   }
   
 # ----------------------------- Subscribe to a resource, return URL if possible  # ----------------------------- Subscribe to a resource, return URL if possible
   
 sub subscribe {  sub subscribe {
Line 369  sub subscribe { Line 486  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 380  sub repcopy { Line 500  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 774  sub allowed { Line 894  sub allowed {
     }      }
   
 # Course: uri itself is a course  # Course: uri itself is a course
       my $courseuri=$uri;
     if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$uri}      $courseuri=~s/\_(\d)/\/$1/;
       if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseuri}
        =~/$priv\&([^\:]*)/) {         =~/$priv\&([^\:]*)/) {
        $thisallowed.=$1;         $thisallowed.=$1;
     }      }
Line 1028  sub fileembstyle { Line 1149  sub fileembstyle {
   
 # ------------------------------------------------------------ Description Text  # ------------------------------------------------------------ Description Text
   
 sub filedecription {  sub filedescription {
     my $ending=shift;      my $ending=shift;
     return $fd{$ending};      return $fd{$ending};
 }  }
Line 1191  sub condval { Line 1312  sub condval {
   
 sub EXT {  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 1255  sub EXT { Line 1377  sub EXT {
     } elsif ($realm eq 'resource') {      } elsif ($realm eq 'resource') {
       if ($ENV{'request.course.id'}) {        if ($ENV{'request.course.id'}) {
 # ----------------------------------------------------- Cascading lookup scheme  # ----------------------------------------------------- Cascading lookup scheme
        my $reslevel=         my $symbp=&symbread();
     $ENV{'request.course.id'}.'.'.&symbread().'.'.$spacequalifierrest;         my $mapp=(split(/\_\_\_/,$symbp))[0];
   
          my $symbparm=$symbp.'.'.$spacequalifierrest;
          my $mapparm=$mapp.'___(all).'.$spacequalifierrest;
   
        my $seclevel=         my $seclevel=
             $ENV{'request.course.id'}.'.'.              $ENV{'request.course.id'}.'.['.
  $ENV{'request.course.sec'}.'.'.$spacequalifierrest;   $ENV{'request.course.sec'}.'].'.$spacequalifierrest;
          my $seclevelr=
               $ENV{'request.course.id'}.'.['.
    $ENV{'request.course.sec'}.'].'.$symbparm;
          my $seclevelm=
               $ENV{'request.course.id'}.'.['.
    $ENV{'request.course.sec'}.'].'.$mapparm;
   
        my $courselevel=         my $courselevel=
             $ENV{'request.course.id'}.'.'.$spacequalifierrest;              $ENV{'request.course.id'}.'.'.$spacequalifierrest;
          my $courselevelr=
               $ENV{'request.course.id'}.'.'.$symbparm;
          my $courselevelm=
               $ENV{'request.course.id'}.'.'.$mapparm;
   
   
 # ----------------------------------------------------------- first, check user  # ----------------------------------------------------------- first, check user
        my %resourcedata=get('resourcedata',($reslevel,$seclevel,$courselevel));        my %resourcedata=get('resourcedata',
        if ($resourcedata{$reslevel}) { return $resourcedata{$reslevel}; }                             ($courselevelr,$courselevelm,$courselevel));
        if ($resourcedata{$seclevel}) { return $resourcedata{$seclevel}; }        if ($resourcedata{$courselevelr}!~/^error\:/) {
   
          if ($resourcedata{$courselevelr}) { 
             return $resourcedata{$courselevelr}; }
          if ($resourcedata{$courselevelm}) { 
             return $resourcedata{$courselevelm}; }
        if ($resourcedata{$courselevel}) { return $resourcedata{$courselevel}; }         if ($resourcedata{$courselevel}) { return $resourcedata{$courselevel}; }
   
         }
 # -------------------------------------------------------- second, check course  # -------------------------------------------------------- second, check course
         my $section='';          my $section='';
         if ($ENV{'request.course.sec'}) {          if ($ENV{'request.course.sec'}) {
Line 1278  sub EXT { Line 1422  sub EXT {
               $ENV{'course.'.$ENV{'request.course.id'}.$section.'.domain'}.':'.                $ENV{'course.'.$ENV{'request.course.id'}.$section.'.domain'}.':'.
               $ENV{'course.'.$ENV{'request.course.id'}.$section.'.num'}.                $ENV{'course.'.$ENV{'request.course.id'}.$section.'.num'}.
               ':resourcedata:'.                ':resourcedata:'.
               escape($reslevel).':'.escape($seclevel).':'.escape($courselevel),   escape($seclevelr).':'.escape($seclevelm).':'.escape($seclevel).':'.
    escape($courselevelr).':'.escape($courselevelm).':'.escape($courselevel),
    $ENV{'course.'.$ENV{'request.course.id'}.$section.'.home'});     $ENV{'course.'.$ENV{'request.course.id'}.$section.'.home'});
         if ($reply!~/^error\:/) {
         map {          map {
            my ($name,$value)=split(/\=/,$_);             my ($name,$value)=split(/\=/,$_);
            $resourcedata{unescape($name)}=unescape($value);               $resourcedata{unescape($name)}=unescape($value);  
         } split(/\&/,$reply);          } split(/\&/,$reply);
        if ($resourcedata{$reslevel}) { return $resourcedata{$reslevel}; }  
          if ($resourcedata{$seclevelr}) { return $resourcedata{$seclevelr}; }
          if ($resourcedata{$seclevelm}) { return $resourcedata{$seclevelm}; }  
        if ($resourcedata{$seclevel}) { return $resourcedata{$seclevel}; }         if ($resourcedata{$seclevel}) { return $resourcedata{$seclevel}; }
   
          if ($resourcedata{$courselevelr}) { 
             return $resourcedata{$courselevelr}; }
          if ($resourcedata{$courselevelm}) { 
             return $resourcedata{$courselevelm}; }
        if ($resourcedata{$courselevel}) { return $resourcedata{$courselevel}; }         if ($resourcedata{$courselevel}) { return $resourcedata{$courselevel}; }
   
         }
   
 # ------------------------------------------------------ third, check map parms  # ------------------------------------------------------ third, check map parms
                 my %parmhash=();
        if ($ENV{'resource.parms.'.$reslevel}) {         my $thisparm='';       
    return $ENV{'resource.parms.'.$reslevel};         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  # --------------------------------------------- last, look in resource metadata
  my $uri=&declutter($ENV{'request.filename'});  
         my $filename=$perlvar{'lonDocRoot'}.'/res/'.$ENV.'.meta';        my $metadata=&metadata($ENV{'request.filename'},$spacequalifierrest);
         if (-e $filename) {        if ($metadata) { return $metadata; }
             my @content;  
             {  
              my $fh=Apache::File->new($filename);  
              @content=<$fh>;  
             }  
             if (join('',@content)=~  
                  /\<$space[^\>]*\>([^\<]*)\<\/$space\>/) {  
         return $1;  
      }  
         }  
 # ---------------------------------------------------- Any other user namespace  # ---------------------------------------------------- Any other user namespace
     } elsif ($realm eq 'environment') {      } elsif ($realm eq 'environment') {
 # ----------------------------------------------------------------- environment  # ----------------------------------------------------------------- environment
Line 1322  sub EXT { Line 1472  sub EXT {
     return '';      return '';
 }  }
   
 # ---------------------------------------- Append resource parms to environment  # ---------------------------------------------------------------- Get metadata
   
 sub appendparms {  sub metadata {
     my ($symb,$parms)=@_;      my ($uri,$what)=@_;
     my %storehash=();      $uri=&declutter($uri);
     my $prefix='resource.parms.'.$ENV{'request.course.id'}.'.'.$symb;      my $filename=$uri;
     map {      $uri=~s/\.meta$//;
  my ($typename,$value)=split(/\=/,$_);      unless ($metacache{$uri.':keys'}) {
         my ($type,$name)=split(/\:/,$typename);          unless ($filename=~/\.meta$/) { $filename.='.meta'; }
         $storehash{$prefix.'.'.unescape($name)}=unescape($value);   my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename);
  $storehash{$prefix.'.'.unescape($name).'.type'}=unescape($type);          my $parser=HTML::TokeParser->new(\$metastring);
     } split(/\&/,$parms);          my $token;
     &appenv(%storehash);          while ($token=$parser->get_token) {
              if ($token->[0] eq 'S') {
         my $entry=$token->[1];
                 my $unikey=$entry;
                 if (defined($token->[2]->{'part'})) { 
                    $unikey.='_'.$token->[2]->{'part'}; 
         }
                 if (defined($token->[2]->{'name'})) { 
                    $unikey.='_'.$token->[2]->{'name'}; 
         }
                 if ($metacache{$uri.':keys'}) {
                    $metacache{$uri.':keys'}.=','.$unikey;
                 } else {
                    $metacache{$uri.':keys'}=$unikey;
         }
                 map {
     $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};
                 } @{$token->[3]};
                 $metacache{$uri.':'.$unikey}=$parser->get_text('/'.$entry);
             }
          }
       }
       return $metacache{$uri.':'.$what};
 }  }
   
 # ------------------------------------------------- Update symbolic store links  # ------------------------------------------------- Update symbolic store links
Line 1368  sub symbread { Line 1540  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 1390  sub symbread { Line 1561  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);
                  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 1407  sub symbread { Line 1580  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 1420  sub symbread { Line 1592  sub symbread {
            }              } 
         }          }
         if ($syval) {          if ($syval) {
            if ($parms) {  
        &appendparms($syval.'___'.$thisfn,$parms);  
            }  
            return $syval.'___'.$thisfn;              return $syval.'___'.$thisfn; 
         }          }
     }      }
Line 1605  if ($readit ne 'done') { Line 1774  if ($readit ne 'done') {
     }      }
 }  }
   
   %metacache=();
   
 $readit='done';  $readit='done';
 &logthis('<font color=yellow>INFO: Read configuration</font>');  &logthis('<font color=yellow>INFO: Read configuration</font>');
Removed from v.1.62  
changed lines
  Added in v.1.74

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