--- loncom/lonnet/perl/lonnet.pm	2003/03/14 15:08:20	1.339
+++ loncom/lonnet/perl/lonnet.pm	2003/07/03 19:26:21	1.386
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.339 2003/03/14 15:08:20 albertel Exp $
+# $Id: lonnet.pm,v 1.386 2003/07/03 19:26:21 matthew Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -74,8 +74,8 @@ use HTTP::Headers;
 use vars 
 qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom 
    %libserv %pr %prp %metacache %packagetab %titlecache 
-   %courselogs %accesshash $processmarker $dumpcount 
-   %coursedombuf %coursehombuf %courseresdatacache 
+   %courselogs %accesshash %userrolehash $processmarker $dumpcount 
+   %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache 
    %domaindescription %domain_auth_def %domain_auth_arg_def $tmpdir);
 use IO::Socket;
 use GDBM_File;
@@ -243,6 +243,26 @@ sub critical {
     }
     return $answer;
 }
+ 
+# ------------------------------------------- Transfer profile into environment
+
+sub transfer_profile_to_env {
+    my ($lonidsdir,$handle)=@_;
+    my @profile;
+    {
+	my $idf=Apache::File->new("$lonidsdir/$handle.id");
+	flock($idf,LOCK_SH);
+	@profile=<$idf>;
+	$idf->close();
+    }
+    my $envi;
+    for ($envi=0;$envi<=$#profile;$envi++) {
+	chomp($profile[$envi]);
+	my ($envname,$envvalue)=split(/=/,$profile[$envi]);
+	$ENV{$envname} = $envvalue;
+    }
+    $ENV{'user.environment'} = "$lonidsdir/$handle.id";
+}
 
 # ---------------------------------------------------------- Append Environment
 
@@ -347,6 +367,30 @@ sub delenv {
     return 'ok';
 }
 
