[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.134 and 1.151

version 1.134, 2001/07/27 20:17:14 version 1.151, 2001/08/17 19:50:28
Line 121 Line 121
 # 5/26,5/28 Gerd Kortemeyer  # 5/26,5/28 Gerd Kortemeyer
 # 5/30 H. K. Ng  # 5/30 H. K. Ng
 # 6/1 Gerd Kortemeyer  # 6/1 Gerd Kortemeyer
 #  # July Guy Albertelli
   # 8/4,8/7,8/8,8/9,8/11,8/16,8/17 Gerd Kortemeyer
   
 package Apache::lonnet;  package Apache::lonnet;
   
Line 130  use Apache::File; Line 131  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 %metacache);  qw(%perlvar %hostname %homecache %hostip %spareid %hostdom %libserv %pr %prp %fe %fd $readit %metacache %packagetab);
 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 275  sub appenv { Line 276  sub appenv {
     map {      map {
  if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) {   if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) {
             &logthis("<font color=blue>WARNING: ".              &logthis("<font color=blue>WARNING: ".
                 "Attempt to modify environment ".$_." to ".$newenv{$_});                  "Attempt to modify environment ".$_." to ".$newenv{$_}
                   .'</font>');
     delete($newenv{$_});      delete($newenv{$_});
         } else {          } else {
             $ENV{$_}=$newenv{$_};              $ENV{$_}=$newenv{$_};
Line 658  sub log { Line 660  sub log {
     return critical("log:$dom:$nam:$what",$hom);      return critical("log:$dom:$nam:$what",$hom);
 }  }
   
   # ----------------------------------------------------------- Check out an item
   
   sub checkout {
       my ($symb,$tuname,$tudom,$tcrsid)=@_;
       my $now=time;
       my $lonhost=$perlvar{'lonHostID'};
       my $infostr=&escape(
                    $tuname.'&'.
                    $tudom.'&'.
                    $tcrsid.'&'.
                    $symb.'&'.
    $now.'&'.$ENV{'REMOTE_ADDR'});
       my $token=&reply('tmpput:'.$infostr,$lonhost);
       if ($token=~/^error\:/) { 
           &logthis("<font color=blue>WARNING: ".
                   "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.
                    "</font>");
           return ''; 
       }
   
       $token=~s/^(\d+)\_.*\_(\d+)$/$1\*$2\*$lonhost/;
       $token=~tr/a-z/A-Z/;
   
       my %infohash=('outtoken' => $token,
                     'checkouttime' => $now,
                     'outremote' => $ENV{'REMOTE_ADDR'});
   
       unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
          return '';
       } else {
           &logthis("<font color=blue>WARNING: ".
                   "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.
                    "</font>");
       }    
   
       if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
                            &escape('Checkout '.$infostr.' - '.
                                                    $token)) ne 'ok') {
    return '';
       } else {
           &logthis("<font color=blue>WARNING: ".
                   "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.
                    "</font>");
       }
       return $token;
   }
   
   # ------------------------------------------------------------ Check in an item
   
   sub checkin {
       my $token=shift;
       my $now=time;
       my ($ta,$tb,$lonhost)=split(/\*/,$token);
       $lonhost=~tr/A-Z/a-z/;
       my $dtoken=$ta.'_'.$hostip{$lonhost}.'_'.$tb;
       $dtoken=~s/\W/\_/g;
       my ($tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
                    split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));
   
       my %infohash=('intoken' => $token,
                     'checkintime' => $now,
                     'inremote' => $ENV{'REMOTE_ADDR'});
   
       unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
          return '';
       }    
   
       if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
                            &escape('Checkin - '.$token)) ne 'ok') {
    return '';
       }
   
       return ($symb,$tuname,$tudom,$tcrsid);    
   }
   
 # --------------------------------------------- Set Expire Date for Spreadsheet  # --------------------------------------------- Set Expire Date for Spreadsheet
   
 sub expirespread {  sub expirespread {
Line 895  sub rolesinit { Line 972  sub rolesinit {
         my $author=0;          my $author=0;
         map {          map {
             %thesepriv=();              %thesepriv=();
             if ($_!~/^st/) { $adv=1; }              if (($_!~/^st/) && ($_!~/^ta/) && ($_!~/^cm/)) { $adv=1; }
             if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; }              if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; }
             map {              map {
                 if ($_ ne '') {                  if ($_ ne '') {
Line 1107  sub allowed { Line 1184  sub allowed {
            }             }
        }         }
                 
        if (($ENV{'HTTP_REFERER'}) && ($checkreferer)) {         if ($checkreferer) {
   my $refuri=$ENV{'HTTP_REFERER'};    my $refuri=$ENV{'httpref.'.$uri};
           $refuri=~s/^http\:\/\/$ENV{'request.host'}//i;  
           $refuri=&declutter($refuri);              unless ($refuri) {
                   map {
       if ($_=~/^httpref\..*\*/) {
    my $pattern=$_;
                           $pattern=~s/\*/\[\^\/\]\+/g;
                           $pattern=~s/\//\\\//g;
                           if ($uri=~/$pattern/) {
       $refuri=$ENV{$_};
                           }
                       }
                   } keys %ENV;
               }
            if ($refuri) { 
           my @uriparts=split(/\//,$refuri);            my @uriparts=split(/\//,$refuri);
           my $filename=$uriparts[$#uriparts];            my $filename=$uriparts[$#uriparts];
           my $pathname=$refuri;            my $pathname=$refuri;
Line 1128  sub allowed { Line 1217  sub allowed {
               }                }
             }              }
           }            }
           }
        }         }
    }     }
   
Line 1673  sub condval { Line 1763  sub condval {
 # --------------------------------------------------------- Value of a Variable  # --------------------------------------------------------- Value of a Variable
   
 sub EXT {  sub EXT {
     my $varname=shift;      my ($varname,$symbparm)=@_;
     unless ($varname) { return ''; }      unless ($varname) { return ''; }
     my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);      my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);
     my $rest;      my $rest;
Line 1734  sub EXT { Line 1824  sub EXT {
                               $spacequalifierrest};                                $spacequalifierrest};
     } elsif ($realm eq 'resource') {      } elsif ($realm eq 'resource') {
        if ($ENV{'request.course.id'}) {         if ($ENV{'request.course.id'}) {
   
   #   print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;
   
   
 # ----------------------------------------------------- Cascading lookup scheme  # ----------------------------------------------------- Cascading lookup scheme
          my $symbp=&symbread();           my $symbp;
            if ($symbparm) {
               $symbp=$symbparm;
    } else {
               $symbp=&symbread();
            }            
          my $mapp=(split(/\_\_\_/,$symbp))[0];           my $mapp=(split(/\_\_\_/,$symbp))[0];
   
          my $symbparm=$symbp.'.'.$spacequalifierrest;           my $symbparm=$symbp.'.'.$spacequalifierrest;
Line 1823  sub EXT { Line 1922  sub EXT {
                                          'parameter_'.$spacequalifierrest);                                           'parameter_'.$spacequalifierrest);
       if ($metadata) { return $metadata; }        if ($metadata) { return $metadata; }
   
   # ------------------------------------------------------------------ Cascade up
   
         unless ($space eq '0') {
             my ($part,$id)=split(/\_/,$space);
             if ($id) {
         my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,
                                      $symbparm);
                 if ($partgeneral) { return $partgeneral; }
             } else {
                 my $resourcegeneral=&EXT('resource.0.'.$qualifierrest,
                                          $symbparm);
                 if ($resourcegeneral) { return $resourcegeneral; }
             }
         }
   
 # ---------------------------------------------------- Any other user namespace  # ---------------------------------------------------- Any other user namespace
     } elsif ($realm eq 'environment') {      } elsif ($realm eq 'environment') {
 # ----------------------------------------------------------------- environment  # ----------------------------------------------------------------- environment
Line 1845  sub metadata { Line 1959  sub metadata {
     my $filename=$uri;      my $filename=$uri;
     $uri=~s/\.meta$//;      $uri=~s/\.meta$//;
     unless ($metacache{$uri.':keys'}) {      unless ($metacache{$uri.':keys'}) {
           my %metathesekeys=();
         unless ($filename=~/\.meta$/) { $filename.='.meta'; }          unless ($filename=~/\.meta$/) { $filename.='.meta'; }
  my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename);   my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename);
         my $parser=HTML::TokeParser->new(\$metastring);          my $parser=HTML::TokeParser->new(\$metastring);
         my $token;          my $token;
           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'})) {
         my $package=$token->[2]->{'package'};
         my $keyroot='';
                 if (defined($token->[2]->{'part'})) { 
                    $keyroot.='_'.$token->[2]->{'part'}; 
         }
                 if (defined($token->[2]->{'id'})) { 
                    $keyroot.='_'.$token->[2]->{'id'}; 
         }
                 if ($metacache{$uri.':packages'}) {
                    $metacache{$uri.':packages'}.=','.$package.$keyroot;
                 } else {
                    $metacache{$uri.':packages'}=$package.$keyroot;
         }
                 map {
     if ($_=~/^$package\&/) {
         my ($pack,$name,$subp)=split(/\&/,$_);
                         my $value=$packagetab{$_};
         my $part=$keyroot;
                         $part=~s/^\_//;
                         if ($subp eq 'display') {
     $value.=' [Part: '.$part.']';
                         }
                         my $unikey='parameter'.$keyroot.'_'.$name;
                         $metathesekeys{$unikey}=1;
                         $metacache{$uri.':'.$unikey.'.part'}=$part;
                         unless 
                          (defined($metacache{$uri.':'.$unikey.'.'.$subp})) {
                            $metacache{$uri.':'.$unikey.'.'.$subp}=$value;
         }
                     }
                 } keys %packagetab;
                } else {
       my $entry=$token->[1];        my $entry=$token->[1];
               my $unikey=$entry;                my $unikey=$entry;
               if (defined($token->[2]->{'part'})) {                 if (defined($token->[2]->{'part'})) { 
                  $unikey.='_'.$token->[2]->{'part'};                    $unikey.='_'.$token->[2]->{'part'}; 
       }        }
                 if (defined($token->[2]->{'id'})) { 
                    $unikey.='_'.$token->[2]->{'id'}; 
         }
               if (defined($token->[2]->{'name'})) {                 if (defined($token->[2]->{'name'})) { 
                  $unikey.='_'.$token->[2]->{'name'};                    $unikey.='_'.$token->[2]->{'name'}; 
       }        }
               if ($metacache{$uri.':keys'}) {                $metathesekeys{$unikey}=1;
                  $metacache{$uri.':keys'}.=','.$unikey;  
               } else {  
                  $metacache{$uri.':keys'}=$unikey;  
       }  
               map {                map {
   $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};    $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};
               } @{$token->[3]};                } @{$token->[3]};
Line 1872  sub metadata { Line 2020  sub metadata {
       ) { $metacache{$uri.':'.$unikey}=        ) { $metacache{$uri.':'.$unikey}=
       $metacache{$uri.':'.$unikey.'.default'};        $metacache{$uri.':'.$unikey.'.default'};
       }        }
           }      }
    }
        }         }
          $metacache{$uri.':keys'}=join(',',keys %metathesekeys);
     }      }
     return $metacache{$uri.':'.$what};      return $metacache{$uri.':'.$what};
 }  }
