--- loncom/lonnet/perl/lonnet.pm	2003/12/08 13:50:57	1.457
+++ loncom/lonnet/perl/lonnet.pm	2004/03/09 16:25:19	1.476
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.457 2003/12/08 13:50:57 raeburn Exp $
+# $Id: lonnet.pm,v 1.476 2004/03/09 16:25:19 raeburn Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -377,7 +377,12 @@ sub delenv {
 	    return 'error: '.$!;
 	}
 	foreach (@oldenv) {
-	    unless ($_=~/^$delthis/) { print $fh $_; }
+	    if ($_=~/^$delthis/) { 
+                my ($key,undef) = split('=',$_);
+                delete($ENV{$key});
+            } else {
+                print $fh $_; 
+            }
 	}
 	close($fh);
     }
@@ -524,38 +529,21 @@ sub authenticate {
     my ($uname,$upass,$udom)=@_;
     $upass=escape($upass);
     $uname=~s/\W//g;
-    if (($perlvar{'lonRole'} eq 'library') && 
-        ($udom eq $perlvar{'lonDefDomain'})) {
-    my $answer=reply("encrypt:auth:$udom:$uname:$upass",$perlvar{'lonHostID'});
-        if ($answer =~ /authorized/) {
-              if ($answer eq 'authorized') {
-                 &logthis("User $uname at $udom authorized by local server"); 
-                 return $perlvar{'lonHostID'}; 
-              }
-              if ($answer eq 'non_authorized') {
-                 &logthis("User $uname at $udom rejected by local server"); 
-                 return 'no_host'; 
-              }
-	}
+    my $uhome=&homeserver($uname,$udom);
+    if (!$uhome) {
+	&logthis("User $uname at $udom is unknown in authenticate");
+	return 'no_host';
     }
-
-    my $tryserver;
-    foreach $tryserver (keys %libserv) {
-	if ($hostdom{$tryserver} eq $udom) {
-           my $answer=reply("encrypt:auth:$udom:$uname:$upass",$tryserver);
-           if ($answer =~ /authorized/) {
-              if ($answer eq 'authorized') {
-                 &logthis("User $uname at $udom authorized by $tryserver"); 
-                 return $tryserver; 
-              }
-              if ($answer eq 'non_authorized') {
-                 &logthis("User $uname at $udom rejected by $tryserver");
-                 return 'no_host';
-              } 
-	   }
-       }
+    my $answer=reply("encrypt:auth:$udom:$uname:$upass",$uhome);
+    if ($answer eq 'authorized') {
+	&logthis("User $uname at $udom authorized by $uhome"); 
+	return $uhome; 
+    }
+    if ($answer eq 'non_authorized') {
+	&logthis("User $uname at $udom rejected by $uhome");
+	return 'no_host'; 
     }
-    &logthis("User $uname at $udom could not be authenticated");    
+    &logthis("User $uname at $udom threw error $answer when checking authentication mechanism");
     return 'no_host';
 }
 
@@ -1198,8 +1186,13 @@ sub tokenwrapper {
 # output: url of file in userspace
 
 sub userfileupload {
-    my ($formname,$coursedoc)=@_;
-    my $fname=$ENV{'form.'.$formname.'.filename'};
+    my ($formname,$coursedoc,$filename,$fpath,$source)=@_;
+    my $fname;
+    if (defined($filename)) {
+        $fname = $filename;
+    } else {
+        $fname=$ENV{'form.'.$formname.'.filename'};
+    }
 # Replace Windows backslashes by forward slashes
     $fname=~s/\\/\//g;
 # Get rid of everything but the actual filename
@@ -1210,7 +1203,11 @@ sub userfileupload {
     $fname=~s/[^\w\.\-]//g;
 # See if there is anything left
     unless ($fname) { return 'error: no uploaded file'; }
-    chop($ENV{'form.'.$formname});
+    if ( defined($formname) ) {
+        if ( defined($ENV{'form.'.$formname}) ) {
+            chop($ENV{'form.'.$formname});
+        }
+    }
 # Create the directory if not present
     my $docuname='';
     my $docudom='';
@@ -1225,12 +1222,12 @@ sub userfileupload {
         $docuhome=$ENV{'user.home'};
     }
     return 
-        &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname);
+        &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname,$fpath,$source);
 }
 
 sub finishuserfileupload {
-    my ($docuname,$docudom,$docuhome,$formname,$fname)=@_;
-    my $path=$docudom.'/'.$docuname.'/';
+    my ($docuname,$docudom,$docuhome,$formname,$fname,$fpath,$source)=@_;
+    my $path=$docudom.'/'.$docuname.'/'.$fpath;
     my $filepath=$perlvar{'lonDocRoot'};
     my @parts=split(/\//,$filepath.'/userfiles/'.$path);
     my $count;
@@ -1242,15 +1239,20 @@ sub finishuserfileupload {
     }
 # Save the file
     {
-       open(my $fh,'>'.$filepath.'/'.$fname);
-       print $fh $ENV{'form.'.$formname};
-       close($fh);
+       if ($source eq '') {
+           open(my $fh,'>'.$filepath.'/'.$fname);
+           print $fh $ENV{'form.'.$formname};
+           close($fh);
+       } else {
+           my $destination = $filepath.'/'.$fname;
+           rename($source,$destination);
+       }
     }
 # Notify homeserver to grep it
 #
     
-    my $fetchresult= 
- &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,$docuhome);
+    my $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname.
+			    ':'.$fpath,$docuhome);
     if ($fetchresult eq 'ok') {
 #
 # Return the URL to it
@@ -1319,8 +1321,15 @@ sub flushcourselogs {
 # Writes to the dynamic metadata of resources to get hit counts, etc.
 #
     foreach my $entry (keys(%accesshash)) {
-        my ($dom,$name,undef,$type)=($entry=~m:___(\w+)/(\w+)/(.*)___(\w+)$:);
-        if ($type eq 'count'){
+        if ($entry =~ /___count$/) {
+            my ($dom,$name);
+            ($dom,$name,undef)=($entry=~m:___(\w+)/(\w+)/(.*)___count$:);
+            if (! defined($dom) || $dom eq '' || 
+                ! defined($name) || $name eq '') {
+                my $cid = $ENV{'request.course.id'};
+                $dom  = $ENV{'request.'.$cid.'.domain'};
+                $name = $ENV{'request.'.$cid.'.num'};
+            }
             my $value = $accesshash{$entry};
             my (undef,$url,undef) = ($entry =~ /^(.*)___(.*)___count$/);
             my %temphash=($url => $value);
@@ -1335,6 +1344,7 @@ sub flushcourselogs {
                 }
             }
         } else {
+            my ($dom,$name) = ($entry=~m:___(\w+)/(\w+)/(.*)___(\w+)$:);
             my %temphash=($entry => $accesshash{$entry});
             if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {
                 delete $accesshash{$entry};
@@ -1375,8 +1385,7 @@ sub courselog {
     } else {
 	$courselogs{$ENV{'request.course.id'}}.=$what;
     }
-#    if (length($courselogs{$ENV{'request.course.id'}})>4048) {
-    if (length($courselogs{$ENV{'request.course.id'}})>48) {
+    if (length($courselogs{$ENV{'request.course.id'}})>4048) {
 	&flushcourselogs();
     }
 }
@@ -1398,6 +1407,7 @@ sub courseacclog {
 
 sub countacc {
     my $url=&declutter(shift);
+    return if (! defined($url) || $url eq '');
     unless ($ENV{'request.course.id'}) { return ''; }
     $accesshash{$ENV{'request.course.id'}.'___'.$url.'___course'}=1;
     my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count';
@@ -1416,7 +1426,7 @@ sub userrolelog {
     my ($trole,$username,$domain,$area,$tstart,$tend)=@_;
     if (($trole=~/^ca/) || ($trole=~/^in/) || 
         ($trole=~/^cc/) || ($trole=~/^ep/) ||
-        ($trole=~/^cr/)) {
+        ($trole=~/^cr/) || ($trole=~/^ta/)) {
        my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
        $userrolehash
          {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
@@ -1428,6 +1438,10 @@ sub get_course_adv_roles {
     my $cid=shift;
     $cid=$ENV{'request.course.id'} unless (defined($cid));
     my %coursehash=&coursedescription($cid);
+    my %nothide=();
+    foreach (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
+	$nothide{join(':',split(/[\@\:]/,$_))}=1;
+    }
     my %returnhash=();
     my %dumphash=
             &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});
@@ -1438,6 +1452,8 @@ sub get_course_adv_roles {
         if (($tend) && ($tend<$now)) { next; }
         if (($tstart) && ($now<$tstart)) { next; }
         my ($role,$username,$domain,$section)=split(/\:/,$_);
+	if ((&privileged($username,$domain)) && 
+	    (!$nothide{$username.':'.$domain})) { next; }
         my $key=&plaintext($role);
         if ($section) { $key.=' (Sec/Grp '.$section.')'; }
         if ($returnhash{$key}) {
@@ -2119,6 +2135,36 @@ sub coursedescription {
     return %returnhash;
 }
 
+# -------------------------------------------------See if a user is privileged
+
+sub privileged {
+    my ($username,$domain)=@_;
+    my $rolesdump=&reply("dump:$domain:$username:roles",
+			&homeserver($username,$domain));
+    if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return 0; }
+    my $now=time;
+    if ($rolesdump ne '') {
+        foreach (split(/&/,$rolesdump)) {
+	    if ($_!~/^rolesdef\&/) {
+		my ($area,$role)=split(/=/,$_);
+		$area=~s/\_\w\w$//;
+		my ($trole,$tend,$tstart)=split(/_/,$role);
+		if (($trole eq 'dc') || ($trole eq 'su')) {
+		    my $active=1;
+		    if ($tend) {
+			if ($tend<$now) { $active=0; }
+		    }
+		    if ($tstart) {
+			if ($tstart>$now) { $active=0; }
+		    }
+		    if ($active) { return 1; }
+		}
+	    }
+	}
+    }
+    return 0;
+}
+
 # -------------------------------------------------------- Get user privileges
 
 sub rolesinit {
@@ -3695,12 +3741,13 @@ sub EXT {
 		    if ($$result{$courselevel}) {
 			return $$result{$courselevel}; }
 		} else {
-		    if ($tmp!~/No such file/) {
+		    #error 2 occurs when the .db doesn't exist
+		    if ($tmp!~/error: 2 /) {
 			&logthis("<font color=blue>WARNING:".
 				 " Trying to get resource data for ".
 				 $uname." at ".$udom.": ".
 				 $tmp."</font>");
-		    } elsif ($tmp=~/error:No such file/) {
+		    } elsif ($tmp=~/error: 2 /) {
                         &EXT_cache_set($udom,$uname);
 		    } elsif ($tmp =~ /^(con_lost|no_such_host)/) {
 			return $tmp;
@@ -3782,9 +3829,12 @@ sub packages_tab_default {
     my $packages=&metadata($uri,'packages');
     foreach my $package (split(/,/,$packages)) {
 	my ($pack_type,$pack_part)=split(/_/,$package,2);
-	if ($pack_part eq $part) {
+	if (defined($packagetab{"$pack_type&$name&default"})) {
 	    return $packagetab{"$pack_type&$name&default"};
 	}
+	if (defined($packagetab{$pack_type."_".$pack_part."&$name&default"})) {
+	    return $packagetab{$pack_type."_".$pack_part."&$name&default"};
+	}
     }
     return undef;
 }
@@ -3813,8 +3863,8 @@ sub metadata {
     # if it is a non metadata possible uri return quickly
     if (($uri eq '') || (($uri =~ m|^/*adm/|) && ($uri !~ m|^adm/includes|)) ||
         ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) ||
-	($uri =~ m|home/[^/]+/public_html/|)) {
-	return '';
+	($uri =~ m|home/[^/]+/public_html/|) || ($uri =~ m|^uploaded/|)) {
+	return undef;
     }
     my $filename=$uri;
     $uri=~s/\.meta$//;
@@ -4362,49 +4412,83 @@ sub setup_random_from_rndseed {
     }
 }
 
+sub latest_receipt_algorithm_id {
+    return 'receipt2';
+}
+
 sub ireceipt {
-    my ($funame,$fudom,$fucourseid,$fusymb)=@_;
+    my ($funame,$fudom,$fucourseid,$fusymb,$part)=@_;
     my $cuname=unpack("%32C*",$funame);
     my $cudom=unpack("%32C*",$fudom);
     my $cucourseid=unpack("%32C*",$fucourseid);
     my $cusymb=unpack("%32C*",$fusymb);
     my $cunique=unpack("%32C*",$perlvar{'lonReceipt'});
-    return unpack("%32C*",$perlvar{'lonHostID'}).'-'.
-           ($cunique%$cuname+
-            $cunique%$cudom+
-            $cusymb%$cuname+
-            $cusymb%$cudom+
-            $cucourseid%$cuname+
-            $cucourseid%$cudom);
+    my $cpart=unpack("%32S*",$part);
+    my $return =unpack("%32C*",$perlvar{'lonHostID'}).'-';
+    if ($ENV{"course.$fucourseid.receiptalg"} eq 'receipt2' ||
+	$ENV{'request.state'} eq 'construct') {
+	&Apache::lonxml::debug("doing receipt2  using parts $cpart, uname $cuname and udom $cudom gets  ".($cpart%$cuname).
+			       " and ".($cpart%$cudom));
+			       
+	$return.= ($cunique%$cuname+
+		   $cunique%$cudom+
+		   $cusymb%$cuname+
+		   $cusymb%$cudom+
+		   $cucourseid%$cuname+
+		   $cucourseid%$cudom+
+		   $cpart%$cuname+
+		   $cpart%$cudom);
+    } else {
+	$return.= ($cunique%$cuname+
+		   $cunique%$cudom+
+		   $cusymb%$cuname+
+		   $cusymb%$cudom+
+		   $cucourseid%$cuname+
+		   $cucourseid%$cudom);
+    }
+    return $return;
 }
 
 sub receipt {
-  my ($symb,$courseid,$domain,$name) = &Apache::lonxml::whichuser();
-  return &ireceipt($name,$domain,$courseid,$symb);
+    my ($part)=@_;
+    my ($symb,$courseid,$domain,$name) = &Apache::lonxml::whichuser();
+    return &ireceipt($name,$domain,$courseid,$symb,$part);
 }
 
 # ------------------------------------------------------------ Serves up a file
-# returns either the contents of the file or a -1
+# returns either the contents of the file or 
+# -1 if the file doesn't exist
+# -2 if an error occured when trying to aqcuire the file
+
 sub getfile {
- my $file=shift;
- if ($file=~/^\/*uploaded\//) { # user file
-    my $ua=new LWP::UserAgent;
-    my $request=new HTTP::Request('GET',&tokenwrapper($file));
-    my $response=$ua->request($request);
-    if ($response->is_success()) {
-       return $response->content;
-    } else { 
-       return -1; 
-    }
- } else { # normal file from res space
-  &repcopy($file);
-  if (! -e $file ) { return -1; };
-  my $fh;
-  open($fh,"<$file");
-  my $a='';
-  while (<$fh>) { $a .=$_; }
-  return $a;
- }
+    my $file=shift;
+    if ($file=~/^\/*uploaded\//) { # user file
+	my $ua=new LWP::UserAgent;
+	my $request=new HTTP::Request('GET',&tokenwrapper($file));
+	my $response=$ua->request($request);
+	if ($response->is_success()) {
+	    return $response->content;
+	} else { 
+	    #&logthis("Return Code is ".$response->code." for $file ".
+	    #         &tokenwrapper($file));
+	    # 500 for ISE when tokenwrapper can't figure out what server to
+            #  contact
+            # 503 when lonuploadacc can't contact the requested server
+	    if ($response->code eq 503 || $response->code eq 500) {
+		return -2;
+	    } else {
+		return -1;
+	    }
+	}
+    } else { # normal file from res space
+	&repcopy($file);
+	if (! -e $file ) { return -1; };
+	my $fh;
+	open($fh,"<$file");
+	my $a='';
+	while (<$fh>) { $a .=$_; }
+	return $a;
+    }
 }
 
 sub filelocation {
@@ -4418,7 +4502,7 @@ sub filelocation {
     $location=$file;
   } else {
     $file=~s/^$perlvar{'lonDocRoot'}//;
-    $file=~s:^/*res::;
+    $file=~s:^/res/:/:;
     if ( !( $file =~ m:^/:) ) {
       $location = $dir. '/'.$file;
     } else {
@@ -4427,19 +4511,47 @@ sub filelocation {
   }
   $location=~s://+:/:g; # remove duplicate /
   while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..
+  while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./
   return $location;
 }
 
 sub hreflocation {
     my ($dir,$file)=@_;
-    unless (($file=~/^http:\/\//i) || ($file=~/^\//)) {
-       my $finalpath=filelocation($dir,$file);
-       $finalpath=~s/^\/home\/httpd\/html//;
-       $finalpath=~s-/home/(\w+)/public_html/-/~$1/-;
-       return $finalpath;
-    } else {
-       return $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=~s-^/home/(\w+)/public_html/-/~$1/-;
+	return $file;
+    }
+    return $file;
+}
+
+sub current_machine_domains {
+    my $hostname=$hostname{$perlvar{'lonHostID'}};
+    my @domains;
+    while( my($id, $name) = each(%hostname)) {
+#	&logthis("-$id-$name-$hostname-");
+	if ($hostname eq $name) {
+	    push(@domains,$hostdom{$id});
+	}
+    }
+    return @domains;
+}
+
+sub current_machine_ids {
+    my $hostname=$hostname{$perlvar{'lonHostID'}};
+    my @ids;
+    while( my($id, $name) = each(%hostname)) {
+#	&logthis("-$id-$name-$hostname-");
+	if ($hostname eq $name) {
+	    push(@ids,$id);
+	}
     }
+    return @ids;
 }
 
 # ------------------------------------------------------------- Declutters URLs