--- loncom/lonnet/perl/lonnet.pm	2006/11/10 19:01:59	1.782.2.5
+++ loncom/lonnet/perl/lonnet.pm	2006/09/19 21:36:41	1.783
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.782.2.5 2006/11/10 19:01:59 albertel Exp $
+# $Id: lonnet.pm,v 1.783 2006/09/19 21:36:41 albertel Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -292,12 +292,36 @@ sub error {
     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
 my $env_loaded;
 sub transfer_profile_to_env {
-    my ($lonidsdir,$handle,$force_transfer) = @_;
-    if (!$force_transfer && $env_loaded) { return; } 
+    if ($env_loaded) { return; } 
 
+    my ($lonidsdir,$handle)=@_;
     if (!defined($lonidsdir)) {
 	$lonidsdir = $perlvar{'lonIDsDir'};
     }
@@ -305,30 +329,26 @@ sub transfer_profile_to_env {
         ($handle) = ($env{'user.environment'} =~m|/([^/]+)\.id$| );
     }
 
-    my @profile;
-    {
-	open(my $idf,"$lonidsdir/$handle.id");
-	flock($idf,LOCK_SH);
-	@profile=<$idf>;
-	close($idf);
+    my %remove;
+    if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",&GDBM_READER(),
+	    0640)) {
+	@env{keys(%disk_env)} = @disk_env{keys(%disk_env)};
+	untie(%disk_env);
+    } else {
+	&convert_and_load_session_env($lonidsdir,$handle);
     }
-    my $envi;
-    my %Remove;
-    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;
+
+    while ( my $envname = each(%env) ) {
         if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {
             if ($time < time-300) {
-                $Remove{$key}++;
+                $remove{$key}++;
             }
         }
     }
+
     $env{'user.environment'} = "$lonidsdir/$handle.id";
     $env_loaded=1;
-    foreach my $expired_key (keys(%Remove)) {
+    foreach my $expired_key (keys(%remove)) {
         &delenv($expired_key);
     }
 }
@@ -347,54 +367,13 @@ sub appenv {
             $env{$key}=$newenv{$key};
         }
     }
-    foreach my $key (keys(%newenv)) {
-	my $value = &escape($newenv{$key});
-	delete($newenv{$key});
-	$newenv{&escape($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: '.$!;
+    if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(),
+	    0640)) {
+	while (my ($key,$value) = each(%newenv)) {
+	    $disk_env{$key} = $value;
 	}
-	@oldenv=<$fh>;
-	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;
-	    }
-        }
+	untie(%disk_env);
     }
-    {
-	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';
 }
 # ----------------------------------------------------- Delete from Environment
@@ -406,43 +385,15 @@ sub delenv {
                 "Attempt to delete from environment ".$delthis);
         return 'error';
     }
-    my @oldenv;
-    {
-	my $fh;
-	unless (open($fh,"$env{'user.environment'}")) {
-	    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);
+    if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(),
+	    0640)) {
+	foreach my $key (keys(%disk_env)) {
+	    if ($key=~/^$delthis/) { 
                 delete($env{$key});
-            } else {
-                print $fh $cur_key; 
+                delete($disk_env{$key});
             }
 	}
-	close($fh);
+	untie(%disk_env);
     }
     return 'ok';
 }
@@ -499,60 +450,41 @@ sub overloaderror {
 
 sub spareserver {
     my ($loadpercent,$userloadpercent,$want_server_name) = @_;
-    my $spare_server;
+    my $tryserver;
+    my $spareserver='';
     if ($userloadpercent !~ /\d/) { $userloadpercent=0; }
-    my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent 
-                                                     :  $userloadpercent;
-    
-    foreach my $try_server (@{ $spareid{'primary'} }) {
-	($spare_server, $lowest_load) =
-	    &compare_server_load($try_server, $spare_server, $lowest_load);
-    }
-
-    my $found_server = ($spare_server ne '' && $lowest_load < 100);
-
-    if (!$found_server) {
-	foreach my $try_server (@{ $spareid{'default'} }) {
-	    ($spare_server, $lowest_load) =
-		&compare_server_load($try_server, $spare_server, $lowest_load);
-	}
-    }
-
-    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;
+    my $lowestserver=$loadpercent > $userloadpercent?
+	             $loadpercent :  $userloadpercent;
+    foreach $tryserver (keys(%spareid)) {
+	my $loadans=&reply('load',$tryserver);
+	my $userloadans=&reply('userload',$tryserver);
+	if ($loadans !~ /\d/ && $userloadans !~ /\d/) {
+	    next; #didn't get a number from the server
+	}
+	my $answer;
+	if ($loadans =~ /\d/) {
+	    if ($userloadans =~ /\d/) {
+		#both are numbers, pick the bigger one
+		$answer=$loadans > $userloadans?
+		    $loadans :  $userloadans;
+	    } else {
+		$answer = $loadans;
+	    }
 	} 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
 
 sub changepass {
@@ -1219,6 +1151,15 @@ sub absolute_url {
     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 {
 
     my ($fn,%form)=@_;
@@ -6573,7 +6514,6 @@ sub rndseed {
     if (!$domain) { $domain=$wdomain; }
     if (!$username) { $username=$wusername }
     my $which=&get_rand_alg();
-
     if (defined(&getCODE())) {
 	if ($which eq '64bit5') {
 	    return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username);
@@ -6631,6 +6571,7 @@ sub rndseed_64bit {
 	#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
 	#&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); }
 	return "$num1,$num2";
     }
 }
@@ -6653,7 +6594,6 @@ sub rndseed_64bit2 {
 	my $num2=$nameseed+$domainseed+$courseseed;
 	#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
 	#&Apache::lonxml::debug("rndseed :$num:$symb");
-	if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
 	return "$num1,$num2";
     }
 }
@@ -7229,9 +7169,7 @@ sub get_iphost {
     while (my $configline=<$config>) {
        chomp($configline);
        if ($configline) {
-	   my ($host,$type) = split(':',$configline,2);
-	   if (!defined($type) || $type eq '') { $type = 'default' };
-	   push(@{ $spareid{$type} }, $host);
+          $spareid{$configline}=1;
        }
     }
     close($config);
@@ -7293,9 +7231,7 @@ sub get_iphost {
 
 }
 
-$memcache=new Cache::Memcached({'servers'           => ['127.0.0.1:11211'],
-				'compress_threshold'=> 20_000,
- 			        });
+$memcache=new Cache::Memcached({'servers'=>['127.0.0.1:11211']});
 
 $processmarker='_'.time.'_'.$perlvar{'lonHostID'};
 $dumpcount=0;