+# ------------------------------------------ Find out current server userload
+# there is a copy in lond
+sub userload {
+    my $numusers=0;
+    {
+	opendir(LONIDS,$perlvar{'lonIDsDir'});
+	my $filename;
+	my $curtime=time;
+	while ($filename=readdir(LONIDS)) {
+	    if ($filename eq '.' || $filename eq '..') {next;}
+	    my ($atime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[8];
+	    if ($curtime-$atime < 3600) { $numusers++; }
+	}
+	closedir(LONIDS);
+    }
+    my $userloadpercent=0;
+    my $maxuserload=$perlvar{'lonUserLoadLim'};
+    if ($maxuserload) {
+	$userloadpercent=100*$numusers/$maxuserload;
+    }
+    $userloadpercent=sprintf("%.2f",$userloadpercent);
+    return $userloadpercent;
+}
+
 # ------------------------------------------ Fight off request when overloaded
 
 sub overloaderror {
@@ -373,17 +417,23 @@ sub overloaderror {
 # ------------------------------ Find server with least workload from spare.tab
 
 sub spareserver {
-    my $loadpercent = shift;
+    my ($loadpercent,$userloadpercent) = @_;
     my $tryserver;
     my $spareserver='';
-    my $lowestserver=$loadpercent; 
+    if ($userloadpercent !~ /\d/) { $userloadpercent=0; }
+    my $lowestserver=$loadpercent > $userloadpercent?
+	             $loadpercent :  $userloadpercent;
     foreach $tryserver (keys %spareid) {
-       my $answer=reply('load',$tryserver);
+       my $loadans=reply('load',$tryserver);
+       my $userloadans=reply('userload',$tryserver);
+       if ($userloadans !~ /\d/) { $userloadans=0; }
+       my $answer=$loadans > $userloadans?
+                  $loadans :  $userloadans;
        if (($answer =~ /\d/) && ($answer<$lowestserver)) {
 	   $spareserver="http://$hostname{$tryserver}";
            $lowestserver=$answer;
        }
-    }    
+    }
     return $spareserver;
 }
 
@@ -588,6 +638,132 @@ sub idput {
     }
 }
 
+# --------------------------------------------------- Assign a key to a student
+
+sub assign_access_key {
+#
+# a valid key looks like uname:udom#comments
+# comments are being appended
+#
+    my ($ckey,$cdom,$cnum,$udom,$uname,$logentry)=@_;
+    $cdom=
+   $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));
+    $cnum=
+   $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));
+    $udom=$ENV{'user.name'} unless (defined($udom));
+    $uname=$ENV{'user.domain'} unless (defined($uname));
+    my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
+    if (($existing{$ckey}=~/^\#(.*)$/) || # - new key
+        ($existing{$ckey}=~/^$uname\:$udom\#(.*)$/)) { 
+                                                  # assigned to this person
+                                                  # - this should not happen,
+                                                  # unless something went wrong
+                                                  # the first time around
+# ready to assign
+        $logentry=$1.'; '.$logentry;
+        if (&put('accesskey',{$ckey=>$uname.':'.$udom.'#'.$logentry},
+                                                 $cdom,$cnum) eq 'ok') {
+# key now belongs to user
+	    my $envkey='key.'.$cdom.'_'.$cnum;
+            if (&put('environment',{$envkey => $ckey}) eq 'ok') {
+                &appenv('environment.'.$envkey => $ckey);
+                return 'ok';
+            } else {
+                return 
+  'error: Count not permanently assign key, will need to be re-entered later.';
+	    }
+        } else {
+            return 'error: Could not assign key, try again later.';
+        }
+    } elsif (!$existing{$ckey}) {
+# the key does not exist
+	return 'error: The key does not exist';
+    } else {
+# the key is somebody else's
+	return 'error: The key is already in use';
+    }
+}
+
+# ------------------------------------------ put an additional comment on a key
+
+sub comment_access_key {
+#
+# a valid key looks like uname:udom#comments
+# comments are being appended
+#
+    my ($ckey,$cdom,$cnum,$logentry)=@_;
+    $cdom=
+   $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));
+    $cnum=
+   $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));
+    my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
+    if ($existing{$ckey}) {
+        $existing{$ckey}.='; '.$logentry;
+# ready to assign
+        if (&put('accesskeys',{$ckey=>$existing{$ckey}},
+                                                 $cdom,$cnum) eq 'ok') {
+	    return 'ok';
+        } else {
+	    return 'error: Count not store comment.';
+        }
+    } else {
+# the key does not exist
+	return 'error: The key does not exist';
+    }
+}
+
+# ------------------------------------------------------ Generate a set of keys
+
+sub generate_access_keys {
+    my ($number,$cdom,$cnum,$logentry)=@_;
+    $cdom=
+   $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));
+    $cnum=
+   $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));
+    unless (&allowed('mky',$cdom)) { return 0; }
+    unless (($cdom) && ($cnum)) { return 0; }
+    if ($number>10000) { return 0; }
+    sleep(2); # make sure don't get same seed twice
+    srand(time()^($$+($$<<15))); # from "Programming Perl"
+    my $total=0;
+    for (my $i=1;$i<=$number;$i++) {
+       my $newkey=sprintf("%lx",int(100000*rand)).'-'.
+                  sprintf("%lx",int(100000*rand)).'-'.
+                  sprintf("%lx",int(100000*rand));
+       $newkey=~s/1/g/g; # folks mix up 1 and l
+       $newkey=~s/0/h/g; # and also 0 and O
+       my %existing=&get('accesskeys',[$newkey],$cdom,$cnum);
+       if ($existing{$newkey}) {
+           $i--;
+       } else {
+	  if (&put('accesskeys',
+              { $newkey => '# generated '.localtime().
+                           ' by '.$ENV{'user.name'}.'@'.$ENV{'user.domain'}.
+                           '; '.$logentry },
+		   $cdom,$cnum) eq 'ok') {
+              $total++;
+	  }
+       }
+    }
+    &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.home'},
+         'Generated '.$total.' keys for '.$cnum.' at '.$cdom);
+    return $total;
+}
+
+# ------------------------------------------------------- Validate an accesskey
+
+sub validate_access_key {
+    my ($ckey,$cdom,$cnum,$udom,$uname)=@_;
+    $cdom=
+   $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));
+    $cnum=
+   $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));
+    $udom=$ENV{'user.name'} unless (defined($udom));
+    $uname=$ENV{'user.domain'} unless (defined($uname));
+    my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
+    return ($existing{$ckey}=~/^$uname\:$udom\#/);
+}
+
 # ------------------------------------- Find the section of student in a course
 
 sub getsection {
@@ -806,9 +982,9 @@ sub repcopy {
 
 # ------------------------------------------------ Get server side include body
 sub ssi_body {
-    my $filelink=shift;
+    my ($filelink,%form)=@_;
     my $output=($filelink=~/^http\:/?&externalssi($filelink):
-                                     &ssi($filelink));
+                                     &ssi($filelink,%form));
     $output=~s/^.*\<body[^\>]*\>//si;
     $output=~s/\<\/body\s*\>.*$//si;
     $output=~
@@ -941,12 +1117,24 @@ sub log {
 }
 
 # ------------------------------------------------------------------ Course Log
+#
+# This routine flushes several buffers of non-mission-critical nature
+#
 
 sub flushcourselogs {
-    &logthis('Flushing course log buffers');
+    &logthis('Flushing log buffers');
+#
+# course logs
+# This is a log of all transactions in a course, which can be used
+# for data mining purposes
+#
+# It also collects the courseid database, which lists last transaction
+# times and course titles for all courseids
+#
+    my %courseidbuffer=();
     foreach (keys %courselogs) {
         my $crsid=$_;
-        if (&reply('log:'.$coursedombuf{$crsid}.':'.
+        if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$crsid}.':'.
 		          &escape($courselogs{$crsid}),
 		          $coursehombuf{$crsid}) eq 'ok') {
 	    delete $courselogs{$crsid};
@@ -957,9 +1145,26 @@ sub flushcourselogs {
                         " exceeded maximum size, deleting.</font>");
                delete $courselogs{$crsid};
             }
-        }        
+        }
+        if ($courseidbuffer{$coursehombuf{$crsid}}) {
+           $courseidbuffer{$coursehombuf{$crsid}}.='&'.
+			 &escape($crsid).'='.&escape($coursedescrbuf{$crsid});
+        } else {
+           $courseidbuffer{$coursehombuf{$crsid}}=
+			 &escape($crsid).'='.&escape($coursedescrbuf{$crsid});
+        }    
     }
