--- loncom/lonnet/perl/lonnet.pm	2006/03/27 23:00:18	1.722
+++ loncom/lonnet/perl/lonnet.pm	2006/05/01 06:17:32	1.733
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.722 2006/03/27 23:00:18 albertel Exp $
+# $Id: lonnet.pm,v 1.733 2006/05/01 06:17:32 raeburn Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -45,7 +45,6 @@ qw(%perlvar %hostname %badServerCache %i
 
 use IO::Socket;
 use GDBM_File;
-use Apache::Constants qw(:common :http);
 use HTML::LCParser;
 use HTML::Parser;
 use Fcntl qw(:flock);
@@ -86,6 +85,29 @@ delayed.
 
 
 # --------------------------------------------------------------------- Logging
+{
+    my $logid;
+    sub instructor_log {
+	my ($hash_name,$storehash,$delflag,$uname,$udom)=@_;
+	$logid++;
+	my $id=time().'00000'.$$.'00000'.$logid;
+	return &Apache::lonnet::put('nohist_'.$hash_name,
+				    { $id => {
+					'exe_uname' => $env{'user.name'},
+					'exe_udom'  => $env{'user.domain'},
+					'exe_time'  => time(),
+					'exe_ip'    => $ENV{'REMOTE_ADDR'},
+					'delflag'   => $delflag,
+					'logentry'  => $storehash,
+					'uname'     => $uname,
+					'udom'      => $udom,
+				    }
+				  },
+				    $env{'course.'.$env{'request.course.id'}.'.domain'},
+				    $env{'course.'.$env{'request.course.id'}.'.num'}
+				    );
+    }
+}
 
 sub logtouch {
     my $execdir=$perlvar{'lonDaemons'};
@@ -279,6 +301,8 @@ sub transfer_profile_to_env {
     for ($envi=0;$envi<=$#profile;$envi++) {
 	chomp($profile[$envi]);
 	my ($envname,$envvalue)=split(/=/,$profile[$envi],2);
+	$envname=&unescape($envname);
+	$envvalue=&unescape($envvalue);
 	$env{$envname} = $envvalue;
         if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {
             if ($time < time-300) {
@@ -331,6 +355,8 @@ sub appenv {
         chomp($oldenv[$i]);
         if ($oldenv[$i] ne '') {
 	    my ($name,$value)=split(/=/,$oldenv[$i],2);
+	    $name=&unescape($name);
+	    $value=&unescape($value);
 	    unless (defined($newenv{$name})) {
 		$newenv{$name}=$value;
 	    }
@@ -343,7 +369,7 @@ sub appenv {
 	}
 	my $newname;
 	foreach $newname (keys %newenv) {
-	    print $fh "$newname=$newenv{$newname}\n";
+	    print $fh &escape($newname).'='.&escape($newenv{$newname})."\n";
 	}
 	close($fh);
     }
@@ -355,7 +381,6 @@ sub appenv {
 
 sub delenv {
     my $delthis=shift;
-    my %newenv=();
     if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {
         &logthis("<font color=\"blue\">WARNING: ".
                 "Attempt to delete from environment ".$delthis);
@@ -388,8 +413,10 @@ sub delenv {
 	    return 'error: '.$!;
 	}
 	foreach my $cur_key (@oldenv) {
-	    if ($cur_key=~/^$delthis/) { 
-                my ($key,undef) = split('=',$cur_key,2);
+	    my $unescaped_cur_key = &unescape($cur_key);
+	    if ($unescaped_cur_key=~/^$delthis/) { 
+                my ($key) = split('=',$cur_key,2);
+		$key = &unescape($key);
                 delete($env{$key});
             } else {
                 print $fh $cur_key; 
@@ -847,12 +874,9 @@ sub getsection {
 }
 
 sub save_cache {
-    my ($r)=@_;
-    if (! $r->is_initial_req()) { return DECLINED; }
     &purge_remembered();
     #&Apache::loncommon::validate_page();
     undef(%env);
-    return OK;
 }
 
 my $to_remember=-1;
@@ -1004,13 +1028,13 @@ sub retrievestudentphoto {
 # -------------------------------------------------------------------- New chat
 
 sub chatsend {
-    my ($newentry,$anon)=@_;
+    my ($newentry,$anon,$group)=@_;
     my $cnum=$env{'course.'.$env{'request.course.id'}.'.num'};
     my $cdom=$env{'course.'.$env{'request.course.id'}.'.domain'};
     my $chome=$env{'course.'.$env{'request.course.id'}.'.home'};
     &reply('chatsend:'.$cdom.':'.$cnum.':'.
 	   &escape($env{'user.domain'}.':'.$env{'user.name'}.':'.$anon.':'.
-		   &escape($newentry)),$chome);
+		   &escape($newentry)).':'.$group,$chome);
 }
 
 # ------------------------------------------ Find current version of a resource
@@ -2576,7 +2600,7 @@ sub restore {
 # ---------------------------------------------------------- Course Description
 
 sub coursedescription {
-    my $courseid=shift;
+    my ($courseid,$args)=@_;
     $courseid=~s/^\///;
     $courseid=~s/\_/\//g;
     my ($cdomain,$cnum)=split(/\//,$courseid);
@@ -2586,7 +2610,27 @@ sub coursedescription {
     # trying and trying and trying to get the course description.
     my %envhash=();
     my %returnhash=();
-    $envhash{'course.'.$normalid.'.last_cache'}=time;
+    
+    my $expiretime=600;
+    if ($env{'request.course.id'} eq $normalid) {
+	$expiretime=120;
+    }
+
+    my $prefix='course.'.$cdomain.'_'.$cnum.'.';
+    if (!$args->{'freshen_cache'}
+	&& ((time-$env{$prefix.'last_cache'}) < $expiretime) ) {
+	foreach my $key (keys(%env)) {
+	    next if ($key !~ /^\Q$prefix\E(.*)/);
+	    my ($setting) = $1;
+	    $returnhash{$setting} = $env{$key};
+	}
+	return %returnhash;
+    }
+
+    # get the data agin
+    if (!$args->{'one_time'}) {
+	$envhash{'course.'.$normalid.'.last_cache'}=time;
+    }
     if ($chome ne 'no_host') {
        %returnhash=&dump('environment',$cdomain,$cnum);
        if (!exists($returnhash{'con_lost'})) {
@@ -2604,7 +2648,9 @@ sub coursedescription {
            $envhash{'course.'.$normalid.'.num'}=$cnum;
        }
     }
-    &appenv(%envhash);
+    if (!$args->{'one_time'}) {
+	&appenv(%envhash);
+    }
     return %returnhash;
 }
 
@@ -3424,7 +3470,7 @@ sub allowed {
 	       my ($cdom,$cnum,$csec)=split(/\//,$courseid);
                my $prefix='course.'.$cdom.'_'.$cnum.'.';
                if ((time-$env{$prefix.'last_cache'})>$expiretime) {
-		   &coursedescription($courseid);
+		   &coursedescription($courseid,{'freshen_cache' => 1});
                }
                if (($env{$prefix.'res.'.$uri.'.lock.sections'}=~/\,\Q$csec\E\,/)
                 || ($env{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) {
@@ -3970,31 +4016,51 @@ sub get_group_membership {
 
 sub get_users_groups {
     my ($udom,$uname,$courseid) = @_;
+    my @usersgroups;
     my $cachetime=1800;
     $courseid=~s/\_/\//g;
     $courseid=~s/^(\w)/\/$1/;
 
     my $hashid="$udom:$uname:$courseid";
-    my ($result,$cached)=&is_cached_new('getgroups',$hashid);
-    if (defined($cached)) { return $result; }
-
-    my %roleshash = &dump('roles',$udom,$uname,$courseid);
-    my ($tmp) = keys(%roleshash);
-    if ($tmp=~/^error:/) {
-        &logthis('Error retrieving roles: '.$tmp.' for '.$uname.':'.$udom);
-        return '';
-    } else {
-        my $grouplist;
-        foreach my $key (keys %roleshash) {
-            if ($key =~ /^\Q$courseid\E\/(\w+)\_gr$/) {
-                unless ($roleshash{$key} =~ /_1_1$/) {   # deleted membership
-                    $grouplist .= $1.':';
+    my ($grouplist,$cached)=&is_cached_new('getgroups',$hashid);
+    if (defined($cached)) {
+        @usersgroups = split/:/,$grouplist;
+    } else {  
+        $grouplist = '';
+        my %roleshash = &dump('roles',$udom,$uname,$courseid);
+        my ($tmp) = keys(%roleshash);
+        if ($tmp=~/^error:/) {
+            &logthis('Error retrieving roles: '.$tmp.' for '.$uname.':'.$udom);
+        } else {
+            my $access_end = $env{'course.'.$courseid.
+                                  '.default_enrollment_end_date'};
+            my $now = time;
+            foreach my $key (keys %roleshash) {
+                if ($key =~ /^\Q$courseid\E\/(\w+)\_gr$/) {
+                    my $group = $1;
+                    if ($roleshash{$key} =~ /_(\d+)_(\d+)$/) {
+                        my $start = $2;
+                        my $end = $1;
+                        if ($start == -1) { next; } # deleted from group
+                        if (($start!=0) && ($start>$now)) { next; }
+                        if (($end!=0) && ($end<$now)) {
+                            if ($access_end && $access_end < $now) {
+                                if ($access_end - $end < 86400) {
+                                    push(@usersgroups,$group);
+                                }
+                            }
+                            next;
+                        }
+                        push(@usersgroups,$group);
+                    }
                 }
             }
+            @usersgroups = &sort_course_groups($courseid,@usersgroups);
+            $grouplist = join(':',@usersgroups);
+            &do_cache_new('getgroups',$hashid,$grouplist,$cachetime);
         }
-        $grouplist =~ s/:$//;
-        return &do_cache_new('getgroups',$hashid,$grouplist,$cachetime);
     }
+    return @usersgroups;
 }
 
 sub devalidate_getgroups_cache {
@@ -4743,11 +4809,10 @@ sub stat_file {
     $uri = &clutter($uri);
 
     # we want just the url part without the unneeded accessor url bits
-    if ($file =~ m-^/adm/-) {
-	$file=~s-^/adm/wrapper/-/-;
-	$file=~s-^/adm/coursedocs/showdoc/-/-;
+    if ($uri =~ m-^/adm/-) {
+	$uri=~s-^/adm/wrapper/-/-;
+	$uri=~s-^/adm/coursedocs/showdoc/-/-;
     }
-    
     my ($udom,$uname,$file,$dir);
     if ($uri =~ m-^/(uploaded|editupload)/-) {
 	($udom,$uname,$file) =
@@ -5114,20 +5179,15 @@ sub EXT {
 	    if (($env{'user.name'} eq $uname) &&
 		($env{'user.domain'} eq $udom)) {
 		$section=$env{'request.course.sec'};
-                @groups=&sort_course_groups($env{'request.course.groups'},$courseid); 
-                if (@groups > 0) {
-                    @groups = sort(@groups);
-                }
+                @groups = split(/:/,$env{'request.course.groups'});  
+                @groups=&sort_course_groups($courseid,@groups); 
 	    } else {
 		if (! defined($usection)) {
 		    $section=&getsection($udom,$uname,$courseid);
 		} else {
 		    $section = $usection;
 		}
-                my $grouplist = &get_users_groups($udom,$uname,$courseid);
-                if ($grouplist) {
-                    @groups=&sort_course_groups($grouplist,$courseid);
-                }
+                @groups = &get_users_groups($udom,$uname,$courseid);
 	    }
 
 	    my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
@@ -5251,8 +5311,8 @@ sub check_group_parms {
 }
 
 sub sort_course_groups { # Sort groups based on defined rankings. Default is sort().
-    my ($grouplist,$courseid) = @_;
-    my @groups = sort(split(/:/,$grouplist));
+    my ($courseid,@groups) = @_;
+    @groups = sort(@groups);
     return @groups;
 }
 
@@ -6524,7 +6584,6 @@ sub goodbye {
    &logthis(sprintf("%-20s is %s",'hits',$hits));
    &flushcourselogs();
    &logthis("Shutting down");
-   return DONE;
 }
 
 BEGIN {