[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.197 and 1.211

version 1.197, 2002/01/04 16:31:41 version 1.211, 2002/05/06 13:46:41
Line 66 Line 66
 # 12/18 Scott Harrison  # 12/18 Scott Harrison
 # 12/21,12/22,12/27,12/28 Gerd Kortemeyer  # 12/21,12/22,12/27,12/28 Gerd Kortemeyer
 # YEAR=2002  # YEAR=2002
 # 1/4 Gerd Kortemeyer  # 1/4,2/4,2/7 Gerd Kortemeyer
 #  #
 ###  ###
   
Line 80  use vars Line 80  use vars
 qw(%perlvar %hostname %homecache %hostip %spareid %hostdom   qw(%perlvar %hostname %homecache %hostip %spareid %hostdom 
    %libserv %pr %prp %metacache %packagetab      %libserv %pr %prp %metacache %packagetab 
    %courselogs %accesshash $processmarker $dumpcount      %courselogs %accesshash $processmarker $dumpcount 
    %coursedombuf %coursehombuf);     %coursedombuf %coursehombuf %courseresdatacache);
 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;  use HTML::LCParser;
 use Fcntl qw(:flock);  use Fcntl qw(:flock);
 my $readit;  my $readit;
   
Line 137  sub subreply { Line 137  sub subreply {
   
 sub reply {  sub reply {
     my ($cmd,$server)=@_;      my ($cmd,$server)=@_;
       unless (defined($hostname{$server})) { return 'no_such_host'; }
     my $answer=subreply($cmd,$server);      my $answer=subreply($cmd,$server);
     if ($answer eq 'con_lost') { $answer=subreply($cmd,$server); }      if ($answer eq 'con_lost') {
          sleep 5; 
          $answer=subreply($cmd,$server);
          if ($answer eq 'con_lost') {
      &logthis("Second attempt con_lost on $server");
              my $peerfile="$perlvar{'lonSockDir'}/$server";
              my $client=IO::Socket::UNIX->new(Peer    =>"$peerfile",
                                               Type    => SOCK_STREAM,
                                               Timeout => 10)
                         or return "con_lost";
              &logthis("Killing socket");
              print $client "close_connection_exit\n";
              sleep 5;
              $answer=subreply($cmd,$server);       
          }   
       }
     if (($answer=~/^refused/) || ($answer=~/^rejected/)) {      if (($answer=~/^refused/) || ($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 348  sub spareserver { Line 364  sub spareserver {
     return $spareserver;      return $spareserver;
 }  }
   
   # --------------------------------------------- Try to change a user's password
   
   sub changepass {
       my ($uname,$udom,$currentpass,$newpass,$server)=@_;
       $currentpass = &escape($currentpass);
       $newpass     = &escape($newpass);
       my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass",
          $server);
       if (! $answer) {
    &logthis("No reply on password change request to $server ".
    "by $uname in domain $udom.");
       } elsif ($answer =~ "^ok") {
           &logthis("$uname in $udom successfully changed their password ".
    "on $server.");
       } elsif ($answer =~ "^pwchange_failure") {
    &logthis("$uname in $udom was unable to change their password ".
    "on $server.  The action was blocked by either lcpasswd ".
    "or pwchange");
       } elsif ($answer =~ "^non_authorized") {
           &logthis("$uname in $udom did not get their password correct when ".
    "attempting to change it on $server.");
       } elsif ($answer =~ "^auth_mode_error") {
           &logthis("$uname in $udom attempted to change their password despite ".
    "not being locally or internally authenticated on $server.");
       } elsif ($answer =~ "^unknown_user") {
           &logthis("$uname in $udom attempted to change their password ".
    "on $server but were unable to because $server is not ".
    "their home server.");
       } elsif ($answer =~ "^refused") {
    &logthis("$server refused to change $uname in $udom password because ".
    "it was sent an unencrypted request to change the password.");
       }
       return $answer;
   }
   
 # ----------------------- Try to determine user's current authentication scheme  # ----------------------- Try to determine user's current authentication scheme
   
 sub queryauthenticate {  sub queryauthenticate {
Line 391  sub queryauthenticate { Line 442  sub queryauthenticate {
 sub authenticate {  sub authenticate {
     my ($uname,$upass,$udom)=@_;      my ($uname,$upass,$udom)=@_;
     $upass=escape($upass);      $upass=escape($upass);
       $uname=~s/\W//g;
     if (($perlvar{'lonRole'} eq 'library') &&       if (($perlvar{'lonRole'} eq 'library') && 
         ($udom eq $perlvar{'lonDefDomain'})) {          ($udom eq $perlvar{'lonDefDomain'})) {
     my $answer=reply("encrypt:auth:$udom:$uname:$upass",$perlvar{'lonHostID'});      my $answer=reply("encrypt:auth:$udom:$uname:$upass",$perlvar{'lonHostID'});
Line 640  sub ssi { Line 692  sub ssi {
           
     if (%form) {      if (%form) {
       $request=new HTTP::Request('POST',"http://".$ENV{'HTTP_HOST'}.$fn);        $request=new HTTP::Request('POST',"http://".$ENV{'HTTP_HOST'}.$fn);
       $request->content(join '&', map { "$_=$form{$_}" } keys %form);        $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form));
     } else {      } else {
       $request=new HTTP::Request('GET',"http://".$ENV{'HTTP_HOST'}.$fn);        $request=new HTTP::Request('GET',"http://".$ENV{'HTTP_HOST'}.$fn);
     }      }
Line 664  sub flushcourselogs { Line 716  sub flushcourselogs {
     &logthis('Flushing course log buffers');      &logthis('Flushing course log buffers');
     foreach (keys %courselogs) {      foreach (keys %courselogs) {
         my $crsid=$_;          my $crsid=$_;
    &logthis(":$crsid:$coursehombuf{$crsid}");
         if (&reply('log:'.$coursedombuf{$crsid}.':'.          if (&reply('log:'.$coursedombuf{$crsid}.':'.
           &escape($courselogs{$crsid}),            &escape($courselogs{$crsid}),
           $coursehombuf{$crsid}) eq 'ok') {            $coursehombuf{$crsid}) eq 'ok') {
Line 861  sub devalidate { Line 914  sub devalidate {
     }      }
 }  }
   
   sub arrayref2str {
     my ($arrayref) = @_;
     my $result='_ARRAY_REF__';
     foreach my $elem (@$arrayref) {
       if (ref($elem) eq 'ARRAY') {
         $result.=&escape(&arrayref2str($elem)).'&';
       } elsif (ref($elem) eq 'HASH') {
         $result.=&escape(&hashref2str($elem)).'&';
       } elsif (ref($elem)) {
         &logthis("Got a ref of ".(ref($elem))." skipping.");
       } else {
         $result.=&escape($elem).'&';
       }
     }
     $result=~s/\&$//;
     return $result;
   }
   
 sub hash2str {  sub hash2str {
   my (%hash)=@_;    my (%hash) = @_;
   my $result='';    my $result=&hashref2str(\%hash);
   foreach (keys %hash) { $result.=escape($_).'='.escape($hash{$_}).'&'; }    $result=~s/^_HASH_REF__//;
     return $result;
   }
   
   sub hashref2str {
     my ($hashref)=@_;
     my $result='_HASH_REF__';
     foreach (keys(%$hashref)) {
       if (ref($_) eq 'ARRAY') {
         $result.=&escape(&arrayref2str($_)).'=';
       } elsif (ref($_) eq 'HASH') {
         $result.=&escape(&hashref2str($_)).'=';
       } elsif (ref($_)) {
         &logthis("Got a ref of ".(ref($_))." skipping.");
       } else {
         $result.=&escape($_).'=';
       }
   
       if (ref($$hashref{$_}) eq 'ARRAY') {
         $result.=&escape(&arrayref2str($$hashref{$_})).'&';
       } elsif (ref($$hashref{$_}) eq 'HASH') {
         $result.=&escape(&hashref2str($$hashref{$_})).'&';
       } elsif (ref($$hashref{$_})) {
         &logthis("Got a ref of ".(ref($$hashref{$_}))." skipping.");
       } else {
         $result.=&escape($$hashref{$_}).'&';
       }
     }
   $result=~s/\&$//;    $result=~s/\&$//;
   return $result;    return $result;
 }  }
Line 874  sub str2hash { Line 972  sub str2hash {
   my %returnhash;    my %returnhash;
   foreach (split(/\&/,$string)) {    foreach (split(/\&/,$string)) {
     my ($name,$value)=split(/\=/,$_);      my ($name,$value)=split(/\=/,$_);
     $returnhash{&unescape($name)}=&unescape($value);      $name=&unescape($name);
       $value=&unescape($value);
       if ($value =~ /^_HASH_REF__/) {
         $value =~ s/^_HASH_REF__//;
         my %hash=&str2hash($value);
         $value=\%hash;
       } elsif ($value =~ /^_ARRAY_REF__/) {
         $value =~ s/^_ARRAY_REF__//;
         my @array=&str2array($value);
         $value=\@array;
       }
       $returnhash{$name}=$value;
   }    }
   return %returnhash;    return (%returnhash);
   }
   
   sub str2array {
     my ($string) = @_;
     my @returnarray;
     foreach my $value (split(/\&/,$string)) {
       $value=&unescape($value);
       if ($value =~ /^_HASH_REF__/) {
         $value =~ s/^_HASH_REF__//;
         my %hash=&str2hash($value);
         $value=\%hash;
       } elsif ($value =~ /^_ARRAY_REF__/) {
         $value =~ s/^_ARRAY_REF__//;
         my @array=&str2array($value);
         $value=\@array;
       }
       push(@returnarray,$value);
     }
     return (@returnarray);
 }  }
   
 # -------------------------------------------------------------------Temp Store  # -------------------------------------------------------------------Temp Store
Line 1732  sub modifyuserauth { Line 1860  sub modifyuserauth {
   
 # --------------------------------------------------------------- Modify a user  # --------------------------------------------------------------- Modify a user
   
   
 sub modifyuser {  sub modifyuser {
     my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,      my ($udom,    $uname, $uid,
         $forceid)=@_;          $umode,   $upass, $first,
           $middle,  $last,  $gene,
           $forceid, $desiredhome)=@_;
       $udom=~s/\W//g;
       $uname=~s/\W//g;
     &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.      &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
              $umode.', '.$first.', '.$middle.', '.               $umode.', '.$first.', '.$middle.', '.
      $last.', '.$gene.'(forceid: '.$forceid.') by '.       $last.', '.$gene.'(forceid: '.$forceid.')'.
              $ENV{'user.name'}.' at '.$ENV{'user.domain'});                 (defined($desiredhome) ? ' desiredhome = '.$desiredhome :
                                        ' desiredhome not specified'). 
                ' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'});
     my $uhome=&homeserver($uname,$udom);      my $uhome=&homeserver($uname,$udom);
 # ----------------------------------------------------------------- Create User  # ----------------------------------------------------------------- Create User
     if (($uhome eq 'no_host') && ($umode) && ($upass)) {      if (($uhome eq 'no_host') && ($umode) && ($upass)) {
         my $unhome='';          my $unhome='';
  if ($ENV{'course.'.$ENV{'request.course.id'}.'.domain'} eq $udom) {          if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) { 
               $unhome = $desiredhome;
    } elsif($ENV{'course.'.$ENV{'request.course.id'}.'.domain'} eq $udom) {
     $unhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'};      $unhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'};
         } else {          } else { # load balancing routine for determining $unhome
             my $tryserver;              my $tryserver;
             my $loadm=10000000;              my $loadm=10000000;
             foreach $tryserver (keys %libserv) {              foreach $tryserver (keys %libserv) {
Line 1760  sub modifyuser { Line 1895  sub modifyuser {
     }      }
         }          }
         if (($unhome eq '') || ($unhome eq 'no_host')) {          if (($unhome eq '') || ($unhome eq 'no_host')) {
     return 'error: find home';      return 'error: unable to find a home server for '.$uname.
                      ' in domain '.$udom;
         }          }
         my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':'.$umode.':'.          my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':'.$umode.':'.
                          &escape($upass),$unhome);                           &escape($upass),$unhome);
Line 1771  sub modifyuser { Line 1907  sub modifyuser {
         if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) {          if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) {
     return 'error: verify home';      return 'error: verify home';
         }          }
     }      }   # End of creation of new user
 # ---------------------------------------------------------------------- Add ID  # ---------------------------------------------------------------------- Add ID
     if ($uid) {      if ($uid) {
        $uid=~tr/A-Z/a-z/;         $uid=~tr/A-Z/a-z/;
Line 1789  sub modifyuser { Line 1925  sub modifyuser {
     my %names=&get('environment',      my %names=&get('environment',
    ['firstname','middlename','lastname','generation'],     ['firstname','middlename','lastname','generation'],
    $udom,$uname);     $udom,$uname);
       if ($names{'firstname'} =~ m/^error:.*/) { %names=(); }
     if ($first)  { $names{'firstname'}  = $first; }      if ($first)  { $names{'firstname'}  = $first; }
     if ($middle) { $names{'middlename'} = $middle; }      if ($middle) { $names{'middlename'} = $middle; }
     if ($last)   { $names{'lastname'}   = $last; }      if ($last)   { $names{'lastname'}   = $last; }
Line 1806  sub modifyuser { Line 1943  sub modifyuser {
   
 sub modifystudent {  sub modifystudent {
     my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,      my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
         $end,$start,$forceid)=@_;          $end,$start,$forceid,$desiredhome)=@_;
     my $cid='';      my $cid='';
     unless ($cid=$ENV{'request.course.id'}) {      unless ($cid=$ENV{'request.course.id'}) {
  return 'not_in_class';   return 'not_in_class';
     }      }
 # --------------------------------------------------------------- Make the user  # --------------------------------------------------------------- Make the user
     my $reply=&modifyuser      my $reply=&modifyuser
  ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid);   ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid,
            $desiredhome);
     unless ($reply eq 'ok') { return $reply; }      unless ($reply eq 'ok') { return $reply; }
     my $uhome=&homeserver($uname,$udom);      my $uhome=&homeserver($uname,$udom);
     if (($uhome eq '') || ($uhome eq 'no_host')) {       if (($uhome eq '') || ($uhome eq 'no_host')) { 
Line 2021  sub condval { Line 2159  sub condval {
     return $result;      return $result;
 }  }
   
   # --------------------------------------------------- Course Resourcedata Query
   
   sub courseresdata {
       my ($coursenum,$coursedomain,@which)=@_;
       my $coursehom=&homeserver($coursenum,$coursedomain);
       my $hashid=$coursenum.':'.$coursedomain;
       unless (defined($courseresdatacache{$hashid.'.time'})) {
    unless (time-$courseresdatacache{$hashid.'.time'}<300) {
              my $coursehom=&homeserver($coursenum,$coursedomain);
              if ($coursehom) {
                 my $dumpreply=&reply('dump:'.$coursedomain.':'.$coursenum.
        ':resourcedata:.',$coursehom);
         unless ($dumpreply=~/^error\:/) {
            $courseresdatacache{$hashid.'.time'}=time;
                    $courseresdatacache{$hashid}=$dumpreply;
        }
     }
          }
       }
      my @pairs=split(/\&/,$courseresdatacache{$hashid});
      my %returnhash=();
      foreach (@pairs) {
         my ($key,$value)=split(/=/,$_);
         $returnhash{unescape($key)}=unescape($value);
      }
       my $item;
      foreach $item (@which) {
          if ($returnhash{$item}) { return $returnhash{$item}; }
      }
      return '';
   }
   
 # --------------------------------------------------------- Value of a Variable  # --------------------------------------------------------- Value of a Variable
   
 sub EXT {  sub EXT {
Line 2141  sub EXT { Line 2311  sub EXT {
   
 # -------------------------------------------------------- second, check course  # -------------------------------------------------------- second, check course
   
         my $reply=&reply('get:'.          my $coursereply=&courseresdata(
               $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.':'.                          $ENV{'course.'.$ENV{'request.course.id'}.'.num'},
               $ENV{'course.'.$ENV{'request.course.id'}.'.num'}.                          $ENV{'course.'.$ENV{'request.course.id'}.'.domain'},
       ':resourcedata:'.                          ($seclevelr,$seclevelm,$seclevel,
    &escape($seclevelr).'&'.&escape($seclevelm).'&'.&escape($seclevel).'&'.                           $courselevelr,$courselevelm,$courselevel));
    &escape($courselevelr).'&'.&escape($courselevelm).'&'.&escape($courselevel),          if ($coursereply) { return $coursereply; }
    $ENV{'course.'.$ENV{'request.course.id'}.'.home'});  
       if ($reply!~/^error\:/) {  
   foreach (split(/\&/,$reply)) {  
       if ($_) { return &unescape($_); }  
           }  
       }  
       if (($reply=~/^con_lost/) || ($reply=~/^error\:/)) {  
   &logthis("<font color=blue>WARNING:".  
                 " Getting ".$reply." asking for ".$varname." for ".  
                 $ENV{'course.'.$ENV{'request.course.id'}.'.num'}.  
                 ' at '.  
                 $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.  
                 ' from '.  
                 $ENV{'course.'.$ENV{'request.course.id'}.'.home'}.  
                  "</font>");  
       }  
 # ------------------------------------------------------ third, check map parms  # ------------------------------------------------------ third, check map parms
        my %parmhash=();         my %parmhash=();
        my $thisparm='';                my $thisparm='';       
Line 2235  sub metadata { Line 2390  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($perlvar{'lonDocRoot'}.'/res/'.$filename);
         my $parser=HTML::TokeParser->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) {
Line 2324  sub metadata { Line 2479  sub metadata {
   $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};    $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};
               }                }
               unless (                unless (
                  $metacache{$uri.':'.$unikey}=$parser->get_text('/'.$entry)                   $metacache{$uri.':'.$unikey}=&HTML::Entities::decode($parser->get_text('/'.$entry))
       ) { $metacache{$uri.':'.$unikey}=        ) { $metacache{$uri.':'.$unikey}=
       $metacache{$uri.':'.$unikey.'.default'};        $metacache{$uri.':'.$unikey.'.default'};
       }        }
Line 2362  sub symblist { Line 2517  sub symblist {
     return 'error';      return 'error';
 }  }
   
   # --------------------------------------------------------------- Clean-up symb
   
   sub symbclean {
       my $symb=shift;
   # remove version from map
       $symb=~s/\.(\d+)\.(\w+)\_\_\_/\.$2\_\_\_/;
   # remove version from URL
       $symb=~s/\.(\d+)\.(\w+)$/\.$2/;
       return $symb;
   }
   
 # ------------------------------------------------------ Return symb list entry  # ------------------------------------------------------ Return symb list entry
   
 sub symbread {  sub symbread {
     my $thisfn=shift;      my $thisfn=shift;
     unless ($thisfn) {      unless ($thisfn) {
         if ($ENV{'request.symb'}) { return $ENV{'request.symb'}; }          if ($ENV{'request.symb'}) { return &symbclean($ENV{'request.symb'}); }
  $thisfn=$ENV{'request.filename'};   $thisfn=$ENV{'request.filename'};
     }      }
     $thisfn=declutter($thisfn);      $thisfn=declutter($thisfn);
Line 2426  sub symbread { Line 2592  sub symbread {
            }              } 
         }          }
         if ($syval) {          if ($syval) {
            return $syval.'___'.$thisfn;              return &symbclean($syval.'___'.$thisfn); 
         }          }
     }      }
     &appenv('request.ambiguous' => $thisfn);      &appenv('request.ambiguous' => $thisfn);
Line 2565  sub unescape { Line 2731  sub unescape {
 # ================================================================ Main Program  # ================================================================ Main Program
   
 sub goodbye {  sub goodbye {
      &logthis("Starting Shut down");
    &flushcourselogs();     &flushcourselogs();
    &logthis("Shutting down");     &logthis("Shutting down");
 }  }
Line 2827  devalidate($symb) : devalidate spreadshe Line 2994  devalidate($symb) : devalidate spreadshe
 =item *  =item *
   
 hash2str(%hash) : convert a hash into a string complete with escaping and '='  hash2str(%hash) : convert a hash into a string complete with escaping and '='
 and '&' separators  and '&' separators, supports elements that are arrayrefs and hashrefs
   
   =item *
   
   hashref2str($hashref) : convert a hashref into a string complete with
   escaping and '=' and '&' separators, supports elements that are
   arrayrefs and hashrefs
   
   =item *
   
   arrayref2str($arrayref) : convert an arrayref into a string complete
   with escaping and '&' separators, supports elements that are arrayrefs
   and hashrefs
   
   =item *
   
   str2hash($string) : convert string to hash using unescaping and
   splitting on '=' and '&', supports elements that are arrayrefs and
   hashrefs
   
 =item *  =item *
   
 str2hash($string) : convert string to hash using unescaping and splitting on  str2array($string) : convert string to hash using unescaping and
 '=' and '&'  splitting on '&', supports elements that are arrayrefs and hashrefs
   
 =item *  =item *
   
Removed from v.1.197  
changed lines
  Added in v.1.211

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