[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.133 and 1.142

version 1.133, 2001/07/26 21:40:27 version 1.142, 2001/08/07 14:54:51
Line 42 Line 42
 #                      current enviroment  #                      current enviroment
 #  #
 #  #
 # for the next 4 functions udom and uname are optional  # for the next 6 functions udom and uname are optional
 #         if supplied they use udom as the domain and uname  #         if supplied they use udom as the domain and uname
 #         as the username for the function (supply a courseid  #         as the username for the function (supply a courseid
 #         for the uname if you want a course database)  #         for the uname if you want a course database)
Line 57 Line 57
 #                      in from namesp  #                      in from namesp
 # dump(namesp,udom,uname) : dumps the complete namespace into a hash  # dump(namesp,udom,uname) : dumps the complete namespace into a hash
 # del(namesp,array,udom,uname)  : deletes keys out of array from namesp  # del(namesp,array,udom,uname)  : deletes keys out of array from namesp
   # put(namesp,hash,udom,uname)   : stores hash in namesp
   # cput(namesp,hash,udom,uname)  : critical put
 #  #
 #  #
 # put(namesp,hash)   : stores hash in namesp  
 # cput(namesp,hash)  : critical put  
 # ssi(url,hash)      : does a complete request cycle on url to localhost, posts  # ssi(url,hash)      : does a complete request cycle on url to localhost, posts
 #                      hash  #                      hash
 # coursedescription(id) : returns and caches course description for id  # coursedescription(id) : returns and caches course description for id
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 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 %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 895  sub rolesinit { Line 896  sub rolesinit {
         my $author=0;          my $author=0;
         map {          map {
             %thesepriv=();              %thesepriv=();
             if ($_!~/^st/) { $adv=1; }              if (($_!~/^st/) && ($_!~/^ta/)) { $adv=1; }
             if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; }              if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; }
             map {              map {
                 if ($_ ne '') {                  if ($_ ne '') {
Line 980  sub dump { Line 981  sub dump {
 # --------------------------------------------------------------- put interface  # --------------------------------------------------------------- put interface
   
 sub put {  sub put {
    my ($namespace,%storehash)=@_;     my ($namespace,$storehash,$udomain,$uname)=@_;
      if (!$udomain) { $udomain=$ENV{'user.domain'}; }
      if (!$uname) { $uname=$ENV{'user.name'}; }
      my $uhome=&homeserver($uname,$udomain);
    my $items='';     my $items='';
    map {     map {
        $items.=escape($_).'='.escape($storehash{$_}).'&';         $items.=&escape($_).'='.&escape($$storehash{$_}).'&';
    } keys %storehash;     } keys %$storehash;
    $items=~s/\&$//;     $items=~s/\&$//;
    return reply("put:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",     return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
                  $ENV{'user.home'});  
 }  }
   
 # ------------------------------------------------------ critical put interface  # ------------------------------------------------------ critical put interface
   
 sub cput {  sub cput {
    my ($namespace,%storehash)=@_;     my ($namespace,$storehash,$udomain,$uname)=@_;
      if (!$udomain) { $udomain=$ENV{'user.domain'}; }
      if (!$uname) { $uname=$ENV{'user.name'}; }
      my $uhome=&homeserver($uname,$udomain);
    my $items='';     my $items='';
    map {     map {
        $items.=escape($_).'='.escape($storehash{$_}).'&';         $items.=escape($_).'='.escape($$storehash{$_}).'&';
    } keys %storehash;     } keys %$storehash;
    $items=~s/\&$//;     $items=~s/\&$//;
    return critical     return &critical("put:$udomain:$uname:$namespace:$items",$uhome);
            ("put:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",  
                  $ENV{'user.home'});  
 }  }
   
 # -------------------------------------------------------------- eget interface  # -------------------------------------------------------------- eget interface
Line 1432  sub modifyuser { Line 1436  sub modifyuser {
        }         }
     }      }
 # -------------------------------------------------------------- Add names, etc  # -------------------------------------------------------------- Add names, etc
     my $names=&reply('get:'.$udom.':'.$uname.      my %names=&get('environment',
                      ':environment:firstname&middlename&lastname&generation',     ['firstname','middlename','lastname','generation'],
                      $uhome);     $udom,$uname);
     my ($efirst,$emiddle,$elast,$egene)=split(/\&/,$names);      if ($first)  { $names{'firstname'}  = $first; }
     if ($first)  { $efirst  = &escape($first); }      if ($middle) { $names{'middlename'} = $middle; }
     if ($middle) { $emiddle = &escape($middle); }      if ($last)   { $names{'lastname'}   = $last; }
     if ($last)   { $elast   = &escape($last); }      if ($gene)   { $names{'generation'} = $gene; }
     if ($gene)   { $egene   = &escape($gene); }      my $reply = &put('environment', \%names, $udom,$uname);
     my $reply=&reply('put:'.$udom.':'.$uname.      if ($reply ne 'ok') { return 'error: '.$reply; }
            ':environment:firstname='.$efirst.  
                       '&middlename='.$emiddle.  
                         '&lastname='.$elast.  
                       '&generation='.$egene,$uhome);  
     if ($reply ne 'ok') {  
  return 'error: '.$reply;  
     }  
     &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.      &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
              $umode.', '.$first.', '.$middle.', '.               $umode.', '.$first.', '.$middle.', '.
      $last.', '.$gene.' by '.       $last.', '.$gene.' by '.
              $ENV{'user.name'}.' at '.$ENV{'user.domain'});               $ENV{'user.name'}.' at '.$ENV{'user.domain'});
     return 'ok';       return 'ok';
 }  }
   
 # -------------------------------------------------------------- Modify student  # -------------------------------------------------------------- Modify student
Line 1826  sub EXT { Line 1823  sub EXT {
       $metadata=&metadata($ENV{'request.filename'},        $metadata=&metadata($ENV{'request.filename'},
                                          'parameter_'.$spacequalifierrest);                                           'parameter_'.$spacequalifierrest);
       if ($metadata) { return $metadata; }        if ($metadata) { return $metadata; }
         
         $spacequalifierrest=~/[^\_]+$/;
         
         $metadata=&metadata($ENV{'request.filename'},'parameter_0'.$1);
   
         if ($metadata) { return $metadata; }
   
 # ---------------------------------------------------- Any other user namespace  # ---------------------------------------------------- Any other user namespace
     } elsif ($realm eq 'environment') {      } elsif ($realm eq 'environment') {
Line 1849  sub metadata { Line 1852  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{$_};
                         if ($subp eq 'display') {
     my $part=$keyroot;
                             $part=~s/^\_//;
     $value.=' [Part: '.$part.']';
                         }
                         my $unikey='parameter'.$keyroot.'_'.$name;
                         $metathesekeys{$unikey}=1;
                         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 1876  sub metadata { Line 1912  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 2158  if ($readit ne 'done') { Line 2196  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);
          if ($plain ne '') { $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.133  
changed lines
  Added in v.1.142

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