--- loncom/lonnet/perl/lonnet.pm	2006/03/04 06:03:30	1.717
+++ loncom/lonnet/perl/lonnet.pm	2006/05/16 18:50:55	1.738
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.717 2006/03/04 06:03:30 albertel Exp $
+# $Id: lonnet.pm,v 1.738 2006/05/16 18:50:55 albertel 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'};
@@ -260,6 +282,13 @@ sub critical {
 
 sub transfer_profile_to_env {
     my ($lonidsdir,$handle)=@_;
+    if (!defined($lonidsdir)) {
+	$lonidsdir = $perlvar{'lonIDsDir'};
+    }
+    if (!defined($handle)) {
+        ($handle) = ($env{'user.environment'} =~m|/([^/]+)\.id$| );
+    }
+
     my @profile;
     {
 	open(my $idf,"$lonidsdir/$handle.id");
@@ -272,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) {
@@ -324,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;
 	    }
@@ -336,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);
     }
@@ -348,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);
@@ -381,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; 
@@ -840,11 +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;
@@ -996,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
@@ -1320,7 +1352,7 @@ sub clean_filename {
 
 # --------------- Take an uploaded file and put it into the userfiles directory
 # input: $formname - the contents of the file are in $env{"form.$formname"}
-#                    the desired filenam is in $env{"form.$formname"}
+#                    the desired filenam is in $env{"form.$formname.filename"}
 #        $coursedoc - if true up to the current course
 #                     if false
 #        $subdir - directory in userfile to store the file into
@@ -1331,7 +1363,7 @@ sub clean_filename {
 
 
 sub userfileupload {
-    my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase)=@_;
+    my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname,$destudom)=@_;
     if (!defined($subdir)) { $subdir='unknown'; }
     my $fname=$env{'form.'.$formname.'.filename'};
     $fname=&clean_filename($fname);
@@ -1354,6 +1386,7 @@ sub userfileupload {
         close($fh);
         return $fullpath.'/'.$fname; 
     }
+    
 # Create the directory if not present
     $fname="$subdir/$fname";
     if ($coursedoc) {
@@ -1369,6 +1402,12 @@ sub userfileupload {
 				       $fname,$formname,$parser,
 				       $allfiles,$codebase);
         }
+    } elsif (defined($destuname)) {
+        my $docuname=$destuname;
+        my $docudom=$destudom;
+	return &finishuserfileupload($docuname,$docudom,$formname,
+				     $fname,$parser,$allfiles,$codebase);
+        
     } else {
         my $docuname=$env{'user.name'};
         my $docudom=$env{'user.domain'};
@@ -2561,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);
@@ -2571,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'})) {
@@ -2589,7 +2648,9 @@ sub coursedescription {
            $envhash{'course.'.$normalid.'.num'}=$cnum;
        }
     }
-    &appenv(%envhash);
+    if (!$args->{'one_time'}) {
+	&appenv(%envhash);
+    }
     return %returnhash;
 }
 