Line 2117  if ($readit ne 'done') { Line 2267  if ($readit ne 'done') {
        my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);         my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
        $hostname{$id}=$name;         $hostname{$id}=$name;
        $hostdom{$id}=$domain;         $hostdom{$id}=$domain;
          $hostip{$id}=$ip;
        if ($role eq 'library') { $libserv{$id}=$name; }         if ($role eq 'library') { $libserv{$id}=$name; }
     }      }
 }  }
Line 2154  if ($readit ne 'done') { Line 2305  if ($readit ne 'done') {
     }      }
 }  }
   
   # ---------------------------------------------------------- Read package table
   {
       my $config=Apache::File->new("$perlvar{'lonTabDir'}/packages.tab");
   
       while (my $configline=<$config>) {
          chomp($configline);
          my ($short,$plain)=split(/:/,$configline);
          my ($pack,$name)=split(/\&/,$short);
          if ($plain ne '') {
             $packagetab{$pack.'&'.$name.'&name'}=$name; 
             $packagetab{$short}=$plain; 
          }
       }
   }
   
 # ------------------------------------------------------------- Read file types  # ------------------------------------------------------------- Read file types
 {  {
     my $config=Apache::File->new("$perlvar{'lonTabDir'}/filetypes.tab");      my $config=Apache::File->new("$perlvar{'lonTabDir'}/filetypes.tab");
Removed from v.1.134  
changed lines
  Added in v.1.151

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