--- loncom/lonnet/perl/lonnet.pm	2007/04/11 22:52:03	1.869
+++ loncom/lonnet/perl/lonnet.pm	2007/05/17 09:31:13	1.879
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.869 2007/04/11 22:52:03 albertel Exp $
+# $Id: lonnet.pm,v 1.879 2007/05/17 09:31:13 foxr Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -31,22 +31,21 @@ package Apache::lonnet;
 
 use strict;
 use LWP::UserAgent();
-use HTTP::Headers;
 use HTTP::Date;
 # use Date::Parse;
-use vars 
-qw(%perlvar %badServerCache %spareid 
-   %pr %prp $memcache %packagetab 
-   %courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount 
-   %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %coursetypebuf
-   $tmpdir $_64bit %env);
+use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir
+            $_64bit %env);
+
+my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash,
+    %userrolehash, $processmarker, $dumpcount, %coursedombuf,
+    %coursenumbuf, %coursehombuf, %coursedescrbuf, %courseinstcodebuf,
+    %courseownerbuf, %coursetypebuf);
 
 use IO::Socket;
 use GDBM_File;
 use HTML::LCParser;
-use HTML::Parser;
 use Fcntl qw(:flock);
-use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze);
+use Storable qw(thaw nfreeze);
 use Time::HiRes qw( gettimeofday tv_interval );
 use Cache::Memcached;
 use Digest::MD5;
