version 1.778, 2006/09/05 20:42:15
|
version 1.788, 2006/10/04 19:48:32
|
Line 292 sub error {
|
Line 292 sub error {
|
return undef; |
return undef; |
} |
} |
|
|
# ------------------------------------------- Transfer profile into environment |
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 { |
sub transfer_profile_to_env { |
my ($lonidsdir,$handle)=@_; |
my ($lonidsdir,$handle,$force_transfer) = @_; |
|
if (!$force_transfer && $env_loaded) { return; } |
|
|
if (!defined($lonidsdir)) { |
if (!defined($lonidsdir)) { |
$lonidsdir = $perlvar{'lonIDsDir'}; |
$lonidsdir = $perlvar{'lonIDsDir'}; |
} |
} |
Line 303 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"; |
foreach my $expired_key (keys(%Remove)) { |
$env_loaded=1; |
|
foreach my $expired_key (keys(%remove)) { |
&delenv($expired_key); |
&delenv($expired_key); |
} |
} |
} |
} |
Line 344 sub appenv {
|
Line 381 sub appenv {
|
$env{$key}=$newenv{$key}; |
$env{$key}=$newenv{$key}; |
} |
} |
} |
} |
|
if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(), |
my $lockfh; |
0640)) { |
unless (open($lockfh,"$env{'user.environment'}")) { |
while (my ($key,$value) = each(%newenv)) { |
return 'error: '.$!; |
$disk_env{$key} = $value; |
} |
|
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>; |
|
close($fh); |
|
} |
|
for (my $i=0; $i<=$#oldenv; $i++) { |
|
chomp($oldenv[$i]); |
|
if ($oldenv[$i] ne '') { |
|
my ($name,$value)=split(/=/,$oldenv[$i],2); |
|
$name=&unescape($name); |
|
$value=&unescape($value); |
|
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 &escape($newname).'='.&escape($newenv{$newname})."\n"; |
|
} |
} |
close($fh); |
untie(%disk_env); |
} |
} |
|
|
close($lockfh); |
|
return 'ok'; |
return 'ok'; |
} |
} |
# ----------------------------------------------------- Delete from Environment |
# ----------------------------------------------------- Delete from Environment |
Line 400 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 493 sub overloaderror {
|
Line 464 sub overloaderror {
|
|
|
sub spareserver { |
sub spareserver { |
my ($loadpercent,$userloadpercent,$want_server_name) = @_; |
my ($loadpercent,$userloadpercent,$want_server_name) = @_; |
my $tryserver; |
my $spare_server; |
my $spareserver=''; |
|
if ($userloadpercent !~ /\d/) { $userloadpercent=0; } |
if ($userloadpercent !~ /\d/) { $userloadpercent=0; } |
my $lowestserver=$loadpercent > $userloadpercent? |
my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent |
$loadpercent : $userloadpercent; |
: $userloadpercent; |
foreach $tryserver (keys(%spareid)) { |
|
my $loadans=&reply('load',$tryserver); |
foreach my $try_server (@{ $spareid{'primary'} }) { |
my $userloadans=&reply('userload',$tryserver); |
($spare_server, $lowest_load) = |
if ($loadans !~ /\d/ && $userloadans !~ /\d/) { |
&compare_server_load($try_server, $spare_server, $lowest_load); |
next; #didn't get a number from the server |
} |
} |
|
my $answer; |
my $found_server = ($spare_server ne '' && $lowest_load < 100); |
if ($loadans =~ /\d/) { |
|
if ($userloadans =~ /\d/) { |
if (!$found_server) { |
#both are numbers, pick the bigger one |
foreach my $try_server (@{ $spareid{'default'} }) { |
$answer=$loadans > $userloadans? |
($spare_server, $lowest_load) = |
$loadans : $userloadans; |
&compare_server_load($try_server, $spare_server, $lowest_load); |
} else { |
|
$answer = $loadans; |
|
} |
|
} else { |
|
$answer = $userloadans; |
|
} |
|
if (($answer =~ /\d/) && ($answer<$lowestserver)) { |
|
if ($want_server_name) { |
|
$spareserver=$tryserver; |
|
} else { |
|
$spareserver="http://$hostname{$tryserver}"; |
|
} |
|
$lowestserver=$answer; |
|
} |
} |
} |
} |
return $spareserver; |
|
|
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 { |
|
$load = $loadans; |
|
} |
|
} else { |
|
$load = $userloadans; |
|
} |
|
|
|
if (($load =~ /\d/) && ($load < $lowest_load)) { |
|
$spare_server = $try_server; |
|
$lowest_load = $load; |
|
} |
|
return ($spare_server,$lowest_load); |
|
} |
# --------------------------------------------- Try to change a user's password |
# --------------------------------------------- Try to change a user's password |
|
|
sub changepass { |
sub changepass { |
Line 891 sub save_cache {
|
Line 881 sub save_cache {
|
&purge_remembered(); |
&purge_remembered(); |
#&Apache::loncommon::validate_page(); |
#&Apache::loncommon::validate_page(); |
undef(%env); |
undef(%env); |
|
undef($env_loaded); |
} |
} |
|
|
my $to_remember=-1; |
my $to_remember=-1; |
Line 1184 sub ssi_body {
|
Line 1175 sub ssi_body {
|
|
|
# --------------------------------------------------------- Server Side Include |
# --------------------------------------------------------- Server Side Include |
|
|
|
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'}; |
|
} |
|
return $protocol.$host_name; |
|
} |
|
|
sub ssi { |
sub ssi { |
|
|
my ($fn,%form)=@_; |
my ($fn,%form)=@_; |
Line 1195 sub ssi {
|
Line 1204 sub ssi {
|
$form{'no_update_last_known'}=1; |
$form{'no_update_last_known'}=1; |
|
|
if (%form) { |
if (%form) { |
$request=new HTTP::Request('POST',"http://".$ENV{'HTTP_HOST'}.$fn); |
$request=new HTTP::Request('POST',&absolute_url().$fn); |
$request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form)); |
$request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form)); |
} else { |
} else { |
$request=new HTTP::Request('GET',"http://".$ENV{'HTTP_HOST'}.$fn); |
$request=new HTTP::Request('GET',&absolute_url().$fn); |
} |
} |
|
|
$request->header(Cookie => $ENV{'HTTP_COOKIE'}); |
$request->header(Cookie => $ENV{'HTTP_COOKIE'}); |
Line 5277 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 6219 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 7058 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 7110 BEGIN {
|
Line 7120 BEGIN {
|
# ----------------------------------- Read loncapa.conf and loncapa_apache.conf |
# ----------------------------------- Read loncapa.conf and loncapa_apache.conf |
unless ($readit) { |
unless ($readit) { |
{ |
{ |
# FIXME: Use LONCAPA::Configuration::read_conf here and omit next block |
my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf'); |
open(my $config,"</etc/httpd/conf/loncapa.conf"); |
%perlvar = (%perlvar,%{$configvars}); |
|
|
while (my $configline=<$config>) { |
|
if ($configline=~/\S/ && $configline =~ /^[^\#]*PerlSetVar/) { |
|
my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); |
|
chomp($varvalue); |
|
$perlvar{$varname}=$varvalue; |
|
} |
|
} |
|
close($config); |
|
} |
|
{ |
|
open(my $config,"</etc/httpd/conf/loncapa_apache.conf"); |
|
|
|
while (my $configline=<$config>) { |
|
if ($configline =~ /^[^\#]*PerlSetVar/) { |
|
my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); |
|
chomp($varvalue); |
|
$perlvar{$varname}=$varvalue; |
|
} |
|
} |
|
close($config); |
|
} |
} |
|
|
# ------------------------------------------------------------ Read domain file |
# ------------------------------------------------------------ Read domain file |
Line 7214 sub get_iphost {
|
Line 7203 sub get_iphost {
|
while (my $configline=<$config>) { |
while (my $configline=<$config>) { |
chomp($configline); |
chomp($configline); |
if ($configline) { |
if ($configline) { |
$spareid{$configline}=1; |
my ($host,$type) = split(':',$configline,2); |
|
if (!defined($type) || $type eq '') { $type = 'default' }; |
|
push(@{ $spareid{$type} }, $host); |
} |
} |
} |
} |
close($config); |
close($config); |