--- loncom/lonnet/perl/lonnet.pm 2006/08/02 19:29:32 1.767
+++ loncom/lonnet/perl/lonnet.pm 2006/09/28 20:03:55 1.785
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.767 2006/08/02 19:29:32 albertel Exp $
+# $Id: lonnet.pm,v 1.785 2006/09/28 20:03:55 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -292,9 +292,35 @@ 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) {
+ 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 {
+ if ($env_loaded) { return; }
+
my ($lonidsdir,$handle)=@_;
if (!defined($lonidsdir)) {
$lonidsdir = $perlvar{'lonIDsDir'};
@@ -303,29 +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";
- foreach my $expired_key (keys(%Remove)) {
+ $env_loaded=1;
+ foreach my $expired_key (keys(%remove)) {
&delenv($expired_key);
}
}
@@ -344,51 +367,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: '.$!;
- }
- @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";
+ 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
@@ -400,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';
}
@@ -493,41 +450,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 +867,7 @@ sub save_cache {
&purge_remembered();
#&Apache::loncommon::validate_page();
undef(%env);
+ undef($env_loaded);
}
my $to_remember=-1;
@@ -1176,7 +1153,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 +1161,24 @@ 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 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 +1190,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'});
@@ -2845,7 +2840,7 @@ sub set_userprivs {
if (keys(%{$allgroups}) > 0) {
foreach my $role (keys %{$allroles}) {
my ($trole,$area,$sec,$extendedarea);
- if ($role =~ m|^(\w+)\.(/\w+/\w+)(/?\w*)|) {
+ if ($role =~ m-^(\w+|cr/\w+/\w+/\w+)\.(/\w+/\w+)(/?\w*)-) {
$trole = $1;
$area = $2;
$sec = $3;
@@ -3474,8 +3469,9 @@ sub allowed {
if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }
# Free bre access to adm and meta resources
- if (((($uri=~/^adm\//) && ($uri !~ m|/bulletinboard$|))
- || ($uri=~/\.meta$/)) && ($priv eq 'bre')) {
+ if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard)$}))
+ || (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) ))
+ && ($priv eq 'bre')) {
return 'F';
}
@@ -4073,7 +4069,7 @@ sub auto_run {
my $response = &reply('autorun:'.$cdom,$homeserver);
return $response;
}
-
+
sub auto_get_sections {
my ($cnum,$cdom,$inst_coursecode) = @_;
my $homeserver = &homeserver($cnum,$cdom);
@@ -4084,21 +4080,21 @@ sub auto_get_sections {
}
return @secs;
}
-
+
sub auto_new_course {
my ($cnum,$cdom,$inst_course_id,$owner) = @_;
my $homeserver = &homeserver($cnum,$cdom);
my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.$owner.':'.$cdom,$homeserver));
return $response;
}
-
+
sub auto_validate_courseID {
my ($cnum,$cdom,$inst_course_id) = @_;
my $homeserver = &homeserver($cnum,$cdom);
my $response=&unescape(&reply('autovalidatecourse:'.$inst_course_id.':'.$cdom,$homeserver));
return $response;
}
-
+
sub auto_create_password {
my ($cnum,$cdom,$authparam) = @_;
my $homeserver = &homeserver($cnum,$cdom);
@@ -4192,33 +4188,49 @@ sub auto_photoupdate {
sub auto_instcode_format {
my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,$cat_order) = @_;
my $courses = '';
- my $homeserver;
+ my @homeservers;
if ($caller eq 'global') {
foreach my $tryserver (keys %libserv) {
if ($hostdom{$tryserver} eq $codedom) {
- $homeserver = $tryserver;
- last;
+ if (!grep/^\Q$tryserver\E$/,@homeservers) {
+ push(@homeservers,$tryserver);
+ }
}
}
- if (($env{'user.name'}) && ($env{'user.domain'} eq $codedom)) {
- $homeserver = &homeserver($env{'user.name'},$codedom);
- }
} else {
- $homeserver = &homeserver($caller,$codedom);
+ push(@homeservers,&homeserver($caller,$codedom));
}
foreach (keys %{$instcodes}) {
$courses .= &escape($_).'='.&escape($$instcodes{$_}).'&';
}
chop($courses);
- my $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$homeserver);
- unless ($response =~ /(con_lost|error|no_such_host|refused)/) {
- my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = split/:/,$response;
- %{$codes} = &str2hash($codes_str);
- @{$codetitles} = &str2array($codetitles_str);
- %{$cat_titles} = &str2hash($cat_titles_str);
- %{$cat_order} = &str2hash($cat_order_str);
+ my $ok_response = 0;
+ my $response;
+ while (@homeservers > 0 && $ok_response == 0) {
+ my $server = shift(@homeservers);
+ $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$server);
+ if ($response !~ /(con_lost|error|no_such_host|refused)/) {
+ my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) =
+ split/:/,$response;
+ %{$codes} = (%{$codes},&str2hash($codes_str));
+ push(@{$codetitles},&str2array($codetitles_str));
+ %{$cat_titles} = (%{$cat_titles},&str2hash($cat_titles_str));
+ %{$cat_order} = (%{$cat_order},&str2hash($cat_order_str));
+ $ok_response = 1;
+ }
+ }
+ if ($ok_response) {
return 'ok';
+ } else {
+ return $response;
}
+}
+
+sub auto_validate_class_sec {
+ my ($cdom,$cnum,$owner,$inst_class) = @_;
+ my $homeserver = &homeserver($cnum,$cdom);
+ my $response=&reply('autovalidateclass_sec:'.$inst_class.':'.
+ &escape($owner).':'.$cdom,$homeserver);
return $response;
}
@@ -4914,11 +4926,13 @@ sub get_portfile_permissions {
sub get_access_controls {
my ($current_permissions,$group,$file) = @_;
- my %access;
+ my %access;
+ my $real_file = $file;
+ $file =~ s/\.meta$//;
if (defined($file)) {
if (ref($$current_permissions{$file."\0".'accesscontrol'}) eq 'HASH') {
foreach my $control (keys(%{$$current_permissions{$file."\0".'accesscontrol'}})) {
- $access{$file}{$control} = $$current_permissions{$file."\0".$control};
+ $access{$real_file}{$control} = $$current_permissions{$file."\0".$control};
}
}
} else {
@@ -5734,6 +5748,9 @@ sub EXT {
if (($uname eq $env{'user.name'})&&($udom eq $env{'user.domain'})) {
return $env{'environment.'.$spacequalifierrest};
} else {
+ if ($uname eq 'anonymous' && $udom eq '') {
+ return '';
+ }
my %returnhash=&userenvironment($udom,$uname,
$spacequalifierrest);
return $returnhash{$spacequalifierrest};
@@ -5884,7 +5901,7 @@ sub metadata {
my %metathesekeys=();
unless ($filename=~/\.meta$/) { $filename.='.meta'; }
my $metastring;
- if ($uri !~ m -^(uploaded|editupload)/-) {
+ if ($uri !~ m -^(editupload)/-) {
my $file=&filelocation('',&clutter($filename));
#push(@{$metaentry{$uri.'.file'}},$file);
$metastring=&getfile($file);
@@ -7088,29 +7105,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
@@ -7192,7 +7188,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);