@@ -745,7 +744,7 @@ sub get_dom {
         if (defined(&domain($udom,'primary'))) {
             $uhome=&domain($udom,'primary');
         } else {
-            $uhome eq '';
+            undef($uhome);
         }
     } else {
         if (!$uhome) {
@@ -757,14 +756,13 @@ sub get_dom {
     if ($udom && $uhome && ($uhome ne 'no_host')) {
         my $rep=&reply("getdom:$udom:$namespace:$items",$uhome);
         my %returnhash;
-        if ($rep =~ /^error: 2 /) {
+        if ($rep eq '' || $rep =~ /^error: 2 /) {
             return %returnhash;
         }
         my @pairs=split(/\&/,$rep);
         if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) {
             return @pairs;
         }
-        my %returnhash=();
         my $i=0;
         foreach my $item (@$storearr) {
             $returnhash{$item}=&thaw_unescape($pairs[$i]);
@@ -785,7 +783,7 @@ sub put_dom {
         if (defined(&domain($udom,'primary'))) {
             $uhome=&domain($udom,'primary');
         } else {
-            $uhome eq '';
+            undef($uhome);
         }
     } else {
         if (!$uhome) {
@@ -1066,7 +1064,10 @@ my $kicks=0;
 my $hits=0;
 sub make_key {
     my ($name,$id) = @_;
-    if (length($id) > 200) { $id=length($id).':'.&Digest::MD5::md5_hex($id); }
+    if (length($id) > 65 
+	&& length(&escape($id)) > 200) {
+	$id=length($id).':'.&Digest::MD5::md5_hex($id);
+    }
     return &escape($name.':'.$id);
 }
 
@@ -1113,7 +1114,9 @@ sub do_cache_new {
 	$time=600;
     }
     if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); }
-    $memcache->set($id,$setvalue,$time);
+    if (!($memcache->set($id,$setvalue,$time))) {
+	&logthis("caching of id -> $id  failed");
+    }
     # need to make a copy of $value
     #&make_room($id,$value,$debug);
     return $value;
@@ -4451,8 +4454,18 @@ sub userlog_query {
 
 sub auto_run {
     my ($cnum,$cdom) = @_;
-    my $homeserver = &homeserver($cnum,$cdom);
-    my $response = &reply('autorun:'.$cdom,$homeserver);
+    my $response = 0;
+    my $settings;
+    my %domconfig = &get_dom('configuration',['autoenroll'],$cdom);
+    if (ref($domconfig{'autoenroll'}) eq 'HASH') {
+        $settings = $domconfig{'autoenroll'};
+        if ($settings->{'run'} eq '1') {
+            $response = 1;
+        }
+    } else {
+        my $homeserver = &homeserver($cnum,$cdom);
+        $response = &reply('autorun:'.$cdom,$homeserver);
+    }
     return $response;
 }
 
@@ -4482,15 +4495,27 @@ sub auto_validate_courseID {
 }
 
 sub auto_create_password {
-    my ($cnum,$cdom,$authparam) = @_;
-    my $homeserver = &homeserver($cnum,$cdom); 
+    my ($cnum,$cdom,$authparam,$udom) = @_;
+    my ($homeserver,$response);
     my $create_passwd = 0;
     my $authchk = '';
-    my $response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver));
-    if ($response eq 'refused') {
-        $authchk = 'refused';
+    if ($udom =~ /^$match_domain$/) {
+        $homeserver = &domain($udom,'primary');
+    }
+    if ($homeserver eq '') {
+        if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) {
+            $homeserver = &homeserver($cnum,$cdom);
+        }
+    }
+    if ($homeserver eq '') {
+        $authchk = 'nodomain';
     } else {
-        ($authparam,$create_passwd,$authchk) = split/:/,$response;
+        $response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver));
+        if ($response eq 'refused') {
+            $authchk = 'refused';
+        } else {
+            ($authparam,$create_passwd,$authchk) = split/:/,$response;
+        }
     }
     return ($authparam,$create_passwd,$authchk);
 }
@@ -5295,7 +5320,7 @@ sub save_selected_files {
     my ($user, $path, @files) = @_;
     my $filename = $user."savedfiles";
     my @other_files = &files_not_in_path($user, $path);
-    open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
+    open (OUT, '>'.$tmpdir.$filename);
     foreach my $file (@files) {
         print (OUT $env{'form.currentpath'}.$file."\n");
     }
@@ -5887,6 +5912,13 @@ sub devalidatecourseresdata {
 
 
 # --------------------------------------------------- Course Resourcedata Query
+#
+#  Parameters:
+#      $coursenum    - Number of the course.
+#      $coursedomain - Domain at which the course was created.
+#  Returns:
+#     A hash of the course parameters along (I think) with timestamps
+#     and version info.
 
 sub get_courseresdata {
     my ($coursenum,$coursedomain)=@_;
@@ -5945,7 +5977,21 @@ sub get_userresdata {
     }
     return $tmp;
 }
-
+#----------------------------------------------- resdata - return resource data
+#  Purpose:
+#    Return resource data for either users or for a course.
+#  Parameters:
+#     $name      - Course/user name.
+#     $domain    - Name of the domain the user/course is registered on.
+#     $type      - Type of thing $name is (must be 'course' or 'user'
+#     @which     - Array of names of resources desired.
+#  Returns:
+#     The value of the first reasource in @which that is found in the
+#     resource hash.
+#  Exceptional Conditions:
+#     If the $type passed in is not valid (not the string 'course' or 
+#     'user', an undefined  reference is returned.
+#     If none of the resources are found, an undef is returned
 sub resdata {
     my ($name,$domain,$type,@which)=@_;
     my $result;
@@ -7663,18 +7709,18 @@ sub correct_line_ends {
 sub goodbye {
    &logthis("Starting Shut down");
 #not converted to using infrastruture and probably shouldn't be
-   &logthis(sprintf("%-20s is %s",'%badServerCache',length(&freeze(\%badServerCache))));
+   &logthis(sprintf("%-20s is %s",'%badServerCache',length(&nfreeze(\%badServerCache))));
 #converted
 #   &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));
-   &logthis(sprintf("%-20s is %s",'%homecache',length(&freeze(\%homecache))));
-#   &logthis(sprintf("%-20s is %s",'%titlecache',length(&freeze(\%titlecache))));
-#   &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&freeze(\%courseresdatacache))));
+   &logthis(sprintf("%-20s is %s",'%homecache',length(&nfreeze(\%homecache))));
+#   &logthis(sprintf("%-20s is %s",'%titlecache',length(&nfreeze(\%titlecache))));
+#   &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&nfreeze(\%courseresdatacache))));
 #1.1 only
-#   &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&freeze(\%userresdatacache))));
-#   &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&freeze(\%getsectioncache))));
-#   &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&freeze(\%courseresversioncache))));
-#   &logthis(sprintf("%-20s is %s",'%resversioncache',length(&freeze(\%resversioncache))));
-   &logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered))));
+#   &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&nfreeze(\%userresdatacache))));
+#   &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&nfreeze(\%getsectioncache))));
+#   &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&nfreeze(\%courseresversioncache))));
+#   &logthis(sprintf("%-20s is %s",'%resversioncache',length(&nfreeze(\%resversioncache))));
+   &logthis(sprintf("%-20s is %s",'%remembered',length(&nfreeze(\%remembered))));
    &logthis(sprintf("%-20s is %s",'kicks',$kicks));
    &logthis(sprintf("%-20s is %s",'hits',$hits));
    &flushcourselogs();
@@ -7711,8 +7757,9 @@ sub get_dns {
 	return;
     }
     close($config);
-    &logthis("unable to contact DNS defaulting to on disk file\n");
-    open($config,"<$perlvar{'lonTabDir'}/dns_hosts.tab");
+    my $which = (split('/',$url))[3];
+    &logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n");
+    open($config,"<$perlvar{'lonTabDir'}/dns_$which.tab");
     my @content = <$config>;
     &$func(\@content);
     return;
@@ -8504,6 +8551,14 @@ setting for a specific $type, where $typ
 @what should be a list of parameters to ask about. This routine caches
 answers for 5 minutes.
 
+=item *
+
+get_courseresdata($courseid, $domain) : dump the entire course resource
+data base, returning a hash that is keyed by the resource name and has
+values that are the resource value.  I believe that the timestamps and
+versions are also returned.
+
+
 =back
 
 =head2 Course Modification
@@ -9186,3 +9241,4 @@ symblist($mapname,%newhash) : update sym
 =back
 
 =cut
+