--- loncom/lonnet/perl/lonnet.pm	2007/02/23 15:49:23	1.836
+++ loncom/lonnet/perl/lonnet.pm	2007/03/03 01:54:13	1.842
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.836 2007/02/23 15:49:23 www Exp $
+# $Id: lonnet.pm,v 1.842 2007/03/03 01:54:13 albertel Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -35,7 +35,7 @@ use HTTP::Headers;
 use HTTP::Date;
 # use Date::Parse;
 use vars 
-qw(%perlvar %hostname %badServerCache %iphost %spareid %hostdom 
+qw(%perlvar %badServerCache %iphost %spareid %hostdom 
    %libserv %pr %prp $memcache %packagetab 
    %courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount 
    %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %coursetypebuf
@@ -149,7 +149,7 @@ sub logperm {
 # -------------------------------------------------- Non-critical communication
 sub subreply {
     my ($cmd,$server)=@_;
-    my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$server};
+    my $peerfile="$perlvar{'lonSockDir'}/".&hostname($server);
     #
     #  With loncnew process trimming, there's a timing hole between lonc server
     #  process exit and the master server picking up the listen on the AF_UNIX
@@ -189,7 +189,7 @@ sub subreply {
 
 sub reply {
     my ($cmd,$server)=@_;
-    unless (defined($hostname{$server})) { return 'no_such_host'; }
+    unless (defined(&hostname($server))) { return 'no_such_host'; }
     my $answer=subreply($cmd,$server);
     if (($answer=~/^refused/) || ($answer=~/^rejected/)) {
        &logthis("<font color=\"blue\">WARNING:".
@@ -224,7 +224,7 @@ sub reconlonc {
 
 sub critical {
     my ($cmd,$server)=@_;
-    unless ($hostname{$server}) {
+    unless (&hostname($server)) {
         &logthis("<font color=\"blue\">WARNING:".
                " Critical message to unknown server ($server)</font>");
         return 'no_such_host';
@@ -517,7 +517,7 @@ sub spareserver {
     }
 
     if (!$want_server_name) {
-	$spare_server="http://$hostname{$spare_server}";
+	$spare_server="http://".&hostname($spare_server);
     }
     return $spare_server;
 }
@@ -640,19 +640,19 @@ sub homeserver {
     my $index="$uname:$udom";
 
     if (exists($homecache{$index})) { return $homecache{$index}; }
-    my $tryserver;
-    foreach $tryserver (keys %libserv) {
+
+    my %servers = &get_servers($udom,'library');
+    foreach my $tryserver (keys(%servers)) {
         next if ($ignoreBadCache ne 'true' && 
 		 exists($badServerCache{$tryserver}));
-	if ($hostdom{$tryserver} eq $udom) {
-           my $answer=reply("home:$udom:$uname",$tryserver);
-           if ($answer eq 'found') {
-               delete($badServerCache{$tryserver}); 
-	       return $homecache{$index}=$tryserver;
-           } elsif ($answer eq 'no_host') {
-	       $badServerCache{$tryserver}=1;
-           }
-       }
+
+	my $answer=reply("home:$udom:$uname",$tryserver);
+	if ($answer eq 'found') {
+	    delete($badServerCache{$tryserver}); 
+	    return $homecache{$index}=$tryserver;
+	} elsif ($answer eq 'no_host') {
+	    $badServerCache{$tryserver}=1;
+	}
     }    
     return 'no_host';
 }
@@ -663,24 +663,22 @@ sub idget {
     my ($udom,@ids)=@_;
     my %returnhash=();
     
-    my $tryserver;
-    foreach $tryserver (keys %libserv) {
-       if ($hostdom{$tryserver} eq $udom) {
-	  my $idlist=join('&',@ids);
-          $idlist=~tr/A-Z/a-z/; 
-	  my $reply=&reply("idget:$udom:".$idlist,$tryserver);
-          my @answer=();
-          if (($reply ne 'con_lost') && ($reply!~/^error\:/)) {
-	      @answer=split(/\&/,$reply);
-          }                    ;
-          my $i;
-          for ($i=0;$i<=$#ids;$i++) {
-              if ($answer[$i]) {
-		  $returnhash{$ids[$i]}=$answer[$i];
-              } 
-          }
-       }
-    }    
+    my %servers = &get_servers($udom,'library');
+    foreach my $tryserver (keys(%servers)) {
+	my $idlist=join('&',@ids);
+	$idlist=~tr/A-Z/a-z/; 
+	my $reply=&reply("idget:$udom:".$idlist,$tryserver);
+	my @answer=();
+	if (($reply ne 'con_lost') && ($reply!~/^error\:/)) {
+	    @answer=split(/\&/,$reply);
+	}                    ;
+	my $i;
+	for ($i=0;$i<=$#ids;$i++) {
+	    if ($answer[$i]) {
+		$returnhash{$ids[$i]}=$answer[$i];
+	    } 
+	}
+    } 
     return %returnhash;
 }
 
@@ -766,6 +764,30 @@ sub put_dom {
     }
 }
 
+sub retrieve_inst_usertypes {
+    my ($udom) = @_;
+    my (%returnhash,@order);
+    if (exists($domain_primary{$udom})) {
+        my $uhome=$domain_primary{$udom};
+        my $rep=&reply("inst_usertypes:$udom",$uhome);
+        my ($hashitems,$orderitems) = split(/:/,$rep); 
+        my @pairs=split(/\&/,$hashitems);
+        foreach my $item (@pairs) {
+            my ($key,$value)=split(/=/,$item,2);
+            $key = &unescape($key);
+            next if ($key =~ /^error: 2 /);
+            $returnhash{$key}=&thaw_unescape($value);
+        }
+        my @esc_order = split(/\&/,$orderitems);
+        foreach my $item (@esc_order) {
+            push(@order,&unescape($item));
+        }
+    } else {
+        &logthis("get_dom failed - no primary domain server for $udom");
+    }
+    return (\%returnhash,\@order);
+}
+
 # --------------------------------------------------- Assign a key to a student
 
 sub assign_access_key {
@@ -1819,8 +1841,9 @@ sub flushcourselogs {
 # Write course id database (reverse lookup) to homeserver of courses 
 # Is used in pickcourse
 #
-    foreach my $crsid (keys(%courseidbuffer)) {
-        &courseidput($hostdom{$crsid},$courseidbuffer{$crsid},$crsid);
+    foreach my $crs_home (keys(%courseidbuffer)) {
+        &courseidput($hostdom{$crs_home},$courseidbuffer{$crs_home},
+		     $crs_home);
     }
 #
 # File accesses
@@ -1887,13 +1910,12 @@ sub flushcourselogs {
         delete $domainrolehash{$entry};
     }
     foreach my $dom (keys(%domrolebuffer)) {
-        foreach my $tryserver (keys %libserv) {
-            if ($hostdom{$tryserver} eq $dom) {
-                unless (&reply('domroleput:'.$dom.':'.
-                  $domrolebuffer{$dom},$tryserver) eq 'ok') {
-                    &logthis('Put of domain roles failed for '.$dom.' and  '.$tryserver);
-                }
-            }
+	my %servers = &get_servers($dom,'library');
+	foreach my $tryserver (keys(%servers)) {
+	    unless (&reply('domroleput:'.$dom.':'.
+			   $domrolebuffer{$dom},$tryserver) eq 'ok') {
+		&logthis('Put of domain roles failed for '.$dom.' and  '.$tryserver);
+	    }
         }
     }
     $dumpcount++;
@@ -2169,19 +2191,19 @@ sub get_domain_roles {
     }
     my $rolelist = join(':',@{$roles});
     my %personnel = ();
-    foreach my $tryserver (keys(%libserv)) {
-        if ($hostdom{$tryserver} eq $dom) {
-            %{$personnel{$tryserver}}=();
-            foreach my $line (
-                split(/\&/,&reply('domrolesdump:'.$dom.':'.
-                   &escape($startdate).':'.&escape($enddate).':'.
-                   &escape($rolelist), $tryserver))) {
-                my ($key,$value) = split(/\=/,$line,2);
-                if (($key) && ($value)) {
-                    $personnel{$tryserver}{&unescape($key)} = &unescape($value);
-                }
-            }
-        }
+
+    my %servers = &get_servers($dom,'library');
+    foreach my $tryserver (keys(%servers)) {
+	%{$personnel{$tryserver}}=();
+	foreach my $line (split(/\&/,&reply('domrolesdump:'.$dom.':'.
+					    &escape($startdate).':'.
+					    &escape($enddate).':'.
+					    &escape($rolelist), $tryserver))) {
+	    my ($key,$value) = split(/\=/,$line,2);
+	    if (($key) && ($value)) {
+		$personnel{$tryserver}{&unescape($key)} = &unescape($value);
+	    }
+	}
     }
     return %personnel;
 }
@@ -2271,7 +2293,7 @@ sub checkin {
     my $now=time;
     my ($ta,$tb,$lonhost)=split(/\*/,$token);
     $lonhost=~tr/A-Z/a-z/;
-    my $dtoken=$ta.'_'.$hostname{$lonhost}.'_'.$tb;
+    my $dtoken=$ta.'_'.&hostname($lonhost).'_'.$tb;
     $dtoken=~s/\W/\_/g;
     my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
                  split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));
@@ -2940,7 +2962,7 @@ sub custom_roleprivs {
     my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_;
     my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
     my $homsvr=homeserver($rauthor,$rdomain);
-    if ($hostname{$homsvr} ne '') {
+    if (&hostname($homsvr) ne '') {
         my ($rdummy,$roledef)=
             &get('roles',["rolesdef_$rrole"],$rdomain,$rauthor);
         if (($rdummy ne 'con_lost') && ($roledef ne '')) {
@@ -4171,7 +4193,7 @@ sub log_query {
     my ($uname,$udom,$query,%filters)=@_;
     my $uhome=&homeserver($uname,$udom);
     if ($uhome eq 'no_host') { return 'error: no_host'; }
-    my $uhost=$hostname{$uhome};
+    my $uhost=&hostname($uhome);
     my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys(%filters)));
     my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command,
                        $uhome);
@@ -4203,7 +4225,7 @@ sub fetch_enrollment_query {
     } else {
         $homeserver = &homeserver($cnum,$dom);
     }
-    my $host=$hostname{$homeserver};
+    my $host=&hostname($homeserver);
     my $cmd = '';
     foreach my $affiliate (keys %{$affiliatesref}) {
         $cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';
@@ -4394,7 +4416,7 @@ sub auto_photochoice {
 sub auto_photoupdate {
     my ($affiliatesref,$dom,$cnum,$photo) = @_;
     my $homeserver = &homeserver($cnum,$dom);
-    my $host=$hostname{$homeserver};
+    my $host=&hostname($homeserver);
     my $cmd = '';
     my $maxtries = 1;
     foreach my $affiliate (keys(%{$affiliatesref})) {
@@ -4434,12 +4456,11 @@ sub auto_instcode_format {
     my $courses = '';
     my @homeservers;
     if ($caller eq 'global') {
-        foreach my $tryserver (keys(%libserv)) {
-            if ($hostdom{$tryserver} eq $codedom) {
-                if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
-                    push(@homeservers,$tryserver);
-                }
-            }
+	my %servers = &get_servers($codedom,'library');
+	foreach my $tryserver (keys(%servers)) {
+	    if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
+		push(@homeservers,$tryserver);
+	    }
         }
     } else {
         push(@homeservers,&homeserver($caller,$codedom));
@@ -4473,35 +4494,31 @@ sub auto_instcode_format {
 sub auto_instcode_defaults {
     my ($domain,$returnhash,$code_order) = @_;
     my @homeservers;
-    foreach my $tryserver (keys(%libserv)) {
-        if ($hostdom{$tryserver} eq $domain) {
-            if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
-                push(@homeservers,$tryserver);
-            }
-        }
+
+    my %servers = &get_servers($domain,'library');
+    foreach my $tryserver (keys(%servers)) {
+	if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
+	    push(@homeservers,$tryserver);
+	}
     }
-    my $ok_response = 0;
+
     my $response;
-    while (@homeservers > 0 && $ok_response == 0) {
-        my $server = shift(@homeservers);
+    foreach my $server (@homeservers) {
         $response=&reply('autoinstcodedefaults:'.$domain,$server);
-        if ($response !~ /(con_lost|error|no_such_host|refused)/) {
-            foreach my $pair (split(/\&/,$response)) {
-                my ($name,$value)=split(/\=/,$pair);
-                if ($name eq 'code_order') {
-                    @{$code_order} = split(/\&/,&unescape($value));
-                } else {
-                    $returnhash->{&unescape($name)}=&unescape($value);
-                }
-            }
-            $ok_response = 1;
-        }
-    }
-    if ($ok_response) {
-        return 'ok';
-    } else {
-        return $response;
+        next if ($response =~ /(con_lost|error|no_such_host|refused)/);
+	
+	foreach my $pair (split(/\&/,$response)) {
+	    my ($name,$value)=split(/\=/,$pair);
+	    if ($name eq 'code_order') {
+		@{$code_order} = split(/\&/,&unescape($value));
+	    } else {
+		$returnhash->{&unescape($name)}=&unescape($value);
+	    }
+	}
+	return 'ok';
     }
+
+    return $response;
 } 
 
 sub auto_validate_class_sec {
@@ -4799,16 +4816,14 @@ sub modifyuser {
 	} elsif($env{'course.'.$env{'request.course.id'}.'.domain'} eq $udom) {
 	    $unhome=$env{'course.'.$env{'request.course.id'}.'.home'};
         } else { # load balancing routine for determining $unhome
-            my $tryserver;
             my $loadm=10000000;
-            foreach $tryserver (keys %libserv) {
-	       if ($hostdom{$tryserver} eq $udom) {
-                  my $answer=reply('load',$tryserver);
-                  if (($answer=~/\d+/) && ($answer<$loadm)) {
-		      $loadm=$answer;
-                      $unhome=$tryserver;
-                  }
-	       }
+	    my %servers = &get_servers($udom,'library');
+	    foreach my $tryserver (keys(%servers)) {
+		my $answer=reply('load',$tryserver);
+		if (($answer=~/\d+/) && ($answer<$loadm)) {
+		    $loadm=$answer;
+		    $unhome=$tryserver;
+		}
 	    }
         }
         if (($unhome eq '') || ($unhome eq 'no_host')) {
@@ -5556,28 +5571,27 @@ sub dirlist {
             return @listing_results;
         } elsif(!defined($alternateDirectoryRoot)) {
             my %allusers;
-            foreach my $tryserver (keys(%libserv)) {
-                if($hostdom{$tryserver} eq $udom) {
-                    my $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'.
-					 $udom, $tryserver);
-                    my @listing_results;
-                    if ($listing eq 'unknown_cmd') {
-                        $listing = &reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.
-					  $udom, $tryserver);
-                        @listing_results = split(/:/,$listing);
-                    } else {
-                        @listing_results =
-                            map { &unescape($_); } split(/:/,$listing);
-                    }
-                    if ($listing_results[0] ne 'no_such_dir' && 
-                        $listing_results[0] ne 'empty'       &&
-                        $listing_results[0] ne 'con_lost') {
-                        foreach my $line (@listing_results) {
-                            my ($entry) = split(/&/,$line,2);
-                            $allusers{$entry} = 1;
-                        }
-                    }
-                }
+	    my %servers = &get_servers($udom,'library');
+	    foreach my $tryserver (keys(%servers)) {
+		my $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'.
+				     $udom, $tryserver);
+		my @listing_results;
+		if ($listing eq 'unknown_cmd') {
+		    $listing = &reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.
+				      $udom, $tryserver);
+		    @listing_results = split(/:/,$listing);
+		} else {
+		    @listing_results =
+			map { &unescape($_); } split(/:/,$listing);
+		}
+		if ($listing_results[0] ne 'no_such_dir' && 
+		    $listing_results[0] ne 'empty'       &&
+		    $listing_results[0] ne 'con_lost') {
+		    foreach my $line (@listing_results) {
+			my ($entry) = split(/&/,$line,2);
+			$allusers{$entry} = 1;
+		    }
+		}
             }
             my $alluserstr='';
             foreach my $user (sort(keys(%allusers))) {
@@ -5589,18 +5603,12 @@ sub dirlist {
             return ('missing user name');
         }
     } elsif(!defined($alternateDirectoryRoot)) {
-        my $tryserver;
-        my %alldom=();
-        foreach $tryserver (keys(%libserv)) {
-            $alldom{$hostdom{$tryserver}}=1;
-        }
-        my $alldomstr='';
-        foreach my $domain (sort(keys(%alldom))) {
-            $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain:';
-        }
-        $alldomstr=~s/:$//;
-        return split(/:/,$alldomstr);       
-    } else {
+        my @all_domains = sort(&all_domains());
+         foreach my $domain (@all_domains) {
+             $domain = $perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain';
+         }
+         return @all_domains;
+     } else {
         return ('missing domain');
     }
 }
@@ -7262,7 +7270,7 @@ sub repcopy_userfile {
     if (-e $transferfile) { return 'ok'; }
     my $request;
     $uri=~s/^\///;
-    $request=new HTTP::Request('GET','http://'.$hostname{&homeserver($cnum,$cdom)}.'/raw/'.$uri);
+    $request=new HTTP::Request('GET','http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri);
     my $response=$ua->request($request,$transferfile);
 # did it work?
     if ($response->is_error()) {
@@ -7285,7 +7293,7 @@ sub tokenwrapper {
     if ($udom && $uname && $file) {
 	$file=~s|(\?\.*)*$||;
         &appenv("userfile.$udom/$uname/$file" => $env{'request.course.id'});
-        return 'http://'.$hostname{ &homeserver($uname,$udom)}.'/'.$uri.
+        return 'http://'.&hostname(&homeserver($uname,$udom)).'/'.$uri.
                (($uri=~/\?/)?'&':'?').'token='.$token.
                                '&tokenissued='.$perlvar{'lonHostID'};
     } else {
@@ -7300,7 +7308,7 @@ sub tokenwrapper {
 sub getuploaded {
     my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
     $uri=~s/^\///;
-    $uri = 'http://'.$hostname{ &homeserver($cnum,$cdom)}.'/raw/'.$uri;
+    $uri = 'http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri;
     my $ua=new LWP::UserAgent;
     my $request=new HTTP::Request($reqtype,$uri);
     my $response=$ua->request($request);
@@ -7390,8 +7398,9 @@ sub hreflocation {
 }
 
 sub current_machine_domains {
-    my $hostname=$hostname{$perlvar{'lonHostID'}};
+    my $hostname=&hostname($perlvar{'lonHostID'});
     my @domains;
+    my %hostname = &all_hostnames();
     while( my($id, $name) = each(%hostname)) {
 #	&logthis("-$id-$name-$hostname-");
 	if ($hostname eq $name) {
@@ -7402,8 +7411,9 @@ sub current_machine_domains {
 }
 
 sub current_machine_ids {
-    my $hostname=$hostname{$perlvar{'lonHostID'}};
+    my $hostname=&hostname($perlvar{'lonHostID'});
     my @ids;
+    my %hostname = &all_hostnames();
     while( my($id, $name) = each(%hostname)) {
 #	&logthis("-$id-$name-$hostname-");
 	if ($hostname eq $name) {
@@ -7581,6 +7591,7 @@ BEGIN {
 
 # ------------------------------------------------------------- Read hosts file
 {
+    my %hostname;
     open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
 
     while (my $configline=<$config>) {
@@ -7597,11 +7608,54 @@ BEGIN {
     close($config);
     # FIXME: dev server don't want this, production servers _do_ want this
     #&get_iphost();
+
+    sub hostname {
+	my ($lonid) = @_;
+	return $hostname{$lonid};
+    }
+    sub all_hostnames {
+	return %hostname;
+    }
+    sub get_servers {
+	my ($domain,$type) = @_;
+	my %possible_hosts = ($type eq 'library') ? %libserv
+	                                          : %hostname;
+	my %result;
+	if (ref($domain) eq 'ARRAY') {
+	    while ( my ($host,$hostname) = each(%possible_hosts)) {
+		if (grep(/\Q$hostdom{$host}\E/,@$domain)) {
+		    $result{$host} = $hostname;
+		}
+	    }
+	} else {
+	    while ( my ($host,$hostname) = each(%possible_hosts)) {
+		if ($hostdom{$host} eq $domain) {
+		    $result{$host} = $hostname;
+		}
+	    }
+	}
+	return %result;
+    }
+    sub all_domains {
+	my %seen;
+	my @uniq = grep(!$seen{$_}++, values(%hostdom));
+	return @uniq;
+    }
+}
+
+sub get_hosts_from_ip {
+    my ($ip) = @_;
+    my %iphosts = &get_iphost();
+    if (ref($iphosts{$ip})) {
+	return @{$iphosts{$ip}};
+    }
+    return;
 }
 
 sub get_iphost {
     if (%iphost) { return %iphost; }
     my %name_to_ip;
+    my %hostname = &all_hostnames();
     foreach my $id (keys(%hostname)) {
 	my $name=$hostname{$id};
 	my $ip;