version 1.782.2.4, 2006/10/20 20:39:44
|
version 1.788, 2006/10/04 19:48:32
|
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) { |
|
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 |
# ------------------------------------------- Transfer profile into environment |
my $env_loaded; |
my $env_loaded; |
sub transfer_profile_to_env { |
sub transfer_profile_to_env { |
Line 305 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 @profile; |
my $convert; |
{ |
{ |
open(my $idf,"$lonidsdir/$handle.id"); |
open(my $idf,"$lonidsdir/$handle.id"); |
flock($idf,LOCK_SH); |
flock($idf,LOCK_SH); |
@profile=<$idf>; |
if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id", |
close($idf); |
&GDBM_READER(),0640)) { |
|
@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 $envi; |
|
my %Remove; |
my %remove; |
for ($envi=0;$envi<=$#profile;$envi++) { |
while ( my $envname = each(%env) ) { |
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 381 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 399 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 1219 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 5312 sub GetFileTimestamp {
|
Line 5286 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 6254 sub symblist {
|
Line 6223 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 7093 sub clutter {
|
Line 7059 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 7292 sub get_iphost {
|
Line 7267 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; |