--- loncom/lonnet/perl/lonnet.pm 2006/10/20 20:39:44 1.782.2.4 +++ loncom/lonnet/perl/lonnet.pm 2006/09/28 21:24:56 1.786 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.782.2.4 2006/10/20 20:39:44 albertel Exp $ +# $Id: lonnet.pm,v 1.786 2006/09/28 21:24:56 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -292,12 +292,40 @@ 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) { + if ($line !~ m/=/) { + return 0; + } + 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); + } + return 1; +} + # ------------------------------------------- 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 +333,36 @@ sub transfer_profile_to_env { ($handle) = ($env{'user.environment'} =~m|/([^/]+)\.id$| ); } - my @profile; + my $convert; { - open(my $idf,"$lonidsdir/$handle.id"); + open(my $idf,"$lonidsdir/$handle.id"); flock($idf,LOCK_SH); - @profile=<$idf>; - close($idf); + 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 = 1; + } } - 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; + 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) ) { 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 +381,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("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>; - 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"; + if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(), + 0640)) { + while (my ($key,$value) = each(%newenv)) { + $disk_env{$key} = $value; } - close($fh); + untie(%disk_env); } - - close($lockfh); return 'ok'; } # ----------------------------------------------------- Delete from Environment @@ -406,43 +399,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("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("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'; } @@ -1219,6 +1184,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)=@_; @@ -7292,9 +7266,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;