[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.782.2.5 and 1.783

version 1.782.2.5, 2006/11/10 19:01:59 version 1.783, 2006/09/19 21:36:41
Line 292  sub error { Line 292  sub error {
     return undef;      return undef;
 }  }
   
   sub convert_and_load_session_env {
       my ($lonidsdir,$handle)=@_;
       my @profile;
       {
    open(my $idf,"$lonidsdir/$handle.id");
    flock($idf,LOCK_SH);
    @profile=<$idf>;
    close($idf);
       }
       my %temp_env;
       foreach my $line (@profile) {
    chomp($line);
    my ($envname,$envvalue)=split(/=/,$line,2);
    $temp_env{&unescape($envname)} = &unescape($envvalue);
       }
       unlink("$lonidsdir/$handle.id");
       if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",&GDBM_WRCREAT(),
       0640)) {
    %disk_env = %temp_env;
    @env{keys(%temp_env)} = @disk_env{keys(%temp_env)};
    untie(%disk_env);
       }
   }
   
 # ------------------------------------------- Transfer profile into environment  # ------------------------------------------- Transfer profile into environment
 my $env_loaded;  my $env_loaded;
 sub transfer_profile_to_env {  sub transfer_profile_to_env {
     my ($lonidsdir,$handle,$force_transfer) = @_;      if ($env_loaded) { return; } 
     if (!$force_transfer && $env_loaded) { return; }   
   
       my ($lonidsdir,$handle)=@_;
     if (!defined($lonidsdir)) {      if (!defined($lonidsdir)) {
  $lonidsdir = $perlvar{'lonIDsDir'};   $lonidsdir = $perlvar{'lonIDsDir'};
     }      }
Line 305  sub transfer_profile_to_env { Line 329  sub transfer_profile_to_env {
         ($handle) = ($env{'user.environment'} =~m|/([^/]+)\.id$| );          ($handle) = ($env{'user.environment'} =~m|/([^/]+)\.id$| );
     }      }
   
     my @profile;      my %remove;
     {      if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",&GDBM_READER(),
  open(my $idf,"$lonidsdir/$handle.id");      0640)) {
  flock($idf,LOCK_SH);   @env{keys(%disk_env)} = @disk_env{keys(%disk_env)};
  @profile=<$idf>;   untie(%disk_env);
  close($idf);      } else {
    &convert_and_load_session_env($lonidsdir,$handle);
     }      }
     my $envi;  
     my %Remove;      while ( my $envname = each(%env) ) {
     for ($envi=0;$envi<=$#profile;$envi++) {  
  chomp($profile[$envi]);  
  my ($envname,$envvalue)=split(/=/,$profile[$envi],2);  
  $envname=&unescape($envname);  
  $envvalue=&unescape($envvalue);  
  $env{$envname} = $envvalue;  
         if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {          if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {
             if ($time < time-300) {              if ($time < time-300) {
                 $Remove{$key}++;                  $remove{$key}++;
             }              }
         }          }
     }      }
   
     $env{'user.environment'} = "$lonidsdir/$handle.id";      $env{'user.environment'} = "$lonidsdir/$handle.id";
     $env_loaded=1;      $env_loaded=1;
     foreach my $expired_key (keys(%Remove)) {      foreach my $expired_key (keys(%remove)) {
         &delenv($expired_key);          &delenv($expired_key);
     }      }
 }  }
