--- loncom/lonnet/perl/lonnet.pm	2003/03/22 21:23:35	1.345
+++ loncom/lonnet/perl/lonnet.pm	2003/03/28 21:20:16	1.356
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.345 2003/03/22 21:23:35 www Exp $
+# $Id: lonnet.pm,v 1.356 2003/03/28 21:20:16 albertel 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;
@@ -600,14 +600,14 @@ sub assign_access_key {
     $uname=$ENV{'user.domain'} unless (defined($uname));
     my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
     if (($existing{$ckey}=~/^\d+$/) || # has time - new key
-        ($existing{$ckey} eq $udom.':'.$uname)) { # this should not happen,
+        ($existing{$ckey} eq $uname.':'.$udom)) { # this should not happen,
                                                   # unless something went wrong
                                                   # the first time around
 # ready to assign
     } elsif (!$existing{$ckey}) {
-        if (&put('accesskey',{$ckey=>$udom.':'.$uname},$cdom,$cnum) eq 'ok') {
+        if (&put('accesskey',{$ckey=>$uname.':'.$udom},$cdom,$cnum) eq 'ok') {
 # key now belongs to user
-	    my $envkey='key.'.$cdom.'.'.$cnum;
+	    my $envkey='key.'.$cdom.'_'.$cnum;
             if (&put('environment',{$envkey => $ckey}) eq 'ok') {
                 &appenv('environment.'.$envkey => $ckey);
                 return 'ok';
@@ -671,7 +671,7 @@ sub validate_access_key {
     $udom=$ENV{'user.name'} unless (defined($udom));
     $uname=$ENV{'user.domain'} unless (defined($uname));
     my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
-    return ($existing{$ckey} eq $udom.':'.$uname);
+    return ($existing{$ckey} eq $uname.':'.$udom);
 }
 
 # ------------------------------------- Find the section of student in a course
@@ -1027,12 +1027,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};
@@ -1043,9 +1055,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});
+        }    
+    }
+#
+# Write course id database (reverse lookup) to homeserver of courses 
+# Is used in pickcourse
+#
+    foreach (keys %courseidbuffer) {
+        &courseidput($hostdom{$_},$courseidbuffer{$_},$_);
     }
-    &logthis('Flushing access logs');
+#
+# File accesses
+# Writes to the dynamic metadata of resources to get hit counts, etc.
+#
     foreach (keys %accesshash) {
         my $entry=$_;
         $entry=~/\_\_\_(\w+)\/(\w+)\/(.*)\_\_\_(\w+)$/;
@@ -1054,6 +1083,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++;
 }
 
@@ -1062,10 +1105,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 {
@@ -1102,7 +1148,75 @@ sub countacc {
         $accesshash{$key}=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 sort %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 {
@@ -1707,6 +1821,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='';
@@ -1718,42 +1834,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'};
+			    }
+			}
+		    }
+		}
             }
           } 
         }
@@ -2453,7 +2581,11 @@ sub assignrole {
            $command.='_0_'.$start;
         }
     }
-    return &reply($command,&homeserver($uname,$udom));
+    my $answer=&reply($command,&homeserver($uname,$udom));
+    if ($answer eq 'ok') {
+	&userrolelog($mrole,$uname,$udom,$url,$start,$end);
+    }
+    return $answer;
 }
 
 # -------------------------------------------------- Modify user authentication
@@ -3224,16 +3356,20 @@ sub metadata {
 				$value.=' [Part: '.$part.']';
 			    }
 			    my $unikey='parameter'.$keyroot.'_'.$name;
-			    if ($subp eq 'default') { $unikey='parameter_0_'.$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 {
@@ -3329,7 +3465,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;
 	  }
 	}