--- loncom/lond	2006/05/18 02:17:27	1.327
+++ loncom/lond	2006/07/11 02:28:17	1.336
@@ -2,7 +2,7 @@
 # The LearningOnline Network
 # lond "LON Daemon" Server (port "LOND" 5663)
 #
-# $Id: lond,v 1.327 2006/05/18 02:17:27 www Exp $
+# $Id: lond,v 1.336 2006/07/11 02:28:17 raeburn Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -58,9 +58,8 @@ my $DEBUG = 0;		       # Non zero to ena
 
 my $status='';
 my $lastlog='';
-my $lond_max_wait_time = 13;
 
-my $VERSION='$Revision: 1.327 $'; #' stupid emacs
+my $VERSION='$Revision: 1.336 $'; #' stupid emacs
 my $remoteVERSION;
 my $currenthostid="default";
 my $currentdomainid;
@@ -940,181 +939,6 @@ sub EditFile {
     return "ok\n";
 }
 
-#---------------------------------------------------------------
-#
-# Manipulation of hash based databases (factoring out common code
-# for later use as we refactor.
-#
-#  Ties a domain level resource file to a hash.
-#  If requested a history entry is created in the associated hist file.
-#
-#  Parameters:
-#     domain    - Name of the domain in which the resource file lives.
-#     namespace - Name of the hash within that domain.
-#     how       - How to tie the hash (e.g. GDBM_WRCREAT()).
-#     loghead   - Optional parameter, if present a log entry is created
-#                 in the associated history file and this is the first part
-#                  of that entry.
-#     logtail   - Goes along with loghead,  The actual logentry is of the
-#                 form $loghead:<timestamp>:logtail.
-# Returns:
-#    Reference to a hash bound to the db file or alternatively undef
-#    if the tie failed.
-#
-sub tie_domain_hash {
-    my ($domain,$namespace,$how,$loghead,$logtail) = @_;
-    
-    # Filter out any whitespace in the domain name:
-    
-    $domain =~ s/\W//g;
-    
-    # We have enough to go on to tie the hash:
-    
-    my $user_top_dir   = $perlvar{'lonUsersDir'};
-    my $domain_dir     = $user_top_dir."/$domain";
-    my $resource_file  = $domain_dir."/$namespace";
-    return &_locking_hash_tie($resource_file,$namespace,$how,$loghead,$logtail);
-}
-
-sub untie_domain_hash {
-    return &_locking_hash_untie(@_);
-}
-#
-#   Ties a user's resource file to a hash.  
-#   If necessary, an appropriate history
-#   log file entry is made as well.
-#   This sub factors out common code from the subs that manipulate
-#   the various gdbm files that keep keyword value pairs.
-# Parameters:
-#   domain       - Name of the domain the user is in.
-#   user         - Name of the 'current user'.
-#   namespace    - Namespace representing the file to tie.
-#   how          - What the tie is done to (e.g. GDBM_WRCREAT().
-#   loghead      - Optional first part of log entry if there may be a
-#                  history file.
-#   what         - Optional tail of log entry if there may be a history
-#                  file.
-# Returns:
-#   hash to which the database is tied.  It's up to the caller to untie.
-#   undef if the has could not be tied.
-#
-sub tie_user_hash {
-    my ($domain,$user,$namespace,$how,$loghead,$what) = @_;
-
-    $namespace=~s/\//\_/g;	# / -> _
-    $namespace=~s/\W//g;		# whitespace eliminated.
-    my $proname     = propath($domain, $user);
-
-    my $file_prefix="$proname/$namespace";
-    return &_locking_hash_tie($file_prefix,$namespace,$how,$loghead,$what);
-}
-
-sub untie_user_hash {
-    return &_locking_hash_untie(@_);
-}
-
-# internal routines that handle the actual tieing and untieing process
-
-sub _do_hash_tie {
-    my ($file_prefix,$namespace,$how,$loghead,$what) = @_;
-    my %hash;
-    if(tie(%hash, 'GDBM_File', "$file_prefix.db", $how, 0640)) {
-	# If this is a namespace for which a history is kept,
-	# make the history log entry:    
-	if (($namespace !~/^nohist\_/) && (defined($loghead))) {
-	    my $args = scalar @_;
-	    Debug(" Opening history: $file_prefix $args");
-	    my $hfh = IO::File->new(">>$file_prefix.hist"); 
-	    if($hfh) {
-		my $now = time;
-		print $hfh "$loghead:$now:$what\n";
-	    }
-	    $hfh->close;
-	}
-	return \%hash;
-    } else {
-	return undef;
-    }
-}
-
-sub _do_hash_untie {
-    my ($hashref) = @_;
-    my $result = untie(%$hashref);
-    return $result;
-}
-
-{
-    my $sym;
-
-    sub _locking_hash_tie {
-	my ($file_prefix,$namespace,$how,$loghead,$what) = @_;
-        my $lock_type=LOCK_SH;
-# Are we reading or writing?
-        if ($how eq &GDBM_READER()) {
-# We are reading
-           unless (open($sym,"$file_prefix.db.lock")) {
-# We don't have a lock file. This could mean
-# - that there is no such db-file
-# - that it does not have a lock file yet
-               unless ((-e "$file_prefix.db") || (-e "$file_prefix.db.gz")) {
-# No such file. Forget it.                
-                   $! = 2;
-                   return undef;
-               }
-# Apparently just no lock file yet. Make one
-               open($sym,">>$file_prefix.db.lock");
-           } 
-        } elsif ($how eq &GDBM_WRCREAT()) {
-# We are writing
-           open($sym,">>$file_prefix.db.lock");
-# Writing needs exclusive lock
-           $lock_type=LOCK_EX;
-        } else {
-           &logthis("Unknown method $how for $file_prefix");
-           die();
-        }
-# If this is compressed, we will also need an exclusive lock
-       if (-e "$file_prefix.db.gz") { $lock_type=LOCK_EX; }
-# Okay, try to obtain the lock we want
-       my $failed=0;
-       eval {
-           local $SIG{__DIE__}='DEFAULT';
-           local $SIG{ALRM}=sub {
-               $failed=1;
-               die("failed lock");
-           };
-           alarm($lond_max_wait_time);
-           flock($sym,$lock_type);
-           alarm(0);
-       };
-       if ($failed) {
-           $! = 100; # throwing error # 100
-           return undef;
-       }
-# The file is ours!
-# If it is archived, un-archive it now
-       if (-e "$file_prefix.db.gz") {
-           system("gunzip $file_prefix.db.gz");
-	   if (-e "$file_prefix.hist.gz") {
-	       system("gunzip $file_prefix.hist.gz");
-	   }
-       }
-# Change access mode to non-blocking
-       $how=$how|&GDBM_NOLOCK();
-# Go ahead and tie the hash
-       return &_do_hash_tie($file_prefix,$namespace,$how,$loghead,$what);
-    }
-
-    sub _locking_hash_untie {
-	my ($hashref) = @_;
-	my $result = untie(%$hashref);
-	flock($sym,LOCK_UN);
-	close($sym);
-	undef($sym);
-	return $result;
-    }
-}
-
 #   read_profile
 #
 #   Returns a set of specific entries from a user's profile file.