-    &logthis('Flushing access logs');
+#
+# Write course id database (reverse lookup) to homeserver of courses 
+# Is used in pickcourse
+#
+    foreach (keys %courseidbuffer) {
+        &courseidput($hostdom{$_},$courseidbuffer{$_},$_);
+    }
+#
+# File accesses
+# Writes to the dynamic metadata of resources to get hit counts, etc.
+#
     foreach (keys %accesshash) {
         my $entry=$_;
         $entry=~/\_\_\_(\w+)\/(\w+)\/(.*)\_\_\_(\w+)$/;
@@ -968,6 +1173,20 @@ sub flushcourselogs {
 	    delete $accesshash{$entry};
         }
     }
+#
+# Roles
+# Reverse lookup of user roles for course faculty/staff and co-authorship
+#
+    foreach (keys %userrolehash) {
+        my $entry=$_;
+        my ($role,$uname,$udom,$runame,$rudom,$rsec)=
+	    split(/\:/,$entry);
+        if (&Apache::lonnet::put('nohist_userroles',
+             { $role.':'.$uname.':'.$udom.':'.$rsec => $userrolehash{$entry} },
+                $rudom,$runame) eq 'ok') {
+	    delete $userrolehash{$entry};
+        }
+    }
     $dumpcount++;
 }
 
