--- loncom/lonnet/perl/lonnet.pm	2007/01/12 22:14:28	1.823
+++ loncom/lonnet/perl/lonnet.pm	2007/01/14 02:01:16	1.824
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.823 2007/01/12 22:14:28 albertel Exp $
+# $Id: lonnet.pm,v 1.824 2007/01/14 02:01:16 raeburn Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -7302,6 +7302,29 @@ sub current_machine_ids {
     return @ids;
 }
 
+sub additional_machine_domains {
+    my @domains;
+    open(my $fh,"<$perlvar{'lonTabDir'}/expected_domains.tab");
+    while( my $line = <$fh>) {
+        $line =~ s/\s//g;
+        push(@domains,$line);
+    }
+    return @domains;
+}
+
+sub default_login_domain {
+    my $domain = $perlvar{'lonDefDomain'};
+    my $testdomain=(split(/\./,$ENV{'HTTP_HOST'}))[0];
+    foreach my $posdom (&current_machine_domains(),
+                        &additional_machine_domains()) {
+        if (lc($posdom) eq lc($testdomain)) {
+            $domain=$posdom;
+            last;
+        }
+    }
+    return $domain;
+}
+
 # ------------------------------------------------------------- Declutters URLs
 
 sub declutter {