@@ -2023,6 +1847,7 @@ sub update_resource_handler {
 		my $reply=&reply("unsub:$fname","$clientname");
 		&devalidate_meta_cache($fname);
 		unlink("$fname");
+		unlink("$fname.meta");
 	    } else {
 		my $transname="$fname.in.transfer";
 		my $remoteurl=&reply("sub:$fname","$clientname");
@@ -2302,8 +2127,11 @@ sub token_auth_user_file_handler {
     my $reply="non_auth\n";
     if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.
 	     $session.'.id')) {
+	flock(ENVIN,LOCK_SH);
 	while (my $line=<ENVIN>) {
-	    if ($line=~ m|userfile\.\Q$fname\E\=|) { $reply="ok\n"; }
+	    my ($envname)=split(/=/,$line,2);
+	    $envname=&unescape($envname);
+	    if ($envname=~ m|^userfile\.\Q$fname\E|) { $reply="ok\n"; }
 	}
 	close(ENVIN);
 	&Reply($client, $reply, "$cmd:$tail");
@@ -3461,10 +3289,10 @@ sub put_course_id_handler {
             my @new_items = split(/:/,$courseinfo);
             my $numnew = scalar(@new_items);
             if ($numcurrent > 0) {
-                if ($numnew == 1) { # flushcourselogs() from 1.1 or earlier
-                    $courseinfo .= ':'.join(':',@current_items);
-                } elsif ($numnew == 2) { # flushcourselogs() from 1.2.X
-                    $courseinfo .= ':'.$current_items[$numcurrent-1];
+                if ($numnew <= $numcurrent) { # flushcourselogs() from pre 2.2 
+                    for (my $j=$numcurrent-$numnew; $j>=0; $j--) {
+                        $courseinfo .= ':'.$current_items[$numcurrent-$j-1];
+                    }
                 }
             }
 	    $hashref->{$key}=$courseinfo.':'.$now;
@@ -3508,12 +3336,11 @@ sub put_course_id_handler {
 #                 institutional code - optional supplied code to filter 
 #                            the dump. Only courses with an institutional code 
 #                            that match the supplied code will be returned.
-#                 owner    - optional supplied username of owner to filter
-#                            the dump.  Only courses for which the course 
-#                            owner matches the supplied username will be
-#                            returned. Implicit assumption that owner
-#                            is a user in the domain in which the
-#                            course database is defined.
+#                 owner    - optional supplied username and domain of owner to
+#                            filter the dump.  Only courses for which the course
+#                            owner matches the supplied username and/or domain
+#                            will be returned. Pre-2.2.0 legacy entries from 
+#                            nohist_courseiddump will only contain usernames.
 #     $client  - The socket open on the client.
 # Returns:
 #    1     - Continue processing.
@@ -3524,7 +3351,8 @@ sub dump_course_id_handler {
 
     my $userinput = "$cmd:$tail";
 
-    my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter) =split(/:/,$tail);
+    my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter,
+        $typefilter) =split(/:/,$tail);
     if (defined($description)) {
 	$description=&unescape($description);
     } else {
@@ -3535,26 +3363,42 @@ sub dump_course_id_handler {
     } else {
         $instcodefilter='.';
     }
+    my ($ownerunamefilter,$ownerdomfilter);
     if (defined($ownerfilter)) {
         $ownerfilter=&unescape($ownerfilter);
+        if ($ownerfilter ne '.' && defined($ownerfilter)) {
+            if ($ownerfilter =~ /^([^:]*):([^:]*)$/) {
+                 $ownerunamefilter = $1;
+                 $ownerdomfilter = $2;
+            } else {
+                $ownerunamefilter = $ownerfilter;
+                $ownerdomfilter = '';
+            }
+        }
     } else {
         $ownerfilter='.';
     }
+
     if (defined($coursefilter)) {
         $coursefilter=&unescape($coursefilter);
     } else {
         $coursefilter='.';
     }
+    if (defined($typefilter)) {
+        $typefilter=&unescape($typefilter);
+    } else {
+        $typefilter='.';
+    }
 
     unless (defined($since)) { $since=0; }
     my $qresult='';
     my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());
     if ($hashref) {
 	while (my ($key,$value) = each(%$hashref)) {
-	    my ($descr,$lasttime,$inst_code,$owner);
+	    my ($descr,$lasttime,$inst_code,$owner,$type);
             my @courseitems = split(/:/,$value);
             $lasttime = pop(@courseitems);
-	    ($descr,$inst_code,$owner)=@courseitems;
+	    ($descr,$inst_code,$owner,$type)=@courseitems;
 	    if ($lasttime<$since) { next; }
             my $match = 1;
 	    unless ($description eq '.') {
@@ -3571,8 +3415,37 @@ sub dump_course_id_handler {
 	    }
             unless ($ownerfilter eq '.' || !defined($ownerfilter)) {
                 my $unescapeOwner = &unescape($owner);
-                unless (eval('$unescapeOwner=~/\Q$ownerfilter\E/i')) {
-                    $match = 0;
+                if (($ownerunamefilter ne '') && ($ownerdomfilter ne '')) {
+                    if ($unescapeOwner =~ /:/) {
+                        if (eval('$unescapeOwner !~ 
+                             /\Q$ownerunamefilter\E:\Q$ownerdomfilter\E$/i')) {
+                            $match = 0;
+                        } 
+                    } else {
+                        if (eval('$unescapeOwner!~/\Q$ownerunamefilter\E/i')) {
+                            $match = 0;
+                        }
+                    }
+                } elsif ($ownerunamefilter ne '') {
+                    if ($unescapeOwner =~ /:/) {
+                        if (eval('$unescapeOwner!~/\Q$ownerunamefilter\E:[^:]+$/i')) {
+                             $match = 0;
+                        }
+                    } else {
+                        if (eval('$unescapeOwner!~/\Q$ownerunamefilter\E/i')) {
+                            $match = 0;
+                        }
+                    }
+                } elsif ($ownerdomfilter ne '') {
+                    if ($unescapeOwner =~ /:/) {
+                        if (eval('$unescapeOwner!~/^[^:]+:\Q$ownerdomfilter\E/')) {
+                             $match = 0;
+                        }
+                    } else {
+                        if ($ownerdomfilter ne $udom) {
+                            $match = 0;
+                        }
+                    }
                 }
             }
             unless ($coursefilter eq '.' || !defined($coursefilter)) {
@@ -3581,6 +3454,18 @@ sub dump_course_id_handler {
                     $match = 0;
                 }
             }
+            unless ($typefilter eq '.' || !defined($typefilter)) {
+                my $unescapeType = &unescape($type);
+                if (!defined($type)) {
+                    if ($typefilter ne 'Course') {
+                        $match = 0;
+                    }
+                } else { 
+                    unless (eval('$unescapeType=~/^\Q$typefilter\E$/')) {
+                        $match = 0;
+                    }
+                }
+            }
             if ($match == 1) {
                 $qresult.=$key.'='.$descr.':'.$inst_code.':'.$owner.'&';
             }
@@ -4254,6 +4139,7 @@ sub validate_course_owner_handler {
     my $userinput = "$cmd:$tail";
     my ($inst_course_id, $owner, $cdom) = split(/:/, $tail);
 
+    $owner = &unescape($owner);
     my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom);
     &Reply($client, "$outcome\n", $userinput);
 
@@ -5269,18 +5155,6 @@ sub sub_sql_reply {
     return $answer;
 }
 
-# -------------------------------------------- Return path to profile directory
-
-sub propath {
-    my ($udom,$uname)=@_;
-    $udom=~s/\W//g;
-    $uname=~s/\W//g;
-    my $subdir=$uname.'__';
-    $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
-    my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
-    return $proname;
-} 
-
 # --------------------------------------- Is this the home server of an author?
 
 sub ishome {
@@ -5879,7 +5753,7 @@ sub get_chat {
     my @entries=();
     my $namespace = 'nohist_chatroom';
     my $namespace_inroom = 'nohist_inchatroom';
-    if (defined($group)) {
+    if ($group ne '') {
         $namespace .= '_'.$group;
         $namespace_inroom .= '_'.$group;
     }
@@ -5911,7 +5785,7 @@ sub chat_add {
     my $time=time;
     my $namespace = 'nohist_chatroom';
     my $logfile = 'chatroom.log';
-    if (defined($group)) {
+    if ($group ne '') {
         $namespace .= '_'.$group;
         $logfile = 'chatroom_'.$group.'.log';
     }
<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">
<html><head>
<title>500 Internal Server Error</title>
</head><body>
<h1>Internal Server Error</h1>
<p>The server encountered an internal error or
misconfiguration and was unable to complete
your request.</p>
<p>Please contact the server administrator at 
 root@localhost to inform them of the time this error occurred,
 and the actions you performed just before this error.</p>
<p>More information about this error may be available
in the server error log.</p>
</body></html>