Return to lond CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.237 and 1.318.2.1

-version 1.237, 2004/08/24 07:26:04
+version 1.318.2.1, 2006/02/09 20:23:28
  Line 46  use Authen::Krb5;
  use lib '/home/httpd/lib/perl/';
  use localauth;
  use localenroll;
+ use localstudentphoto;
  use File::Copy;
+ use File::Find;
  use LONCAPA::ConfigFileEdit;
  use LONCAPA::lonlocal;
  use LONCAPA::lonssl;
  use Fcntl qw(:flock);
+ use Symbol;
  my $DEBUG = 0;		       # Non zero to enable debug log entries.
  my $status='';
  my $lastlog='';
+ my $lond_max_wait_time = 13;
  my $VERSION='$Revision$'; #' stupid emacs
  my $remoteVERSION;
- Line 64  my $currentdomainid;
+ Line 68  my $currentdomainid;
  my $client;
  my $clientip;			# IP address of client.
- my $clientdns;			# DNS name of client.
  my $clientname;			# LonCAPA name of client.
  my $server;
- Line 86  my $ConnectionType;
+ Line 89  my $ConnectionType;
  my %hostid;			# ID's for hosts in cluster by ip.
  my %hostdom;			# LonCAPA domain for hosts in cluster.
+ my %hostname;			# DNSname -> ID's mapping.
  my %hostip;			# IPs for hosts in cluster.
  my %hostdns;			# ID's of hosts looked up by DNS name.
- Line 112  my %Dispatcher;
+ Line 116  my %Dispatcher;
  #
  my $lastpwderror    = 13;		# Largest error number from lcpasswd.
  my @passwderrors = ("ok",
- 		   "lcpasswd must be run as user 'www'",
+ 		   "pwchange_failure - lcpasswd must be run as user 'www'",
- 		   "lcpasswd got incorrect number of arguments",
+ 		   "pwchange_failure - lcpasswd got incorrect number of arguments",
- 		   "lcpasswd did not get the right nubmer of input text lines",
+ 		   "pwchange_failure - lcpasswd did not get the right nubmer of input text lines",
- 		   "lcpasswd too many simultaneous pwd changes in progress",
+ 		   "pwchange_failure - lcpasswd too many simultaneous pwd changes in progress",
- 		   "lcpasswd User does not exist.",
+ 		   "pwchange_failure - lcpasswd User does not exist.",
- 		   "lcpasswd Incorrect current passwd",
+ 		   "pwchange_failure - lcpasswd Incorrect current passwd",
- 		   "lcpasswd Unable to su to root.",
+ 		   "pwchange_failure - lcpasswd Unable to su to root.",
- 		   "lcpasswd Cannot set new passwd.",
+ 		   "pwchange_failure - lcpasswd Cannot set new passwd.",
- 		   "lcpasswd Username has invalid characters",
+ 		   "pwchange_failure - lcpasswd Username has invalid characters",
- 		   "lcpasswd Invalid characters in password",
+ 		   "pwchange_failure - lcpasswd Invalid characters in password",
- 		   "lcpasswd User already exists",
+ 		   "pwchange_failure - lcpasswd User already exists",
-                    "lcpasswd Something went wrong with user addition.",
+                    "pwchange_failure - lcpasswd Something went wrong with user addition.",
- 		    "lcpasswd Password mismatch",
+ 		   "pwchange_failure - lcpasswd Password mismatch",
- 		    "lcpasswd Error filename is invalid");
+ 		   "pwchange_failure - lcpasswd Error filename is invalid");
  #  The array below are lcuseradd error strings.:
