Return to lond CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.247 and 1.323

-version 1.247, 2004/09/02 18:37:44
+version 1.323, 2006/03/04 00:59:59
  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 1299  sub push_file_handler {
+ Line 1415  sub push_file_handler {
  # 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;
      }
-     my $duout = `du -ks $ududir 2>/dev/null`;
+     #  Since $ududir could have some nasties in it,
-     $duout=~s/[^\d]//g; #preserve only the numbers
+     #  we will require that ududir is a valid
-     &Reply($client,"$duout\n","$cmd:$ududir");
+     #  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
- Line 1331  sub du_handler {
+ Line 1468  sub du_handler {
  #   The reply is written to  $client.
  #
  sub ls_handler {
+     # obsoleted by ls2_handler
      my ($cmd, $ulsdir, $client) = @_;
      my $userinput = "$cmd:$ulsdir";
- Line 1343  sub ls_handler {
+ Line 1481  sub ls_handler {
  	if(-d $ulsdir) {
  	    if (opendir(LSDIR,$ulsdir)) {
  		while ($ulsfn=readdir(LSDIR)) {
- 		    undef $obs, $rights;
+ 		    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)|) { $obs = 1; }
+ 			    if($obsolete =~ m/(<obsolete>)(on|1)/) { $obs = 1; }
  			    if($obsolete =~ m|(<copyright>)(default)|) { $rights = 1; }
  			}
  		    }
- Line 1370  sub ls_handler {
+ Line 1509  sub ls_handler {
  	$ulsout='no_such_dir';
      }
      if ($ulsout eq '') { $ulsout='empty'; }
-     print $client "$ulsout\n";
+     &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 1409  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 1451  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 1507  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 1571  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 1599  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 1639  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 1691  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 1707  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 1792  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 1822  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 1835  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 1865  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 1923  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 1939  sub remove_user_file_handler {
+ Line 2167  sub remove_user_file_handler {
  	if (-e $udir) {
  	    my $file=$udir.'/userfiles/'.$ufile;
  	    if (-e $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 1969  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 1983  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 2011  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 2045  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 2056  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 2109  sub unsubscribe_handler {
+ Line 2332  sub unsubscribe_handler {
      return 1;
  }
  &register_handler("unsub", \&unsubscribe_handler, 0, 1, 0);
  #   Subscribe to a resource
  #
  # Parameters:
- Line 2187  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 2219  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 2227  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 2238  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 2268  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 2292  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 2332  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 2390  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 2431  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 2486  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 2540  sub get_profile_entry_encrypted {
+ Line 2803  sub get_profile_entry_encrypted {
  #     0   - Exit server.
  #
  #
  sub delete_profile_entry {
      my ($cmd, $tail, $client) = @_;
- Line 2556  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 2569  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 2597  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 2658  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 2713  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 2747  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 2779  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 2796  sub store_handler {
+ Line 3075  sub store_handler {
  	    $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 2813  sub store_handler {
+ Line 3092  sub store_handler {
      return 1;
  }
  &register_handler("store", \&store_handler, 0, 1, 0);
+ #  Modify a set of key=value pairs associated with a versioned name.
+ #
+ #  Parameters:
+ #    $cmd                - Request command keyword.
+ #    $tail               - Tail of the request.  This is a colon
+ #                          separated list containing:
+ #                          domain/user - User and authentication domain.
+ #                          namespace   - Name of the database being modified
+ #                          rid         - Resource keyword to modify.
+ #                          v           - Version item to modify
+ #                          what        - new value associated with rid.
+ #
+ #    $client             - Socket open on the client.
+ #
+ #
+ #  Returns:
+ #      1 (keep on processing).
+ #  Side-Effects:
+ #    Writes to the client
+ sub putstore_handler {
+     my ($cmd, $tail, $client) = @_;
+     my $userinput = "$cmd:$tail";
+     my ($udom,$uname,$namespace,$rid,$v,$what) =split(/:/,$tail);
+     if ($namespace ne 'roles') {
+ 	chomp($what);
+ 	my $hashref  = &tie_user_hash($udom, $uname, $namespace,
+ 				       &GDBM_WRCREAT(), "M",
+ 				       "$rid:$v:$what");
+ 	if ($hashref) {
+ 	    my $now = time;
+ 	    my %data = &hash_extract($what);
+ 	    my @allkeys;
+ 	    while (my($key,$value) = each(%data)) {
+ 		push(@allkeys,$key);
+ 		$hashref->{"$v:$rid:$key"} = $value;
+ 	    }
+ 	    my $allkeys = join(':',@allkeys);
+ 	    $hashref->{"$v:keys:$rid"}=$allkeys;
+ 	    if (&untie_user_hash($hashref)) {
+ 		&Reply($client, "ok\n", $userinput);
+ 	    } else {
+ 		&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
+ 			"while attempting store\n", $userinput);
+ 	    }
+ 	} else {
+ 	    &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
+ 		     "while attempting store\n", $userinput);
+ 	}
+     } else {
+ 	&Failure($client, "refused\n", $userinput);
+     }
+     return 1;
+ }
+ &register_handler("putstore", \&putstore_handler, 0, 1, 0);
+ sub hash_extract {
+     my ($str)=@_;
+     my %hash;
+     foreach my $pair (split(/\&/,$str)) {
+ 	my ($key,$value)=split(/=/,$pair);
+ 	$hash{$key}=$value;
+     }
+     return (%hash);
+ }
+ sub hash_to_str {
+     my ($hash_ref)=@_;
+     my $str;
+     foreach my $key (keys(%$hash_ref)) {
+ 	$str.=$key.'='.$hash_ref->{$key}.'&';
+     }
+     $str=~s/\&$//;
+     return $str;
+ }
  #
  #  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 2847  sub restore_handler {
+ Line 3206  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) {
- 		$qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&";
+ 		$qresult.="$scope:$key=".$hashref->{"$scope:$rid:$key"}."&";
  	    }
  	}
- 	if (untie(%hash)) {
+ 	if (&untie_user_hash($hashref)) {
  	    $qresult=~s/\&$//;
  	    &Reply( $client, "$qresult\n", $userinput);
  	} else {
- Line 2913  sub send_chat_handler {
+ Line 3270  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 3048  sub reply_query_handler {
+ Line 3406  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 3061  sub put_course_id_handler {
+ Line 3427  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 3069  sub put_course_id_handler {
+ Line 3435  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 3107  sub put_course_id_handler {
+ Line 3490  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 3117  sub dump_course_id_handler {
+ Line 3509  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 3193  sub put_id_handler {
+ Line 3619  sub put_id_handler {
  	    my ($key,$value)=split(/=/,$pair);
  	    $hashref->{$key}=$value;
  	}
- 	if (untie(%$hashref)) {
+ 	if (&untie_domain_hash($hashref)) {
  	    &Reply($client, "ok\n", $userinput);
  	} else {
  	    &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
- Line 3206  sub put_id_handler {
+ Line 3632  sub put_id_handler {
      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
- Line 3242  sub get_id_handler {
+ Line 3668  sub get_id_handler {
  	for (my $i=0;$i<=$#queries;$i++) {
  	    $qresult.="$hashref->{$queries[$i]}&";
  	}
- 	if (untie(%$hashref)) {
+ 	if (&untie_domain_hash($hashref)) {
  	    $qresult=~s/\&$//;
  	    &Reply($client, "$qresult\n", $userinput);
  	} else {
- Line 3256  sub get_id_handler {
+ Line 3682  sub get_id_handler {
      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);
- register_handler("idget", \&get_id_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.
- Line 3300  sub tmp_put_handler {
+ Line 3977  sub tmp_put_handler {
  }
  &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.
  #
- Line 3312  sub tmp_put_handler {
+ Line 3990  sub tmp_put_handler {
  #    1         - Inidcating processing can continue.
  # Side effects:
  #   A reply is sent to the client.
  #
  sub tmp_get_handler {
      my ($cmd, $id, $client) = @_;
- Line 3335  sub tmp_get_handler {
+ Line 4012  sub tmp_get_handler {
      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.
- Line 3368  sub tmp_del_handler {
+ Line 4046  sub tmp_del_handler {
  }
  &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
- Line 3406  sub set_announce_handler {
+ Line 4085  sub set_announce_handler {
      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
- Line 3430  sub get_version_handler {
+ Line 4110  sub get_version_handler {
      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
- Line 3482  sub exit_handler {
+ Line 4163  sub exit_handler {
      return 0;
  }
- &register_handler("exit", \&exit_handler, 0,,1);
+ &register_handler("exit", \&exit_handler, 0,1,1);
- &register_handler("init", \&exit_handler, 0,,1);
+ &register_handler("init", \&exit_handler, 0,1,1);
- &register_handler("quit", \&exit_handler, 0,,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;
+     eval {
+ 	local($SIG{__DIE__})='DEFAULT';
+ 	$outcome = &localenroll::photo_permission($cdom,\$perm_reqd,
+ 						  \$conditions);
+     };
+     if (!$@) {
+ 	&Reply($client, &escape($outcome.':'.$perm_reqd.':'. $conditions)."\n",
+ 	       $userinput);
+     } else {
+ 	&Failure($client,"unknown_cmd\n",$userinput);
+     }
+     return 1;
+ }
+ &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);
+     return 1;
+ }
+ &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);
+     eval {
+ 	local($SIG{__DIE__})='DEFAULT';
+ 	($update,$comment)    = &localenroll::manager_photo_update($cdom);
+     };
+     if (!$@) {
+ 	&Reply($client,&escape($update).':'.&escape($comment)."\n",$userinput);
+     } else {
+ 	&Failure($client,"unknown_cmd\n",$userinput);
+     }
+     return 1;
+ }
+ &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') {
+ 	eval {
+ 	    local($SIG{__DIE__})='DEFAULT';
+ 	    $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 3529  sub process_request {
+ Line 4594  sub process_request {
                                  # fix all the userinput -> user_input.
      my $wasenc    = 0;		# True if request was encrypted.
  # ------------------------------------------------------------ See if encrypted
+     # for command
+     # sethost:<server>
+     # <command>:<args>
+     #   we just send it to the processor
+     # for
+     # sethost:<server>:<command>:<args>
+     #  we do the implict set host and then do the command
+     if ($userinput =~ /^sethost:/) {
+ 	(my $cmd,my $newid,$userinput) = split(':',$userinput,3);
+ 	if (defined($userinput)) {
+ 	    &sethost("$cmd:$newid");
+ 	} else {
+ 	    $userinput = "$cmd:$newid";
+ 	}
+     }
      if ($userinput =~ /^enc/) {
  	$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 3603  sub process_request {
+ Line 4684  sub process_request {
      }
- #------------------- Commands not yet in spearate handlers. --------------
+     print $client "unknown_cmd\n";
- #------------------------------- is auto-enrollment enabled?
-     if ($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 3970  sub ReadHostTable {
+ Line 4945  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 4113  sub Reply {
+ Line 5102  sub Reply {
      Debug("Request was $request  Reply was $reply");
      $Transactions++;
  }
- Line 4157  sub logstatus {
+ Line 5144  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 4228  sub reconlonc {
+ Line 5215  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 4249  sub reply {
+ Line 5236  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 4276  sub sub_sql_reply {
+ Line 5263  sub sub_sql_reply {
                                        Type    => SOCK_STREAM,
                                        Timeout => 10)
         or return "con_lost";
-     print $sclient "$cmd\n";
+     print $sclient "$cmd:$currentdomainid\n";
      my $answer=<$sclient>;
      chomp($answer);
      if (!$answer) { $answer="con_lost"; }
- Line 4342  $SIG{USR2} = \&UpdateHosts;
+ Line 5329  $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 4388  sub make_new_child {
+ Line 5377  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 4419  sub make_new_child {
+ Line 5406  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 4429  sub make_new_child {
+ Line 5418  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 4548  sub make_new_child {
+ Line 5542  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 4584  sub make_new_child {
+ Line 5578  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;
+     if (defined($hashref)) {
+ 	$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 4597  sub make_new_child {
+ Line 5621  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 4622  sub manage_permissions
+ Line 5647  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 4702  sub get_auth_type
+ Line 5722  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 4740  sub validate_user {
+ Line 5755  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 4804  sub validate_user {
+ Line 5820  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 4828  sub validate_user {
+ Line 5844  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 4856  sub addline {
+ Line 5876  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 4897  sub chat_add {
+ Line 5917  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 5000  sub thisversion {
+ Line 6021  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 5044  sub subscribe {
+ Line 6065  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 5051  sub make_passwd_file {
+ Line 6101  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 5060  sub make_passwd_file {
+ Line 6114  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 5091  sub make_passwd_file {
+ Line 6153  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 5118  sub make_passwd_file {
+ Line 6194  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);
+     # ignore sethost if we are already correct
+     if ($hostid eq $currenthostid) {
+ 	return 'ok';
+     }
      if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; }
      if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) {
  	$currenthostid  =$hostid;

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.247
changed lines
	Added in v.1.323