--- loncom/lonnet/perl/lonnet.pm 2006/08/31 12:30:23 1.777
+++ loncom/lonnet/perl/lonnet.pm 2006/10/04 21:02:41 1.789
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.777 2006/08/31 12:30:23 albertel Exp $
+# $Id: lonnet.pm,v 1.789 2006/10/04 21:02:41 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -292,10 +292,40 @@ sub error {
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 {
- my ($lonidsdir,$handle)=@_;
+ my ($lonidsdir,$handle,$force_transfer) = @_;
+ if (!$force_transfer && $env_loaded) { return; }
+
if (!defined($lonidsdir)) {
$lonidsdir = $perlvar{'lonIDsDir'};
}
@@ -303,29 +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;
+ }
+ }
+ if ($convert) {
+ if (!&convert_and_load_session_env($lonidsdir,$handle)) {
+ &logthis("Failed to load session, or convert session.");
+ }
}
- 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;
+
+ 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";
- foreach my $expired_key (keys(%Remove)) {
+ $env_loaded=1;
+ foreach my $expired_key (keys(%remove)) {
&delenv($expired_key);
}
}
@@ -344,51 +381,13 @@ sub appenv {
$env{$key}=$newenv{$key};
}
}
-
- 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);
- $name=&unescape($name);
- $value=&unescape($value);
- 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 &escape($newname).'='.&escape($newenv{$newname})."\n";
- }
- close($fh);
- }
-
- close($lockfh);
return 'ok';
}
# ----------------------------------------------------- Delete from Environment
@@ -400,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("<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';
}
@@ -493,41 +464,60 @@ sub overloaderror {
sub spareserver {
my ($loadpercent,$userloadpercent,$want_server_name) = @_;
- my $tryserver;
- my $spareserver='';
+ my $spare_server;
if ($userloadpercent !~ /\d/) { $userloadpercent=0; }
- 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 {
- $answer = $userloadans;
- }
- if (($answer =~ /\d/) && ($answer<$lowestserver)) {
- if ($want_server_name) {
- $spareserver=$tryserver;
- } else {
- $spareserver="http://$hostname{$tryserver}";
- }
- $lowestserver=$answer;
+ 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);
}
}
- 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
sub changepass {
@@ -891,6 +881,7 @@ sub save_cache {
&purge_remembered();
#&Apache::loncommon::validate_page();
undef(%env);
+ undef($env_loaded);
}
my $to_remember=-1;
@@ -1176,7 +1167,7 @@ sub ssi_body {
}
my $output=($filelink=~/^http\:/?&externalssi($filelink):
&ssi($filelink,%form));
- $output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+// END LON-CAPA Internal\s*(-->)?\s||gs;
+ $output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+?// END LON-CAPA Internal\s*(-->)?\s||gs;
$output=~s/^.*?\<body[^\>]*\>//si;
$output=~s/(.*)\<\/body\s*\>.*?$/$1/si;
return $output;
@@ -1184,6 +1175,15 @@ sub ssi_body {
# --------------------------------------------------------- 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 ssi {
my ($fn,%form)=@_;
@@ -1195,10 +1195,10 @@ sub ssi {
$form{'no_update_last_known'}=1;
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));
} 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'});
@@ -5277,13 +5277,8 @@ sub GetFileTimestamp {
sub stat_file {
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);
if ($uri =~ m-^/(uploaded|editupload)/-) {
($udom,$uname,$file) =
@@ -6219,9 +6214,6 @@ sub symblist {
sub symbverify {
my ($symb,$thisurl)=@_;
my $thisfn=$thisurl;
-# wrapper not part of symbs
- $thisfn=~s/^\/adm\/wrapper//;
- $thisfn=~s/^\/adm\/coursedocs\/showdoc\///;
$thisfn=&declutter($thisfn);
# direct jump to resource in page or to a sequence - will construct own symbs
if ($thisfn=~/\.(page|sequence)$/) { return 1; }
@@ -7058,6 +7050,15 @@ sub clutter {
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 {
my ($value)=@_;
if (ref($value)) {
@@ -7110,29 +7111,8 @@ BEGIN {
# ----------------------------------- Read loncapa.conf and loncapa_apache.conf
unless ($readit) {
{
- # FIXME: Use LONCAPA::Configuration::read_conf here and omit next block
- open(my $config,"</etc/httpd/conf/loncapa.conf");
-
- 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);
+ my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf');
+ %perlvar = (%perlvar,%{$configvars});
}
# ------------------------------------------------------------ Read domain file
@@ -7214,7 +7194,9 @@ sub get_iphost {
while (my $configline=<$config>) {
chomp($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);