--- loncom/lonnet/perl/lonnet.pm	2005/09/13 19:45:11	1.651.2.3
+++ loncom/lonnet/perl/lonnet.pm	2005/10/28 21:51:50	1.670
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.651.2.3 2005/09/13 19:45:11 albertel Exp $
+# $Id: lonnet.pm,v 1.670 2005/10/28 21:51:50 albertel Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -37,7 +37,7 @@ use HTTP::Date;
 use vars 
 qw(%perlvar %hostname %badServerCache %iphost %spareid %hostdom 
    %libserv %pr %prp $memcache %packagetab 
-   %courselogs %accesshash %userrolehash $processmarker $dumpcount 
+   %courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount 
    %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf
    %domaindescription %domain_auth_def %domain_auth_arg_def 
    %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir $_64bit
@@ -443,15 +443,15 @@ sub overloaderror {
 # ------------------------------ Find server with least workload from spare.tab
 
 sub spareserver {
-    my ($loadpercent,$userloadpercent) = @_;
+    my ($loadpercent,$userloadpercent,$want_server_name) = @_;
     my $tryserver;
     my $spareserver='';
     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);
+    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
 	}
@@ -468,7 +468,11 @@ sub spareserver {
 	    $answer = $userloadans;
 	}
 	if (($answer =~ /\d/) && ($answer<$lowestserver)) {
-	    $spareserver="http://$hostname{$tryserver}";
+	    if ($want_server_name) {
+		$spareserver=$tryserver;
+	    } else {
+		$spareserver="http://$hostname{$tryserver}";
+	    }
 	    $lowestserver=$answer;
 	}
     }
@@ -767,6 +771,13 @@ sub validate_access_key {
 }
 
 # ------------------------------------- Find the section of student in a course
+sub devalidate_getsection_cache {
+    my ($udom,$unam,$courseid)=@_;
+    $courseid=~s/\_/\//g;
+    $courseid=~s/^(\w)/\/$1/;
+    my $hashid="$udom:$unam:$courseid";
+    &devalidate_cache_new('getsection',$hashid);
+}
 
 sub getsection {
     my ($udom,$unam,$courseid)=@_;
@@ -1169,7 +1180,6 @@ sub process_coursefile {
         $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
 			     $home);
     } else {
-        my $fetchresult = '';
         my $fpath = '';
         my $fname = $file;
         ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|);
@@ -1603,6 +1613,31 @@ sub flushcourselogs {
 	    delete $userrolehash{$entry};
         }
     }
+#
+# Reverse lookup of domain roles (dc, ad, li, sc, au)
+#
+    my %domrolebuffer = ();
+    foreach my $entry (keys %domainrolehash) {
+        my ($role,$uname,$udom,$runame,$rudom,$rsec)=split/:/,$entry;
+        if ($domrolebuffer{$rudom}) {
+            $domrolebuffer{$rudom}.='&'.&escape($entry).
+                      '='.&escape($domainrolehash{$entry});
+        } else {
+            $domrolebuffer{$rudom}.=&escape($entry).
+                      '='.&escape($domainrolehash{$entry});
+        }
+        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);
+                }
+            }
+        }
+    }
     $dumpcount++;
 }
 