@@ -976,10 +1195,13 @@ sub courselog {
     $what=time.':'.$what;
     unless ($ENV{'request.course.id'}) { return ''; }
     $coursedombuf{$ENV{'request.course.id'}}=
-       $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.':'.
+       $ENV{'course.'.$ENV{'request.course.id'}.'.domain'};
+    $coursenumbuf{$ENV{'request.course.id'}}=
        $ENV{'course.'.$ENV{'request.course.id'}.'.num'};
     $coursehombuf{$ENV{'request.course.id'}}=
        $ENV{'course.'.$ENV{'request.course.id'}.'.home'};
+    $coursedescrbuf{$ENV{'request.course.id'}}=
+       $ENV{'course.'.$ENV{'request.course.id'}.'.description'};
     if (defined $courselogs{$ENV{'request.course.id'}}) {
 	$courselogs{$ENV{'request.course.id'}}.='&'.$what;
     } else {
@@ -1016,7 +1238,83 @@ sub countacc {
         $accesshash{$key}=1;
     }
 }
-    
+
+sub linklog {
+    my ($from,$to)=@_;
+    $from=&declutter($from);
+    $to=&declutter($to);
+    $accesshash{$from.'___'.$to.'___comefrom'}=1;
+    $accesshash{$to.'___'.$from.'___goto'}=1;
+}
+  
+sub userrolelog {
+    my ($trole,$username,$domain,$area,$tstart,$tend)=@_;
+    if (($trole=~/^ca/) || ($trole=~/^in/) || 
+        ($trole=~/^cc/) || ($trole=~/^ep/) ||
+        ($trole=~/^cr/)) {
+       my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
+       $userrolehash
+         {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
+                    =$tend.':'.$tstart;
+   }
+}
+
+sub get_course_adv_roles {
+    my $cid=shift;
+    $cid=$ENV{'request.course.id'} unless (defined($cid));
+    my %coursehash=&coursedescription($cid);
+    my %returnhash=();
+    my %dumphash=
+            &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});
+    my $now=time;
+    foreach (keys %dumphash) {
+	my ($tend,$tstart)=split(/\:/,$dumphash{$_});
+        if (($tstart) && ($tstart<0)) { next; }
+        if (($tend) && ($tend<$now)) { next; }
+        if (($tstart) && ($now<$tstart)) { next; }
+        my ($role,$username,$domain,$section)=split(/\:/,$_);
+        my $key=&plaintext($role);
+        if ($section) { $key.=' (Sec/Grp '.$section.')'; }
+        if ($returnhash{$key}) {
+	    $returnhash{$key}.=','.$username.':'.$domain;
+        } else {
+            $returnhash{$key}=$username.':'.$domain;
+        }
+     }
+    return %returnhash;
+}
+
+# ---------------------------------------------------------- Course ID routines
+# Deal with domain's nohist_courseid.db files
+#
+
+sub courseidput {
+    my ($domain,$what,$coursehome)=@_;
+    return &reply('courseidput:'.$domain.':'.$what,$coursehome);
+}
+
+sub courseiddump {
+    my ($domfilter,$descfilter,$sincefilter)=@_;
+    my %returnhash=();
+    unless ($domfilter) { $domfilter=''; }
+    foreach my $tryserver (keys %libserv) {
+	if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) {
+	    foreach (
+             split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'.
+			       $sincefilter.':'.&escape($descfilter),
+                               $tryserver))) {
+		my ($key,$value)=split(/\=/,$_);
+                if (($key) && ($value)) {
+		    $returnhash{&unescape($key)}=&unescape($value);
+                }
+            }
+
+        }
+    }
+    return %returnhash;
+}
+
+#
 # ----------------------------------------------------------- Check out an item
 
 sub checkout {
@@ -1345,7 +1643,7 @@ sub tmpreset {
   my ($symb,$namespace,$domain,$stuname) = @_;
   if (!$symb) {
     $symb=&symbread();
-    if (!$symb) { $symb= $ENV{'REQUEST_URI'}; }
+    if (!$symb) { $symb= $ENV{'request.url'}; }
   }
   $symb=escape($symb);
 
@@ -1621,6 +1919,8 @@ sub rolesinit {
             my ($trole,$tend,$tstart)=split(/_/,$role);
             $userroles.='user.role.'.$trole.'.'.$area.'='.
                         $tstart.'.'.$tend."\n";
+# log the associated role with the area
+            &userrolelog($trole,$username,$domain,$area,$tstart,$tend);
             if ($tend!=0) {
 	        if ($tend<$now) {
 	            $trole='';
@@ -1632,42 +1932,54 @@ sub rolesinit {
                 }
             }
             if (($area ne '') && ($trole ne '')) {
-	       my $spec=$trole.'.'.$area;
-               my ($tdummy,$tdomain,$trest)=split(/\//,$area);
-               if ($trole =~ /^cr\//) {
-		   my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
-                   my $homsvr=homeserver($rauthor,$rdomain);
-                   if ($hostname{$homsvr} ne '') {
-                      my $roledef=
-			  reply("get:$rdomain:$rauthor:roles:rolesdef_$rrole",
-                                $homsvr);
-                      if (($roledef ne 'con_lost') && ($roledef ne '')) {
-                         my ($syspriv,$dompriv,$coursepriv)=
-			     split(/\_/,unescape($roledef));
- 	                 $allroles{'cm./'}.=':'.$syspriv;
-                         $allroles{$spec.'./'}.=':'.$syspriv;
-                         if ($tdomain ne '') {
-                             $allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv;
-                             $allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv;
-                             if ($trest ne '') {
-		                $allroles{'cm.'.$area}.=':'.$coursepriv;
-		                $allroles{$spec.'.'.$area}.=':'.$coursepriv;
-                             }
-	                 }
-                      }
-                   }
-               } else {
-	           $allroles{'cm./'}.=':'.$pr{$trole.':s'};
-	           $allroles{$spec.'./'}.=':'.$pr{$trole.':s'};
-                   if ($tdomain ne '') {
-                     $allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
-                     $allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
-                      if ($trest ne '') {
-		          $allroles{'cm.'.$area}.=':'.$pr{$trole.':c'};
-		          $allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'};
-                      }
-	           }
-	       }
+		my $spec=$trole.'.'.$area;
+		my ($tdummy,$tdomain,$trest)=split(/\//,$area);
+		if ($trole =~ /^cr\//) {
+		    my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
+		    my $homsvr=homeserver($rauthor,$rdomain);
+		    if ($hostname{$homsvr} ne '') {
+			my $roledef=
+			    reply("get:$rdomain:$rauthor:roles:rolesdef_$rrole",
+				  $homsvr);
+			if (($roledef ne 'con_lost') && ($roledef ne '')) {
+			    my ($syspriv,$dompriv,$coursepriv)=
+				split(/\_/,unescape($roledef));
+			    if (defined($syspriv)) {
+				$allroles{'cm./'}.=':'.$syspriv;
+				$allroles{$spec.'./'}.=':'.$syspriv;
+			    }
+			    if ($tdomain ne '') {
+				if (defined($dompriv)) {
+				    $allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv;
+				    $allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv;
+				}
+				if ($trest ne '') {
+				    if (defined($coursepriv)) {
+					$allroles{'cm.'.$area}.=':'.$coursepriv;
+					$allroles{$spec.'.'.$area}.=':'.$coursepriv;
+				    }
+				}
+			    }
+			}
+		    }
+		} else {
+		    if (defined($pr{$trole.':s'})) {
+			$allroles{'cm./'}.=':'.$pr{$trole.':s'};
+			$allroles{$spec.'./'}.=':'.$pr{$trole.':s'};
+		    }
+		    if ($tdomain ne '') {
+			if (defined($pr{$trole.':d'})) {
+			    $allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
+			    $allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
+			}
+			if ($trest ne '') {
+			    if (defined($pr{$trole.':c'})) {
+				$allroles{'cm.'.$area}.=':'.$pr{$trole.':c'};
+				$allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'};
+			    }
+			}
+		    }
+		}
             }
           } 
         }
@@ -1870,6 +2182,37 @@ sub eget {
    return %returnhash;
 }
 
+# ---------------------------------------------- Custom access rule evaluation
+
+sub customaccess {
+    my ($priv,$uri)=@_;
+    my ($urole,$urealm)=split(/\./,$ENV{'request.role'});
+    $urealm=~s/^\W//;
+    my ($udom,$ucrs,$usec)=split(/\//,$urealm);
+    my $access=0;
+    foreach (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) {
+	my ($effect,$realm,$role)=split(/\:/,$_);
+        if ($role) {
+	   if ($role ne $urole) { next; }
+        }
+        foreach (split(/\s*\,\s*/,$realm)) {
+            my ($tdom,$tcrs,$tsec)=split(/\_/,$_);
+            if ($tdom) {
+		if ($tdom ne $udom) { next; }
+            }
+            if ($tcrs) {
+		if ($tcrs ne $ucrs) { next; }
+            }
+            if ($tsec) {
+		if ($tsec ne $usec) { next; }
+            }
+            $access=($effect eq 'allow');
+            last;
+        }
+    }
+    return $access;
+}
+
 # ------------------------------------------------- Check for a user privilege
 
 sub allowed {
@@ -1908,6 +2251,9 @@ sub allowed {
             # Library role, so allow browsing of resources in this domain.
             return 'F';
         }
+        if ($copyright eq 'custom') {
+	    unless (&customaccess($priv,$uri)) { return ''; }
+        }
     }
     # Domain coordinator is trying to create a course
     if (($priv eq 'ccc') && ($ENV{'request.role'} =~ /^dc\./)) {
@@ -2125,20 +2471,10 @@ sub allowed {
 
    if ($thisallowed=~/R/) {
        my $rolecode=(split(/\./,$ENV{'request.role'}))[0];
-       my $filename=$perlvar{'lonDocRoot'}.'/res/'.$uri.'.meta';
-       if (-e $filename) {
-           my @content;
-           {
-	     my $fh=Apache::File->new($filename);
-             @content=<$fh>;
-	   }
-           if (join('',@content)=~
-                    /\<roledeny[^\>]*\>[^\<]*$rolecode[^\<]*\<\/roledeny\>/) {
-	       &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},
+       if (&metadata($uri,'roledeny')=~/$rolecode/) {
+	  &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},
                     'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
-           return '';
-
-           }
+          return '';
        }
    }
 
@@ -2312,7 +2648,7 @@ sub plaintext {
 # ----------------------------------------------------------------- Assign Role
 
 sub assignrole {
-    my ($udom,$uname,$url,$role,$end,$start)=@_;
+    my ($udom,$uname,$url,$role,$end,$start,$deleteflag)=@_;
     my $mrole;
     if ($role =~ /^cr\//) {
 	unless (&allowed('ccr',$url)) {
@@ -2325,7 +2661,7 @@ sub assignrole {
     } else {
         my $cwosec=$url;
         $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;
-        unless (&allowed('c'.$role,$cwosec)) { 
+        unless ((&allowed('c'.$role,$cwosec)) || &allowed('c'.$role,$udom)) { 
            &logthis('Refused assignrole: '.
              $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
 		    $ENV{'user.name'}.' at '.$ENV{'user.domain'});
@@ -2343,7 +2679,25 @@ sub assignrole {
            $command.='_0_'.$start;
         }
     }
-    return &reply($command,&homeserver($uname,$udom));
+# actually delete
+    if ($deleteflag) {
+	if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) {
+# modify command to delete the role
+           $command="encrypt:rolesdel:$ENV{'user.domain'}:$ENV{'user.name'}:".
+                "$udom:$uname:$url".'_'."$mrole";
+	   &logthis("$ENV{'user.name'} at $ENV{'user.domain'} deletes $mrole in $url for $uname at $udom"); 
+# set start and finish to negative values for userrolelog
+           $start=-1;
+           $end=-1;
+        }
+    }
+# send command
+    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);
+    }
+    return $answer;
 }
 
 # -------------------------------------------------- Modify user authentication
@@ -2420,7 +2774,7 @@ sub modifyuser {
         }   
         $uhome=&homeserver($uname,$udom,'true');
         if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) {
-	    return 'error: verify home';
+	    return 'error: unable verify users home machine.';
         }
     }   # End of creation of new user
 # ---------------------------------------------------------------------- Add ID
@@ -2430,7 +2784,8 @@ sub modifyuser {
        if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/) 
          && (!$forceid)) {
 	  unless ($uid eq $uidhash{$uname}) {
-	      return 'error: mismatch '.$uidhash{$uname}.' versus '.$uid;
+	      return 'error: user id "'.$uid.'" does not match '.
+                  'current user id "'.$uidhash{$uname}.'".';
           }
        } else {
 	  &idput($udom,($uname => $uid));
@@ -2446,10 +2801,10 @@ sub modifyuser {
     } else {
         %names = @tmp;
     }
-    if ($first)  { $names{'firstname'}  = $first; }
-    if ($middle) { $names{'middlename'} = $middle; }
-    if ($last)   { $names{'lastname'}   = $last; }
-    if ($gene)   { $names{'generation'} = $gene; }
+    if (defined($first))  { $names{'firstname'}  = $first; }
+    if (defined($middle)) { $names{'middlename'} = $middle; }
+    if (defined($last))   { $names{'lastname'}   = $last; }
+    if (defined($gene))   { $names{'generation'} = $gene; }
     my $reply = &put('environment', \%names, $udom,$uname);
     if ($reply ne 'ok') { return 'error: '.$reply; }
     &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
@@ -2589,6 +2944,11 @@ sub createcourse {
 	return 'error: no such course';
     }
 # ----------------------------------------------------------------- Course made
+# log existance
+    &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description),
+                 $uhome);
+    &flushcourselogs();
+# set toplevel url
     my $topurl=$url;
     unless ($nonstandard) {
 # ------------------------------------------ For standard courses, make top url
@@ -2617,25 +2977,26 @@ ENDINITMAP
 # ---------------------------------------------------------- Assign Custom Role
 
 sub assigncustomrole {
-    my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start)=@_;
+    my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag)=@_;
     return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename,
-                       $end,$start);
+                       $end,$start,$deleteflag);
 }
 
 # ----------------------------------------------------------------- Revoke Role
 
 sub revokerole {
-    my ($udom,$uname,$url,$role)=@_;
+    my ($udom,$uname,$url,$role,$deleteflag)=@_;
     my $now=time;
-    return &assignrole($udom,$uname,$url,$role,$now);
+    return &assignrole($udom,$uname,$url,$role,$now,$deleteflag);
 }
 
 # ---------------------------------------------------------- Revoke Custom Role
 
 sub revokecustomrole {
-    my ($udom,$uname,$url,$rdom,$rnam,$rolename)=@_;
+    my ($udom,$uname,$url,$rdom,$rnam,$rolename,$deleteflag)=@_;
     my $now=time;
-    return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now);
+    return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now,
+           $deleteflag);
 }
 
 # ------------------------------------------------------------ Directory lister
