[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.783 and 1.789

version 1.783, 2006/09/19 21:36:41 version 1.789, 2006/10/04 21:02:41
Line 303  sub convert_and_load_session_env { Line 303  sub convert_and_load_session_env {
     }      }
     my %temp_env;      my %temp_env;
     foreach my $line (@profile) {      foreach my $line (@profile) {
    if ($line !~ m/=/) {
       return 0;
    }
  chomp($line);   chomp($line);
  my ($envname,$envvalue)=split(/=/,$line,2);   my ($envname,$envvalue)=split(/=/,$line,2);
  $temp_env{&unescape($envname)} = &unescape($envvalue);   $temp_env{&unescape($envname)} = &unescape($envvalue);
Line 314  sub convert_and_load_session_env { Line 317  sub convert_and_load_session_env {
  @env{keys(%temp_env)} = @disk_env{keys(%temp_env)};   @env{keys(%temp_env)} = @disk_env{keys(%temp_env)};
  untie(%disk_env);   untie(%disk_env);
     }      }
       return 1;
 }  }
   
 # ------------------------------------------- Transfer profile into environment  # ------------------------------------------- Transfer profile into environment
 my $env_loaded;  my $env_loaded;
 sub transfer_profile_to_env {  sub transfer_profile_to_env {
     if ($env_loaded) { return; }       my ($lonidsdir,$handle,$force_transfer) = @_;
       if (!$force_transfer && $env_loaded) { return; } 
   
     my ($lonidsdir,$handle)=@_;  
     if (!defined($lonidsdir)) {      if (!defined($lonidsdir)) {
  $lonidsdir = $perlvar{'lonIDsDir'};   $lonidsdir = $perlvar{'lonIDsDir'};
     }      }
Line 329  sub transfer_profile_to_env { Line 333  sub transfer_profile_to_env {
         ($handle) = ($env{'user.environment'} =~m|/([^/]+)\.id$| );          ($handle) = ($env{'user.environment'} =~m|/([^/]+)\.id$| );
     }      }
   
     my %remove;      my $convert;
     if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",&GDBM_READER(),      {
     0640)) {      open(my $idf,"$lonidsdir/$handle.id");
  @env{keys(%disk_env)} = @disk_env{keys(%disk_env)};   flock($idf,LOCK_SH);
  untie(%disk_env);   if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",
     } else {   &GDBM_READER(),0640)) {
  &convert_and_load_session_env($lonidsdir,$handle);      @env{keys(%disk_env)} = @disk_env{keys(%disk_env)};
       untie(%disk_env);
    } else {
       $convert = 1;
    }
       }
       if ($convert) {
    if (!&convert_and_load_session_env($lonidsdir,$handle)) {
       &logthis("Failed to load session, or convert session.");
    }
     }      }
   
       my %remove;
     while ( my $envname = each(%env) ) {      while ( my $envname = each(%env) ) {
         if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {          if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {
             if ($time < time-300) {              if ($time < time-300) {
Line 450  sub overloaderror { Line 464  sub overloaderror {
   
 sub spareserver {  sub spareserver {
     my ($loadpercent,$userloadpercent,$want_server_name) = @_;      my ($loadpercent,$userloadpercent,$want_server_name) = @_;
     my $tryserver;      my $spare_server;
     my $spareserver='';  
     if ($userloadpercent !~ /\d/) { $userloadpercent=0; }      if ($userloadpercent !~ /\d/) { $userloadpercent=0; }
     my $lowestserver=$loadpercent > $userloadpercent?      my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent 
              $loadpercent :  $userloadpercent;                                                       :  $userloadpercent;
     foreach $tryserver (keys(%spareid)) {      
  my $loadans=&reply('load',$tryserver);      foreach my $try_server (@{ $spareid{'primary'} }) {
  my $userloadans=&reply('userload',$tryserver);   ($spare_server, $lowest_load) =
  if ($loadans !~ /\d/ && $userloadans !~ /\d/) {      &compare_server_load($try_server, $spare_server, $lowest_load);
     next; #didn't get a number from the server      }
  }  
  my $answer;      my $found_server = ($spare_server ne '' && $lowest_load < 100);
  if ($loadans =~ /\d/) {  
     if ($userloadans =~ /\d/) {      if (!$found_server) {
  #both are numbers, pick the bigger one   foreach my $try_server (@{ $spareid{'default'} }) {
  $answer=$loadans > $userloadans?      ($spare_server, $lowest_load) =
     $loadans :  $userloadans;   &compare_server_load($try_server, $spare_server, $lowest_load);
     } else {  
  $answer = $loadans;  
     }  
  } else {  
     $answer = $userloadans;  
  }  
  if (($answer =~ /\d/) && ($answer<$lowestserver)) {  
     if ($want_server_name) {  
  $spareserver=$tryserver;  
     } else {  
  $spareserver="http://$hostname{$tryserver}";  
     }  
     $lowestserver=$answer;  
  }   }
     }      }
     return $spareserver;  
       if (!$want_server_name) {
    $spare_server="http://$hostname{$spare_server}";
       }
       return $spare_server;
 }  }
   
   sub compare_server_load {
       my ($try_server, $spare_server, $lowest_load) = @_;
   
       my $loadans     = &reply('load',    $try_server);
       my $userloadans = &reply('userload',$try_server);
   
       if ($loadans !~ /\d/ && $userloadans !~ /\d/) {
    next; #didn't get a number from the server
       }
   
       my $load;
       if ($loadans =~ /\d/) {
    if ($userloadans =~ /\d/) {
       #both are numbers, pick the bigger one
       $load = ($loadans > $userloadans) ? $loadans 
                                 : $userloadans;
    } else {
       $load = $loadans;
    }
       } else {
    $load = $userloadans;
       }
   
       if (($load =~ /\d/) && ($load < $lowest_load)) {
    $spare_server = $try_server;
    $lowest_load  = $load;
       }
       return ($spare_server,$lowest_load);
   }
 # --------------------------------------------- Try to change a user's password  # --------------------------------------------- Try to change a user's password
   
 sub changepass {  sub changepass {
Line 1151  sub absolute_url { Line 1184  sub absolute_url {
     return $protocol.$host_name;      return $protocol.$host_name;
 }  }
   
 sub absolute_url {  
     my ($host_name) = @_;  
     my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://');  
     if ($host_name eq '') {  
  $host_name = $ENV{'SERVER_NAME'};  
     }  
     return $protocol.$host_name;  
 }  
   
 sub ssi {  sub ssi {
   
     my ($fn,%form)=@_;      my ($fn,%form)=@_;
Line 5253  sub GetFileTimestamp { Line 5277  sub GetFileTimestamp {
   
 sub stat_file {  sub stat_file {
     my ($uri) = @_;      my ($uri) = @_;
     $uri = &clutter($uri);      $uri = &clutter_with_no_wrapper($uri);
   
     # we want just the url part without the unneeded accessor url bits  
     if ($uri =~ m-^/adm/-) {  
  $uri=~s-^/adm/wrapper/-/-;  
  $uri=~s-^/adm/coursedocs/showdoc/-/-;  
     }  
     my ($udom,$uname,$file,$dir);      my ($udom,$uname,$file,$dir);
     if ($uri =~ m-^/(uploaded|editupload)/-) {      if ($uri =~ m-^/(uploaded|editupload)/-) {
  ($udom,$uname,$file) =   ($udom,$uname,$file) =
Line 6195  sub symblist { Line 6214  sub symblist {
 sub symbverify {  sub symbverify {
     my ($symb,$thisurl)=@_;      my ($symb,$thisurl)=@_;
     my $thisfn=$thisurl;      my $thisfn=$thisurl;
 # wrapper not part of symbs  
     $thisfn=~s/^\/adm\/wrapper//;  
     $thisfn=~s/^\/adm\/coursedocs\/showdoc\///;  
     $thisfn=&declutter($thisfn);      $thisfn=&declutter($thisfn);
 # direct jump to resource in page or to a sequence - will construct own symbs  # direct jump to resource in page or to a sequence - will construct own symbs
     if ($thisfn=~/\.(page|sequence)$/) { return 1; }      if ($thisfn=~/\.(page|sequence)$/) { return 1; }
Line 7034  sub clutter { Line 7050  sub clutter {
     return $thisfn;      return $thisfn;
 }  }
   
   sub clutter_with_no_wrapper {
       my $uri = &clutter(shift);
       if ($uri =~ m-^/adm/-) {
    $uri =~ s-^/adm/wrapper/-/-;
    $uri =~ s-^/adm/coursedocs/showdoc/-/-;
       }
       return $uri;
   }
   
 sub freeze_escape {  sub freeze_escape {
     my ($value)=@_;      my ($value)=@_;
     if (ref($value)) {      if (ref($value)) {
Line 7169  sub get_iphost { Line 7194  sub get_iphost {
     while (my $configline=<$config>) {      while (my $configline=<$config>) {
        chomp($configline);         chomp($configline);
        if ($configline) {         if ($configline) {
           $spareid{$configline}=1;     my ($host,$type) = split(':',$configline,2);
      if (!defined($type) || $type eq '') { $type = 'default' };
      push(@{ $spareid{$type} }, $host);
        }         }
     }      }
     close($config);      close($config);
Removed from v.1.783  
changed lines
  Added in v.1.789

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