--- loncom/lonnet/perl/lonnet.pm	2007/03/08 01:58:41	1.846
+++ loncom/lonnet/perl/lonnet.pm	2007/03/28 21:44:13	1.854
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.846 2007/03/08 01:58:41 albertel Exp $
+# $Id: lonnet.pm,v 1.854 2007/03/28 21:44: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 %badServerCache %iphost %spareid 
+qw(%perlvar %badServerCache %spareid 
    %pr %prp $memcache %packagetab 
    %courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount 
    %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %coursetypebuf
@@ -53,6 +53,7 @@ use Digest::MD5;
 use Math::Random;
 use LONCAPA qw(:DEFAULT :match);
 use LONCAPA::Configuration;
+use Apache::lonhosts;
 
 my $readit;
 my $max_connection_retries = 10;     # Or some such value.
@@ -144,6 +145,20 @@ sub logperm {
     return 1;
 }
 
+sub create_connection {
+    my ($hostname,$lonid) = @_;
+    my $client=IO::Socket::UNIX->new(Peer    => $perlvar{'lonSockCreate'},
+				     Type    => SOCK_STREAM,
+				     Timeout => 10);
+    return 0 if (!$client);
+    print $client (join(':',$hostname,$lonid,&machine_ids($lonid))."\n");
+    my $result = <$client>;
+    chomp($result);
+    return 1 if ($result eq 'done');
+    return 0;
+}
+
+
 # -------------------------------------------------- Non-critical communication
 sub subreply {
     my ($cmd,$server)=@_;
@@ -170,8 +185,10 @@ sub subreply {
 				      Timeout => 10);
 	if($client) {
 	    last;		# Connected!
+	} else {
+	    &create_connection(&hostname($server),$server);
 	}
-	sleep(1);		# Try again later if failed connection.
+        sleep(1);		# Try again later if failed connection.
     }
     my $answer;
     if ($client) {
@@ -1010,10 +1027,16 @@ my %remembered;
 my %accessed;
 my $kicks=0;
 my $hits=0;
+sub make_key {
+    my ($name,$id) = @_;
+    if (length($id) > 200) { $id=length($id).':'.&Digest::MD5::md5_hex($id); }
+    return &escape($name.':'.$id);
+}
+
 sub devalidate_cache_new {
     my ($name,$id,$debug) = @_;
     if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); }
-    $id=&escape($name.':'.$id);
+    $id=&make_key($name,$id);
     $memcache->delete($id);
     delete($remembered{$id});
     delete($accessed{$id});
@@ -1021,7 +1044,7 @@ sub devalidate_cache_new {
 
 sub is_cached_new {
     my ($name,$id,$debug) = @_;
-    $id=&escape($name.':'.$id);
+    $id=&make_key($name,$id);
     if (exists($remembered{$id})) {
 	if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); }
 	$accessed{$id}=[&gettimeofday()];
@@ -1044,7 +1067,7 @@ sub is_cached_new {
 
 sub do_cache_new {
     my ($name,$id,$value,$time,$debug) = @_;
-    $id=&escape($name.':'.$id);
+    $id=&make_key($name,$id);
     my $setvalue=$value;
     if (!defined($setvalue)) {
 	$setvalue='__undef__';
@@ -6176,7 +6199,8 @@ sub packages_tab_default {
 	    $do_default=1;
 	} elsif ($pack_type eq 'extension') {
 	    push(@extension,[$package,$pack_type,$pack_part]);
-	} else {
+	} elsif ($pack_part eq $part) {
+	    # only look at packages defaults for packages that this id is
 	    push(@specifics,[$package,$pack_type,$pack_part]);
 	}
     }
@@ -7403,7 +7427,11 @@ sub hreflocation {
 }
 
 sub current_machine_domains {
-    my $hostname=&hostname($perlvar{'lonHostID'});
+    return &machine_domains(&hostname($perlvar{'lonHostID'}));
+}
+
+sub machine_domains {
+    my ($hostname) = @_;
     my @domains;
     my %hostname = &all_hostnames();
     while( my($id, $name) = each(%hostname)) {
@@ -7416,7 +7444,12 @@ sub current_machine_domains {
 }
 
 sub current_machine_ids {
-    my $hostname=&hostname($perlvar{'lonHostID'});
+    return &machine_ids(&hostname($perlvar{'lonHostID'}));
+}
+
+sub machine_ids {
+    my ($hostname) = @_;
+    $hostname ||= &hostname($perlvar{'lonHostID'});
     my @ids;
     my %hostname = &all_hostnames();
     while( my($id, $name) = each(%hostname)) {
@@ -7564,17 +7597,33 @@ BEGIN {
     %perlvar = (%perlvar,%{$configvars});
 }
 
+sub get_dns {
+    my ($url,$func) = @_;
+    open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
+    foreach my $dns (<$config>) {
+	next if ($dns !~ /^\^(\S*)/x);
+	$dns = $1;
+	my $ua=new LWP::UserAgent;
+	my $request=new HTTP::Request('GET',"http://$dns$url");
+	my $response=$ua->request($request);
+	next if ($response->is_error());
+	my @content = split("\n",$response->content);
+	&$func(\@content);
+    }
+    close($config);
+}
 # ------------------------------------------------------------ Read domain file
 {
+    my $loaded;
     my %domain;
 
-    my $fh;
-    if (open($fh,"<".$Apache::lonnet::perlvar{'lonTabDir'}.'/domain.tab')) {
-	while (my $line = <$fh>) {
-	    next if ($line =~ /^(\#|\s*$ )/);
+    sub parse_domain_tab {
+	my ($lines) = @_;
+	foreach my $line (@$lines) {
+	    next if ($line =~ /^(\#|\s*$ )/x);
 
 	    chomp($line);
-	    my ($name,@elements) =  split(/:/,$line,9);
+	    my ($name,@elements) = split(/:/,$line,9);
 	    my %this_domain;
 	    foreach my $field ('description', 'auth_def', 'auth_arg_def',
 			       'lang_def', 'city', 'longi', 'lati',
@@ -7582,12 +7631,24 @@ BEGIN {
 		$this_domain{$field} = shift(@elements);
 	    }
 	    $domain{$name} = \%this_domain;
-#          &logthis("Domain.tab: $domain ".$domaindescription{$domain} );
+	    &logthis("Domain.tab: $name ".$domain{$name}{'description'} );
 	}
     }
-    close ($fh);
+    
+    sub load_domain_tab {
+	&get_dns('/adm/dns/domain',\&parse_domain_tab);
+	my $fh;
+	if (open($fh,"<".$perlvar{'lonTabDir'}.'/domain.tab')) {
+	    my @lines = <$fh>;
+	    &parse_domain_tab(\@lines);
+	}
+	close($fh);
+	$loaded = 1;
+    }
 
     sub domain {
+	&load_domain_tab() if (!$loaded);
+
 	my ($name,$what) = @_;
 	return if ( !exists($domain{$name}) );
 
@@ -7604,41 +7665,65 @@ BEGIN {
     my %hostname;
     my %hostdom;
     my %libserv;
-    open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
+    my $loaded;
 
-    while (my $configline=<$config>) {
-       next if ($configline =~ /^(\#|\s*$)/);
-       chomp($configline);
-       my ($id,$domain,$role,$name)=split(/:/,$configline);
-       $name=~s/\s//g;
-       if ($id && $domain && $role && $name) {
-	 $hostname{$id}=$name;
-	 $hostdom{$id}=$domain;
-	 if ($role eq 'library') { $libserv{$id}=$name; }
-       }
+    sub parse_hosts_tab {
+	my ($file) = @_;
+	foreach my $configline (@$file) {
+	    next if ($configline =~ /^(\#|\s*$ )/x);
+	    next if ($configline =~ /^\^/);
+	    chomp($configline);
+	    my ($id,$domain,$role,$name)=split(/:/,$configline);
+	    $name=~s/\s//g;
+	    if ($id && $domain && $role && $name) {
+		$hostname{$id}=$name;
+		$hostdom{$id}=$domain;
+		if ($role eq 'library') { $libserv{$id}=$name; }
+	    }
+	    &logthis("Hosts.tab: $name ".$id );
+	}
     }
-    close($config);
+
+    sub load_hosts_tab {
+	&get_dns('/adm/dns/hosts',\&parse_hosts_tab);
+	open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
+	my @config = <$config>;
+	&parse_hosts_tab(\@config);
+	close($config);
+	$loaded=1;
+    }
+
     # FIXME: dev server don't want this, production servers _do_ want this
     #&get_iphost();
 
     sub hostname {
+	&load_hosts_tab() if (!$loaded);
+
 	my ($lonid) = @_;
 	return $hostname{$lonid};
     }
 
     sub all_hostnames {
+	&load_hosts_tab() if (!$loaded);
+
 	return %hostname;
     }
 
     sub is_library {
+	&load_hosts_tab() if (!$loaded);
+
 	return exists($libserv{$_[0]});
     }
 
     sub all_library {
+	&load_hosts_tab() if (!$loaded);
+
 	return %libserv;
     }
 
     sub get_servers {
+	&load_hosts_tab() if (!$loaded);
+
 	my ($domain,$type) = @_;
 	my %possible_hosts = ($type eq 'library') ? %libserv
 	                                          : %hostname;
@@ -7660,47 +7745,54 @@ BEGIN {
     }
 
     sub host_domain {
+	&load_hosts_tab() if (!$loaded);
+
 	my ($lonid) = @_;
 	return $hostdom{$lonid};
     }
 
     sub all_domains {
+	&load_hosts_tab() if (!$loaded);
+
 	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}};
+{ 
+    my %iphost;
+    sub get_hosts_from_ip {
+	my ($ip) = @_;
+	my %iphosts = &get_iphost();
+	if (ref($iphosts{$ip})) {
+	    return @{$iphosts{$ip}};
+	}
+	return;
     }
-    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;
-	if (!exists($name_to_ip{$name})) {
-	    $ip = gethostbyname($name);
-	    if (!$ip || length($ip) ne 4) {
-		&logthis("Skipping host $id name $name no IP found");
-		next;
+    
+    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;
+	    if (!exists($name_to_ip{$name})) {
+		$ip = gethostbyname($name);
+		if (!$ip || length($ip) ne 4) {
+		    &logthis("Skipping host $id name $name no IP found");
+		    next;
+		}
+		$ip=inet_ntoa($ip);
+		$name_to_ip{$name} = $ip;
+	    } else {
+		$ip = $name_to_ip{$name};
 	    }
-	    $ip=inet_ntoa($ip);
-	    $name_to_ip{$name} = $ip;
-	} else {
-	    $ip = $name_to_ip{$name};
+	    push(@{$iphost{$ip}},$id);
 	}
-	push(@{$iphost{$ip}},$id);
+	return %iphost;
     }
-    return %iphost;
 }
 
 # ------------------------------------------------------ Read spare server file