Line 347  sub appenv { Line 367  sub appenv {
             $env{$key}=$newenv{$key};              $env{$key}=$newenv{$key};
         }          }
     }      }
     foreach my $key (keys(%newenv)) {      if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(),
  my $value = &escape($newenv{$key});      0640)) {
  delete($newenv{$key});   while (my ($key,$value) = each(%newenv)) {
  $newenv{&escape($key)}=$value;      $disk_env{$key} = $value;
     }  
   
     my $lockfh;  
     unless (open($lockfh,"$env{'user.environment'}")) {  
  return 'error: '.$!;  
     }  
     unless (flock($lockfh,LOCK_EX)) {  
          &logthis("<font color=\"blue\">WARNING: ".  
                   'Could not obtain exclusive lock in appenv: '.$!);  
          close($lockfh);  
          return 'error: '.$!;  
     }  
   
     my @oldenv;  
     {  
  my $fh;  
  unless (open($fh,"$env{'user.environment'}")) {  
     return 'error: '.$!;  
  }   }
  @oldenv=<$fh>;   untie(%disk_env);
  close($fh);  
     }  
     for (my $i=0; $i<=$#oldenv; $i++) {  
         chomp($oldenv[$i]);  
         if ($oldenv[$i] ne '') {  
     my ($name,$value)=split(/=/,$oldenv[$i],2);  
     unless (defined($newenv{$name})) {  
  $newenv{$name}=$value;  
     }  
         }  
     }      }
     {  
  my $fh;  
  unless (open($fh,">$env{'user.environment'}")) {  
     return 'error';  
  }  
  my $newname;  
  foreach $newname (keys %newenv) {  
     print $fh $newname.'='.$newenv{$newname}."\n";  
  }  
  close($fh);  
     }  
   
     close($lockfh);  
     return 'ok';      return 'ok';
 }  }
 # ----------------------------------------------------- Delete from Environment  # ----------------------------------------------------- Delete from Environment
Line 406  sub delenv { Line 385  sub delenv {
                 "Attempt to delete from environment ".$delthis);                  "Attempt to delete from environment ".$delthis);
         return 'error';          return 'error';
     }      }
     my @oldenv;      if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(),
     {      0640)) {
  my $fh;   foreach my $key (keys(%disk_env)) {
  unless (open($fh,"$env{'user.environment'}")) {      if ($key=~/^$delthis/) { 
     return 'error';  
  }  
  unless (flock($fh,LOCK_SH)) {  
     &logthis("<font color=\"blue\">WARNING: ".  
      'Could not obtain shared lock in delenv: '.$!);  
     close($fh);  
     return 'error: '.$!;  
  }  
  @oldenv=<$fh>;  
  close($fh);  
     }  
     {  
  my $fh;  
  unless (open($fh,">$env{'user.environment'}")) {  
     return 'error';  
  }  
  unless (flock($fh,LOCK_EX)) {  
     &logthis("<font color=\"blue\">WARNING: ".  
      'Could not obtain exclusive lock in delenv: '.$!);  
     close($fh);  
     return 'error: '.$!;  
  }  
  foreach my $cur_key (@oldenv) {  
     my $unescaped_cur_key = &unescape($cur_key);  
     if ($unescaped_cur_key=~/^$delthis/) {   
                 my ($key) = split('=',$cur_key,2);  
  $key = &unescape($key);  
                 delete($env{$key});                  delete($env{$key});
             } else {                  delete($disk_env{$key});
                 print $fh $cur_key;   
             }              }
  }   }
  close($fh);   untie(%disk_env);
     }      }
     return 'ok';      return 'ok';
 }  }
