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

version 1.207, 2002/04/04 20:37:05 version 1.211, 2002/05/06 13:46:41
Line 84  qw(%perlvar %hostname %homecache %hostip Line 84  qw(%perlvar %hostname %homecache %hostip
 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 1877  sub modifyuser { Line 1877  sub modifyuser {
 # ----------------------------------------------------------------- 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=$ENV{'course.'.$ENV{'request.course.id'}.'.home'};  
         } elsif (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) {   
             $unhome = $desiredhome;              $unhome = $desiredhome;
         } else {   } elsif($ENV{'course.'.$ENV{'request.course.id'}.'.domain'} eq $udom) {
       $unhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'};
           } 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 1907  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 1943  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 2389  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 2478  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 2516  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 2580  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);
Removed from v.1.207  
changed lines
  Added in v.1.211

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