--- loncom/lonnet/perl/lonnet.pm	2006/08/04 19:42:59	1.768
+++ loncom/lonnet/perl/lonnet.pm	2006/10/20 20:39:44	1.782.2.4
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.768 2006/08/04 19:42:59 albertel Exp $
+# $Id: lonnet.pm,v 1.782.2.4 2006/10/20 20:39:44 albertel Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -293,9 +293,11 @@ sub error {
 }
 
 # ------------------------------------------- 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'};
     }
@@ -325,6 +327,7 @@ sub transfer_profile_to_env {
         }
     }
     $env{'user.environment'} = "$lonidsdir/$handle.id";
+    $env_loaded=1;
     foreach my $expired_key (keys(%Remove)) {
         &delenv($expired_key);
     }
@@ -344,6 +347,11 @@ 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'}")) {
@@ -369,8 +377,6 @@ sub appenv {
         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;
 	    }
@@ -383,7 +389,7 @@ sub appenv {
 	}
 	my $newname;
 	foreach $newname (keys %newenv) {
-	    print $fh &escape($newname).'='.&escape($newenv{$newname})."\n";
+	    print $fh $newname.'='.$newenv{$newname}."\n";
 	}
 	close($fh);
     }
@@ -493,41 +499,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 +916,7 @@ sub save_cache {
     &purge_remembered();
     #&Apache::loncommon::validate_page();
     undef(%env);
+    undef($env_loaded);
 }
 
 my $to_remember=-1;
@@ -1176,7 +1202,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 +1210,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 +1230,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 +2880,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 +3509,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 +4109,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 +4120,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 +4228,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 +4966,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 +5788,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};
@@ -7088,29 +7145,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 +7228,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);
@@ -7254,7 +7292,9 @@ 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'};
 $dumpcount=0;