@@ -1636,7 +1671,7 @@ sub courseacclog {
     my $fnsymb=shift;
     unless ($env{'request.course.id'}) { return ''; }
     my $what=$fnsymb.':'.$env{'user.name'}.':'.$env{'user.domain'};
-    if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|page)$/) {
+    if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|task|page)$/) {
         $what.=':POST';
         # FIXME: Probably ought to escape things....
 	foreach (keys %env) {
@@ -1678,14 +1713,24 @@ sub linklog {
   
 sub userrolelog {
     my ($trole,$username,$domain,$area,$tstart,$tend)=@_;
-    if (($trole=~/^ca/) || ($trole=~/^in/) || 
-        ($trole=~/^cc/) || ($trole=~/^ep/) ||
-        ($trole=~/^cr/) || ($trole=~/^ta/)) {
+    if (($trole=~/^ca/) || ($trole=~/^aa/) ||
+        ($trole=~/^in/) || ($trole=~/^cc/) ||
+        ($trole=~/^ep/) || ($trole=~/^cr/) ||
+        ($trole=~/^ta/)) {
        my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
        $userrolehash
          {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
                     =$tend.':'.$tstart;
-   }
+    }
+    if (($trole=~/^dc/) || ($trole=~/^ad/) ||
+        ($trole=~/^li/) || ($trole=~/^li/) ||
+        ($trole=~/^au/) || ($trole=~/^dg/) ||
+        ($trole=~/^sc/)) {
+       my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
+       $domainrolehash
+         {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
+                    = $tend.':'.$tstart;
+    }
 }
 
 sub get_course_adv_roles {
@@ -1804,7 +1849,65 @@ sub courseiddump {
     return %returnhash;
 }
 
-#
+# ---------------------------------------------------------- DC e-mail
+
+sub dcmailput {
+    my ($domain,$msgid,$contents,$server)=@_;
+    my $status = &Apache::lonnet::critical(
+       'dcmailput:'.$domain.':'.&Apache::lonnet::escape($msgid).'='.
+       &Apache::lonnet::escape($$contents{$server}),$server);
+    return $status;
+}
+
+sub dcmaildump {
+    my ($dom,$startdate,$enddate,$senders) = @_;
+    my %returnhash=(); 
+    foreach my $tryserver (keys(%libserv)) {
+        if ($hostdom{$tryserver} eq $dom) {
+            %{$returnhash{$tryserver}}=();
+	    my $cmd='dcmaildump:'.$dom.':'.
+		&escape($startdate).':'.&escape($enddate).':';
+	    my @esc_senders=map { &escape($_)} @$senders;
+	    $cmd.=&escape(join('&',@esc_senders));
+	    foreach (split(/\&/,&reply($cmd,$tryserver))) {
+                my ($key,$value) = split(/\=/,$_);
+                if (($key) && ($value)) {
+                    $returnhash{$tryserver}{&unescape($key)} = &unescape($value);
+                }
+            }
+        }
+    }
+    return %returnhash;
+}
+# ---------------------------------------------------------- Domain roles
+
+sub get_domain_roles {
+    my ($dom,$roles,$startdate,$enddate)=@_;
+    if (undef($startdate) || $startdate eq '') {
+        $startdate = '.';
+    }
+    if (undef($enddate) || $enddate eq '') {
+        $enddate = '.';
+    }
+    my $rolelist = join(':',@{$roles});
+    my %personnel = ();
+    foreach my $tryserver (keys(%libserv)) {
+        if ($hostdom{$tryserver} eq $dom) {
+            %{$personnel{$tryserver}}=();
+            foreach (
+                split(/\&/,&reply('domrolesdump:'.$dom.':'.
+                   &escape($startdate).':'.&escape($enddate).':'.
+                   &escape($rolelist), $tryserver))) {
+                my($key,$value) = split(/\=/,$_);
+                if (($key) && ($value)) {
+                    $personnel{$tryserver}{&unescape($key)} = &unescape($value);
+                }
+            }
+        }
+    }
+    return %personnel;
+}
+
 # ----------------------------------------------------------- Check out an item
 
 sub get_first_access {
@@ -2479,7 +2582,6 @@ sub rolesinit {
 	  if ($_!~/^rolesdef_/) {
             my ($area,$role)=split(/=/,$_);
 	    $area=~s/\_\w\w$//;
-	    
             my ($trole,$tend,$tstart);
 	    if ($role=~/^cr/) { 
 		if ($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|) {
@@ -2503,7 +2605,7 @@ sub rolesinit {
                     &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
 		}
             }
-          } 
+          }
         }
         my ($author,$adv) = &set_userprivs(\$userroles,\%allroles);
         $userroles.='user.adv='.$adv."\n".
@@ -2856,6 +2958,29 @@ sub eget {
    return %returnhash;
 }
 
+# ------------------------------------------------------------ tmpput interface
+sub tmpput {
+    my ($storehash,$server)=@_;
+    my $items='';
+    foreach (keys(%$storehash)) {
+	$items.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&';
+    }
+    $items=~s/\&$//;
+    return &reply("tmpput:$items",$server);
+}
+
+# ------------------------------------------------------------ tmpget interface
+sub tmpget {
+    my ($token)=@_;
+    my $rep=&reply("tmpget:$token",$perlvar{'lonHostID'});
+    my %returnhash;
+    foreach my $item (split(/\&/,$rep)) {
+	my ($key,$value)=split(/=/,$item);
+	$returnhash{&unescape($key)}=&thaw_unescape($value);
+    }
+    return %returnhash;
+}
+
 # ---------------------------------------------- Custom access rule evaluation
 
 sub customaccess {
@@ -2977,14 +3102,23 @@ sub allowed {
        $thisallowed.=$1;
     }
 
-# URI is an uploaded document for this course
+# URI is an uploaded document for this course, default permissions don't matter
 # not allowing 'edit' access (editupload) to uploaded course docs
     if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) {
+	$thisallowed='';
 	my $refuri=$env{'httpref.'.$orguri};
 	if ($refuri) {
 	    if ($refuri =~ m|^/adm/|) {
 		$thisallowed='F';
+	    } else {
+                $refuri=&declutter($refuri);
+                my ($match) = &is_on_map($refuri);
+                if ($match) {
+                    $thisallowed='F';
+                }
 	    }
+	} else {
+	    $thisallowed='';
 	}
     }
 
@@ -3201,8 +3335,7 @@ sub allowed {
 # --------------------------------------------------- Is a resource on the map?
 
 sub is_on_map {
-    my $uri=&declutter(shift);
-    $uri=~s/\.\d+\.(\w+)$/\.$1/;
+    my $uri=&deversion(&declutter(shift));
     my @uriparts=split(/\//,$uri);
     my $filename=$uriparts[$#uriparts];
     my $pathname=$uri;
@@ -3572,7 +3705,7 @@ sub assignrole {
     my $answer=&reply($command,&homeserver($uname,$udom));
 # log new user role if status is ok
     if ($answer eq 'ok') {
-	&userrolelog($mrole,$uname,$udom,$url,$start,$end);
+	&userrolelog($role,$uname,$udom,$url,$start,$end);
     }
     return $answer;
 }
@@ -3775,6 +3908,8 @@ sub modify_student_enrollment {
 		   $cdom,$cnum);
     unless (($reply eq 'ok') || ($reply eq 'delayed')) {
 	return 'error: '.$reply;
+    } else {
+	&devalidate_getsection_cache($udom,$uname,$cid);
     }
     # Add student role to user
     my $uurl='/'.$cid;
@@ -5686,14 +5821,15 @@ sub filelocation {
 sub hreflocation {
     my ($dir,$file)=@_;
     unless (($file=~m-^http://-i) || ($file=~m-^/-)) {
-	my $finalpath=filelocation($dir,$file);
-	$finalpath=~s-^/home/httpd/html--;
-	$finalpath=~s-^/home/(\w+)/public_html/-/~$1/-;
-	return $finalpath;
-    } elsif ($file=~m-^/home-) {
-	$file=~s-^/home/httpd/html--;
+	$file=filelocation($dir,$file);
+    }
+    if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) {
+	$file=~s-^\Q$perlvar{'lonDocRoot'}\E--;
+    } elsif ($file=~m-/home/(\w+)/public_html/-) {
 	$file=~s-^/home/(\w+)/public_html/-/~$1/-;
-	return $file;
+    } elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) {
+	$file=~s-^/home/httpd/lonUsers/([^/]*)/./././([^/]*)/userfiles/
+	    -/uploaded/$1/$2/-x;
     }
     return $file;
 }
@@ -5890,7 +6026,7 @@ BEGIN {
     }
     close($config);
     # FIXME: dev server don't want this, production servers _do_ want this
-    &get_iphost();
+    #&get_iphost();
 }
 
 sub get_iphost {