@@ -2724,12 +3085,12 @@ sub GetFileTimestamp {
     $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
     my $proname="$studentDomain/$subdir/$studentName";
     $proname .= '/'.$filename;
-    my @dir = &Apache::lonnet::dirlist($proname, $studentDomain, $studentName,
-                                       $root);
-    my $fileStat = $dir[0];
+    my ($fileStat) = &Apache::lonnet::dirlist($proname, $studentDomain, 
+                                              $studentName, $root);
     my @stats = split('&', $fileStat);
     if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {
-        return $stats[9];
+        # @stats contains first the filename, then the stat output
+        return $stats[10]; # so this is 10 instead of 9.
     } else {
         return -1;
     }
@@ -2825,16 +3186,42 @@ sub courseresdata {
     return undef;
 }
 
-# --------------------------------------------------------- Value of a Variable
+#
+# EXT resource caching routines
+#
+
+sub clear_EXT_cache_status {
+    &delenv('cache.EXT.');
+}
 
+sub EXT_cache_status {
+    my ($target_domain,$target_user) = @_;
+    my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain;
+    if (exists($ENV{$cachename}) && ($ENV{$cachename}+1800) > time) {
+        # We know already the user has no data
+        return 1;
+    } else {
+        return 0;
+    }
+}
+
+sub EXT_cache_set {
+    my ($target_domain,$target_user) = @_;
+    my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain;
+    &appenv($cachename => time);
+}
+
+# --------------------------------------------------------- Value of a Variable
 sub EXT {
-    my ($varname,$symbparm,$udom,$uname,)=@_;
+    my ($varname,$symbparm,$udom,$uname,$usection)=@_;
 
     unless ($varname) { return ''; }
     #get real user name/domain, courseid and symb
     my $courseid;
+    my $publicuser;
     if (!($uname && $udom)) {
-      (my $cursymb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();
+      (my $cursymb,$courseid,$udom,$uname,$publicuser)=
+	  &Apache::lonxml::whichuser($symbparm);
       if (!$symbparm) {	$symbparm=$cursymb; }
     } else {
 	$courseid=$ENV{'request.course.id'};
@@ -2857,7 +3244,12 @@ sub EXT {
 	    if (defined($Apache::lonhomework::parsing_a_problem)) {
 		return $Apache::lonhomework::history{$qualifierrest};
 	    } else {
-		my %restored=&restore($symbparm,$courseid,$udom,$uname);
+		my %restored;
+		if ($publicuser || $ENV{'request.state'} eq 'construct') {
+		    %restored=&tmprestore($symbparm,$courseid,$udom,$uname);
+		} else {
+		    %restored=&restore($symbparm,$courseid,$udom,$uname);
+		}
 		return $restored{$qualifierrest};
 	    }
 # ----------------------------------------------------------------- user.access
@@ -2870,7 +3262,11 @@ sub EXT {
 		($udom eq $ENV{'user.domain'})) {
 		return $ENV{join('.',('environment',$qualifierrest))};
 	    } else {
-		my %returnhash=&userenvironment($udom,$uname,$qualifierrest);
+		my %returnhash;
+		if (!$publicuser) {
+		    %returnhash=&userenvironment($udom,$uname,
+						 $qualifierrest);
+		}
 		return $returnhash{$qualifierrest};
 	    }
 # ----------------------------------------------------------------- user.course
@@ -2894,13 +3290,17 @@ sub EXT {
             return $uname;
 # ---------------------------------------------------- Any other user namespace
         } else {
-            my %reply=&get($space,[$qualifierrest],$udom,$uname);
-            return $reply{$qualifierrest};
+	    my %reply;
+	    if (!$publicuser) {
+		%reply=&get($space,[$qualifierrest],$udom,$uname);
+	    }
+	    return $reply{$qualifierrest};
         }
     } elsif ($realm eq 'query') {
 # ---------------------------------------------- pull stuff out of query string
-        &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'},[$space]);
-	return $ENV{'form.'.$space}; 
+        &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'},
+						[$spacequalifierrest]);
+	return $ENV{'form.'.$spacequalifierrest}; 
    } elsif ($realm eq 'request') {
 # ------------------------------------------------------------- request.browser
         if ($space eq 'browser') {
@@ -2914,7 +3314,7 @@ sub EXT {
         return $ENV{'course.'.$courseid.'.'.$spacequalifierrest};
     } elsif ($realm eq 'resource') {
 
-	if ($courseid eq $ENV{'request.course.id'}) {
+	if (defined($courseid) && $courseid eq $ENV{'request.course.id'}) {
 
 	    #print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;
 
@@ -2931,7 +3331,11 @@ sub EXT {
 		($ENV{'user.domain'} eq $udom)) {
 		$section=$ENV{'request.course.sec'};
 	    } else {
-		$section=&usection($udom,$uname,$courseid);
+                if (! defined($usection)) {
+                    $section=&usection($udom,$uname,$courseid);
+                } else {
+                    $section = $usection;
+                }
 	    }
 
 	    my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
@@ -2943,11 +3347,9 @@ sub EXT {
 	    my $courselevelm=$courseid.'.'.$mapparm;
 
 # ----------------------------------------------------------- first, check user
-	    #most student don't have any data set, check if there is some data
+	    #most student don\'t have any data set, check if there is some data
             #every thirty minutes
-	    if (!
-		(exists($ENV{'cache.studentresdata'})
-		    && (($ENV{'cache.studentresdata'}+1800) > time))) {
+	    if (! &EXT_cache_status($udom,$uname)) {
 		my %resourcedata=&get('resourcedata',
 				      [$courselevelr,$courselevelm,$courselevel],
 				      $udom,$uname);
@@ -2966,9 +3368,7 @@ sub EXT {
 				 $uname." at ".$udom.": ".
 				 $tmp."</font>");
 		    } elsif ($tmp=~/error:No such file/) {
-			$ENV{'cache.studentresdata'}=time;
-			&appenv(('cache.studentresdata'=>
-				 $ENV{'cache.studentresdata'}));
+                        &EXT_cache_set($udom,$uname);
 		    } elsif ($tmp =~ /^(con_lost|no_such_host)/) {
 			return $tmp;
 		    }
@@ -3088,6 +3488,7 @@ sub metadata {
         my $parser=HTML::LCParser->new(\$metastring);
         my $token;
         undef %metathesekeys;
+	delete($metacache{$uri.':packages'});
         while ($token=$parser->get_token) {
 	    if ($token->[0] eq 'S') {
 		if (defined($token->[2]->{'package'})) {
@@ -3114,15 +3515,20 @@ sub metadata {
 				$value.=' [Part: '.$part.']';
 			    }
 			    my $unikey='parameter'.$keyroot.'_'.$name;
-			    $metathesekeys{$unikey}=1;
-			    $metacache{$uri.':'.$unikey.'.part'}=$part;
+			    if ($subp eq 'default') {
+				$unikey='parameter_0_'.$name;
+				$metacache{$uri.':'.$unikey.'.part'}='0';
+			    } else {
+				$metacache{$uri.':'.$unikey.'.part'}=$part;
+				$metathesekeys{$unikey}=1;
+			    }
 			    unless (defined($metacache{$uri.':'.$unikey.'.'.$subp})) {
 				$metacache{$uri.':'.$unikey.'.'.$subp}=$value;
 			    }
 			    if (defined($metacache{$uri.':'.$unikey.'.default'})) {
 				$metacache{$uri.':'.$unikey}=
-				    $metacache{$uri.':'.$unikey.'.default'}
-				}
+				    $metacache{$uri.':'.$unikey.'.default'};
+			    }
 			}
 		    }
 		} else {
@@ -3218,7 +3624,7 @@ sub metadata_generate_part0 {
 	if ($metakey=~/^parameter\_(.*)/) {
 	  my $part=$$metacache{$uri.':'.$metakey.'.part'};
 	  my $name=$$metacache{$uri.':'.$metakey.'.name'};
-	  if (! exists($$metadata{'parameter_0_'.$name})) {
+	  if (! exists($$metadata{'parameter_0_'.$name.'.name'})) {
 	    $allnames{$name}=$part;
 	  }
 	}
@@ -3248,7 +3654,13 @@ sub gettitle {
 	unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; }
         return &metadata($urlsymb,'title'); 
     }
-    if ($titlecache{$symb}) { return $titlecache{$symb}; }
+    if ($titlecache{$symb}) {
+	if (time < ($titlecache{$symb}[1] + 600)) {
+	    return $titlecache{$symb}[0];
+	} else {
+	    delete($titlecache{$symb});
+	}
+    }
     my ($map,$resid,$url)=split(/\_\_\_/,$symb);
     my $title='';
     my %bighash;
@@ -3258,8 +3670,9 @@ sub gettitle {
         $title=$bighash{'title_'.$mapid.'.'.$resid};
         untie %bighash;
     }
+    $title=~s/\&colon\;/\:/gs;
     if ($title) {
-        $titlecache{$symb}=$title;
+        $titlecache{$symb}=[$title,time];
         return $title;
     } else {
 	return &metadata($urlsymb,'title');
@@ -3431,29 +3844,92 @@ sub numval {
     $txt=~tr/u-z/0-5/;
     $txt=~s/\D//g;
     return int($txt);
-}    
+}
+
+sub latest_rnd_algorithm_id {
+    return '64bit';
+}
 
 sub rndseed {
     my ($symb,$courseid,$domain,$username)=@_;
+
+    my ($wsymb,$wcourseid,$wdomain,$wusername)=&Apache::lonxml::whichuser();
     if (!$symb) {
-      unless ($symb=&symbread()) { return time; }
+	unless ($symb=$wsymb) { return time; }
+    }
+    if (!$courseid) { $courseid=$wcourseid; }
+    if (!$domain) { $domain=$wdomain; }
+    if (!$username) { $username=$wusername }
+    my $which=$ENV{"course.$courseid.rndseed"};
+    my $CODE=$ENV{'scantron.CODE'};
+    if (defined($CODE)) {
+	&rndseed_CODE_64bit($symb,$courseid,$domain,$username);
+    } elsif ($which eq '64bit') {
+	return &rndseed_64bit($symb,$courseid,$domain,$username);
+    }
+    return &rndseed_32bit($symb,$courseid,$domain,$username);
+}
+
+sub rndseed_32bit {
+    my ($symb,$courseid,$domain,$username)=@_;
+    {
+	use integer;
+	my $symbchck=unpack("%32C*",$symb) << 27;
+	my $symbseed=numval($symb) << 22;
+	my $namechck=unpack("%32C*",$username) << 17;
+	my $nameseed=numval($username) << 12;
+	my $domainseed=unpack("%32C*",$domain) << 7;
+	my $courseseed=unpack("%32C*",$courseid);
+	my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;
+	#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
+	#&Apache::lonxml::debug("rndseed :$num:$symb");
+	return $num;
+    }
+}
+
+sub rndseed_64bit {
+    my ($symb,$courseid,$domain,$username)=@_;
+    {
+	use integer;
+	my $symbchck=unpack("%32S*",$symb) << 21;
+	my $symbseed=numval($symb) << 10;
+	my $namechck=unpack("%32S*",$username);
+	
+	my $nameseed=numval($username) << 21;
+	my $domainseed=unpack("%32S*",$domain) << 10;
+	my $courseseed=unpack("%32S*",$courseid);
+	
+	my $num1=$symbchck+$symbseed+$namechck;
+	my $num2=$nameseed+$domainseed+$courseseed;
+	#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
+	#&Apache::lonxml::debug("rndseed :$num:$symb");
+	return "$num1,$num2";
     }
-    if (!$courseid) { $courseid=$ENV{'request.course.id'};}
-    if (!$domain) {$domain=$ENV{'user.domain'};}
-    if (!$username) {$username=$ENV{'user.name'};}
+}
+
+sub rndseed_CODE_64bit {
+    my ($symb,$courseid,$domain,$username)=@_;
     {
-      use integer;
-      my $symbchck=unpack("%32C*",$symb) << 27;
-      my $symbseed=numval($symb) << 22;
-      my $namechck=unpack("%32C*",$username) << 17;
-      my $nameseed=numval($username) << 12;
-      my $domainseed=unpack("%32C*",$domain) << 7;
-      my $courseseed=unpack("%32C*",$courseid);
-      my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;
-      #uncommenting these lines can break things!
-      #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
-      #&Apache::lonxml::debug("rndseed :$num:$symb");
-      return $num;
+	use integer;
+	my $symbchck=unpack("%32S*",$symb) << 16;
+	my $symbseed=numval($symb);
+	my $CODEseed=numval($ENV{'scantron.CODE'}) << 16;
+	my $courseseed=unpack("%32S*",$courseid);
+	my $num1=$symbseed+$CODEseed;
+	my $num2=$courseseed+$symbchck;
+	#&Apache::lonxml::debug("$symbseed:$CODEseed|$courseseed:$symbchck");
+	#&Apache::lonxml::debug("rndseed :$num1:$num2:$symb");
+	return "$num1,$num2";
+    }
+}
+
+sub setup_random_from_rndseed {
+    my ($rndseed)=@_;
+    if ($rndseed =~/,/) {
+	my ($num1,$num2)=split(/,/,$rndseed);
+	&Math::Random::random_set_seed(abs($num1),abs($num2));
+    } else {
+	&Math::Random::random_set_seed_from_phrase($rndseed);
     }
 }
 
@@ -3579,6 +4055,7 @@ sub goodbye {
    &logthis("Starting Shut down");
    &flushcourselogs();
    &logthis("Shutting down");
+   return DONE;
 }
 
 BEGIN {