--- loncom/lonnet/perl/lonnet.pm	2006/09/19 19:03:24	1.782
+++ 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 2006/09/19 19:03:24 albertel Exp $
+# $Id: lonnet.pm,v 1.783 2006/09/19 21:36:41 albertel Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -292,6 +292,30 @@ 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 {
@@ -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);
+	untie(%disk_env);
     }
-    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';
 }
 # ----------------------------------------------------- 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';
 }
@@ -1193,6 +1144,15 @@ sub ssi_body {
 
 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 absolute_url {
+    my ($host_name) = @_;
     my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://');
     if ($host_name eq '') {
 	$host_name = $ENV{'SERVER_NAME'};