@@ -3409,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')) {
@@ -3955,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 {
@@ -4726,6 +4807,12 @@ sub GetFileTimestamp {
 sub stat_file {
     my ($uri) = @_;
     $uri = &clutter($uri);
+
+    # we want just the url part without the unneeded accessor url bits
+    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) =
@@ -4746,6 +4833,7 @@ sub stat_file {
 
     my ($result) = &dirlist($file,$udom,$uname,$dir);
     my @stats = split('&', $result);
+    
     if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {
 	shift(@stats); #filename is first
 	return @stats;
@@ -5083,7 +5171,7 @@ sub EXT {
 
 # ----------------------------------------------------- Cascading lookup scheme
 	    my $symbp=$symbparm;
-	    my $mapp=(&decode_symb($symbp))[0];
+	    my $mapp=&deversion((&decode_symb($symbp))[0]);
 
 	    my $symbparm=$symbp.'.'.$spacequalifierrest;
 	    my $mapparm=$mapp.'___(all).'.$spacequalifierrest;
@@ -5091,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;
@@ -5228,20 +5311,37 @@ sub check_group_parms {
 }
 
 sub sort_course_groups { # Sort groups based on defined rankings. Default is sort().
-    my ($grouplist,$courseid) = @_;
-    my @groups = split/:/,$grouplist;
-    if (@groups > 1) {
-        @groups = sort(@groups);
-    }
+    my ($courseid,@groups) = @_;
+    @groups = sort(@groups);
     return @groups;
 }
 
 sub packages_tab_default {
     my ($uri,$varname)=@_;
     my (undef,$part,$name)=split(/\./,$varname);
-    my $packages=&metadata($uri,'packages');
-    foreach my $package (split(/,/,$packages)) {
+
+    my (@extension,@specifics,$do_default);
+    foreach my $package (split(/,/,&metadata($uri,'packages'))) {
 	my ($pack_type,$pack_part)=split(/_/,$package,2);
+	if ($pack_type eq 'default') {
+	    $do_default=1;
+	} elsif ($pack_type eq 'extension') {
+	    push(@extension,[$package,$pack_type,$pack_part]);
+	} else {
+	    push(@specifics,[$package,$pack_type,$pack_part]);
+	}
+    }
+    # first look for a package that matches the requested part id
+    foreach my $package (@specifics) {
+	my (undef,$pack_type,$pack_part)=@{$package};
+	next if ($pack_part ne $part);
+	if (defined($packagetab{"$pack_type&$name&default"})) {
+	    return $packagetab{"$pack_type&$name&default"};
+	}
+    }
+    # look for any possible matching non extension_ package
+    foreach my $package (@specifics) {
+	my (undef,$pack_type,$pack_part)=@{$package};
 	if (defined($packagetab{"$pack_type&$name&default"})) {
 	    return $packagetab{"$pack_type&$name&default"};
 	}
@@ -5250,6 +5350,20 @@ sub packages_tab_default {
 	    return $packagetab{$pack_type."_".$pack_part."&$name&default"};
 	}
     }
+    # look for any posible extension_ match
+    foreach my $package (@extension) {
+	my ($package,$pack_type)=@{$package};
+	if (defined($packagetab{"$pack_type&$name&default"})) {
+	    return $packagetab{"$pack_type&$name&default"};
+	}
+	if (defined($packagetab{$package."&$name&default"})) {
+	    return $packagetab{$package."&$name&default"};
+	}
+    }
+    # look for a global default setting
+    if ($do_default && defined($packagetab{"default&$name&default"})) {
+	return $packagetab{"default&$name&default"};
+    }
     return undef;
 }
 
@@ -5335,16 +5449,16 @@ sub metadata {
 		    } else {
 			$metaentry{':packages'}=$package.$keyroot;
 		    }
-		    foreach (sort keys %packagetab) {
+		    foreach my $pack_entry (keys(%packagetab)) {
 			my $part=$keyroot;
 			$part=~s/^\_//;
-			if ($_=~/^\Q$package\E\&/ || 
-			    $_=~/^\Q$package\E_0\&/) {
-			    my ($pack,$name,$subp)=split(/\&/,$_);
+			if ($pack_entry=~/^\Q$package\E\&/ || 
+			    $pack_entry=~/^\Q$package\E_0\&/) {
+			    my ($pack,$name,$subp)=split(/\&/,$pack_entry);
 			    # ignore package.tab specified default values
                             # here &package_tab_default() will fetch those
 			    if ($subp eq 'default') { next; }
-			    my $value=$packagetab{$_};
+			    my $value=$packagetab{$pack_entry};
 			    my $unikey;
 			    if ($pack =~ /_0$/) {
 				$unikey='parameter_0_'.$name;
@@ -5392,11 +5506,12 @@ sub metadata {
 			    my $dir=$filename;
 			    $dir=~s|[^/]*$||;
 			    $location=&filelocation($dir,$location);
-			    foreach (sort(split(/\,/,&metadata($uri,'keys',
-							       $location,$unikey,
-							       $depthcount+1)))) {
-				$metaentry{':'.$_}=$metaentry{':'.$_};
-				$metathesekeys{$_}=1;
+			    my $metadata = 
+				&metadata($uri,'keys', $location,$unikey,
+					  $depthcount+1);
+			    foreach my $meta (split(',',$metadata)) {
+				$metaentry{':'.$meta}=$metaentry{':'.$meta};
+				$metathesekeys{$meta}=1;
 			    }
 			}
 		    } else { 
@@ -5405,8 +5520,9 @@ sub metadata {
 			    $unikey.='_'.$token->[2]->{'name'}; 
 			}
 			$metathesekeys{$unikey}=1;
-			foreach (@{$token->[3]}) {
-			    $metaentry{':'.$unikey.'.'.$_}=$token->[2]->{$_};
+			foreach my $param (@{$token->[3]}) {
+			    $metaentry{':'.$unikey.'.'.$param} =
+				$token->[2]->{$param};
 			}
 			my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));
 			my $default=$metaentry{':'.$unikey.'.default'};
@@ -5427,14 +5543,14 @@ sub metadata {
 	    }
 	}
 	my ($extension) = ($uri =~ /\.(\w+)$/);
-	foreach my $key (sort(keys(%packagetab))) {
+	foreach my $key (keys(%packagetab)) {
 	    #no specific packages #how's our extension
 	    if ($key!~/^extension_\Q$extension\E&/) { next; }
 	    &metadata_create_package_def($uri,$key,'extension_'.$extension,
 					 \%metathesekeys);
 	}
 	if (!exists($metaentry{':packages'})) {
-	    foreach my $key (sort(keys(%packagetab))) {
+	    foreach my $key (keys(%packagetab)) {
 		#no specific packages well let's get default then
 		if ($key!~/^default&/) { next; }
 		&metadata_create_package_def($uri,$key,'default',
@@ -5452,15 +5568,22 @@ sub metadata {
 		my $dir=$filename;
 		$dir=~s|[^/]*$||;
 		$location=&filelocation($dir,$location);
-		foreach (sort(split(/\,/,&metadata($uri,'keys',
-						   $location,'_rights',
-						   $depthcount+1)))) {
-		    #$metaentry{':'.$_}=$metacache{$uri}->{':'.$_};
-		    $metathesekeys{$_}=1;
+		my $rights_metadata =
+		    &metadata($uri,'keys',$location,'_rights',
+			      $depthcount+1);
+		foreach my $rights (split(',',$rights_metadata)) {
+		    #$metaentry{':'.$rights}=$metacache{$uri}->{':'.$rights};
+		    $metathesekeys{$rights}=1;
 		}
 	    }
 	}
-	$metaentry{':keys'}=join(',',keys %metathesekeys);
+	# uniqifiy package listing
+	my %seen;
+	my @uniq_packages =
+	    grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'}));
+	$metaentry{':packages'} = join(',',@uniq_packages);
+
+	$metaentry{':keys'} = join(',',keys(%metathesekeys));
 	&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
 	$metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);
 	&do_cache_new('meta',$uri,\%metaentry,60*60);
@@ -5496,7 +5619,7 @@ sub metadata_create_package_def {
 sub metadata_generate_part0 {
     my ($metadata,$metacache,$uri) = @_;
     my %allnames;
-    foreach my $metakey (sort keys %$metadata) {
+    foreach my $metakey (keys(%$metadata)) {
 	if ($metakey=~/^parameter\_(.*)/) {
 	  my $part=$$metacache{':'.$metakey.'.part'};
 	  my $name=$$metacache{':'.$metakey.'.name'};
@@ -6436,7 +6559,7 @@ sub clutter {
 		     && $thisfn!~/\.(sequence|page)$/) {
 		$thisfn='/adm/coursedocs/showdoc'.$thisfn;
 	    } else {
-		&logthis("Got a blank emb style");
+#		&logthis("Got a blank emb style");
 	    }
 	}
     }
@@ -6504,7 +6627,6 @@ sub goodbye {
    &logthis(sprintf("%-20s is %s",'hits',$hits));
    &flushcourselogs();
    &logthis("Shutting down");
-   return DONE;
 }
 
 BEGIN {