Line 499  sub overloaderror { Line 450  sub overloaderror {
   
 sub spareserver {  sub spareserver {
     my ($loadpercent,$userloadpercent,$want_server_name) = @_;      my ($loadpercent,$userloadpercent,$want_server_name) = @_;
     my $spare_server;      my $tryserver;
       my $spareserver='';
     if ($userloadpercent !~ /\d/) { $userloadpercent=0; }      if ($userloadpercent !~ /\d/) { $userloadpercent=0; }
     my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent       my $lowestserver=$loadpercent > $userloadpercent?
                                                      :  $userloadpercent;               $loadpercent :  $userloadpercent;
           foreach $tryserver (keys(%spareid)) {
     foreach my $try_server (@{ $spareid{'primary'} }) {   my $loadans=&reply('load',$tryserver);
  ($spare_server, $lowest_load) =   my $userloadans=&reply('userload',$tryserver);
     &compare_server_load($try_server, $spare_server, $lowest_load);   if ($loadans !~ /\d/ && $userloadans !~ /\d/) {
     }      next; #didn't get a number from the server
    }
     my $found_server = ($spare_server ne '' && $lowest_load < 100);   my $answer;
    if ($loadans =~ /\d/) {
     if (!$found_server) {      if ($userloadans =~ /\d/) {
  foreach my $try_server (@{ $spareid{'default'} }) {   #both are numbers, pick the bigger one
     ($spare_server, $lowest_load) =   $answer=$loadans > $userloadans?
  &compare_server_load($try_server, $spare_server, $lowest_load);      $loadans :  $userloadans;
  }      } else {
     }   $answer = $loadans;
       }
     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 {   } else {
     $load = $loadans;      $answer = $userloadans;
    }
    if (($answer =~ /\d/) && ($answer<$lowestserver)) {
       if ($want_server_name) {
    $spareserver=$tryserver;
       } else {
    $spareserver="http://$hostname{$tryserver}";
       }
       $lowestserver=$answer;
  }   }
     } else {  
  $load = $userloadans;  
     }  
   
     if (($load =~ /\d/) && ($load < $lowest_load)) {  
  $spare_server = $try_server;  
  $lowest_load  = $load;  
     }      }
     return ($spare_server,$lowest_load);      return $spareserver;
 }  }
   
 # --------------------------------------------- Try to change a user's password  # --------------------------------------------- Try to change a user's password
   
 sub changepass {  sub changepass {
Line 1219  sub absolute_url { Line 1151  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 6573  sub rndseed { Line 6514  sub rndseed {
     if (!$domain) { $domain=$wdomain; }      if (!$domain) { $domain=$wdomain; }
     if (!$username) { $username=$wusername }      if (!$username) { $username=$wusername }
     my $which=&get_rand_alg();      my $which=&get_rand_alg();
   
     if (defined(&getCODE())) {      if (defined(&getCODE())) {
  if ($which eq '64bit5') {   if ($which eq '64bit5') {
     return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username);      return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username);
Line 6631  sub rndseed_64bit { Line 6571  sub rndseed_64bit {
  #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");   #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
  #&Apache::lonxml::debug("rndseed :$num:$symb");   #&Apache::lonxml::debug("rndseed :$num:$symb");
  if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }   if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
    if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
  return "$num1,$num2";   return "$num1,$num2";
     }      }
 }  }
Line 6653  sub rndseed_64bit2 { Line 6594  sub rndseed_64bit2 {
  my $num2=$nameseed+$domainseed+$courseseed;   my $num2=$nameseed+$domainseed+$courseseed;
  #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");   #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
  #&Apache::lonxml::debug("rndseed :$num:$symb");   #&Apache::lonxml::debug("rndseed :$num:$symb");
  if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }  
  return "$num1,$num2";   return "$num1,$num2";
     }      }
 }  }
Line 7229  sub get_iphost { Line 7169  sub get_iphost {
     while (my $configline=<$config>) {      while (my $configline=<$config>) {
        chomp($configline);         chomp($configline);
        if ($configline) {         if ($configline) {
    my ($host,$type) = split(':',$configline,2);            $spareid{$configline}=1;
    if (!defined($type) || $type eq '') { $type = 'default' };  
    push(@{ $spareid{$type} }, $host);  
        }         }
     }      }
     close($config);      close($config);
Line 7293  sub get_iphost { Line 7231  sub get_iphost {
   
 }  }
   
 $memcache=new Cache::Memcached({'servers'           => ['127.0.0.1:11211'],  $memcache=new Cache::Memcached({'servers'=>['127.0.0.1:11211']});
  'compress_threshold'=> 20_000,  
          });  
   
 $processmarker='_'.time.'_'.$perlvar{'lonHostID'};  $processmarker='_'.time.'_'.$perlvar{'lonHostID'};
 $dumpcount=0;  $dumpcount=0;
Removed from v.1.782.2.5  
changed lines
  Added in v.1.783

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