- Line 177  sub ResetStatistics {
+ Line 181  sub ResetStatistics {
  #   $initcmd     - The full text of the init command.
  #
  # Implicit inputs:
- #    $clientdns  - The DNS name of the remote client.
  #    $thisserver - Our DNS name.
  #
  # Returns:
- Line 186  sub ResetStatistics {
+ Line 189  sub ResetStatistics {
  #
  sub LocalConnection {
      my ($Socket, $initcmd) = @_;
-     Debug("Attempting local connection: $initcmd client: $clientdns me: $thisserver");
+     Debug("Attempting local connection: $initcmd client: $clientip me: $thisserver");
-     if($clientdns ne $thisserver) {
+     if($clientip ne "127.0.0.1") {
  	&logthis('<font color="red"> LocalConnection rejecting non local: '
- 		 ."$clientdns ne $thisserver </font>");
+ 		 ."$clientip ne $thisserver </font>");
  	close $Socket;
  	return undef;
      }  else {
- Line 331  sub InsecureConnection {
+ Line 334  sub InsecureConnection {
  }
  #
+ #   Safely execute a command (as long as it's not a shel command and doesn
+ #   not require/rely on shell escapes.   The function operates by doing a
+ #   a pipe based fork and capturing stdout and stderr  from the pipe.
+ #
+ # Formal Parameters:
+ #     $line                    - A line of text to be executed as a command.
+ # Returns:
+ #     The output from that command.  If the output is multiline the caller
+ #     must know how to split up the output.
+ #
+ #
+ sub execute_command {
+     my ($line)    = @_;
+     my @words     = split(/\s/, $line);	# Bust the command up into words.
+     my $output    = "";
+     my $pid = open(CHILD, "-|");
+     if($pid) {			# Parent process
+ 	Debug("In parent process for execute_command");
+ 	my @data = <CHILD>;	# Read the child's outupt...
+ 	close CHILD;
+ 	foreach my $output_line (@data) {
+ 	    Debug("Adding $output_line");
+ 	    $output .= $output_line; # Presumably has a \n on it.
+ 	}
+     } else {			# Child process
+ 	close (STDERR);
+ 	open  (STDERR, ">&STDOUT");# Combine stderr, and stdout...
+ 	exec(@words);		# won't return.
+     }
+     return $output;
+ }
  #   GetCertificate: Given a transaction that requires a certificate,
  #   this function will extract the certificate from the transaction
  #   request.  Note that at this point, the only concept of a certificate
- Line 438  sub CopyFile {
+ Line 476  sub CopyFile {
      my ($oldfile, $newfile) = @_;
-     #  The file must exist:
+     if (! copy($oldfile,$newfile)) {
+         return 0;
-     if(-e $oldfile) {
- 	 # Read the old file.
- 	my $oldfh = IO::File->new("< $oldfile");
- 	if(!$oldfh) {
- 	    return 0;
- 	}
- 	my @contents = <$oldfh>;  # Suck in the entire file.
- 	# write the backup file:
- 	my $newfh = IO::File->new("> $newfile");
- 	if(!(defined $newfh)){
- 	    return 0;
- 	}
- 	my $lines = scalar @contents;
- 	for (my $i =0; $i < $lines; $i++) {
- 	    print $newfh ($contents[$i]);
- 	}
- 	$oldfh->close;
- 	$newfh->close;
- 	chmod(0660, $newfile);
- 	return 1;
-     } else {
- 	return 0;
      }
+     chmod(0660, $newfile);
+     return 1;
  }
  #
  #  Host files are passed out with externally visible host IPs.
- Line 963  sub tie_domain_hash {
+ Line 973  sub tie_domain_hash {
      my $user_top_dir   = $perlvar{'lonUsersDir'};
      my $domain_dir     = $user_top_dir."/$domain";
-     my $resource_file  = $domain_dir."/$namespace.db";
+     my $resource_file  = $domain_dir."/$namespace";
-     my %hash;
+     return &_locking_hash_tie($resource_file,$namespace,$how,$loghead,$logtail);
-     if(tie(%hash, 'GDBM_File', $resource_file, $how, 0640)) {
- 	if (defined($loghead)) {	# Need to log the operation.
- 	    my $logFh = IO::File->new(">>$domain_dir/$namespace.hist");
- 	    if($logFh) {
- 		my $timestamp = time;
- 		print $logFh "$loghead:$timestamp:$logtail\n";
- 	    }
- 	    $logFh->close;
- 	}
- 	return \%hash;		# Return the tied hash.
-     } else {
- 	return undef;		# Tie failed.
-     }
  }
+ sub untie_domain_hash {
+     return &_locking_hash_untie(@_);
+ }
  #
  #   Ties a user's resource file to a hash.
  #   If necessary, an appropriate history
  Line 1005  sub tie_user_hash {
      $namespace=~s/\//\_/g;	# / -> _
      $namespace=~s/\W//g;		# whitespace eliminated.
      my $proname     = propath($domain, $user);
-     #  Tie the database.
+     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', "$proname/$namespace.db",
+     if(tie(%hash, 'GDBM_File', "$file_prefix.db", $how, 0640)) {
- 	   $how, 0640)) {
  	# If this is a namespace for which a history is kept,
  	# make the history log entry:
- 	if (($namespace =~/^nohist\_/) && (defined($loghead))) {
+ 	if (($namespace !~/^nohist\_/) && (defined($loghead))) {
  	    my $args = scalar @_;
- 	    Debug(" Opening history: $namespace $args");
+ 	    Debug(" Opening history: $file_prefix $args");
- 	    my $hfh = IO::File->new(">>$proname/$namespace.hist");
+ 	    my $hfh = IO::File->new(">>$file_prefix.hist");
  	    if($hfh) {
  		my $now = time;
  		print $hfh "$loghead:$now:$what\n";
- Line 1027  sub tie_user_hash {
+ Line 1036  sub tie_user_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);
+ 	if ($how eq &GDBM_READER()) {
+ 	    $lock=LOCK_SH;
+ 	    $how=$how|&GDBM_NOLOCK();
+ 	    #if the db doesn't exist we can't read from it
+ 	    if (! -e "$file_prefix.db") {
+ 		$! = 2;
+ 		return undef;
+ 	    }
+ 	} elsif ($how eq &GDBM_WRCREAT()) {
+ 	    $lock=LOCK_EX;
+ 	    $how=$how|&GDBM_NOLOCK();
+ 	    if (! -e "$file_prefix.db") {
+ 		# doesn't exist but we need it to in order to successfully
+                 # lock it so bring it into existance
+ 		open(TOUCH,">>$file_prefix.db");
+ 		close(TOUCH);
+ 	    }
+ 	} else {
+ 	    &logthis("Unknown method $how for $file_prefix");
+ 	    die();
+ 	}
+ 	$sym=&Symbol::gensym();
+ 	open($sym,"$file_prefix.db");
+ 	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);
+ 	    alarm(0);
+ 	};
+ 	if ($failed) {
+ 	    $! = 100; # throwing error # 100
+ 	    return undef;
+ 	}
+ 	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.
+ #   this is a utility function that is used by both get_profile_entry and
+ #   get_profile_entry_encrypted.
+ #
+ # Parameters:
+ #    udom       - Domain in which the user exists.
+ #    uname      - User's account name (loncapa account)
+ #    namespace  - The profile namespace to open.
+ #    what       - A set of & separated queries.
+ # Returns:
+ #    If all ok: - The string that needs to be shipped back to the user.
+ #    If failure - A string that starts with error: followed by the failure
+ #                 reason.. note that this probabyl gets shipped back to the
+ #                 user as well.
+ #
+ sub read_profile {
+     my ($udom, $uname, $namespace, $what) = @_;
+     my $hashref = &tie_user_hash($udom, $uname, $namespace,
+ 				 &GDBM_READER());
+     if ($hashref) {
+         my @queries=split(/\&/,$what);
+         my $qresult='';
+ 	for (my $i=0;$i<=$#queries;$i++) {
+ 	    $qresult.="$hashref->{$queries[$i]}&";    # Presumably failure gives empty string.
+ 	}
+ 	$qresult=~s/\&$//;              # Remove trailing & from last lookup.
+ 	if (&untie_user_hash($hashref)) {
+ 	    return $qresult;
+ 	} else {
+ 	    return "error: ".($!+0)." untie (GDBM) Failed";
+ 	}
+     } else {
+ 	if ($!+0 == 2) {
+ 	    return "error:No such file or GDBM reported bad block error";
+ 	} else {
+ 	    return "error: ".($!+0)." tie (GDBM) Failed";
+ 	}
+     }
+ }
  #--------------------- Request Handlers --------------------------------------------
  #
  #   By convention each request handler registers itself prior to the sub
- Line 1051  sub tie_user_hash {
+ Line 1169  sub tie_user_hash {
  #      0       - Program should exit.
  #  Side effects:
  #      Reply information is sent to the client.
  sub ping_handler {
      my ($cmd, $tail, $client) = @_;
      Debug("$cmd $tail $client .. $currenthostid:");
- Line 1079  sub ping_handler {
+ Line 1196  sub ping_handler {
  #      0       - Program should exit.
  #  Side effects:
  #      Reply information is sent to the client.
  sub pong_handler {
      my ($cmd, $tail, $replyfd) = @_;
- Line 1134  sub establish_key_handler {
+ Line 1250  sub establish_key_handler {
  }
  &register_handler("ekey", \&establish_key_handler, 0, 1,1);
  #     Handler for the load command.  Returns the current system load average
  #     to the requestor.
  #
- Line 1169  sub load_handler {
+ Line 1284  sub load_handler {
      return 1;
  }
- register_handler("load", \&load_handler, 0, 1, 0);
+ &register_handler("load", \&load_handler, 0, 1, 0);
  #
  #   Process the userload request.  This sub returns to the client the current
- Line 1199  sub user_load_handler {
+ Line 1314  sub user_load_handler {
      return 1;
  }
- register_handler("userload", \&user_load_handler, 0, 1, 0);
+ &register_handler("userload", \&user_load_handler, 0, 1, 0);
  #   Process a request for the authorization type of a user:
  #   (userauth).
- Line 1235  sub user_authorization_type {
+ Line 1350  sub user_authorization_type {
  	my ($type,$otherinfo) = split(/:/,$result);
  	if($type =~ /^krb/) {
  	    $type = $result;
- 	}
+ 	} else {
- 	&Reply( $replyfd, "$type:\n", $userinput);
+             $type .= ':';
+         }
+ 	&Reply( $replyfd, "$type\n", $userinput);
      }
      return 1;
- Line 1256  sub user_authorization_type {
+ Line 1373  sub user_authorization_type {
  #      0       - Program should exit
  # Implicit Output:
  #    a reply is written to the client.
  sub push_file_handler {
      my ($cmd, $tail, $client) = @_;
- Line 1282  sub push_file_handler {
+ Line 1398  sub push_file_handler {
  }
  &register_handler("pushfile", \&push_file_handler, 1, 0, 1);
+ #
+ #   du  - list the disk usuage of a directory recursively.
+ #
+ #   note: stolen code from the ls file handler
+ #   under construction by Rick Banghart
+ #    .
+ # Parameters:
+ #    $cmd        - The command that dispatched us (du).
+ #    $ududir     - The directory path to list... I'm not sure what this
+ #                  is relative as things like ls:. return e.g.
+ #                  no_such_dir.
+ #    $client     - Socket open on the client.
+ # Returns:
+ #     1 - indicating that the daemon should not disconnect.
+ # Side Effects:
+ #   The reply is written to  $client.
+ #
+ sub du_handler {
+     my ($cmd, $ududir, $client) = @_;
+     my ($ududir) = split(/:/,$ududir); # Make 'telnet' testing easier.
+     my $userinput = "$cmd:$ududir";
+     if ($ududir=~/\.\./ || $ududir!~m|^/home/httpd/|) {
+ 	&Failure($client,"refused\n","$cmd:$ududir");
+ 	return 1;
+     }
+     #  Since $ududir could have some nasties in it,
+     #  we will require that ududir is a valid
+     #  directory.  Just in case someone tries to
+     #  slip us a  line like .;(cd /home/httpd rm -rf*)
+     #  etc.
+     #
+     if (-d $ududir) {
+ 	my $total_size=0;
+ 	my $code=sub {
+ 	    if ($_=~/\.\d+\./) { return;}
+ 	    if ($_=~/\.meta$/) { return;}
+ 	    $total_size+=(stat($_))[7];
+ 	};
+ 	chdir($ududir);
+ 	find($code,$ududir);
+ 	$total_size=int($total_size/1024);
+ 	&Reply($client,"$total_size\n","$cmd:$ududir");
+     } else {
+ 	&Failure($client, "bad_directory:$ududir\n","$cmd:$ududir");
+     }
+     return 1;
+ }
+ &register_handler("du", \&du_handler, 0, 1, 0);
+ #
+ # The ls_handler routine should be considered obosolete and is retained
+ # for communication with legacy servers.  Please see the ls2_handler.
+ #
+ #   ls  - list the contents of a directory.  For each file in the
+ #    selected directory the filename followed by the full output of
+ #    the stat function is returned.  The returned info for each
+ #    file are separated by ':'.  The stat fields are separated by &'s.
+ # Parameters:
+ #    $cmd        - The command that dispatched us (ls).
+ #    $ulsdir     - The directory path to list... I'm not sure what this
+ #                  is relative as things like ls:. return e.g.
+ #                  no_such_dir.
+ #    $client     - Socket open on the client.
+ # Returns:
+ #     1 - indicating that the daemon should not disconnect.
+ # Side Effects:
+ #   The reply is written to  $client.
+ #
+ sub ls_handler {
+     # obsoleted by ls2_handler
+     my ($cmd, $ulsdir, $client) = @_;
+     my $userinput = "$cmd:$ulsdir";
+     my $obs;
+     my $rights;
+     my $ulsout='';
+     my $ulsfn;
+     if (-e $ulsdir) {
+ 	if(-d $ulsdir) {
+ 	    if (opendir(LSDIR,$ulsdir)) {
+ 		while ($ulsfn=readdir(LSDIR)) {
+ 		    undef($obs);
+ 		    undef($rights);
+ 		    my @ulsstats=stat($ulsdir.'/'.$ulsfn);
+ 		    #We do some obsolete checking here
+ 		    if(-e $ulsdir.'/'.$ulsfn.".meta") {
+ 			open(FILE, $ulsdir.'/'.$ulsfn.".meta");
+ 			my @obsolete=<FILE>;
+ 			foreach my $obsolete (@obsolete) {
+ 			    if($obsolete =~ m/(<obsolete>)(on|1)/) { $obs = 1; }
+ 			    if($obsolete =~ m|(<copyright>)(default)|) { $rights = 1; }
+ 			}
+ 		    }
+ 		    $ulsout.=$ulsfn.'&'.join('&',@ulsstats);
+ 		    if($obs eq '1') { $ulsout.="&1"; }
+ 		    else { $ulsout.="&0"; }
+ 		    if($rights eq '1') { $ulsout.="&1:"; }
+ 		    else { $ulsout.="&0:"; }
+ 		}
+ 		closedir(LSDIR);
+ 	    }
+ 	} else {
+ 	    my @ulsstats=stat($ulsdir);
+ 	    $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';
+ 	}
+     } else {
+ 	$ulsout='no_such_dir';
+     }
+     if ($ulsout eq '') { $ulsout='empty'; }
+     &Reply($client, "$ulsout\n", $userinput); # This supports debug logging.
+     return 1;
+ }
+ &register_handler("ls", \&ls_handler, 0, 1, 0);
+ #
+ # Please also see the ls_handler, which this routine obosolets.
+ # ls2_handler differs from ls_handler in that it escapes its return
+ # values before concatenating them together with ':'s.
+ #
+ #   ls2  - list the contents of a directory.  For each file in the
+ #    selected directory the filename followed by the full output of
+ #    the stat function is returned.  The returned info for each
+ #    file are separated by ':'.  The stat fields are separated by &'s.
+ # Parameters:
+ #    $cmd        - The command that dispatched us (ls).
+ #    $ulsdir     - The directory path to list... I'm not sure what this
+ #                  is relative as things like ls:. return e.g.
+ #                  no_such_dir.
+ #    $client     - Socket open on the client.
+ # Returns:
+ #     1 - indicating that the daemon should not disconnect.
+ # Side Effects:
+ #   The reply is written to  $client.
+ #
+ sub ls2_handler {
+     my ($cmd, $ulsdir, $client) = @_;
+     my $userinput = "$cmd:$ulsdir";
+     my $obs;
+     my $rights;
+     my $ulsout='';
+     my $ulsfn;
+     if (-e $ulsdir) {
+         if(-d $ulsdir) {
+             if (opendir(LSDIR,$ulsdir)) {
+                 while ($ulsfn=readdir(LSDIR)) {
+                     undef($obs);
+ 		    undef($rights);
+                     my @ulsstats=stat($ulsdir.'/'.$ulsfn);
+                     #We do some obsolete checking here
+                     if(-e $ulsdir.'/'.$ulsfn.".meta") {
+                         open(FILE, $ulsdir.'/'.$ulsfn.".meta");
+                         my @obsolete=<FILE>;
+                         foreach my $obsolete (@obsolete) {
+                             if($obsolete =~ m/(<obsolete>)(on|1)/) { $obs = 1; }
+                             if($obsolete =~ m|(<copyright>)(default)|) {
+                                 $rights = 1;
+                             }
+                         }
+                     }
+                     my $tmp = $ulsfn.'&'.join('&',@ulsstats);
+                     if ($obs    eq '1') { $tmp.="&1"; } else { $tmp.="&0"; }
+                     if ($rights eq '1') { $tmp.="&1"; } else { $tmp.="&0"; }
+                     $ulsout.= &escape($tmp).':';
+                 }
+                 closedir(LSDIR);
+             }
+         } else {
+             my @ulsstats=stat($ulsdir);
+             $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';
+         }
+     } else {
+         $ulsout='no_such_dir';
+    }
+    if ($ulsout eq '') { $ulsout='empty'; }
+    &Reply($client, "$ulsout\n", $userinput); # This supports debug logging.
+    return 1;
+ }
+ &register_handler("ls2", \&ls2_handler, 0, 1, 0);
  #   Process a reinit request.  Reinit requests that either
  #   lonc or lond be reinitialized so that an updated
- Line 1313  sub reinit_process_handler {
+ Line 1612  sub reinit_process_handler {
      }
      return 1;
  }
  &register_handler("reinit", \&reinit_process_handler, 1, 0, 1);
  #  Process the editing script for a table edit operation.
- Line 1355  sub edit_table_handler {
+ Line 1653  sub edit_table_handler {
      }
      return 1;
  }
- register_handler("edit", \&edit_table_handler, 1, 0, 1);
+ &register_handler("edit", \&edit_table_handler, 1, 0, 1);
  #
  #   Authenticate a user against the LonCAPA authentication
- Line 1411  sub authenticate_handler {
+ Line 1708  sub authenticate_handler {
      return 1;
  }
+ &register_handler("auth", \&authenticate_handler, 1, 1, 0);
- register_handler("auth", \&authenticate_handler, 1, 1, 0);
  #
  #   Change a user's password.  Note that this function is complicated by
- Line 1475  sub change_password_handler {
+ Line 1771  sub change_password_handler {
  		&Failure( $client, "non_authorized\n",$userinput);
  	    }
  	} elsif ($howpwd eq 'unix') {
- 	    # Unix means we have to access /etc/password
+ 	    my $result = &change_unix_password($uname, $npass);
- 	    &Debug("auth is unix");
- 	    my $execdir=$perlvar{'lonDaemons'};
- 	    &Debug("Opening lcpasswd pipeline");
- 	    my $pf = IO::File->new("|$execdir/lcpasswd > "
- 				   ."$perlvar{'lonDaemons'}"
- 				   ."/logs/lcpasswd.log");
- 	    print $pf "$uname\n$npass\n$npass\n";
- 	    close $pf;
- 	    my $err = $?;
- 	    my $result = ($err>0 ? 'pwchange_failure' : 'ok');
  	    &logthis("Result of password change for $uname: ".
- 		     &lcpasswdstrerror($?));
+ 		     $result);
  	    &Reply($client, "$result\n", $userinput);
  	} else {
  	    # this just means that the current password mode is not
- Line 1503  sub change_password_handler {
+ Line 1789  sub change_password_handler {
      return 1;
  }
- register_handler("passwd", \&change_password_handler, 1, 1, 0);
+ &register_handler("passwd", \&change_password_handler, 1, 1, 0);
  #
  #   Create a new user.  User in this case means a lon-capa user.
- Line 1543  sub add_user_handler {
+ Line 1828  sub add_user_handler {
  	if (-e $passfilename) {
  	    &Failure( $client, "already_exists\n", $userinput);
  	} else {
- 	    my @fpparts=split(/\//,$passfilename);
- 	    my $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2];
  	    my $fperror='';
- 	    for (my $i=3;$i<= ($#fpparts-1);$i++) {
+ 	    if (!&mkpath($passfilename)) {
- 		$fpnow.='/'.$fpparts[$i];
+ 		$fperror="error: ".($!+0)." mkdir failed while attempting "
- 		unless (-e $fpnow) {
+ 		    ."makeuser";
- 		    &logthis("mkdir $fpnow");
- 		    unless (mkdir($fpnow,0777)) {
- 			$fperror="error: ".($!+0)." mkdir failed while attempting "
- 			    ."makeuser";
- 		    }
- 		}
  	    }
  	    unless ($fperror) {
  		my $result=&make_passwd_file($uname, $umode,$npass, $passfilename);
- Line 1595  sub add_user_handler {
+ Line 1872  sub add_user_handler {
  # Implicit inputs:
  #    The authentication systems describe above have their own forms of implicit
  #    input into the authentication process that are described above.
+ # NOTE:
+ #   This is also used to change the authentication credential values (e.g. passwd).
+ #
  #
  sub change_authentication_handler {
- Line 1611  sub change_authentication_handler {
+ Line 1891  sub change_authentication_handler {
  	chomp($npass);
  	$npass=&unescape($npass);
+ 	my $oldauth = &get_auth_type($udom, $uname); # Get old auth info.
  	my $passfilename = &password_path($udom, $uname);
  	if ($passfilename) {	# Not allowed to create a new user!!
- 	    my $result=&make_passwd_file($uname, $umode,$npass,$passfilename);
+ 	    # If just changing the unix passwd. need to arrange to run
- 	    &Reply($client, $result, $userinput);
+ 	    # passwd since otherwise make_passwd_file will run
+ 	    # lcuseradd which fails if an account already exists
+ 	    # (to prevent an unscrupulous LONCAPA admin from stealing
+ 	    # an existing account by overwriting it as a LonCAPA account).
+ 	    if(($oldauth =~/^unix/) && ($umode eq "unix")) {
+ 		my $result = &change_unix_password($uname, $npass);
+ 		&logthis("Result of password change for $uname: ".$result);
+ 		if ($result eq "ok") {
+ 		    &Reply($client, "$result\n")
+ 		} else {
+ 		    &Failure($client, "$result\n");
+ 		}
+ 	    } else {
+ 		my $result=&make_passwd_file($uname, $umode,$npass,$passfilename);
+ 		#
+ 		#  If the current auth mode is internal, and the old auth mode was
+ 		#  unix, or krb*,  and the user is an author for this domain,
+ 		#  re-run manage_permissions for that role in order to be able
+ 		#  to take ownership of the construction space back to www:www
+ 		#
+ 		if( (($oldauth =~ /^unix/) && ($umode eq "internal")) ||
+ 		    (($oldauth =~ /^internal/) && ($umode eq "unix")) ) {
+ 		    if(&is_author($udom, $uname)) {
+ 			&Debug(" Need to manage author permissions...");
+ 			&manage_permissions("/$udom/_au", $udom, $uname, "$umode:");
+ 		    }
+ 		}
+ 		&Reply($client, $result, $userinput);
+ 	    }
  	} else {
- 	    &Failure($client, "non_authorized", $userinput); # Fail the user now.
+ 	    &Failure($client, "non_authorized\n", $userinput); # Fail the user now.
  	}
      }
      return 1;
- Line 1696  sub update_resource_handler {
+ Line 2010  sub update_resource_handler {
  	    my $since=$now-$atime;
  	    if ($since>$perlvar{'lonExpire'}) {
  		my $reply=&reply("unsub:$fname","$clientname");
+ 		&devalidate_meta_cache($fname);
  		unlink("$fname");
  	    } else {
  		my $transname="$fname.in.transfer";
- Line 1726  sub update_resource_handler {
+ Line 2041  sub update_resource_handler {
  			alarm(0);
  		    }
  		    rename($transname,$fname);
+ 		    &devalidate_meta_cache($fname);
  		}
  	    }
  	    &Reply( $client, "ok\n", $userinput);
- Line 1739  sub update_resource_handler {
+ Line 2055  sub update_resource_handler {
  }
  &register_handler("update", \&update_resource_handler, 0 ,1, 0);
+ sub devalidate_meta_cache {
+     my ($url) = @_;
+     use Cache::Memcached;
+     my $memcache = new Cache::Memcached({'servers'=>['127.0.0.1:11211']});
+     $url = &declutter($url);
+     $url =~ s-\.meta$--;
+     my $id = &escape('meta:'.$url);
+     $memcache->delete($id);
+ }
+ sub declutter {
+     my $thisfn=shift;
+     $thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//;
+     $thisfn=~s/^\///;
+     $thisfn=~s|^adm/wrapper/||;
+     $thisfn=~s|^adm/coursedocs/showdoc/||;
+     $thisfn=~s/^res\///;
+     $thisfn=~s/\?.+$//;
+     return $thisfn;
+ }
  #
  #   Fetch a user file from a remote server to the user's home directory
  #   userfiles subdir.
- Line 1769  sub fetch_user_file_handler {
+ Line 2105  sub fetch_user_file_handler {
  	# Note that any regular files in the way of this path are
  	# wiped out to deal with some earlier folly of mine.
- 	my $path = $udir;
+ 	if (!&mkpath($udir.'/'.$ufile)) {
- 	if ($ufile =~m|(.+)/([^/]+)$|) {
+ 	    &Failure($client, "unable_to_create\n", $userinput);
- 	    my @parts=split('/',$1);
- 	    foreach my $part (@parts) {
- 		$path .= '/'.$part;
- 		if( -f $path) {
- 		    unlink($path);
- 		}
- 		if ((-e $path)!=1) {
- 		    mkdir($path,0770);
- 		}
- 	    }
  	}
  	my $destname=$udir.'/'.$ufile;
  	my $transname=$udir.'/'.$ufile.'.in.transit';
  	my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;
- Line 1827  sub fetch_user_file_handler {
+ Line 2152  sub fetch_user_file_handler {
  #
  # Returns:
  #    1    - Continue processing.
  sub remove_user_file_handler {
      my ($cmd, $tail, $client) = @_;
- Line 1843  sub remove_user_file_handler {
+ Line 2167  sub remove_user_file_handler {
  	if (-e $udir) {
  	    my $file=$udir.'/userfiles/'.$ufile;
  	    if (-e $file) {
- 		unlink($file);
+ 		#
+ 		#   If the file is a regular file unlink is fine...
+ 		#   However it's possible the client wants a dir.
+ 		#   removed, in which case rmdir is more approprate:
+ 		#
+ 	        if (-f $file){
+ 		    unlink($file);
+ 		} elsif(-d $file) {
+ 		    rmdir($file);
+ 		}
  		if (-e $file) {
+ 		    #  File is still there after we deleted it ?!?
  		    &Failure($client, "failed\n", "$cmd:$tail");
  		} else {
  		    &Reply($client, "ok\n", "$cmd:$tail");
- Line 1869  sub remove_user_file_handler {
+ Line 2204  sub remove_user_file_handler {
  #
  # Returns:
  #    1    - Continue processing.
  sub mkdir_user_file_handler {
      my ($cmd, $tail, $client) = @_;
- Line 1883  sub mkdir_user_file_handler {
+ Line 2217  sub mkdir_user_file_handler {
      } else {
  	my $udir = &propath($udom,$uname);
  	if (-e $udir) {
- 	    my $newdir=$udir.'/userfiles/'.$ufile;
+ 	    my $newdir=$udir.'/userfiles/'.$ufile.'/';
- 	    if (!-e $newdir) {
+ 	    if (!&mkpath($newdir)) {
- 		mkdir($newdir);
+ 		&Failure($client, "failed\n", "$cmd:$tail");
- 		if (!-e $newdir) {
- 		    &Failure($client, "failed\n", "$cmd:$tail");
- 		} else {
- 		    &Reply($client, "ok\n", "$cmd:$tail");
- 		}
- 	    } else {
- 		&Failure($client, "not_found\n", "$cmd:$tail");
  	    }
+ 	    &Reply($client, "ok\n", "$cmd:$tail");
  	} else {
  	    &Failure($client, "not_home\n", "$cmd:$tail");
  	}
- Line 1911  sub mkdir_user_file_handler {
+ Line 2239  sub mkdir_user_file_handler {
  #
  # Returns:
  #    1    - Continue processing.
  sub rename_user_file_handler {
      my ($cmd, $tail, $client) = @_;
- Line 1945  sub rename_user_file_handler {
+ Line 2272  sub rename_user_file_handler {
  }
  &register_handler("renameuserfile", \&rename_user_file_handler, 0,1,0);
  #
- #  Authenticate access to a user file by checking the user's
+ #  Authenticate access to a user file by checking that the token the user's
- #  session token(?)
+ #  passed also exists in their session file
  #
  # Parameters:
  #   cmd      - The request keyword that dispatched to tus.
- Line 1956  sub rename_user_file_handler {
+ Line 2282  sub rename_user_file_handler {
  #   client   - Filehandle open on the client.
  # Return:
  #    1.
  sub token_auth_user_file_handler {
      my ($cmd, $tail, $client) = @_;
      my ($fname, $session) = split(/:/, $tail);
      chomp($session);
-     my $reply='non_auth';
+     my $reply="non_auth\n";
      if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.
  	     $session.'.id')) {
  	while (my $line=<ENVIN>) {
- 	    if ($line=~ m|userfile\.\Q$fname\E\=|) { $reply='ok'; }
+ 	    if ($line=~ m|userfile\.\Q$fname\E\=|) { $reply="ok\n"; }
  	}
  	close(ENVIN);
- 	&Reply($client, $reply);
+ 	&Reply($client, $reply, "$cmd:$tail");
      } else {
  	&Failure($client, "invalid_token\n", "$cmd:$tail");
      }
      return 1;
  }
  &register_handler("tokenauthuserfile", \&token_auth_user_file_handler, 0,1,0);
  #
  #   Unsubscribe from a resource.
  #
- Line 2009  sub unsubscribe_handler {
+ Line 2332  sub unsubscribe_handler {
      return 1;
  }
  &register_handler("unsub", \&unsubscribe_handler, 0, 1, 0);
  #   Subscribe to a resource
  #
  # Parameters:
- Line 2087  sub activity_log_handler {
+ Line 2411  sub activity_log_handler {
      return 1;
  }
- register_handler("log", \&activity_log_handler, 0, 1, 0);
+ &register_handler("log", \&activity_log_handler, 0, 1, 0);
  #
  #   Put a namespace entry in a user profile hash.
- Line 2108  sub put_user_profile_entry {
+ Line 2432  sub put_user_profile_entry {
      my $userinput = "$cmd:$tail";
-     my ($udom,$uname,$namespace,$what) =split(/:/,$tail);
+     my ($udom,$uname,$namespace,$what) =split(/:/,$tail,4);
      if ($namespace ne 'roles') {
  	chomp($what);
  	my $hashref = &tie_user_hash($udom, $uname, $namespace,
- Line 2119  sub put_user_profile_entry {
+ Line 2443  sub put_user_profile_entry {
  		my ($key,$value)=split(/=/,$pair);
  		$hashref->{$key}=$value;
  	    }
- 	    if (untie(%$hashref)) {
+ 	    if (&untie_user_hash($hashref)) {
  		&Reply( $client, "ok\n", $userinput);
  	    } else {
  		&Failure($client, "error: ".($!+0)." untie(GDBM) failed ".
- Line 2127  sub put_user_profile_entry {
+ Line 2451  sub put_user_profile_entry {
  			$userinput);
  	    }
  	} else {
- 	    &Failure( $client, "error: ".($!)." tie(GDBM) Failed ".
+ 	    &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
  		     "while attempting put\n", $userinput);
  	}
      } else {
- Line 2138  sub put_user_profile_entry {
+ Line 2462  sub put_user_profile_entry {
  }
  &register_handler("put", \&put_user_profile_entry, 0, 1, 0);
+ #   Put a piece of new data in hash, returns error if entry already exists
+ # Parameters:
+ #    $cmd      - The command that got us here.
+ #    $tail     - Tail of the command (remaining parameters).
+ #    $client   - File descriptor connected to client.
+ # Returns
+ #     0        - Requested to exit, caller should shut down.
+ #     1        - Continue processing.
+ #
+ sub newput_user_profile_entry {
+     my ($cmd, $tail, $client)  = @_;
+     my $userinput = "$cmd:$tail";
+     my ($udom,$uname,$namespace,$what) =split(/:/,$tail,4);
+     if ($namespace eq 'roles') {
+         &Failure( $client, "refused\n", $userinput);
+ 	return 1;
+     }
+     chomp($what);
+     my $hashref = &tie_user_hash($udom, $uname, $namespace,
+ 				 &GDBM_WRCREAT(),"N",$what);
+     if(!$hashref) {
+ 	&Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
+ 		  "while attempting put\n", $userinput);
+ 	return 1;
+     }
+     my @pairs=split(/\&/,$what);
+     foreach my $pair (@pairs) {
+ 	my ($key,$value)=split(/=/,$pair);
+ 	if (exists($hashref->{$key})) {
+ 	    &Failure($client, "key_exists: ".$key."\n",$userinput);
+ 	    return 1;
+ 	}
+     }
+     foreach my $pair (@pairs) {
+ 	my ($key,$value)=split(/=/,$pair);
+ 	$hashref->{$key}=$value;
+     }
+     if (&untie_user_hash($hashref)) {
+ 	&Reply( $client, "ok\n", $userinput);
+     } else {
+ 	&Failure($client, "error: ".($!+0)." untie(GDBM) failed ".
+ 		 "while attempting put\n",
+ 		 $userinput);
+     }
+     return 1;
+ }
+ &register_handler("newput", \&newput_user_profile_entry, 0, 1, 0);
  #
  #   Increment a profile entry in the user history file.
  #   The history contains keyword value pairs.  In this case,
- Line 2168  sub increment_user_value_handler {
+ Line 2547  sub increment_user_value_handler {
  	    my @pairs=split(/\&/,$what);
  	    foreach my $pair (@pairs) {
  		my ($key,$value)=split(/=/,$pair);
+                 $value = &unescape($value);
  		# We could check that we have a number...
  		if (! defined($value) || $value eq '') {
  		    $value = 1;
  		}
  		$hashref->{$key}+=$value;
+                 if ($namespace eq 'nohist_resourcetracker') {
+                     if ($hashref->{$key} < 0) {
+                         $hashref->{$key} = 0;
+                     }
+                 }
  	    }
- 	    if (untie(%$hashref)) {
+ 	    if (&untie_user_hash($hashref)) {
  		&Reply( $client, "ok\n", $userinput);
  	    } else {
  		&Failure($client, "error: ".($!+0)." untie(GDBM) failed ".
- Line 2192  sub increment_user_value_handler {
+ Line 2577  sub increment_user_value_handler {
  }
  &register_handler("inc", \&increment_user_value_handler, 0, 1, 0);
  #
  #   Put a new role for a user.  Roles are LonCAPA's packaging of permissions.
  #   Each 'role' a user has implies a set of permissions.  Adding a new role
- Line 2232  sub roles_put_handler {
+ Line 2616  sub roles_put_handler {
      #  is done on close this improves the chances the log will be an un-
      #  corrupted ordered thing.
      if ($hashref) {
+ 	my $pass_entry = &get_auth_type($udom, $uname);
+ 	my ($auth_type,$pwd)  = split(/:/, $pass_entry);
+ 	$auth_type = $auth_type.":";
  	my @pairs=split(/\&/,$what);
  	foreach my $pair (@pairs) {
  	    my ($key,$value)=split(/=/,$pair);
  	    &manage_permissions($key, $udom, $uname,
- 			       &get_auth_type( $udom, $uname));
+ 			       $auth_type);
  	    $hashref->{$key}=$value;
  	}
- 	if (untie($hashref)) {
+ 	if (&untie_user_hash($hashref)) {
  	    &Reply($client, "ok\n", $userinput);
  	} else {
  	    &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
- Line 2290  sub roles_delete_handler {
+ Line 2677  sub roles_delete_handler {
  	foreach my $key (@rolekeys) {
  	    delete $hashref->{$key};
  	}
- 	if (untie(%$hashref)) {
+ 	if (&untie_user_hash($hashref)) {
  	    &Reply($client, "ok\n", $userinput);
  	} else {
  	    &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
- Line 2331  sub get_profile_entry {
+ Line 2718  sub get_profile_entry {
      my ($udom,$uname,$namespace,$what) = split(/:/,$tail);
      chomp($what);
-     my $hashref = &tie_user_hash($udom, $uname, $namespace,
- 				 &GDBM_READER());
+     my $replystring = read_profile($udom, $uname, $namespace, $what);
-     if ($hashref) {
+     my ($first) = split(/:/,$replystring);
-         my @queries=split(/\&/,$what);
+     if($first ne "error") {
-         my $qresult='';
+ 	&Reply($client, "$replystring\n", $userinput);
- 	for (my $i=0;$i<=$#queries;$i++) {
- 	    $qresult.="$hashref->{$queries[$i]}&";    # Presumably failure gives empty string.
- 	}
- 	$qresult=~s/\&$//;              # Remove trailing & from last lookup.
- 	if (untie(%$hashref)) {
- 	    &Reply($client, "$qresult\n", $userinput);
- 	} else {
- 	    &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
- 		    "while attempting get\n", $userinput);
- 	}
      } else {
- 	if ($!+0 == 2) {               # +0 coerces errno -> number 2 is ENOENT
+ 	&Failure($client, $replystring." while attempting get\n", $userinput);
- 	    &Failure($client, "error:No such file or ".
- 		    "GDBM reported bad block error\n", $userinput);
- 	} else {                        # Some other undifferentiated err.
- 	    &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
- 		    "while attempting get\n", $userinput);
- 	}
      }
      return 1;
  }
  &register_handler("get", \&get_profile_entry, 0,1,0);
- Line 2386  sub get_profile_entry_encrypted {
+ Line 2758  sub get_profile_entry_encrypted {
      my ($cmd,$udom,$uname,$namespace,$what) = split(/:/,$userinput);
      chomp($what);
-     my $hashref = &tie_user_hash($udom, $uname, $namespace,
+     my $qresult = read_profile($udom, $uname, $namespace, $what);
- 				 &GDBM_READER());
+     my ($first) = split(/:/, $qresult);
-     if ($hashref) {
+     if($first ne "error") {
-         my @queries=split(/\&/,$what);
-         my $qresult='';
+ 	if ($cipher) {
- 	for (my $i=0;$i<=$#queries;$i++) {
+ 	    my $cmdlength=length($qresult);
- 	    $qresult.="$hashref->{$queries[$i]}&";
+ 	    $qresult.="         ";
- 	}
+ 	    my $encqresult='';
- 	if (untie(%$hashref)) {
+ 	    for(my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {
- 	    $qresult=~s/\&$//;
+ 		$encqresult.= unpack("H16",
- 	    if ($cipher) {
+ 				     $cipher->encrypt(substr($qresult,
- 		my $cmdlength=length($qresult);
+ 							     $encidx,
- 		$qresult.="         ";
+)));
- 		my $encqresult='';
- 		for(my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {
- 		    $encqresult.= unpack("H16",
- 					 $cipher->encrypt(substr($qresult,
- 								 $encidx,
-)));
- 		}
- 		&Reply( $client, "enc:$cmdlength:$encqresult\n", $userinput);
- 	    } else {
- 		&Failure( $client, "error:no_key\n", $userinput);
  	    }
+ 	    &Reply( $client, "enc:$cmdlength:$encqresult\n", $userinput);
  	} else {
- 	    &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
+ 		&Failure( $client, "error:no_key\n", $userinput);
- 		    "while attempting eget\n", $userinput);
+ 	    }
- 	}
      } else {
- 	&Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
+ 	&Failure($client, "$qresult while attempting eget\n", $userinput);
- 		"while attempting eget\n", $userinput);
      }
      return 1;
  }
- &register_handler("eget", \&GetProfileEntryEncrypted, 0, 1, 0);
+ &register_handler("eget", \&get_profile_entry_encrypted, 0, 1, 0);
  #
  #   Deletes a key in a user profile database.
  #
- Line 2440  sub get_profile_entry_encrypted {
+ Line 2803  sub get_profile_entry_encrypted {
  #     0   - Exit server.
  #
  #
  sub delete_profile_entry {
      my ($cmd, $tail, $client) = @_;
- Line 2456  sub delete_profile_entry {
+ Line 2818  sub delete_profile_entry {
  	foreach my $key (@keys) {
  	    delete($hashref->{$key});
  	}
- 	if (untie(%$hashref)) {
+ 	if (&untie_user_hash($hashref)) {
  	    &Reply($client, "ok\n", $userinput);
  	} else {
  	    &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
- Line 2469  sub delete_profile_entry {
+ Line 2831  sub delete_profile_entry {
      return 1;
  }
  &register_handler("del", \&delete_profile_entry, 0, 1, 0);
  #
  #  List the set of keys that are defined in a profile database file.
  #  A successful reply from this will contain an & separated list of
- Line 2497  sub get_profile_keys {
+ Line 2860  sub get_profile_keys {
  	foreach my $key (keys %$hashref) {
  	    $qresult.="$key&";
  	}
- 	if (untie(%$hashref)) {
+ 	if (&untie_user_hash($hashref)) {
  	    $qresult=~s/\&$//;
  	    &Reply($client, "$qresult\n", $userinput);
  	} else {
- Line 2558  sub dump_profile_database {
+ Line 2921  sub dump_profile_database {
  	    $data{$symb}->{$param}=$value;
  	    $data{$symb}->{'v.'.$param}=$v;
  	}
- 	if (untie(%$hashref)) {
+ 	if (&untie_user_hash($hashref)) {
  	    while (my ($symb,$param_hash) = each(%data)) {
  		while(my ($param,$value) = each (%$param_hash)){
  		    next if ($param =~ /^v\./);       # Ignore versions...
- Line 2613  sub dump_with_regexp {
+ Line 2976  sub dump_with_regexp {
      my $userinput = "$cmd:$tail";
-     my ($udom,$uname,$namespace,$regexp)=split(/:/,$tail);
+     my ($udom,$uname,$namespace,$regexp,$range)=split(/:/,$tail);
      if (defined($regexp)) {
  	$regexp=&unescape($regexp);
      } else {
  	$regexp='.';
      }
+     my ($start,$end);
+     if (defined($range)) {
+ 	if ($range =~/^(\d+)\-(\d+)$/) {
+ 	    ($start,$end) = ($1,$2);
+ 	} elsif ($range =~/^(\d+)$/) {
+ 	    ($start,$end) = (0,$1);
+ 	} else {
+ 	    undef($range);
+ 	}
+     }
      my $hashref = &tie_user_hash($udom, $uname, $namespace,
  				 &GDBM_READER());
      if ($hashref) {
          my $qresult='';
+ 	my $count=0;
  	while (my ($key,$value) = each(%$hashref)) {
  	    if ($regexp eq '.') {
+ 		$count++;
+ 		if (defined($range) && $count >= $end)   { last; }
+ 		if (defined($range) && $count <  $start) { next; }
  		$qresult.=$key.'='.$value.'&';
  	    } else {
  		my $unescapeKey = &unescape($key);
  		if (eval('$unescapeKey=~/$regexp/')) {
+ 		    $count++;
+ 		    if (defined($range) && $count >= $end)   { last; }
+ 		    if (defined($range) && $count <  $start) { next; }
  		    $qresult.="$key=$value&";
  		}
  	    }
  	}
- 	if (untie(%$hashref)) {
+ 	if (&untie_user_hash($hashref)) {
  	    chop($qresult);
  	    &Reply($client, "$qresult\n", $userinput);
  	} else {
- Line 2647  sub dump_with_regexp {
+ Line 3027  sub dump_with_regexp {
      return 1;
  }
  &register_handler("dump", \&dump_with_regexp, 0, 1, 0);
  #  Store a set of key=value pairs associated with a versioned name.
- Line 2679  sub store_handler {
+ Line 3058  sub store_handler {
  	chomp($what);
  	my @pairs=split(/\&/,$what);
  	my $hashref  = &tie_user_hash($udom, $uname, $namespace,
- 				       &GDBM_WRCREAT(), "P",
+ 				       &GDBM_WRCREAT(), "S",
  				       "$rid:$what");
  	if ($hashref) {
  	    my $now = time;
- Line 2689  sub store_handler {
+ Line 3068  sub store_handler {
  	    my $version=$hashref->{"version:$rid"};
  	    my $allkeys='';
  	    foreach my $pair (@pairs) {
- 		my ($key,$value)=split(/=/,$pair);
+ 		my ($key)=split(/=/,$pair);
  		$allkeys.=$key.':';
- 		$hashref->{"$version:$rid:$key"}=$value;
  	    }
+ 	    $hashref->{"$version:$rid"}=$what;
  	    $hashref->{"$version:$rid:timestamp"}=$now;
  	    $allkeys.='timestamp';
  	    $hashref->{"$version:keys:$rid"}=$allkeys;
- 	    if (untie($hashref)) {
+ 	    if (&untie_user_hash($hashref)) {
  		&Reply($client, "ok\n", $userinput);
  	    } else {
  		&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
- Line 2713  sub store_handler {
+ Line 3093  sub store_handler {
      return 1;
  }
  &register_handler("store", \&store_handler, 0, 1, 0);
  #
  #  Dump out all versions of a resource that has key=value pairs associated
  # with it for each version.  These resources are built up via the store
- Line 2747  sub restore_handler {
+ Line 3128  sub restore_handler {
      $namespace=~s/\//\_/g;
      $namespace=~s/\W//g;
      chomp($rid);
-     my $proname=&propath($udom,$uname);
      my $qresult='';
-     my %hash;
+     my $hashref = &tie_user_hash($udom, $uname, $namespace, &GDBM_READER());
-     if (tie(%hash,'GDBM_File',"$proname/$namespace.db",
+     if ($hashref) {
- 	    &GDBM_READER(),0640)) {
+ 	my $version=$hashref->{"version:$rid"};
- 	my $version=$hash{"version:$rid"};
  	$qresult.="version=$version&";
  	my $scope;
  	for ($scope=1;$scope<=$version;$scope++) {
- 	    my $vkeys=$hash{"$scope:keys:$rid"};
+ 	    my $vkeys=$hashref->{"$scope:keys:$rid"};
  	    my @keys=split(/:/,$vkeys);
  	    my $key;
  	    $qresult.="$scope:keys=$vkeys&";
- 	    foreach $key (@keys) {
+ 	    if (exists($hashref->{"$scope:$rid"})) {
- 		$qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&";
+ 		my $what=$hashref->{"$scope:$rid"};
- 	    }
+ 		foreach my $pair (split(/\&/,$hashref->{"$scope:$rid"})) {
+ 		    my ($key,$value)=split(/=/,$pair);
+ 		    $qresult.="$scope:".$pair."&";
+ 		}
+ 	    } else {
+ 		foreach $key (@keys) {
+ 		    $qresult.="$scope:$key=".$hashref->{"$scope:$rid:$key"}."&";
+ 		}
+ 	    }
  	}
- 	if (untie(%hash)) {
+ 	if (&untie_user_hash($hashref)) {
  	    $qresult=~s/\&$//;
  	    &Reply( $client, "$qresult\n", $userinput);
  	} else {
- Line 2813  sub send_chat_handler {
+ Line 3200  sub send_chat_handler {
      return 1;
  }
  &register_handler("chatsend", \&send_chat_handler, 0, 1, 0);
  #
  #   Retrieve the set of chat messagss from a discussion board.
  #
- Line 2948  sub reply_query_handler {
+ Line 3336  sub reply_query_handler {
  #   $tail     - Tail of the command.  In this case consists of a colon
  #               separated list contaning the domain to apply this to and
  #               an ampersand separated list of keyword=value pairs.
+ #               Each value is a colon separated list that includes:
+ #               description, institutional code and course owner.
+ #               For backward compatibility with versions included
+ #               in LON-CAPA 1.1.X (and earlier) and 1.2.X, institutional
+ #               code and/or course owner are preserved from the existing
+ #               record when writing a new record in response to 1.1 or
+ #               1.2 implementations of lonnet::flushcourselogs().
+ #
  #   $client   - Socket open on the client.
  # Returns:
  #   1    - indicating that processing should continue
- Line 2961  sub put_course_id_handler {
+ Line 3357  sub put_course_id_handler {
      my $userinput = "$cmd:$tail";
-     my ($udom, $what) = split(/:/, $tail);
+     my ($udom, $what) = split(/:/, $tail,2);
      chomp($what);
      my $now=time;
      my @pairs=split(/\&/,$what);
- Line 2969  sub put_course_id_handler {
+ Line 3365  sub put_course_id_handler {
      my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());
      if ($hashref) {
  	foreach my $pair (@pairs) {
- 	    my ($key,$value)=split(/=/,$pair);
+             my ($key,$courseinfo) = split(/=/,$pair,2);
- 	    $hashref->{$key}=$value.':'.$now;
+             $courseinfo =~ s/=/:/g;
+             my @current_items = split(/:/,$hashref->{$key});
+             shift(@current_items); # remove description
+             pop(@current_items);   # remove last access
+             my $numcurrent = scalar(@current_items);
+             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];
+                 }
+             }
+ 	    $hashref->{$key}=$courseinfo.':'.$now;
  	}
- 	if (untie(%$hashref)) {
+ 	if (&untie_domain_hash($hashref)) {
- 	    &Reply($client, "ok\n", $userinput);
+ 	    &Reply( $client, "ok\n", $userinput);
  	} else {
- 	    &Failure( $client, "error: ".($!+0)
+ 	    &Failure($client, "error: ".($!+0)
  		     ." untie(GDBM) Failed ".
  		     "while attempting courseidput\n", $userinput);
  	}
      } else {
- 	&Failure( $client, "error: ".($!+0)
+ 	&Failure($client, "error: ".($!+0)
  		 ." tie(GDBM) Failed ".
  		 "while attempting courseidput\n", $userinput);
      }
      return 1;
  }
- Line 3007  sub put_course_id_handler {
+ Line 3420  sub put_course_id_handler {
  #                 description - regular expression that is used to filter
  #                            the dump.  Only keywords matching this regexp
  #                            will be used.
+ #                 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.
  #     $client  - The socket open on the client.
  # Returns:
  #    1     - Continue processing.
- Line 3017  sub dump_course_id_handler {
+ Line 3439  sub dump_course_id_handler {
      my $userinput = "$cmd:$tail";
-     my ($udom,$since,$description) =split(/:/,$tail);
+     my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter) =split(/:/,$tail);
      if (defined($description)) {
  	$description=&unescape($description);
      } else {
  	$description='.';
      }
+     if (defined($instcodefilter)) {
+         $instcodefilter=&unescape($instcodefilter);
+     } else {
+         $instcodefilter='.';
+     }
+     if (defined($ownerfilter)) {
+         $ownerfilter=&unescape($ownerfilter);
+     } else {
+         $ownerfilter='.';
+     }
+     if (defined($coursefilter)) {
+         $coursefilter=&unescape($coursefilter);
+     } else {
+         $coursefilter='.';
+     }
      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);
+ 	    my ($descr,$lasttime,$inst_code,$owner);
- 	    if ($value =~ m/^([^\:]*):([^\:]*):(\d+)$/) {
+             my @courseitems = split(/:/,$value);
- 		($descr,$inst_code,$lasttime)=($1,$2,$3);
+             $lasttime = pop(@courseitems);
- 	    } else {
+ 	    ($descr,$inst_code,$owner)=@courseitems;
- 		($descr,$lasttime) = split(/\:/,$value);
- 	    }
  	    if ($lasttime<$since) { next; }
- 	    if ($description eq '.') {
+             my $match = 1;
- 		$qresult.=$key.'='.$descr.':'.$inst_code.'&';
+ 	    unless ($description eq '.') {
- 	    } else {
+ 		my $unescapeDescr = &unescape($descr);
- 		my $unescapeVal = &unescape($descr);
+ 		unless (eval('$unescapeDescr=~/\Q$description\E/i')) {
- 		if (eval('$unescapeVal=~/\Q$description\E/i')) {
+                     $match = 0;
- 		    $qresult.=$key.'='.$descr.':'.$inst_code.'&';
  		}
+             }
+             unless ($instcodefilter eq '.' || !defined($instcodefilter)) {
+                 my $unescapeInstcode = &unescape($inst_code);
+                 unless (eval('$unescapeInstcode=~/\Q$instcodefilter\E/i')) {
+                     $match = 0;
+                 }
  	    }
+             unless ($ownerfilter eq '.' || !defined($ownerfilter)) {
+                 my $unescapeOwner = &unescape($owner);
+                 unless (eval('$unescapeOwner=~/\Q$ownerfilter\E/i')) {
+                     $match = 0;
+                 }
+             }
+             unless ($coursefilter eq '.' || !defined($coursefilter)) {
+                 my $unescapeCourse = &unescape($key);
+                 unless (eval('$unescapeCourse=~/^$udom(_)\Q$coursefilter\E$/')) {
+                     $match = 0;
+                 }
+             }
+             if ($match == 1) {
+                 $qresult.=$key.'='.$descr.':'.$inst_code.':'.$owner.'&';
+             }
  	}
- 	if (untie(%$hashref)) {
+ 	if (&untie_domain_hash($hashref)) {
  	    chop($qresult);
  	    &Reply($client, "$qresult\n", $userinput);
  	} else {
- Line 3060  sub dump_course_id_handler {
+ Line 3516  sub dump_course_id_handler {
      return 1;
  }
  &register_handler("courseiddump", \&dump_course_id_handler, 0, 1, 0);
+ #
+ #  Puts an id to a domains id database.
+ #
+ #  Parameters:
+ #   $cmd     - The command that triggered us.
+ #   $tail    - Remainder of the request other than the command. This is a
+ #              colon separated list containing:
+ #              $domain  - The domain for which we are writing the id.
+ #              $pairs  - The id info to write... this is and & separated list
+ #                        of keyword=value.
+ #   $client  - Socket open on the client.
+ #  Returns:
+ #    1   - Continue processing.
+ #  Side effects:
+ #     reply is written to $client.
+ #
+ sub put_id_handler {
+     my ($cmd,$tail,$client) = @_;
+     my $userinput = "$cmd:$tail";
+     my ($udom,$what)=split(/:/,$tail);
+     chomp($what);
+     my @pairs=split(/\&/,$what);
+     my $hashref = &tie_domain_hash($udom, "ids", &GDBM_WRCREAT(),
+ 				   "P", $what);
+     if ($hashref) {
+ 	foreach my $pair (@pairs) {
+ 	    my ($key,$value)=split(/=/,$pair);
+ 	    $hashref->{$key}=$value;
+ 	}
+ 	if (&untie_domain_hash($hashref)) {
+ 	    &Reply($client, "ok\n", $userinput);
+ 	} else {
+ 	    &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
+ 		     "while attempting idput\n", $userinput);
+ 	}
+     } else {
+ 	&Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
+ 		  "while attempting idput\n", $userinput);
+     }
+     return 1;
+ }
+ &register_handler("idput", \&put_id_handler, 0, 1, 0);
+ #
+ #  Retrieves a set of id values from the id database.
+ #  Returns an & separated list of results, one for each requested id to the
+ #  client.
+ #
+ # Parameters:
+ #   $cmd       - Command keyword that caused us to be dispatched.
+ #   $tail      - Tail of the command.  Consists of a colon separated:
+ #               domain - the domain whose id table we dump
+ #               ids      Consists of an & separated list of
+ #                        id keywords whose values will be fetched.
+ #                        nonexisting keywords will have an empty value.
+ #   $client    - Socket open on the client.
+ #
+ # Returns:
+ #    1 - indicating processing should continue.
+ # Side effects:
+ #   An & separated list of results is written to $client.
+ #
+ sub get_id_handler {
+     my ($cmd, $tail, $client) = @_;
+     my $userinput = "$client:$tail";
+     my ($udom,$what)=split(/:/,$tail);
+     chomp($what);
+     my @queries=split(/\&/,$what);
+     my $qresult='';
+     my $hashref = &tie_domain_hash($udom, "ids", &GDBM_READER());
+     if ($hashref) {
+ 	for (my $i=0;$i<=$#queries;$i++) {
+ 	    $qresult.="$hashref->{$queries[$i]}&";
+ 	}
+ 	if (&untie_domain_hash($hashref)) {
+ 	    $qresult=~s/\&$//;
+ 	    &Reply($client, "$qresult\n", $userinput);
+ 	} else {
+ 	    &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
+ 		      "while attempting idget\n",$userinput);
+ 	}
+     } else {
+ 	&Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
+ 		 "while attempting idget\n",$userinput);
+     }
+     return 1;
+ }
+ &register_handler("idget", \&get_id_handler, 0, 1, 0);
+ #
+ # Puts broadcast e-mail sent by Domain Coordinator in nohist_dcmail database
+ #
+ # Parameters
+ #   $cmd       - Command keyword that caused us to be dispatched.
+ #   $tail      - Tail of the command.  Consists of a colon separated:
+ #               domain - the domain whose dcmail we are recording
+ #               email    Consists of key=value pair
+ #                        where key is unique msgid
+ #                        and value is message (in XML)
+ #   $client    - Socket open on the client.
+ #
+ # Returns:
+ #    1 - indicating processing should continue.
+ # Side effects
+ #     reply is written to $client.
+ #
+ sub put_dcmail_handler {
+     my ($cmd,$tail,$client) = @_;
+     my $userinput = "$cmd:$tail";
+     my ($udom,$what)=split(/:/,$tail);
+     chomp($what);
+     my $hashref = &tie_domain_hash($udom, "nohist_dcmail", &GDBM_WRCREAT());
+     if ($hashref) {
+         my ($key,$value)=split(/=/,$what);
+         $hashref->{$key}=$value;
+     }
+     if (&untie_domain_hash($hashref)) {
+         &Reply($client, "ok\n", $userinput);
+     } else {
+         &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
+                  "while attempting dcmailput\n", $userinput);
+     }
+     return 1;
+ }
+ &register_handler("dcmailput", \&put_dcmail_handler, 0, 1, 0);
+ #
+ # Retrieves broadcast e-mail from nohist_dcmail database
+ # Returns to client an & separated list of key=value pairs,
+ # where key is msgid and value is message information.
+ #
+ # Parameters
+ #   $cmd       - Command keyword that caused us to be dispatched.
+ #   $tail      - Tail of the command.  Consists of a colon separated:
+ #               domain - the domain whose dcmail table we dump
+ #               startfilter - beginning of time window
+ #               endfilter - end of time window
+ #               sendersfilter - & separated list of username:domain
+ #                 for senders to search for.
+ #   $client    - Socket open on the client.
+ #
+ # Returns:
+ #    1 - indicating processing should continue.
+ # Side effects
+ #     reply (& separated list of msgid=messageinfo pairs) is
+ #     written to $client.
+ #
+ sub dump_dcmail_handler {
+     my ($cmd, $tail, $client) = @_;
+     my $userinput = "$cmd:$tail";
+     my ($udom,$startfilter,$endfilter,$sendersfilter) = split(/:/,$tail);
+     chomp($sendersfilter);
+     my @senders = ();
+     if (defined($startfilter)) {
+         $startfilter=&unescape($startfilter);
+     } else {
+         $startfilter='.';
+     }
+     if (defined($endfilter)) {
+         $endfilter=&unescape($endfilter);
+     } else {
+         $endfilter='.';
+     }
+     if (defined($sendersfilter)) {
+         $sendersfilter=&unescape($sendersfilter);
+ 	@senders = map { &unescape($_) } split(/\&/,$sendersfilter);
+     }
+     my $qresult='';
+     my $hashref = &tie_domain_hash($udom, "nohist_dcmail", &GDBM_WRCREAT());
+     if ($hashref) {
+         while (my ($key,$value) = each(%$hashref)) {
+             my $match = 1;
+             my ($timestamp,$subj,$uname,$udom) =
+ 		split(/:/,&unescape(&unescape($key)),5); # yes, twice really
+             $subj = &unescape($subj);
+             unless ($startfilter eq '.' || !defined($startfilter)) {
+                 if ($timestamp < $startfilter) {
+                     $match = 0;
+                 }
+             }
+             unless ($endfilter eq '.' || !defined($endfilter)) {
+                 if ($timestamp > $endfilter) {
+                     $match = 0;
+                 }
+             }
+             unless (@senders < 1) {
+                 unless (grep/^$uname:$udom$/,@senders) {
+                     $match = 0;
+                 }
+             }
+             if ($match == 1) {
+                 $qresult.=$key.'='.$value.'&';
+             }
+         }
+         if (&untie_domain_hash($hashref)) {
+             chop($qresult);
+             &Reply($client, "$qresult\n", $userinput);
+         } else {
+             &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
+                     "while attempting dcmaildump\n", $userinput);
+         }
+     } else {
+         &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
+                 "while attempting dcmaildump\n", $userinput);
+     }
+     return 1;
+ }
+ &register_handler("dcmaildump", \&dump_dcmail_handler, 0, 1, 0);
+ #
+ # Puts domain roles in nohist_domainroles database
+ #
+ # Parameters
+ #   $cmd       - Command keyword that caused us to be dispatched.
+ #   $tail      - Tail of the command.  Consists of a colon separated:
+ #               domain - the domain whose roles we are recording
+ #               role -   Consists of key=value pair
+ #                        where key is unique role
+ #                        and value is start/end date information
+ #   $client    - Socket open on the client.
+ #
+ # Returns:
+ #    1 - indicating processing should continue.
+ # Side effects
+ #     reply is written to $client.
+ #
+ sub put_domainroles_handler {
+     my ($cmd,$tail,$client) = @_;
+     my $userinput = "$cmd:$tail";
+     my ($udom,$what)=split(/:/,$tail);
+     chomp($what);
+     my @pairs=split(/\&/,$what);
+     my $hashref = &tie_domain_hash($udom, "nohist_domainroles", &GDBM_WRCREAT());
+     if ($hashref) {
+         foreach my $pair (@pairs) {
+             my ($key,$value)=split(/=/,$pair);
+             $hashref->{$key}=$value;
+         }
+         if (&untie_domain_hash($hashref)) {
+             &Reply($client, "ok\n", $userinput);
+         } else {
+             &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
+                      "while attempting domroleput\n", $userinput);
+         }
+     } else {
+         &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
+                   "while attempting domroleput\n", $userinput);
+     }
+     return 1;
+ }
+ &register_handler("domroleput", \&put_domainroles_handler, 0, 1, 0);
+ #
+ # Retrieves domain roles from nohist_domainroles database
+ # Returns to client an & separated list of key=value pairs,
+ # where key is role and value is start and end date information.
+ #
+ # Parameters
+ #   $cmd       - Command keyword that caused us to be dispatched.
+ #   $tail      - Tail of the command.  Consists of a colon separated:
+ #               domain - the domain whose domain roles table we dump
+ #   $client    - Socket open on the client.
+ #
+ # Returns:
+ #    1 - indicating processing should continue.
+ # Side effects
+ #     reply (& separated list of role=start/end info pairs) is
+ #     written to $client.
+ #
+ sub dump_domainroles_handler {
+     my ($cmd, $tail, $client) = @_;
+     my $userinput = "$cmd:$tail";
+     my ($udom,$startfilter,$endfilter,$rolesfilter) = split(/:/,$tail);
+     chomp($rolesfilter);
+     my @roles = ();
+     if (defined($startfilter)) {
+         $startfilter=&unescape($startfilter);
+     } else {
+         $startfilter='.';
+     }
+     if (defined($endfilter)) {
+         $endfilter=&unescape($endfilter);
+     } else {
+         $endfilter='.';
+     }
+     if (defined($rolesfilter)) {
+         $rolesfilter=&unescape($rolesfilter);
+ 	@roles = split(/\&/,$rolesfilter);
+     }
+     my $hashref = &tie_domain_hash($udom, "nohist_domainroles", &GDBM_WRCREAT());
+     if ($hashref) {
+         my $qresult = '';
+         while (my ($key,$value) = each(%$hashref)) {
+             my $match = 1;
+             my ($start,$end) = split(/:/,&unescape($value));
+             my ($trole,$uname,$udom,$runame,$rudom,$rsec) = split(/:/,&unescape($key));
+             unless ($startfilter eq '.' || !defined($startfilter)) {
+                 if ($start >= $startfilter) {
+                     $match = 0;
+                 }
+             }
+             unless ($endfilter eq '.' || !defined($endfilter)) {
+                 if ($end <= $endfilter) {
+                     $match = 0;
+                 }
+             }
+             unless (@roles < 1) {
+                 unless (grep/^$trole$/,@roles) {
+                     $match = 0;
+                 }
+             }
+             if ($match == 1) {
+                 $qresult.=$key.'='.$value.'&';
+             }
+         }
+         if (&untie_domain_hash($hashref)) {
+             chop($qresult);
+             &Reply($client, "$qresult\n", $userinput);
+         } else {
+             &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
+                     "while attempting domrolesdump\n", $userinput);
+         }
+     } else {
+         &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
+                 "while attempting domrolesdump\n", $userinput);
+     }
+     return 1;
+ }
+ &register_handler("domrolesdump", \&dump_domainroles_handler, 0, 1, 0);
+ #  Process the tmpput command I'm not sure what this does.. Seems to
+ #  create a file in the lonDaemons/tmp directory of the form $id.tmp
+ # where Id is the client's ip concatenated with a sequence number.
+ # The file will contain some value that is passed in.  Is this e.g.
+ # a login token?
+ #
+ # Parameters:
+ #    $cmd     - The command that got us dispatched.
+ #    $tail    - The remainder of the request following $cmd:
+ #               In this case this will be the contents of the file.
+ #    $client  - Socket connected to the client.
+ # Returns:
+ #    1 indicating processing can continue.
+ # Side effects:
+ #   A file is created in the local filesystem.
+ #   A reply is sent to the client.
+ sub tmp_put_handler {
+     my ($cmd, $what, $client) = @_;
+     my $userinput = "$cmd:$what";	# Reconstruct for logging.
+     my $store;
+     $tmpsnum++;
+     my $id=$$.'_'.$clientip.'_'.$tmpsnum;
+     $id=~s/\W/\_/g;
+     $what=~s/\n//g;
+     my $execdir=$perlvar{'lonDaemons'};
+     if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) {
+ 	print $store $what;
+ 	close $store;
+ 	&Reply($client, "$id\n", $userinput);
+     } else {
+ 	&Failure( $client, "error: ".($!+0)."IO::File->new Failed ".
+ 		  "while attempting tmpput\n", $userinput);
+     }
+     return 1;
+ }
+ &register_handler("tmpput", \&tmp_put_handler, 0, 1, 0);
+ #   Processes the tmpget command.  This command returns the contents
+ #  of a temporary resource file(?) created via tmpput.
+ #
+ # Paramters:
+ #    $cmd      - Command that got us dispatched.
+ #    $id       - Tail of the command, contain the id of the resource
+ #                we want to fetch.
+ #    $client   - socket open on the client.
+ # Return:
+ #    1         - Inidcating processing can continue.
+ # Side effects:
+ #   A reply is sent to the client.
+ #
+ sub tmp_get_handler {
+     my ($cmd, $id, $client) = @_;
+     my $userinput = "$cmd:$id";
+     $id=~s/\W/\_/g;
+     my $store;
+     my $execdir=$perlvar{'lonDaemons'};
+     if ($store=IO::File->new("$execdir/tmp/$id.tmp")) {
+ 	my $reply=<$store>;
+ 	&Reply( $client, "$reply\n", $userinput);
+ 	close $store;
+     } else {
+ 	&Failure( $client, "error: ".($!+0)."IO::File->new Failed ".
+ 		  "while attempting tmpget\n", $userinput);
+     }
+     return 1;
+ }
+ &register_handler("tmpget", \&tmp_get_handler, 0, 1, 0);
+ #
+ #  Process the tmpdel command.  This command deletes a temp resource
+ #  created by the tmpput command.
+ #
+ # Parameters:
+ #   $cmd      - Command that got us here.
+ #   $id       - Id of the temporary resource created.
+ #   $client   - socket open on the client process.
+ #
+ # Returns:
+ #   1     - Indicating processing should continue.
+ # Side Effects:
+ #   A file is deleted
+ #   A reply is sent to the client.
+ sub tmp_del_handler {
+     my ($cmd, $id, $client) = @_;
+     my $userinput= "$cmd:$id";
+     chomp($id);
+     $id=~s/\W/\_/g;
+     my $execdir=$perlvar{'lonDaemons'};
+     if (unlink("$execdir/tmp/$id.tmp")) {
+ 	&Reply($client, "ok\n", $userinput);
+     } else {
+ 	&Failure( $client, "error: ".($!+0)."Unlink tmp Failed ".
+ 		  "while attempting tmpdel\n", $userinput);
+     }
+     return 1;
+ }
+ &register_handler("tmpdel", \&tmp_del_handler, 0, 1, 0);
+ #
+ #   Processes the setannounce command.  This command
+ #   creates a file named announce.txt in the top directory of
+ #   the documentn root and sets its contents.  The announce.txt file is
+ #   printed in its entirety at the LonCAPA login page.  Note:
+ #   once the announcement.txt fileis created it cannot be deleted.
+ #   However, setting the contents of the file to empty removes the
+ #   announcement from the login page of loncapa so who cares.
+ #
+ # Parameters:
+ #    $cmd          - The command that got us dispatched.
+ #    $announcement - The text of the announcement.
+ #    $client       - Socket open on the client process.
+ # Retunrns:
+ #   1             - Indicating request processing should continue
+ # Side Effects:
+ #   The file {DocRoot}/announcement.txt is created.
+ #   A reply is sent to $client.
+ #
+ sub set_announce_handler {
+     my ($cmd, $announcement, $client) = @_;
+     my $userinput    = "$cmd:$announcement";
+     chomp($announcement);
+     $announcement=&unescape($announcement);
+     if (my $store=IO::File->new('>'.$perlvar{'lonDocRoot'}.
+ 				'/announcement.txt')) {
+ 	print $store $announcement;
+ 	close $store;
+ 	&Reply($client, "ok\n", $userinput);
+     } else {
+ 	&Failure($client, "error: ".($!+0)."\n", $userinput);
+     }
+     return 1;
+ }
+ &register_handler("setannounce", \&set_announce_handler, 0, 1, 0);
+ #
+ #  Return the version of the daemon.  This can be used to determine
+ #  the compatibility of cross version installations or, alternatively to
+ #  simply know who's out of date and who isn't.  Note that the version
+ #  is returned concatenated with the tail.
+ # Parameters:
+ #   $cmd        - the request that dispatched to us.
+ #   $tail       - Tail of the request (client's version?).
+ #   $client     - Socket open on the client.
+ #Returns:
+ #   1 - continue processing requests.
+ # Side Effects:
+ #   Replies with version to $client.
+ sub get_version_handler {
+     my ($cmd, $tail, $client) = @_;
+     my $userinput  = $cmd.$tail;
+     &Reply($client, &version($userinput)."\n", $userinput);
+     return 1;
+ }
+ &register_handler("version", \&get_version_handler, 0, 1, 0);
+ #  Set the current host and domain.  This is used to support
+ #  multihomed systems.  Each IP of the system, or even separate daemons
+ #  on the same IP can be treated as handling a separate lonCAPA virtual
+ #  machine.  This command selects the virtual lonCAPA.  The client always
+ #  knows the right one since it is lonc and it is selecting the domain/system
+ #  from the hosts.tab file.
+ # Parameters:
+ #    $cmd      - Command that dispatched us.
+ #    $tail     - Tail of the command (domain/host requested).
+ #    $socket   - Socket open on the client.
+ #
+ # Returns:
+ #     1   - Indicates the program should continue to process requests.
+ # Side-effects:
+ #     The default domain/system context is modified for this daemon.
+ #     a reply is sent to the client.
+ #
+ sub set_virtual_host_handler {
+     my ($cmd, $tail, $socket) = @_;
+     my $userinput  ="$cmd:$tail";
+     &Reply($client, &sethost($userinput)."\n", $userinput);
+     return 1;
+ }
+ &register_handler("sethost", \&set_virtual_host_handler, 0, 1, 0);
+ #  Process a request to exit:
+ #   - "bye" is sent to the client.
+ #   - The client socket is shutdown and closed.
+ #   - We indicate to the caller that we should exit.
+ # Formal Parameters:
+ #   $cmd                - The command that got us here.
+ #   $tail               - Tail of the command (empty).
+ #   $client             - Socket open on the tail.
+ # Returns:
+ #   0      - Indicating the program should exit!!
+ #
+ sub exit_handler {
+     my ($cmd, $tail, $client) = @_;
+     my $userinput = "$cmd:$tail";
+     &logthis("Client $clientip ($clientname) hanging up: $userinput");
+     &Reply($client, "bye\n", $userinput);
+     $client->shutdown(2);        # shutdown the socket forcibly.
+     $client->close();
+     return 0;
+ }
+ &register_handler("exit", \&exit_handler, 0,1,1);
+ &register_handler("init", \&exit_handler, 0,1,1);
+ &register_handler("quit", \&exit_handler, 0,1,1);
+ #  Determine if auto-enrollment is enabled.
+ #  Note that the original had what I believe to be a defect.
+ #  The original returned 0 if the requestor was not a registerd client.
+ #  It should return "refused".
+ # Formal Parameters:
+ #   $cmd       - The command that invoked us.
+ #   $tail      - The tail of the command (Extra command parameters.
+ #   $client    - The socket open on the client that issued the request.
+ # Returns:
+ #    1         - Indicating processing should continue.
+ #
+ sub enrollment_enabled_handler {
+     my ($cmd, $tail, $client) = @_;
+     my $userinput = $cmd.":".$tail; # For logging purposes.
+     my $cdom = split(/:/, $tail);   # Domain we're asking about.
+     my $outcome  = &localenroll::run($cdom);
+     &Reply($client, "$outcome\n", $userinput);
+     return 1;
+ }
+ &register_handler("autorun", \&enrollment_enabled_handler, 0, 1, 0);
+ #   Get the official sections for which auto-enrollment is possible.
+ #   Since the admin people won't know about 'unofficial sections'
+ #   we cannot auto-enroll on them.
+ # Formal Parameters:
+ #    $cmd     - The command request that got us dispatched here.
+ #    $tail    - The remainder of the request.  In our case this
+ #               will be split into:
+ #               $coursecode   - The course name from the admin point of view.
+ #               $cdom         - The course's domain(?).
+ #    $client  - Socket open on the client.
+ # Returns:
+ #    1    - Indiciting processing should continue.
+ #
+ sub get_sections_handler {
+     my ($cmd, $tail, $client) = @_;
+     my $userinput = "$cmd:$tail";
+     my ($coursecode, $cdom) = split(/:/, $tail);
+     my @secs = &localenroll::get_sections($coursecode,$cdom);
+     my $seclist = &escape(join(':',@secs));
+     &Reply($client, "$seclist\n", $userinput);
+     return 1;
+ }
+ &register_handler("autogetsections", \&get_sections_handler, 0, 1, 0);
+ #   Validate the owner of a new course section.
+ #
+ # Formal Parameters:
+ #   $cmd      - Command that got us dispatched.
+ #   $tail     - the remainder of the command.  For us this consists of a
+ #               colon separated string containing:
+ #                  $inst    - Course Id from the institutions point of view.
+ #                  $owner   - Proposed owner of the course.
+ #                  $cdom    - Domain of the course (from the institutions
+ #                             point of view?)..
+ #   $client   - Socket open on the client.
+ #
+ # Returns:
+ #   1        - Processing should continue.
+ #
+ sub validate_course_owner_handler {
+     my ($cmd, $tail, $client)  = @_;
+     my $userinput = "$cmd:$tail";
+     my ($inst_course_id, $owner, $cdom) = split(/:/, $tail);
+     my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom);
+     &Reply($client, "$outcome\n", $userinput);
+     return 1;
+ }
+ &register_handler("autonewcourse", \&validate_course_owner_handler, 0, 1, 0);
+ #
+ #   Validate a course section in the official schedule of classes
+ #   from the institutions point of view (part of autoenrollment).
+ #
+ # Formal Parameters:
+ #   $cmd          - The command request that got us dispatched.
+ #   $tail         - The tail of the command.  In this case,
+ #                   this is a colon separated set of words that will be split
+ #                   into:
+ #                        $inst_course_id - The course/section id from the
+ #                                          institutions point of view.
+ #                        $cdom           - The domain from the institutions
+ #                                          point of view.
+ #   $client       - Socket open on the client.
+ # Returns:
+ #    1           - Indicating processing should continue.
+ #
+ sub validate_course_section_handler {
+     my ($cmd, $tail, $client) = @_;
+     my $userinput = "$cmd:$tail";
+     my ($inst_course_id, $cdom) = split(/:/, $tail);
+     my $outcome=&localenroll::validate_courseID($inst_course_id,$cdom);
+     &Reply($client, "$outcome\n", $userinput);
+     return 1;
+ }
+ &register_handler("autovalidatecourse", \&validate_course_section_handler, 0, 1, 0);
+ #
+ #   Create a password for a new auto-enrollment user.
+ #   I think/guess, this password allows access to the institutions
+ #   AIS class list server/services.  Stuart can correct this comment
+ #   when he finds out how wrong I am.
+ #
+ # Formal Parameters:
+ #    $cmd     - The command request that got us dispatched.
+ #    $tail    - The tail of the command.   In this case this is a colon separated
+ #               set of words that will be split into:
+ #               $authparam - An authentication parameter (username??).
+ #               $cdom      - The domain of the course from the institution's
+ #                            point of view.
+ #    $client  - The socket open on the client.
+ # Returns:
+ #    1 - continue processing.
+ #
+ sub create_auto_enroll_password_handler {
+     my ($cmd, $tail, $client) = @_;
+     my $userinput = "$cmd:$tail";
+     my ($authparam, $cdom) = split(/:/, $userinput);
+     my ($create_passwd,$authchk);
+     ($authparam,
+      $create_passwd,
+      $authchk) = &localenroll::create_password($authparam,$cdom);
+     &Reply($client, &escape($authparam.':'.$create_passwd.':'.$authchk)."\n",
+ 	   $userinput);
+     return 1;
+ }
+ &register_handler("autocreatepassword", \&create_auto_enroll_password_handler,
+, 1, 0);
+ #   Retrieve and remove temporary files created by/during autoenrollment.
+ #
+ # Formal Parameters:
+ #    $cmd      - The command that got us dispatched.
+ #    $tail     - The tail of the command.  In our case this is a colon
+ #                separated list that will be split into:
+ #                $filename - The name of the file to remove.
+ #                            The filename is given as a path relative to
+ #                            the LonCAPA temp file directory.
+ #    $client   - Socket open on the client.
+ #
+ # Returns:
+ #   1     - Continue processing.
+ sub retrieve_auto_file_handler {
+     my ($cmd, $tail, $client)    = @_;
+     my $userinput                = "cmd:$tail";
+     my ($filename)   = split(/:/, $tail);
+     my $source = $perlvar{'lonDaemons'}.'/tmp/'.$filename;
+     if ( (-e $source) && ($filename ne '') ) {
+ 	my $reply = '';
+ 	if (open(my $fh,$source)) {
+ 	    while (<$fh>) {
+ 		chomp($_);
+ 		$_ =~ s/^\s+//g;
+ 		$_ =~ s/\s+$//g;
+ 		$reply .= $_;
+ 	    }
+ 	    close($fh);
+ 	    &Reply($client, &escape($reply)."\n", $userinput);
+ #   Does this have to be uncommented??!?  (RF).
+ #
+ #                                unlink($source);
+ 	} else {
+ 	    &Failure($client, "error\n", $userinput);
+ 	}
+     } else {
+ 	&Failure($client, "error\n", $userinput);
+     }
+     return 1;
+ }
+ &register_handler("autoretrieve", \&retrieve_auto_file_handler, 0,1,0);
  #
+ #   Read and retrieve institutional code format (for support form).
+ # Formal Parameters:
+ #    $cmd        - Command that dispatched us.
+ #    $tail       - Tail of the command.  In this case it conatins
+ #                  the course domain and the coursename.
+ #    $client     - Socket open on the client.
+ # Returns:
+ #    1     - Continue processing.
  #
+ sub get_institutional_code_format_handler {
+     my ($cmd, $tail, $client)   = @_;
+     my $userinput               = "$cmd:$tail";
+     my $reply;
+     my($cdom,$course) = split(/:/,$tail);
+     my @pairs = split/\&/,$course;
+     my %instcodes = ();
+     my %codes = ();
+     my @codetitles = ();
+     my %cat_titles = ();
+     my %cat_order = ();
+     foreach (@pairs) {
+ 	my ($key,$value) = split/=/,$_;
+ 	$instcodes{&unescape($key)} = &unescape($value);
+     }
+     my $formatreply = &localenroll::instcode_format($cdom,
+ 						    \%instcodes,
+ 						    \%codes,
+ 						    \@codetitles,
+ 						    \%cat_titles,
+ 						    \%cat_order);
+     if ($formatreply eq 'ok') {
+ 	my $codes_str = &hash2str(%codes);
+ 	my $codetitles_str = &array2str(@codetitles);
+ 	my $cat_titles_str = &hash2str(%cat_titles);
+ 	my $cat_order_str = &hash2str(%cat_order);
+ 	&Reply($client,
+ 	       $codes_str.':'.$codetitles_str.':'.$cat_titles_str.':'
+ 	       .$cat_order_str."\n",
+ 	       $userinput);
+     } else {
+ 	# this else branch added by RF since if not ok, lonc will
+ 	# hang waiting on reply until timeout.
+ 	#
+ 	&Reply($client, "format_error\n", $userinput);
+     }
+     return 1;
+ }
+ &register_handler("autoinstcodeformat",
+ 		  \&get_institutional_code_format_handler,0,1,0);
+ # Get domain specific conditions for import of student photographs to a course
  #
+ # Retrieves information from photo_permission subroutine in localenroll.
+ # Returns outcome (ok) if no processing errors, and whether course owner is
+ # required to accept conditions of use (yes/no).
+ #
+ #
+ sub photo_permission_handler {
+     my ($cmd, $tail, $client)   = @_;
+     my $userinput               = "$cmd:$tail";
+     my $cdom = $tail;
+     my ($perm_reqd,$conditions);
+     my $outcome = &localenroll::photo_permission($cdom,\$perm_reqd,
+ 						 \$conditions);
+     &Reply($client, &escape($outcome.':'.$perm_reqd.':'. $conditions)."\n",
+ 	   $userinput);
+ }
+ &register_handler("autophotopermission",\&photo_permission_handler,0,1,0);
+ #
+ # Checks if student photo is available for a user in the domain, in the user's
+ # directory (in /userfiles/internal/studentphoto.jpg).
+ # Uses localstudentphoto:fetch() to ensure there is an up to date copy of
+ # the student's photo.
+ sub photo_check_handler {
+     my ($cmd, $tail, $client)   = @_;
+     my $userinput               = "$cmd:$tail";
+     my ($udom,$uname,$pid) = split(/:/,$tail);
+     $udom = &unescape($udom);
+     $uname = &unescape($uname);
+     $pid = &unescape($pid);
+     my $path=&propath($udom,$uname).'/userfiles/internal/';
+     if (!-e $path) {
+         &mkpath($path);
+     }
+     my $response;
+     my $result = &localstudentphoto::fetch($udom,$uname,$pid,\$response);
+     $result .= ':'.$response;
+     &Reply($client, &escape($result)."\n",$userinput);
+ }
+ &register_handler("autophotocheck",\&photo_check_handler,0,1,0);
+ #
+ # Retrieve information from localenroll about whether to provide a button
+ # for users who have enbled import of student photos to initiate an
+ # update of photo files for registered students. Also include
+ # comment to display alongside button.
+ sub photo_choice_handler {
+     my ($cmd, $tail, $client) = @_;
+     my $userinput             = "$cmd:$tail";
+     my $cdom                  = &unescape($tail);
+     my ($update,$comment) = &localenroll::manager_photo_update($cdom);
+     &Reply($client,&escape($update).':'.&escape($comment)."\n",$userinput);
+ }
+ &register_handler("autophotochoice",\&photo_choice_handler,0,1,0);
+ #
+ # Gets a student's photo to exist (in the correct image type) in the user's
+ # directory.
+ # Formal Parameters:
+ #    $cmd     - The command request that got us dispatched.
+ #    $tail    - A colon separated set of words that will be split into:
+ #               $domain - student's domain
+ #               $uname  - student username
+ #               $type   - image type desired
+ #    $client  - The socket open on the client.
+ # Returns:
+ #    1 - continue processing.
+ sub student_photo_handler {
+     my ($cmd, $tail, $client) = @_;
+     my ($domain,$uname,$ext,$type) = split(/:/, $tail);
+     my $path=&propath($domain,$uname). '/userfiles/internal/';
+     my $filename = 'studentphoto.'.$ext;
+     if ($type eq 'thumbnail') {
+         $filename = 'studentphoto_tn.'.$ext;
+     }
+     if (-e $path.$filename) {
+ 	&Reply($client,"ok\n","$cmd:$tail");
+ 	return 1;
+     }
+     &mkpath($path);
+     my $file;
+     if ($type eq 'thumbnail') {
+         $file=&localstudentphoto::fetch_thumbnail($domain,$uname);
+     } else {
+         $file=&localstudentphoto::fetch($domain,$uname);
+     }
+     if (!$file) {
+ 	&Failure($client,"unavailable\n","$cmd:$tail");
+ 	return 1;
+     }
+     if (!-e $path.$filename) { &convert_photo($file,$path.$filename); }
+     if (-e $path.$filename) {
+ 	&Reply($client,"ok\n","$cmd:$tail");
+ 	return 1;
+     }
+     &Failure($client,"unable_to_convert\n","$cmd:$tail");
+     return 1;
+ }
+ &register_handler("studentphoto", \&student_photo_handler, 0, 1, 0);
+ # mkpath makes all directories for a file, expects an absolute path with a
+ # file or a trailing / if just a dir is passed
+ # returns 1 on success 0 on failure
+ sub mkpath {
+     my ($file)=@_;
+     my @parts=split(/\//,$file,-1);
+     my $now=$parts[0].'/'.$parts[1].'/'.$parts[2];
+     for (my $i=3;$i<= ($#parts-1);$i++) {
+ 	$now.='/'.$parts[$i];
+ 	if (!-e $now) {
+ 	    if  (!mkdir($now,0770)) { return 0; }
+ 	}
+     }
+     return 1;
+ }
  #---------------------------------------------------------------
  #
  #   Getting, decoding and dispatching requests:
  #
  #
  #   Get a Request:
  #   Gets a Request message from the client.  The transaction
- Line 3104  sub process_request {
+ Line 4506  sub process_request {
  	$userinput = decipher($userinput);
  	$wasenc=1;
  	if(!$userinput) {	# Cipher not defined.
- 	    &Failure($client, "error: Encrypted data without negotated key");
+ 	    &Failure($client, "error: Encrypted data without negotated key\n");
  	    return 0;
  	}
      }
- Line 3174  sub process_request {
+ Line 4576  sub process_request {
      }
- #------------------- Commands not yet in spearate handlers. --------------
+     print $client "unknown_cmd\n";
- # ----------------------------------------------------------------------- idput
-     if ($userinput =~ /^idput/) {
- 	if(isClient) {
- 	    my ($cmd,$udom,$what)=split(/:/,$userinput);
- 	    chomp($what);
- 	    $udom=~s/\W//g;
- 	    my $proname="$perlvar{'lonUsersDir'}/$udom/ids";
- 	    my $now=time;
- 	    my @pairs=split(/\&/,$what);
- 	    my %hash;
- 	    if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {
- 		{
- 		    my $hfh;
- 		    if ($hfh=IO::File->new(">>$proname.hist")) {
- 			print $hfh "P:$now:$what\n";
- 		    }
- 		}
- 		foreach my $pair (@pairs) {
- 		    my ($key,$value)=split(/=/,$pair);
- 		    $hash{$key}=$value;
- 		}
- 		if (untie(%hash)) {
- 		    print $client "ok\n";
- 		} else {
- 		    print $client "error: ".($!+0)
- 			." untie(GDBM) Failed ".
- 			"while attempting idput\n";
- 		}
- 	    } else {
- 		print $client "error: ".($!+0)
- 		    ." tie(GDBM) Failed ".
- 		    "while attempting idput\n";
- 	    }
- 	} else {
- 	    Reply($client, "refused\n", $userinput);
- 	}
- # ----------------------------------------------------------------------- idget
-     } elsif ($userinput =~ /^idget/) {
- 	if(isClient) {
- 	    my ($cmd,$udom,$what)=split(/:/,$userinput);
- 	    chomp($what);
- 	    $udom=~s/\W//g;
- 	    my $proname="$perlvar{'lonUsersDir'}/$udom/ids";
- 	    my @queries=split(/\&/,$what);
- 	    my $qresult='';
- 	    my %hash;
- 	    if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {
- 		for (my $i=0;$i<=$#queries;$i++) {
- 		    $qresult.="$hash{$queries[$i]}&";
- 		}
- 		if (untie(%hash)) {
- 		    $qresult=~s/\&$//;
- 		    print $client "$qresult\n";
- 		} else {
- 		    print $client "error: ".($!+0)
- 			." untie(GDBM) Failed ".
- 			"while attempting idget\n";
- 		}
- 	    } else {
- 		print $client "error: ".($!+0)
- 		    ." tie(GDBM) Failed ".
- 		    "while attempting idget\n";
- 	    }
- 	} else {
- 	    Reply($client, "refused\n", $userinput);
- 	}
- # ---------------------------------------------------------------------- tmpput
-     } elsif ($userinput =~ /^tmpput/) {
- 	if(isClient) {
- 	    my ($cmd,$what)=split(/:/,$userinput);
- 	    my $store;
- 	    $tmpsnum++;
- 	    my $id=$$.'_'.$clientip.'_'.$tmpsnum;
- 	    $id=~s/\W/\_/g;
- 	    $what=~s/\n//g;
- 	    my $execdir=$perlvar{'lonDaemons'};
- 	    if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) {
- 		print $store $what;
- 		close $store;
- 		print $client "$id\n";
- 	    }
- 	    else {
- 		print $client "error: ".($!+0)
- 		    ."IO::File->new Failed ".
- 		    "while attempting tmpput\n";
- 	    }
- 	} else {
- 	    Reply($client, "refused\n", $userinput);
- 	}
- # ---------------------------------------------------------------------- tmpget
-     } elsif ($userinput =~ /^tmpget/) {
- 	if(isClient) {
- 	    my ($cmd,$id)=split(/:/,$userinput);
- 	    chomp($id);
- 	    $id=~s/\W/\_/g;
- 	    my $store;
- 	    my $execdir=$perlvar{'lonDaemons'};
- 	    if ($store=IO::File->new("$execdir/tmp/$id.tmp")) {
- 		my $reply=<$store>;
- 			    print $client "$reply\n";
- 		close $store;
- 	    }
- 	    else {
- 		print $client "error: ".($!+0)
- 		    ."IO::File->new Failed ".
- 		    "while attempting tmpget\n";
- 	    }
- 	} else {
- 	    Reply($client, "refused\n", $userinput);
- 	}
- # ---------------------------------------------------------------------- tmpdel
-     } elsif ($userinput =~ /^tmpdel/) {
- 	if(isClient) {
- 	    my ($cmd,$id)=split(/:/,$userinput);
- 	    chomp($id);
- 	    $id=~s/\W/\_/g;
- 	    my $execdir=$perlvar{'lonDaemons'};
- 	    if (unlink("$execdir/tmp/$id.tmp")) {
- 		print $client "ok\n";
- 	    } else {
- 		print $client "error: ".($!+0)
- 		    ."Unlink tmp Failed ".
- 		    "while attempting tmpdel\n";
- 	    }
- 	} else {
- 	    Reply($client, "refused\n", $userinput);
- 	}
- # -------------------------------------------------------------------------- ls
-     } elsif ($userinput =~ /^ls/) {
- 	if(isClient) {
- 	    my $obs;
- 	    my $rights;
- 	    my ($cmd,$ulsdir)=split(/:/,$userinput);
- 	    my $ulsout='';
- 	    my $ulsfn;
- 	    if (-e $ulsdir) {
- 		if(-d $ulsdir) {
- 		    if (opendir(LSDIR,$ulsdir)) {
- 			while ($ulsfn=readdir(LSDIR)) {
- 			    undef $obs, $rights;
- 			    my @ulsstats=stat($ulsdir.'/'.$ulsfn);
- 			    #We do some obsolete checking here
- 			    if(-e $ulsdir.'/'.$ulsfn.".meta") {
- 				open(FILE, $ulsdir.'/'.$ulsfn.".meta");
- 				my @obsolete=<FILE>;
- 				foreach my $obsolete (@obsolete) {
- 				    if($obsolete =~ m|(<obsolete>)(on)|) { $obs = 1; }
- 				    if($obsolete =~ m|(<copyright>)(default)|) { $rights = 1; }
- 				}
- 			    }
- 			    $ulsout.=$ulsfn.'&'.join('&',@ulsstats);
- 			    if($obs eq '1') { $ulsout.="&1"; }
- 			    else { $ulsout.="&0"; }
- 			    if($rights eq '1') { $ulsout.="&1:"; }
- 			    else { $ulsout.="&0:"; }
- 			}
- 			closedir(LSDIR);
- 		    }
- 		} else {
- 		    my @ulsstats=stat($ulsdir);
- 		    $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';
- 		}
- 	    } else {
- 		$ulsout='no_such_dir';
- 	    }
- 	    if ($ulsout eq '') { $ulsout='empty'; }
- 	    print $client "$ulsout\n";
- 	} else {
- 	    Reply($client, "refused\n", $userinput);
- 	}
- # ----------------------------------------------------------------- setannounce
-     } elsif ($userinput =~ /^setannounce/) {
- 	if (isClient) {
- 	    my ($cmd,$announcement)=split(/:/,$userinput);
- 	    chomp($announcement);
- 	    $announcement=&unescape($announcement);
- 	    if (my $store=IO::File->new('>'.$perlvar{'lonDocRoot'}.
- 					'/announcement.txt')) {
- 		print $store $announcement;
- 		close $store;
- 		print $client "ok\n";
- 	    } else {
- 		print $client "error: ".($!+0)."\n";
- 	    }
- 	} else {
- 	    Reply($client, "refused\n", $userinput);
- 	}
- # ------------------------------------------------------------------ Hanging up
-     } elsif (($userinput =~ /^exit/) ||
- 	     ($userinput =~ /^init/)) { # no restrictions.
- 	&logthis(
- 		 "Client $clientip ($clientname) hanging up: $userinput");
- 	print $client "bye\n";
- 	$client->shutdown(2);        # shutdown the socket forcibly.
- 	$client->close();
- 	return 0;
- # ---------------------------------- set current host/domain
-     } elsif ($userinput =~ /^sethost/) {
- 	if (isClient) {
- 	    print $client &sethost($userinput)."\n";
- 	} else {
- 	    print $client "refused\n";
- 	}
- #---------------------------------- request file (?) version.
-     } elsif ($userinput =~/^version/) {
- 	if (isClient) {
- 	    print $client &version($userinput)."\n";
- 	} else {
- 	    print $client "refused\n";
- 	}
- #------------------------------- is auto-enrollment enabled?
-     } elsif ($userinput =~/^autorun/) {
- 	if (isClient) {
- 	    my ($cmd,$cdom) = split(/:/,$userinput);
- 	    my $outcome = &localenroll::run($cdom);
- 	    print $client "$outcome\n";
- 	} else {
- 	    print $client "0\n";
- 	}
- #------------------------------- get official sections (for auto-enrollment).
-     } elsif ($userinput =~/^autogetsections/) {
- 	if (isClient) {
- 	    my ($cmd,$coursecode,$cdom)=split(/:/,$userinput);
- 	    my @secs = &localenroll::get_sections($coursecode,$cdom);
- 	    my $seclist = &escape(join(':',@secs));
- 	    print $client "$seclist\n";
- 	} else {
- 	    print $client "refused\n";
- 	}
- #----------------------- validate owner of new course section (for auto-enrollment).
-     } elsif ($userinput =~/^autonewcourse/) {
- 	if (isClient) {
- 	    my ($cmd,$inst_course_id,$owner,$cdom)=split(/:/,$userinput);
- 	    my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom);
- 	    print $client "$outcome\n";
- 	} else {
- 	    print $client "refused\n";
- 	}
- #-------------- validate course section in schedule of classes (for auto-enrollment).
-     } elsif ($userinput =~/^autovalidatecourse/) {
- 	if (isClient) {
- 	    my ($cmd,$inst_course_id,$cdom)=split(/:/,$userinput);
- 	    my $outcome=&localenroll::validate_courseID($inst_course_id,$cdom);
- 	    print $client "$outcome\n";
- 	} else {
- 	    print $client "refused\n";
- 	}
- #--------------------------- create password for new user (for auto-enrollment).
-     } elsif ($userinput =~/^autocreatepassword/) {
- 	if (isClient) {
- 	    my ($cmd,$authparam,$cdom)=split(/:/,$userinput);
- 	    my ($create_passwd,$authchk);
- 	    ($authparam,$create_passwd,$authchk) = &localenroll::create_password($authparam,$cdom);
- 	    print $client &escape($authparam.':'.$create_passwd.':'.$authchk)."\n";
- 	} else {
- 	    print $client "refused\n";
- 	}
- #---------------------------  read and remove temporary files (for auto-enrollment).
-     } elsif ($userinput =~/^autoretrieve/) {
- 	if (isClient) {
- 	    my ($cmd,$filename) = split(/:/,$userinput);
- 	    my $source = $perlvar{'lonDaemons'}.'/tmp/'.$filename;
- 	    if ( (-e $source) && ($filename ne '') ) {
- 		my $reply = '';
- 		if (open(my $fh,$source)) {
- 		    while (<$fh>) {
- 			chomp($_);
- 			$_ =~ s/^\s+//g;
- 			$_ =~ s/\s+$//g;
- 			$reply .= $_;
- 		    }
- 		    close($fh);
- 		    print $client &escape($reply)."\n";
- #                                unlink($source);
- 		} else {
- 		    print $client "error\n";
- 		}
- 	    } else {
- 		print $client "error\n";
- 	    }
- 	} else {
- 	    print $client "refused\n";
- 	}
- #---------------------  read and retrieve institutional code format (for support form).
-     } elsif ($userinput =~/^autoinstcodeformat/) {
- 	if (isClient) {
- 	    my $reply;
- 	    my($cmd,$cdom,$course) = split(/:/,$userinput);
- 	    my @pairs = split/\&/,$course;
- 	    my %instcodes = ();
- 	    my %codes = ();
- 	    my @codetitles = ();
- 	    my %cat_titles = ();
- 	    my %cat_order = ();
- 	    foreach (@pairs) {
- 		my ($key,$value) = split/=/,$_;
- 		$instcodes{&unescape($key)} = &unescape($value);
- 	    }
- 	    my $formatreply = &localenroll::instcode_format($cdom,\%instcodes,\%codes,\@codetitles,\%cat_titles,\%cat_order);
- 	    if ($formatreply eq 'ok') {
- 		my $codes_str = &hash2str(%codes);
- 		my $codetitles_str = &array2str(@codetitles);
- 		my $cat_titles_str = &hash2str(%cat_titles);
- 		my $cat_order_str = &hash2str(%cat_order);
- 		print $client $codes_str.':'.$codetitles_str.':'.$cat_titles_str.':'.$cat_order_str."\n";
- 	    }
- 	} else {
- 	    print $client "refused\n";
- 	}
- # ------------------------------------------------------------- unknown command
-     } else {
- 	# unknown command
- 	print $client "unknown_cmd\n";
-     }
  # -------------------------------------------------------------------- complete
      Debug("process_request - returning 1");
      return 1;
- Line 3761  sub ReadHostTable {
+ Line 4837  sub ReadHostTable {
      open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";
      my $myloncapaname = $perlvar{'lonHostID'};
      Debug("My loncapa name is : $myloncapaname");
+     my %name_to_ip;
      while (my $configline=<CONFIG>) {
- 	if (!($configline =~ /^\s*\#/)) {
+ 	if ($configline !~ /^\s*\#/ && $configline !~ /^\s*$/ ) {
- 	    my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
+ 	    my ($id,$domain,$role,$name)=split(/:/,$configline);
- 	    chomp($ip); $ip=~s/\D+$//;
+ 	    $name=~s/\s//g;
+ 	    my $ip;
+ 	    if (!exists($name_to_ip{$name})) {
+ 		$ip = gethostbyname($name);
+ 		if (!$ip || length($ip) ne 4) {
+ 		    &logthis("Skipping host $id name $name no IP found\n");
+ 		    next;
+ 		}
+ 		$ip=inet_ntoa($ip);
+ 		$name_to_ip{$name} = $ip;
+ 	    } else {
+ 		$ip = $name_to_ip{$name};
+ 	    }
  	    $hostid{$ip}=$id;         # LonCAPA name of host by IP.
  	    $hostdom{$id}=$domain;    # LonCAPA domain name of host.
- 	    $hostip{$id}=$ip;	      # IP address of host.
+ 	    $hostname{$id}=$name;     # LonCAPA name -> DNS name
+ 	    $hostip{$id}=$ip;         # IP address of host.
  	    $hostdns{$name} = $id;    # LonCAPA name of host by DNS.
  	    if ($id eq $perlvar{'lonHostID'}) {
- Line 3904  sub Reply {
+ Line 4994  sub Reply {
      Debug("Request was $request  Reply was $reply");
      $Transactions++;
  }
- Line 3948  sub logstatus {
+ Line 5036  sub logstatus {
  	flock(LOG,LOCK_EX);
  	print LOG $$."\t".$clientname."\t".$currenthostid."\t"
  	    .$status."\t".$lastlog."\t $keymode\n";
- 	flock(DB,LOCK_UN);
+ 	flock(LOG,LOCK_UN);
  	close(LOG);
      }
      &status("Finished logging");
- Line 4019  sub reconlonc {
+ Line 5107  sub reconlonc {
  sub subreply {
      my ($cmd,$server)=@_;
-     my $peerfile="$perlvar{'lonSockDir'}/$server";
+     my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$server};
      my $sclient=IO::Socket::UNIX->new(Peer    =>"$peerfile",
                                        Type    => SOCK_STREAM,
                                        Timeout => 10)
         or return "con_lost";
-     print $sclient "$cmd\n";
+     print $sclient "sethost:$server:$cmd\n";
      my $answer=<$sclient>;
      chomp($answer);
      if (!$answer) { $answer="con_lost"; }
- Line 4040  sub reply {
+ Line 5128  sub reply {
  	$answer=subreply("ping",$server);
          if ($answer ne $server) {
  	    &logthis("sub reply: answer != server answer is $answer, server is $server");
-            &reconlonc("$perlvar{'lonSockDir'}/$server");
+            &reconlonc("$perlvar{'lonSockDir'}/".$hostname{$server});
          }
          $answer=subreply($cmd,$server);
      }
- Line 4133  $SIG{USR2} = \&UpdateHosts;
+ Line 5221  $SIG{USR2} = \&UpdateHosts;
  ReadHostTable;
+ my $dist=`$perlvar{'lonDaemons'}/distprobe`;
  # --------------------------------------------------------------
  #   Accept connections.  When a connection comes in, it is validated
  #   and if good, a child process is created to process transactions
- Line 4179  sub make_new_child {
+ Line 5269  sub make_new_child {
      if (defined($iaddr)) {
  	$clientip  = inet_ntoa($iaddr);
  	Debug("Connected with $clientip");
- 	$clientdns = gethostbyaddr($iaddr, AF_INET);
- 	Debug("Connected with $clientdns by name");
      } else {
  	&logthis("Unable to determine clientip");
  	$clientip='Unavailable';
- Line 4210  sub make_new_child {
+ Line 5298  sub make_new_child {
  #        my $tmpsnum=0;            # Now global
  #---------------------------------------------------- kerberos 5 initialization
          &Authen::Krb5::init_context();
-         &Authen::Krb5::init_ets();
+ 	unless (($dist eq 'fedora4') || ($dist eq 'suse9.3')) {
+ 	    &Authen::Krb5::init_ets();
+ 	}
  	&status('Accepted connection');
  # =============================================================================
- Line 4220  sub make_new_child {
+ Line 5310  sub make_new_child {
  	ReadManagerTable;	# May also be a manager!!
- 	my $clientrec=($hostid{$clientip}     ne undef);
+ 	my $outsideip=$clientip;
- 	my $ismanager=($managers{$clientip}    ne undef);
+ 	if ($clientip eq '127.0.0.1') {
+ 	    $outsideip=$hostip{$perlvar{'lonHostID'}};
+ 	}
+ 	my $clientrec=($hostid{$outsideip}     ne undef);
+ 	my $ismanager=($managers{$outsideip}    ne undef);
  	$clientname  = "[unknonwn]";
  	if($clientrec) {	# Establish client type.
  	    $ConnectionType = "client";
- 	    $clientname = $hostid{$clientip};
+ 	    $clientname = $hostid{$outsideip};
  	    if($ismanager) {
  		$ConnectionType = "both";
  	    }
  	} else {
  	    $ConnectionType = "manager";
- 	    $clientname = $managers{$clientip};
+ 	    $clientname = $managers{$outsideip};
  	}
  	my $clientok;
- Line 4339  sub make_new_child {
+ Line 5434  sub make_new_child {
  		    # no need to try to do recon's to myself
  		    next;
  		}
- 		&reconlonc("$perlvar{'lonSockDir'}/$id");
+ 		&reconlonc("$perlvar{'lonSockDir'}/".$hostname{$id});
  	    }
  	    &logthis("<font color='green'>Established connection: $clientname</font>");
  	    &status('Will listen to '.$clientname);
- Line 4375  sub make_new_child {
+ Line 5470  sub make_new_child {
      exit;
  }
+ #
+ #   Determine if a user is an author for the indicated domain.
+ #
+ # Parameters:
+ #    domain          - domain to check in .
+ #    user            - Name of user to check.
+ #
+ # Return:
+ #     1             - User is an author for domain.
+ #     0             - User is not an author for domain.
+ sub is_author {
+     my ($domain, $user) = @_;
+     &Debug("is_author: $user @ $domain");
+     my $hashref = &tie_user_hash($domain, $user, "roles",
+ 				 &GDBM_READER());
+     #  Author role should show up as a key /domain/_au
+     my $key   = "/$domain/_au";
+     my $value = $hashref->{$key};
+     if(defined($value)) {
+ 	&Debug("$user @ $domain is an author");
+     }
+     return defined($value);
+ }
  #
  #   Checks to see if the input roleput request was to set
  # an author role.  If so, invokes the lchtmldir script to set
- Line 4388  sub make_new_child {
+ Line 5510  sub make_new_child {
  #    user      - Name of the user for which the role is being put.
  #    authtype  - The authentication type associated with the user.
  #
- sub manage_permissions
+ sub manage_permissions {
- {
      my ($request, $domain, $user, $authtype) = @_;
+     &Debug("manage_permissions: $request $domain $user $authtype");
      # See if the request is of the form /$domain/_au
-     if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...
+     if($request =~ /^(\/\Q$domain\E\/_au)$/) { # It's an author rolesput...
  	my $execdir = $perlvar{'lonDaemons'};
  	my $userhome= "/home/$user" ;
  	&logthis("system $execdir/lchtmldir $userhome $user $authtype");
+ 	&Debug("Setting homedir permissions for $userhome");
  	system("$execdir/lchtmldir $userhome $user $authtype");
      }
  }
- Line 4413  sub manage_permissions
+ Line 5536  sub manage_permissions
  #
  sub password_path {
      my ($domain, $user) = @_;
+     return &propath($domain, $user).'/passwd';
-     my $path   = &propath($domain, $user);
-     $path  .= "/passwd";
-     return $path;
  }
  #   Password Filename
- Line 4493  sub get_auth_type
+ Line 5611  sub get_auth_type
  	Debug("Password info = $realpassword\n");
  	my ($authtype, $contentpwd) = split(/:/, $realpassword);
  	Debug("Authtype = $authtype, content = $contentpwd\n");
- 	my $availinfo = '';
+ 	return "$authtype:$contentpwd";
- 	if($authtype eq 'krb4' or $authtype eq 'krb5') {
- 	    $availinfo = $contentpwd;
- 	}
- 	return "$authtype:$availinfo";
      } else {
  	Debug("Returning nouser");
  	return "nouser";
- Line 4531  sub validate_user {
+ Line 5644  sub validate_user {
      # At the end of this function. I'll ensure that it's not still that
      # value so we don't just wind up returning some accidental value
      # as a result of executing an unforseen code path that
-     # did not set $validated.
+     # did not set $validated.  At the end of valid execution paths,
+     # validated shoule be 1 for success or 0 for failuer.
      my $validated = -3.14159;
- Line 4595  sub validate_user {
+ Line 5709  sub validate_user {
  		my $krbserver  = &Authen::Krb5::parse_name($krbservice);
  		my $credentials= &Authen::Krb5::cc_default();
  		$credentials->initialize($krbclient);
- 		my $krbreturn  = &Authen::KRb5::get_in_tkt_with_password($krbclient,
+ 		my $krbreturn  = &Authen::Krb5::get_in_tkt_with_password($krbclient,
  									 $krbserver,
  									 $password,
  									 $credentials);
- Line 4619  sub validate_user {
+ Line 5733  sub validate_user {
      #
      unless ($validated != -3.14159) {
- 	die "ValidateUser - failed to set the value of validated";
+ 	#  I >really really< want to know if this happens.
+ 	#  since it indicates that user authentication is badly
+ 	#  broken in some code path.
+         #
+ 	die "ValidateUser - failed to set the value of validated $domain, $user $password";
      }
      return $validated;
  }
- Line 4647  sub addline {
+ Line 5765  sub addline {
  sub get_chat {
      my ($cdom,$cname,$udom,$uname)=@_;
-     my %hash;
-     my $proname=&propath($cdom,$cname);
      my @entries=();
-     if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db",
+     my $hashref = &tie_user_hash($cdom, $cname, 'nohist_chatroom',
- 	    &GDBM_READER(),0640)) {
+ 				 &GDBM_READER());
- 	@entries=map { $_.':'.$hash{$_} } sort keys %hash;
+     if ($hashref) {
- 	untie %hash;
+ 	@entries=map { $_.':'.$hashref->{$_} } sort(keys(%$hashref));
+ 	&untie_user_hash($hashref);
      }
      my @participants=();
      my $cutoff=time-60;
-     if (tie(%hash,'GDBM_File',"$proname/nohist_inchatroom.db",
+     $hashref = &tie_user_hash($cdom, $cname, 'nohist_inchatroom',
- 	    &GDBM_WRCREAT(),0640)) {
+ 			      &GDBM_WRCREAT());
-         $hash{$uname.':'.$udom}=time;
+     if ($hashref) {
-         foreach (sort keys %hash) {
+         $hashref->{$uname.':'.$udom}=time;
- 	    if ($hash{$_}>$cutoff) {
+         foreach my $user (sort(keys(%$hashref))) {
- 		$participants[$#participants+1]='active_participant:'.$_;
+ 	    if ($hashref->{$user}>$cutoff) {
+ 		push(@participants, 'active_participant:'.$user);
              }
          }
-         untie %hash;
+         &untie_user_hash($hashref);
      }
      return (@participants,@entries);
  }
  sub chat_add {
      my ($cdom,$cname,$newchat)=@_;
-     my %hash;
-     my $proname=&propath($cdom,$cname);
      my @entries=();
      my $time=time;
-     if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db",
+     my $hashref = &tie_user_hash($cdom, $cname, 'nohist_chatroom',
- 	    &GDBM_WRCREAT(),0640)) {
+ 				 &GDBM_WRCREAT());
- 	@entries=map { $_.':'.$hash{$_} } sort keys %hash;
+     if ($hashref) {
+ 	@entries=map { $_.':'.$hashref->{$_} } sort(keys(%$hashref));
  	my ($lastid)=($entries[$#entries]=~/^(\w+)\:/);
  	my ($thentime,$idnum)=split(/\_/,$lastid);
  	my $newid=$time.'_000000';
- Line 4688  sub chat_add {
+ Line 5806  sub chat_add {
  	    $idnum=substr('000000'.$idnum,-6,6);
  	    $newid=$time.'_'.$idnum;
  	}
- 	$hash{$newid}=$newchat;
+ 	$hashref->{$newid}=$newchat;
  	my $expired=$time-3600;
- 	foreach (keys %hash) {
+ 	foreach my $comment (keys(%$hashref)) {
- 	    my ($thistime)=($_=~/(\d+)\_/);
+ 	    my ($thistime) = ($comment=~/(\d+)\_/);
  	    if ($thistime<$expired) {
- 		delete $hash{$_};
+ 		delete $hashref->{$comment};
  	    }
  	}
- 	untie %hash;
+ 	{
-     }
+ 	    my $proname=&propath($cdom,$cname);
-     {
+ 	    if (open(CHATLOG,">>$proname/chatroom.log")) {
- 	my $hfh;
+ 		print CHATLOG ("$time:".&unescape($newchat)."\n");
- 	if ($hfh=IO::File->new(">>$proname/chatroom.log")) {
+ 	    }
- 	    print $hfh "$time:".&unescape($newchat)."\n";
+ 	    close(CHATLOG);
  	}
+ 	&untie_user_hash($hashref);
      }
  }
- Line 4791  sub thisversion {
+ Line 5910  sub thisversion {
  sub subscribe {
      my ($userinput,$clientip)=@_;
      my $result;
-     my ($cmd,$fname)=split(/:/,$userinput);
+     my ($cmd,$fname)=split(/:/,$userinput,2);
      my $ownership=&ishome($fname);
      if ($ownership eq 'owner') {
  # explitly asking for the current version?
- Line 4835  sub subscribe {
+ Line 5954  sub subscribe {
      }
      return $result;
  }
+ #  Change the passwd of a unix user.  The caller must have
+ #  first verified that the user is a loncapa user.
+ #
+ # Parameters:
+ #    user      - Unix user name to change.
+ #    pass      - New password for the user.
+ # Returns:
+ #    ok    - if success
+ #    other - Some meaningfule error message string.
+ # NOTE:
+ #    invokes a setuid script to change the passwd.
+ sub change_unix_password {
+     my ($user, $pass) = @_;
+     &Debug("change_unix_password");
+     my $execdir=$perlvar{'lonDaemons'};
+     &Debug("Opening lcpasswd pipeline");
+     my $pf = IO::File->new("|$execdir/lcpasswd > "
+ 			   ."$perlvar{'lonDaemons'}"
+ 			   ."/logs/lcpasswd.log");
+     print $pf "$user\n$pass\n$pass\n";
+     close $pf;
+     my $err = $?;
+     return ($err < @passwderrors) ? $passwderrors[$err] :
+ 	"pwchange_falure - unknown error";
+ }
  sub make_passwd_file {
      my ($uname, $umode,$npass,$passfilename)=@_;
- Line 4842  sub make_passwd_file {
+ Line 5990  sub make_passwd_file {
      if ($umode eq 'krb4' or $umode eq 'krb5') {
  	{
  	    my $pf = IO::File->new(">$passfilename");
- 	    print $pf "$umode:$npass\n";
+ 	    if ($pf) {
+ 		print $pf "$umode:$npass\n";
+ 	    } else {
+ 		$result = "pass_file_failed_error";
+ 	    }
  	}
      } elsif ($umode eq 'internal') {
  	my $salt=time;
- Line 4851  sub make_passwd_file {
+ Line 6003  sub make_passwd_file {
  	{
  	    &Debug("Creating internal auth");
  	    my $pf = IO::File->new(">$passfilename");
- 	    print $pf "internal:$ncpass\n";
+ 	    if($pf) {
+ 		print $pf "internal:$ncpass\n";
+ 	    } else {
+ 		$result = "pass_file_failed_error";
+ 	    }
  	}
      } elsif ($umode eq 'localauth') {
  	{
  	    my $pf = IO::File->new(">$passfilename");
- 	    print $pf "localauth:$npass\n";
+ 	    if($pf) {
+ 		print $pf "localauth:$npass\n";
+ 	    } else {
+ 		$result = "pass_file_failed_error";
+ 	    }
  	}
      } elsif ($umode eq 'unix') {
  	{
- Line 4882  sub make_passwd_file {
+ Line 6042  sub make_passwd_file {
  		print $se "$npass\n";
  		print $se "$lc_error_file\n"; # Status -> unique file.
  	    }
- 	    my $error = IO::File->new("< $lc_error_file");
+ 	    if (-r $lc_error_file) {
- 	    my $useraddok = <$error>;
+ 		&Debug("Opening error file: $lc_error_file");
- 	    $error->close;
+ 		my $error = IO::File->new("< $lc_error_file");
- 	    unlink($lc_error_file);
+ 		my $useraddok = <$error>;
+ 		$error->close;
- 	    chomp $useraddok;
+ 		unlink($lc_error_file);
- 	    if($useraddok > 0) {
+ 		chomp $useraddok;
- 		my $error_text = &lcuseraddstrerror($useraddok);
- 		&logthis("Failed lcuseradd: $error_text");
+ 		if($useraddok > 0) {
- 		$result = "lcuseradd_failed:$error_text\n";
+ 		    my $error_text = &lcuseraddstrerror($useraddok);
+ 		    &logthis("Failed lcuseradd: $error_text");
+ 		    $result = "lcuseradd_failed:$error_text\n";
+ 		}  else {
+ 		    my $pf = IO::File->new(">$passfilename");
+ 		    if($pf) {
+ 			print $pf "unix:\n";
+ 		    } else {
+ 			$result = "pass_file_failed_error";
+ 		    }
+ 		}
  	    }  else {
- 		my $pf = IO::File->new(">$passfilename");
+ 		&Debug("Could not locate lcuseradd error: $lc_error_file");
- 		print $pf "unix:\n";
+ 		$result="bug_lcuseradd_no_output_file";
  	    }
  	}
      } elsif ($umode eq 'none') {
  	{
  	    my $pf = IO::File->new("> $passfilename");
- 	    print $pf "none:\n";
+ 	    if($pf) {
+ 		print $pf "none:\n";
+ 	    } else {
+ 		$result = "pass_file_failed_error";
+ 	    }
  	}
      } else {
  	$result="auth_mode_error\n";
- Line 4909  sub make_passwd_file {
+ Line 6083  sub make_passwd_file {
      return $result;
  }
+ sub convert_photo {
+     my ($start,$dest)=@_;
+     system("convert $start $dest");
+ }
  sub sethost {
      my ($remotereq) = @_;
      my (undef,$hostid)=split(/:/,$remotereq);

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>

500 Internal Server Error

Internal Server Error

The server encountered an internal error or misconfiguration and was unable to complete your request.

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.

More information about this error may be available in the server error log.

Removed from v.1.237
changed lines
	Added in v.1.318.2.1