loncom/lond - diff

Return to lond CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.372 and 1.401

version 1.372, 2007/04/04 00:49:13	version 1.401, 2008/05/29 05:44:48
Line 33 use strict;	Line 33 use strict;
use lib '/home/httpd/lib/perl/';	use lib '/home/httpd/lib/perl/';
use LONCAPA;	use LONCAPA;
use LONCAPA::Configuration;	use LONCAPA::Configuration;
use Apache::lonnet;

use IO::Socket;	use IO::Socket;
use IO::File;	use IO::File;
Line 53 use File::Find;	Line 52 use File::Find;
use LONCAPA::lonlocal;	use LONCAPA::lonlocal;
use LONCAPA::lonssl;	use LONCAPA::lonssl;
use Fcntl qw(:flock);	use Fcntl qw(:flock);
	use Apache::lonnet;

my $DEBUG = 0; # Non zero to enable debug log entries.	my $DEBUG = 0; # Non zero to enable debug log entries.

Line 69 my $clientip; # IP address of client.	Line 69 my $clientip; # IP address of client.
my $clientname; # LonCAPA name of client.	my $clientname; # LonCAPA name of client.

my $server;	my $server;
my $thisserver; # DNS of us.

my $keymode;	my $keymode;

Line 136 my @adderrors = ("ok",	Line 135 my @adderrors = ("ok",
"lcuseradd Unable to make www member of users's group",	"lcuseradd Unable to make www member of users's group",
"lcuseradd Unable to su to root",	"lcuseradd Unable to su to root",
"lcuseradd Unable to set password",	"lcuseradd Unable to set password",
"lcuseradd Usrname has invalid characters",	"lcuseradd Username has invalid characters",
"lcuseradd Password has an invalid character",	"lcuseradd Password has an invalid character",
"lcuseradd User already exists",	"lcuseradd User already exists",
"lcuseradd Could not add user.",	"lcuseradd Could not add user.",
Line 172 sub ResetStatistics {	Line 171 sub ResetStatistics {
# $Socket - Socket open on client.	# $Socket - Socket open on client.
# $initcmd - The full text of the init command.	# $initcmd - The full text of the init command.
#	#
# Implicit inputs:
# $thisserver - Our DNS name.
#
# Returns:	# Returns:
# IDEA session key on success.	# IDEA session key on success.
# undef on failure.	# undef on failure.
#	#
sub LocalConnection {	sub LocalConnection {
my ($Socket, $initcmd) = @_;	my ($Socket, $initcmd) = @_;
Debug("Attempting local connection: $initcmd client: $clientip me: $thisserver");	Debug("Attempting local connection: $initcmd client: $clientip");
if($clientip ne "127.0.0.1") {	if($clientip ne "127.0.0.1") {
&logthis('<font color="red"> LocalConnection rejecting non local: '	&logthis('<font color="red"> LocalConnection rejecting non local: '
."$clientip ne $thisserver </font>");	."$clientip ne 127.0.0.1 </font>");
close $Socket;	close $Socket;
return undef;	return undef;
} else {	} else {
Line 1000 sub ping_handler {	Line 996 sub ping_handler {
my ($cmd, $tail, $client) = @_;	my ($cmd, $tail, $client) = @_;
Debug("$cmd $tail $client .. $currenthostid:");	Debug("$cmd $tail $client .. $currenthostid:");

Reply( $client,"$currenthostid\n","$cmd:$tail");	Reply( $client,\$currenthostid,"$cmd:$tail");

return 1;	return 1;
}	}
Line 1070 sub establish_key_handler {	Line 1066 sub establish_key_handler {
$key=substr($key,0,32);	$key=substr($key,0,32);
my $cipherkey=pack("H32",$key);	my $cipherkey=pack("H32",$key);
$cipher=new IDEA $cipherkey;	$cipher=new IDEA $cipherkey;
&Reply($replyfd, "$buildkey\n", "$cmd:$tail");	&Reply($replyfd, \$buildkey, "$cmd:$tail");

return 1;	return 1;

Line 1107 sub load_handler {	Line 1103 sub load_handler {

my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'};	my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'};

&Reply( $replyfd, "$loadpercent\n", "$cmd:$tail");	&Reply( $replyfd, \$loadpercent, "$cmd:$tail");

return 1;	return 1;
}	}
Line 1137 sub user_load_handler {	Line 1133 sub user_load_handler {
my ($cmd, $tail, $replyfd) = @_;	my ($cmd, $tail, $replyfd) = @_;

my $userloadpercent=&Apache::lonnet::userload();	my $userloadpercent=&Apache::lonnet::userload();
&Reply($replyfd, "$userloadpercent\n", "$cmd:$tail");	&Reply($replyfd, \$userloadpercent, "$cmd:$tail");

return 1;	return 1;
}	}
Line 1180 sub user_authorization_type {	Line 1176 sub user_authorization_type {
} else {	} else {
$type .= ':';	$type .= ':';
}	}
&Reply( $replyfd, "$type\n", $userinput);	&Reply( $replyfd, \$type, $userinput);
}	}

return 1;	return 1;
Line 1216 sub push_file_handler {	Line 1212 sub push_file_handler {
# process making the request.	# process making the request.

my $reply = &PushFile($userinput);	my $reply = &PushFile($userinput);
&Reply($client, "$reply\n", $userinput);	&Reply($client, \$reply, $userinput);

} else {	} else {
&Failure( $client, "refused\n", $userinput);	&Failure( $client, "refused\n", $userinput);
Line 1225 sub push_file_handler {	Line 1221 sub push_file_handler {
}	}
&register_handler("pushfile", \&push_file_handler, 1, 0, 1);	&register_handler("pushfile", \&push_file_handler, 1, 0, 1);

	# The du_handler routine should be considered obsolete and is retained
	# for communication with legacy servers. Please see the du2_handler.
#	#
# du - list the disk usuage of a directory recursively.	# du - list the disk usage of a directory recursively.
#	#
# note: stolen code from the ls file handler	# note: stolen code from the ls file handler
# under construction by Rick Banghart	# under construction by Rick Banghart
Line 1268 sub du_handler {	Line 1266 sub du_handler {
chdir($ududir);	chdir($ududir);
find($code,$ududir);	find($code,$ududir);
$total_size=int($total_size/1024);	$total_size=int($total_size/1024);
&Reply($client,"$total_size\n","$cmd:$ududir");	&Reply($client,\$total_size,"$cmd:$ududir");
} else {	} else {
&Failure($client, "bad_directory:$ududir\n","$cmd:$ududir");	&Failure($client, "bad_directory:$ududir\n","$cmd:$ududir");
}	}
Line 1276 sub du_handler {	Line 1274 sub du_handler {
}	}
&register_handler("du", \&du_handler, 0, 1, 0);	&register_handler("du", \&du_handler, 0, 1, 0);

	# Please also see the du_handler, which is obsoleted by du2.
	# du2_handler differs from du_handler in that required path to directory
	# provided by &propath() is prepended in the handler instead of on the
	# client side.
#	#
# The ls_handler routine should be considered obosolete and is retained	# du2 - list the disk usage of a directory recursively.
# for communication with legacy servers. Please see the ls2_handler.	#
	# Parameters:
	# $cmd - The command that dispatched us (du).
	# $tail - The tail of the request that invoked us.
	# $tail is a : separated list of the following:
	# - $ududir - directory path to list (before prepending)
	# - $getpropath = 1 if &propath() should prepend
	# - $uname - username to use for &propath or user dir
	# - $udom - domain to use for &propath or user dir
	# All are escaped.
	# $client - Socket open on the client.
	# Returns:
	# 1 - indicating that the daemon should not disconnect.
	# Side Effects:
	# The reply is written to $client.
	#

	sub du2_handler {
	my ($cmd, $tail, $client) = @_;
	my ($ududir,$getpropath,$uname,$udom) = map { &unescape($_) } (split(/:/, $tail));
	my $userinput = "$cmd:$tail";
	if (($ududir=~/\.\./) \|\| (($ududir!~m\|^/home/httpd/\|) && (!$getpropath))) {
	&Failure($client,"refused\n","$cmd:$tail");
	return 1;
	}
	if ($getpropath) {
	if (($uname =~ /^$LONCAPA::match_name$/) && ($udom =~ /^$LONCAPA::match_domain$/)) {
	$ududir = &propath($udom,$uname).'/'.$ududir;
	} else {
	&Failure($client,"refused\n","$cmd:$tail");
	return 1;
	}
	}
	# Since $ududir could have some nasties in it,
	# we will require that ududir is a valid
	# directory. Just in case someone tries to
	# slip us a line like .;(cd /home/httpd rm -rf*)
	# etc.
	#
	if (-d $ududir) {
	my $total_size=0;
	my $code=sub {
	if ($_=~/\.\d+\./) { return;}
	if ($_=~/\.meta$/) { return;}
	if (-d $_) { return;}
	$total_size+=(stat($_))[7];
	};
	chdir($ududir);
	find($code,$ududir);
	$total_size=int($total_size/1024);
	&Reply($client,\$total_size,"$cmd:$ududir");
	} else {
	&Failure($client, "bad_directory:$ududir\n","$cmd:$tail");
	}
	return 1;
	}
	&register_handler("du2", \&du2_handler, 0, 1, 0);

	#
	# The ls_handler routine should be considered obsolete and is retained
	# for communication with legacy servers. Please see the ls3_handler.
#	#
# ls - list the contents of a directory. For each file in the	# ls - list the contents of a directory. For each file in the
# selected directory the filename followed by the full output of	# selected directory the filename followed by the full output of
Line 1337 sub ls_handler {	Line 1399 sub ls_handler {
$ulsout='no_such_dir';	$ulsout='no_such_dir';
}	}
if ($ulsout eq '') { $ulsout='empty'; }	if ($ulsout eq '') { $ulsout='empty'; }
&Reply($client, "$ulsout\n", $userinput); # This supports debug logging.	&Reply($client, \$ulsout, $userinput); # This supports debug logging.

return 1;	return 1;

}	}
&register_handler("ls", \&ls_handler, 0, 1, 0);	&register_handler("ls", \&ls_handler, 0, 1, 0);

#	# The ls2_handler routine should be considered obsolete and is retained
# Please also see the ls_handler, which this routine obosolets.	# for communication with legacy servers. Please see the ls3_handler.
	# Please also see the ls_handler, which was itself obsoleted by ls2.
# ls2_handler differs from ls_handler in that it escapes its return	# ls2_handler differs from ls_handler in that it escapes its return
# values before concatenating them together with ':'s.	# values before concatenating them together with ':'s.
#	#
Line 1406 sub ls2_handler {	Line 1469 sub ls2_handler {
$ulsout='no_such_dir';	$ulsout='no_such_dir';
}	}
if ($ulsout eq '') { $ulsout='empty'; }	if ($ulsout eq '') { $ulsout='empty'; }
&Reply($client, "$ulsout\n", $userinput); # This supports debug logging.	&Reply($client, \$ulsout, $userinput); # This supports debug logging.
return 1;	return 1;
}	}
&register_handler("ls2", \&ls2_handler, 0, 1, 0);	&register_handler("ls2", \&ls2_handler, 0, 1, 0);
	#
	# ls3 - 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).
	# $tail - The tail of the request that invoked us.
	# $tail is a : separated list of the following:
	# - $ulsdir - directory path to list (before prepending)
	# - $getpropath = 1 if &propath() should prepend
	# - $getuserdir = 1 if path to user dir in lonUsers should
	# prepend
	# - $alternate_root - path to prepend
	# - $uname - username to use for &propath or user dir
	# - $udom - domain to use for &propath or user dir
	# All of these except $getpropath and &getuserdir are escaped.
	# 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 ls3_handler {
	my ($cmd, $tail, $client) = @_;
	my $userinput = "$cmd:$tail";
	my ($ulsdir,$getpropath,$getuserdir,$alternate_root,$uname,$udom) =
	split(/:/,$tail);
	if (defined($ulsdir)) {
	$ulsdir = &unescape($ulsdir);
	}
	if (defined($alternate_root)) {
	$alternate_root = &unescape($alternate_root);
	}
	if (defined($uname)) {
	$uname = &unescape($uname);
	}
	if (defined($udom)) {
	$udom = &unescape($udom);
	}

	my $dir_root = $perlvar{'lonDocRoot'};
	if ($getpropath) {
	if (($uname =~ /^$LONCAPA::match_name$/) && ($udom =~ /^$LONCAPA::match_domain$/)) {
	$dir_root = &propath($udom,$uname);
	$dir_root =~ s/\/$//;
	} else {
	&Failure($client,"refused\n","$cmd:$tail");
	return 1;
	}
	} elsif ($getuserdir) {
	if (($uname =~ /^$LONCAPA::match_name$/) && ($udom =~ /^$LONCAPA::match_domain$/)) {
	my $subdir=$uname.'__';
	$subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
	$dir_root = $Apache::lonnet::perlvar{'lonUsersDir'}
	."/$udom/$subdir/$uname";
	} else {
	&Failure($client,"refused\n","$cmd:$tail");
	return 1;
	}
	} elsif ($alternate_root ne '') {
	$dir_root = $alternate_root;
	}
	if ($dir_root ne '') {
	if ($ulsdir =~ /^\//) {
	$ulsdir = $dir_root.$ulsdir;
	} else {
	$ulsdir = $dir_root.'/'.$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, $userinput); # This supports debug logging.
	return 1;
	}
	&register_handler("ls3", \&ls3_handler, 0, 1, 0);

# Process a reinit request. Reinit requests that either	# Process a reinit request. Reinit requests that either
# lonc or lond be reinitialized so that an updated	# lonc or lond be reinitialized so that an updated
Line 1434 sub reinit_process_handler {	Line 1610 sub reinit_process_handler {
if(&ValidManager($cert)) {	if(&ValidManager($cert)) {
chomp($userinput);	chomp($userinput);
my $reply = &ReinitProcess($userinput);	my $reply = &ReinitProcess($userinput);
&Reply( $client, "$reply\n", $userinput);	&Reply( $client, \$reply, $userinput);
} else {	} else {
&Failure( $client, "refused\n", $userinput);	&Failure( $client, "refused\n", $userinput);
}	}
Line 1518 sub authenticate_handler {	Line 1694 sub authenticate_handler {
# udom - User's domain.	# udom - User's domain.
# uname - Username.	# uname - Username.
# upass - User's password.	# upass - User's password.
	# checkdefauth - Pass to validate_user() to try authentication
	# with default auth type(s) if no user account.

my ($udom,$uname,$upass)=split(/:/,$tail);	my ($udom, $uname, $upass, $checkdefauth)=split(/:/,$tail);
&Debug(" Authenticate domain = $udom, user = $uname, password = $upass");	&Debug(" Authenticate domain = $udom, user = $uname, password = $upass, checkdefauth = $checkdefauth");
chomp($upass);	chomp($upass);
$upass=&unescape($upass);	$upass=&unescape($upass);

my $pwdcorrect = &validate_user($udom, $uname, $upass);	my $pwdcorrect = &validate_user($udom,$uname,$upass,$checkdefauth);
if($pwdcorrect) {	if($pwdcorrect) {
&Reply( $client, "authorized\n", $userinput);	&Reply( $client, "authorized\n", $userinput);
#	#
Line 1609 sub change_password_handler {	Line 1787 sub change_password_handler {
my $result = &change_unix_password($uname, $npass);	my $result = &change_unix_password($uname, $npass);
&logthis("Result of password change for $uname: ".	&logthis("Result of password change for $uname: ".
$result);	$result);
&Reply($client, "$result\n", $userinput);	&Reply($client, \$result, $userinput);
} else {	} else {
# this just means that the current password mode is not	# this just means that the current password mode is not
# one we know how to change (e.g the kerberos auth modes or	# one we know how to change (e.g the kerberos auth modes or
Line 1670 sub add_user_handler {	Line 1848 sub add_user_handler {
}	}
unless ($fperror) {	unless ($fperror) {
my $result=&make_passwd_file($uname, $umode,$npass, $passfilename);	my $result=&make_passwd_file($uname, $umode,$npass, $passfilename);
&Reply($client, $result, $userinput); #BUGBUG - could be fail	&Reply($client,\$result, $userinput); #BUGBUG - could be fail
} else {	} else {
&Failure($client, "$fperror\n", $userinput);	&Failure($client, \$fperror, $userinput);
}	}
}	}
umask($oldumask);	umask($oldumask);
Line 1739 sub change_authentication_handler {	Line 1917 sub change_authentication_handler {
my $result = &change_unix_password($uname, $npass);	my $result = &change_unix_password($uname, $npass);
&logthis("Result of password change for $uname: ".$result);	&logthis("Result of password change for $uname: ".$result);
if ($result eq "ok") {	if ($result eq "ok") {
&Reply($client, "$result\n")	&Reply($client, \$result);
} else {	} else {
&Failure($client, "$result\n");	&Failure($client, \$result);
}	}
} else {	} else {
my $result=&make_passwd_file($uname, $umode,$npass,$passfilename);	my $result=&make_passwd_file($uname, $umode,$npass,$passfilename);
Line 1760 sub change_authentication_handler {	Line 1938 sub change_authentication_handler {
&manage_permissions("/$udom/_au", $udom, $uname, "$umode:");	&manage_permissions("/$udom/_au", $udom, $uname, "$umode:");
}	}
}	}
&Reply($client, $result, $userinput);	&Reply($client, \$result, $userinput);
}	}


Line 2099 sub rename_user_file_handler {	Line 2277 sub rename_user_file_handler {
&register_handler("renameuserfile", \&rename_user_file_handler, 0,1,0);	&register_handler("renameuserfile", \&rename_user_file_handler, 0,1,0);

#	#
	# Checks if the specified user has an active session on the server
	# return ok if so, not_found if not
	#
	# Parameters:
	# cmd - The request keyword that dispatched to tus.
	# tail - The tail of the request (colon separated parameters).
	# client - Filehandle open on the client.
	# Return:
	# 1.
	sub user_has_session_handler {
	my ($cmd, $tail, $client) = @_;

	my ($udom, $uname) = map { &unescape($_) } (split(/:/, $tail));

	&logthis("Looking for $udom $uname");
	opendir(DIR,$perlvar{'lonIDsDir'});
	my $filename;
	while ($filename=readdir(DIR)) {
	last if ($filename=~/^\Q$uname\E_\d+_\Q$udom\E_/);
	}
	if ($filename) {
	&Reply($client, "ok\n", "$cmd:$tail");
	} else {
	&Failure($client, "not_found\n", "$cmd:$tail");
	}
	return 1;

	}
	&register_handler("userhassession", \&user_has_session_handler, 0,1,0);

	#
# Authenticate access to a user file by checking that the token the user's	# Authenticate access to a user file by checking that the token the user's
# passed also exists in their session file	# passed also exists in their session file
#	#
Line 2114 sub token_auth_user_file_handler {	Line 2323 sub token_auth_user_file_handler {
my ($fname, $session) = split(/:/, $tail);	my ($fname, $session) = split(/:/, $tail);

chomp($session);	chomp($session);
my $reply="non_auth\n";	my $reply="non_auth";
my $file = $perlvar{'lonIDsDir'}.'/'.$session.'.id';	my $file = $perlvar{'lonIDsDir'}.'/'.$session.'.id';
if (open(ENVIN,"$file")) {	if (open(ENVIN,"$file")) {
flock(ENVIN,LOCK_SH);	flock(ENVIN,LOCK_SH);
tie(my %disk_env,'GDBM_File',"$file",&GDBM_READER(),0640);	tie(my %disk_env,'GDBM_File',"$file",&GDBM_READER(),0640);
if (exists($disk_env{"userfile.$fname"})) {	if (exists($disk_env{"userfile.$fname"})) {
$reply="ok\n";	$reply="ok";
} else {	} else {
foreach my $envname (keys(%disk_env)) {	foreach my $envname (keys(%disk_env)) {
if ($envname=~ m\|^userfile\.\Q$fname\E\|) {	if ($envname=~ m\|^userfile\.\Q$fname\E\|) {
$reply="ok\n";	$reply="ok";
last;	last;
}	}
}	}
}	}
untie(%disk_env);	untie(%disk_env);
close(ENVIN);	close(ENVIN);
&Reply($client, $reply, "$cmd:$tail");	&Reply($client, \$reply, "$cmd:$tail");
} else {	} else {
&Failure($client, "invalid_token\n", "$cmd:$tail");	&Failure($client, "invalid_token\n", "$cmd:$tail");
}	}
Line 2191 sub subscribe_handler {	Line 2400 sub subscribe_handler {
&register_handler("sub", \&subscribe_handler, 0, 1, 0);	&register_handler("sub", \&subscribe_handler, 0, 1, 0);

#	#
# Determine the version of a resource (?) Or is it return	# Determine the latest version of a resource (it looks for the highest
# the top version of the resource? Not yet clear from the	# past version and then returns that +1)
# code in currentversion.
#	#
# Parameters:	# Parameters:
# $cmd - The command that got us here.	# $cmd - The command that got us here.
# $tail - Tail of the command (remaining parameters).	# $tail - Tail of the command (remaining parameters).
	# (Should consist of an absolute path to a file)
# $client - File descriptor connected to client.	# $client - File descriptor connected to client.
# Returns	# Returns
# 0 - Requested to exit, caller should shut down.	# 0 - Requested to exit, caller should shut down.
Line 2555 sub get_profile_entry {	Line 2764 sub get_profile_entry {
my ($udom,$uname,$namespace,$what) = split(/:/,$tail);	my ($udom,$uname,$namespace,$what) = split(/:/,$tail);
chomp($what);	chomp($what);


my $replystring = read_profile($udom, $uname, $namespace, $what);	my $replystring = read_profile($udom, $uname, $namespace, $what);
my ($first) = split(/:/,$replystring);	my ($first) = split(/:/,$replystring);
if($first ne "error") {	if($first ne "error") {
&Reply($client, "$replystring\n", $userinput);	&Reply($client, \$replystring, $userinput);
} else {	} else {
&Failure($client, $replystring." while attempting get\n", $userinput);	&Failure($client, $replystring." while attempting get\n", $userinput);
}	}
Line 2698 sub get_profile_keys {	Line 2908 sub get_profile_keys {
}	}
if (&untie_user_hash($hashref)) {	if (&untie_user_hash($hashref)) {
$qresult=~s/\&$//;	$qresult=~s/\&$//;
&Reply($client, "$qresult\n", $userinput);	&Reply($client, \$qresult, $userinput);
} else {	} else {
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".	&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
"while attempting keys\n", $userinput);	"while attempting keys\n", $userinput);
Line 2768 sub dump_profile_database {	Line 2978 sub dump_profile_database {
}	}
}	}
chop($qresult);	chop($qresult);
&Reply($client , "$qresult\n", $userinput);	&Reply($client , \$qresult, $userinput);
} else {	} else {
&Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".	&Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
"while attempting currentdump\n", $userinput);	"while attempting currentdump\n", $userinput);
Line 2851 sub dump_with_regexp {	Line 3061 sub dump_with_regexp {
}	}
if (&untie_user_hash($hashref)) {	if (&untie_user_hash($hashref)) {
chop($qresult);	chop($qresult);
&Reply($client, "$qresult\n", $userinput);	&Reply($client, \$qresult, $userinput);
} else {	} else {
&Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".	&Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
"while attempting dump\n", $userinput);	"while attempting dump\n", $userinput);
Line 3059 sub restore_handler {	Line 3269 sub restore_handler {
}	}
if (&untie_user_hash($hashref)) {	if (&untie_user_hash($hashref)) {
$qresult=~s/\&$//;	$qresult=~s/\&$//;
&Reply( $client, "$qresult\n", $userinput);	&Reply( $client, \$qresult, $userinput);
} else {	} else {
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".	&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
"while attempting restore\n", $userinput);	"while attempting restore\n", $userinput);
Line 3140 sub retrieve_chat_handler {	Line 3350 sub retrieve_chat_handler {
$reply.=&escape($_).':';	$reply.=&escape($_).':';
}	}
$reply=~s/\:$//;	$reply=~s/\:$//;
&Reply($client, $reply."\n", $userinput);	&Reply($client, \$reply, $userinput);


return 1;	return 1;
Line 3277 sub put_course_id_handler {	Line 3487 sub put_course_id_handler {
foreach my $pair (@pairs) {	foreach my $pair (@pairs) {
my ($key,$courseinfo) = split(/=/,$pair,2);	my ($key,$courseinfo) = split(/=/,$pair,2);
$courseinfo =~ s/=/:/g;	$courseinfo =~ s/=/:/g;
	if (defined($hashref->{$key})) {
	my $value = &Apache::lonnet::thaw_unescape($hashref->{$key});
	if (ref($value) eq 'HASH') {
	my @items = ('description','inst_code','owner','type');
	my @new_items = split(/:/,$courseinfo,-1);
	my %storehash;
	for (my $i=0; $i<@new_items; $i++) {
	$storehash{$items[$i]} = &unescape($new_items[$i]);
	}
	$hashref->{$key} =
	&Apache::lonnet::freeze_escape(\%storehash);
	my $unesc_key = &unescape($key);
	$hashref->{&escape('lasttime:'.$unesc_key)} = $now;
	next;
	}
	}
my @current_items = split(/:/,$hashref->{$key},-1);	my @current_items = split(/:/,$hashref->{$key},-1);
shift(@current_items); # remove description	shift(@current_items); # remove description
pop(@current_items); # remove last access	pop(@current_items); # remove last access
Line 3293 sub put_course_id_handler {	Line 3519 sub put_course_id_handler {
}	}
}	}
}	}
$hashref->{$key}=$courseinfo.':'.$now;	$hashref->{$key}=$courseinfo.':'.$now;
}	}
if (&untie_domain_hash($hashref)) {	if (&untie_domain_hash($hashref)) {
&Reply( $client, "ok\n", $userinput);	&Reply( $client, "ok\n", $userinput);
Line 3307 sub put_course_id_handler {	Line 3533 sub put_course_id_handler {
." tie(GDBM) Failed ".	." tie(GDBM) Failed ".
"while attempting courseidput\n", $userinput);	"while attempting courseidput\n", $userinput);
}	}


return 1;	return 1;
}	}
&register_handler("courseidput", \&put_course_id_handler, 0, 1, 0);	&register_handler("courseidput", \&put_course_id_handler, 0, 1, 0);

	sub put_course_id_hash_handler {
	my ($cmd, $tail, $client) = @_;
	my $userinput = "$cmd:$tail";
	my ($udom,$mode,$what) = split(/:/, $tail,3);
	chomp($what);
	my $now=time;
	my @pairs=split(/\&/,$what);
	my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());
	if ($hashref) {
	foreach my $pair (@pairs) {
	my ($key,$value)=split(/=/,$pair);
	my $unesc_key = &unescape($key);
	if ($mode ne 'timeonly') {
	if (!defined($hashref->{&escape('lasttime:'.$unesc_key)})) {
	my $curritems = &Apache::lonnet::thaw_unescape($key);
	if (ref($curritems) ne 'HASH') {
	my @current_items = split(/:/,$hashref->{$key},-1);
	my $lasttime = pop(@current_items);
	$hashref->{&escape('lasttime:'.$unesc_key)} = $lasttime;
	} else {
	$hashref->{&escape('lasttime:'.$unesc_key)} = '';
	}
	}
	$hashref->{$key} = $value;
	}
	if ($mode ne 'notime') {
	$hashref->{&escape('lasttime:'.$unesc_key)} = $now;
	}
	}
	if (&untie_domain_hash($hashref)) {
	&Reply($client, "ok\n", $userinput);
	} else {
	&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
	"while attempting courseidputhash\n", $userinput);
	}
	} else {
	&Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
	"while attempting courseidputhash\n", $userinput);
	}
	return 1;
	}
	&register_handler("courseidputhash", \&put_course_id_hash_handler, 0, 1, 0);

# Retrieves the value of a course id resource keyword pattern	# Retrieves the value of a course id resource keyword pattern
# defined since a starting date. Both the starting date and the	# defined since a starting date. Both the starting date and the
# keyword pattern are optional. If the starting date is not supplied it	# keyword pattern are optional. If the starting date is not supplied it
Line 3339 sub put_course_id_handler {	Line 3607 sub put_course_id_handler {
# owner matches the supplied username and/or domain	# owner matches the supplied username and/or domain
# will be returned. Pre-2.2.0 legacy entries from	# will be returned. Pre-2.2.0 legacy entries from
# nohist_courseiddump will only contain usernames.	# nohist_courseiddump will only contain usernames.
	# type - optional parameter for selection
	# regexp_ok - if true, allow the supplied institutional code
	# filter to behave as a regular expression.
	# rtn_as_hash - whether to return the information available for
	# each matched item as a frozen hash of all
	# key, value pairs in the item's hash, or as a
	# colon-separated list of (in order) description,
	# institutional code, and course owner.
	#
# $client - The socket open on the client.	# $client - The socket open on the client.
# Returns:	# Returns:
# 1 - Continue processing.	# 1 - Continue processing.
Line 3346 sub put_course_id_handler {	Line 3623 sub put_course_id_handler {
# a reply is written to $client.	# a reply is written to $client.
sub dump_course_id_handler {	sub dump_course_id_handler {
my ($cmd, $tail, $client) = @_;	my ($cmd, $tail, $client) = @_;

my $userinput = "$cmd:$tail";	my $userinput = "$cmd:$tail";

my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter,	my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter,
$typefilter,$regexp_ok) =split(/:/,$tail);	$typefilter,$regexp_ok,$rtn_as_hash,$selfenrollonly,$catfilter) =split(/:/,$tail);
	my $now = time;
if (defined($description)) {	if (defined($description)) {
$description=&unescape($description);	$description=&unescape($description);
} else {	} else {
Line 3390 sub dump_course_id_handler {	Line 3667 sub dump_course_id_handler {
if (defined($regexp_ok)) {	if (defined($regexp_ok)) {
$regexp_ok=&unescape($regexp_ok);	$regexp_ok=&unescape($regexp_ok);
}	}
	if (defined($catfilter)) {
unless (defined($since)) { $since=0; }	$catfilter=&unescape($catfilter);
	}
	my $unpack = 1;
	if ($description eq '.' && $instcodefilter eq '.' && $coursefilter eq '.' &&
	$typefilter eq '.') {
	$unpack = 0;
	}
	if (!defined($since)) { $since=0; }
my $qresult='';	my $qresult='';
my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());	my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());
if ($hashref) {	if ($hashref) {
while (my ($key,$value) = each(%$hashref)) {	while (my ($key,$value) = each(%$hashref)) {
my ($descr,$lasttime,$inst_code,$owner,$type);	my ($unesc_key,$lasttime_key,$lasttime,$is_hash,%val,
my @courseitems = split(/:/,$value);	%unesc_val,$selfenroll_end,$selfenroll_types);
$lasttime = pop(@courseitems);	$unesc_key = &unescape($key);
($descr,$inst_code,$owner,$type)=@courseitems;	if ($unesc_key =~ /^lasttime:/) {
if ($lasttime<$since) { next; }	next;
	} else {
	$lasttime_key = &escape('lasttime:'.$unesc_key);
	}
	if ($hashref->{$lasttime_key} ne '') {
	$lasttime = $hashref->{$lasttime_key};
	next if ($lasttime<$since);
	}
	my $items = &Apache::lonnet::thaw_unescape($value);
	if (ref($items) eq 'HASH') {
	$is_hash = 1;
	if ($unpack \|\| !$rtn_as_hash) {
	$unesc_val{'descr'} = $items->{'description'};
	$unesc_val{'inst_code'} = $items->{'inst_code'};
	$unesc_val{'owner'} = $items->{'owner'};
	$unesc_val{'type'} = $items->{'type'};
	$selfenroll_types = $items->{'selfenroll_types'};
	$selfenroll_end = $items->{'selfenroll_end_date'};
	if ($selfenrollonly) {
	next if (!$selfenroll_types);
	if (($selfenroll_end > 0) && ($selfenroll_end <= $now)) {
	next;
	}
	}
	if ($catfilter ne '') {
	next if ($items->{'category'} ne $catfilter);
	}
	}
	} else {
	next if ($catfilter ne '');
	next if ($selfenrollonly);
	$is_hash = 0;
	my @courseitems = split(/:/,$value);
	$lasttime = pop(@courseitems);
	next if ($lasttime<$since);
	($val{'descr'},$val{'inst_code'},$val{'owner'},$val{'type'}) = @courseitems;
	}
my $match = 1;	my $match = 1;
unless ($description eq '.') {	if ($description ne '.') {
my $unescapeDescr = &unescape($descr);	if (!$is_hash) {
unless (eval('$unescapeDescr=~/\Q$description\E/i')) {	$unesc_val{'descr'} = &unescape($val{'descr'});
	}
	if (eval{$unesc_val{'descr'} !~ /\Q$description\E/i}) {
$match = 0;	$match = 0;
}	}
}	}
unless ($instcodefilter eq '.' \|\| !defined($instcodefilter)) {	if ($instcodefilter ne '.') {
my $unescapeInstcode = &unescape($inst_code);	if (!$is_hash) {
	$unesc_val{'inst_code'} = &unescape($val{'inst_code'});
	}
if ($regexp_ok) {	if ($regexp_ok) {
unless (eval('$unescapeInstcode=~/$instcodefilter/')) {	if (eval{$unesc_val{'inst_code'} !~ /$instcodefilter/}) {
$match = 0;	$match = 0;
}	}
} else {	} else {
unless (eval('$unescapeInstcode=~/\Q$instcodefilter\E/i')) {	if (eval{$unesc_val{'inst_code'} !~ /\Q$instcodefilter\E/i}) {
$match = 0;	$match = 0;
}	}
}	}
}	}
unless ($ownerfilter eq '.' \|\| !defined($ownerfilter)) {	if ($ownerfilter ne '.') {
my $unescapeOwner = &unescape($owner);	if (!$is_hash) {
	$unesc_val{'owner'} = &unescape($val{'owner'});
	}
if (($ownerunamefilter ne '') && ($ownerdomfilter ne '')) {	if (($ownerunamefilter ne '') && ($ownerdomfilter ne '')) {
if ($unescapeOwner =~ /:/) {	if ($unesc_val{'owner'} =~ /:/) {
if (eval('$unescapeOwner !~	if (eval{$unesc_val{'owner'} !~
/\Q$ownerunamefilter\E:\Q$ownerdomfilter\E$/i')) {	/\Q$ownerunamefilter\E:\Q$ownerdomfilter\E$/i}) {
$match = 0;	$match = 0;
}	}
} else {	} else {
if (eval('$unescapeOwner!~/\Q$ownerunamefilter\E/i')) {	if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E/i}) {
$match = 0;	$match = 0;
}	}
}	}
} elsif ($ownerunamefilter ne '') {	} elsif ($ownerunamefilter ne '') {
if ($unescapeOwner =~ /:/) {	if ($unesc_val{'owner'} =~ /:/) {
if (eval('$unescapeOwner!~/\Q$ownerunamefilter\E:[^:]+$/i')) {	if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E:[^:]+$/i}) {
$match = 0;	$match = 0;
}	}
} else {	} else {
if (eval('$unescapeOwner!~/\Q$ownerunamefilter\E/i')) {	if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E/i}) {
$match = 0;	$match = 0;
}	}
}	}
} elsif ($ownerdomfilter ne '') {	} elsif ($ownerdomfilter ne '') {
if ($unescapeOwner =~ /:/) {	if ($unesc_val{'owner'} =~ /:/) {
if (eval('$unescapeOwner!~/^[^:]+:\Q$ownerdomfilter\E/')) {	if (eval{$unesc_val{'owner'} !~ /^[^:]+:\Q$ownerdomfilter\E/}) {
$match = 0;	$match = 0;
}	}
} else {	} else {
Line 3455 sub dump_course_id_handler {	Line 3781 sub dump_course_id_handler {
}	}
}	}
}	}
unless ($coursefilter eq '.' \|\| !defined($coursefilter)) {	if ($coursefilter ne '.') {
my $unescapeCourse = &unescape($key);	if (eval{$unesc_key !~ /^$udom(_)\Q$coursefilter\E$/}) {
unless (eval('$unescapeCourse=~/^$udom(_)\Q$coursefilter\E$/')) {
$match = 0;	$match = 0;
}	}
}	}
unless ($typefilter eq '.' \|\| !defined($typefilter)) {	if ($typefilter ne '.') {
my $unescapeType = &unescape($type);	if (!$is_hash) {
if ($type eq '') {	$unesc_val{'type'} = &unescape($val{'type'});
	}
	if ($unesc_val{'type'} eq '') {
if ($typefilter ne 'Course') {	if ($typefilter ne 'Course') {
$match = 0;	$match = 0;
}	}
} else {	} else {
unless (eval('$unescapeType=~/^\Q$typefilter\E$/')) {	if (eval{$unesc_val{'type'} !~ /^\Q$typefilter\E$/}) {
$match = 0;	$match = 0;
}	}
}	}
}	}
if ($match == 1) {	if ($match == 1) {
$qresult.=$key.'='.$descr.':'.$inst_code.':'.$owner.'&';	if ($rtn_as_hash) {
	if ($is_hash) {
	$qresult.=$key.'='.$value.'&';
	} else {
	my %rtnhash = ( 'description' => &unescape($val{'descr'}),
	'inst_code' => &unescape($val{'inst_code'}),
	'owner' => &unescape($val{'owner'}),
	'type' => &unescape($val{'type'}),
	);
	my $items = &Apache::lonnet::freeze_escape(\%rtnhash);
	$qresult.=$key.'='.$items.'&';
	}
	} else {
	if ($is_hash) {
	$qresult .= $key.'='.&escape($unesc_val{'descr'}).':'.
	&escape($unesc_val{'inst_code'}).':'.
	&escape($unesc_val{'owner'}).'&';
	} else {
	$qresult .= $key.'='.$val{'descr'}.':'.$val{'inst_code'}.
	':'.$val{'owner'}.'&';
	}
	}
}	}
}	}
if (&untie_domain_hash($hashref)) {	if (&untie_domain_hash($hashref)) {
chop($qresult);	chop($qresult);
&Reply($client, "$qresult\n", $userinput);	&Reply($client, \$qresult, $userinput);
} else {	} else {
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".	&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
"while attempting courseiddump\n", $userinput);	"while attempting courseiddump\n", $userinput);
Line 3488 sub dump_course_id_handler {	Line 3836 sub dump_course_id_handler {
&Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".	&Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
"while attempting courseiddump\n", $userinput);	"while attempting courseiddump\n", $userinput);
}	}


return 1;	return 1;
}	}
&register_handler("courseiddump", \&dump_course_id_handler, 0, 1, 0);	&register_handler("courseiddump", \&dump_course_id_handler, 0, 1, 0);
Line 3572 sub get_domain_handler {	Line 3918 sub get_domain_handler {
}	}
if (&untie_domain_hash($hashref)) {	if (&untie_domain_hash($hashref)) {
$qresult=~s/\&$//;	$qresult=~s/\&$//;
&Reply($client, "$qresult\n", $userinput);	&Reply($client, \$qresult, $userinput);
} else {	} else {
&Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".	&Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
"while attempting getdom\n",$userinput);	"while attempting getdom\n",$userinput);
Line 3670 sub get_id_handler {	Line 4016 sub get_id_handler {
}	}
if (&untie_domain_hash($hashref)) {	if (&untie_domain_hash($hashref)) {
$qresult=~s/\&$//;	$qresult=~s/\&$//;
&Reply($client, "$qresult\n", $userinput);	&Reply($client, \$qresult, $userinput);
} else {	} else {
&Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".	&Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
"while attempting idget\n",$userinput);	"while attempting idget\n",$userinput);
Line 3794 sub dump_dcmail_handler {	Line 4140 sub dump_dcmail_handler {
}	}
if (&untie_domain_hash($hashref)) {	if (&untie_domain_hash($hashref)) {
chop($qresult);	chop($qresult);
&Reply($client, "$qresult\n", $userinput);	&Reply($client, \$qresult, $userinput);
} else {	} else {
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".	&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
"while attempting dcmaildump\n", $userinput);	"while attempting dcmaildump\n", $userinput);
Line 3912 sub dump_domainroles_handler {	Line 4258 sub dump_domainroles_handler {
}	}
}	}
unless (@roles < 1) {	unless (@roles < 1) {
unless (grep/^$trole$/,@roles) {	unless (grep/^\Q$trole\E$/,@roles) {
$match = 0;	$match = 0;
}	}
}	}
Line 3922 sub dump_domainroles_handler {	Line 4268 sub dump_domainroles_handler {
}	}
if (&untie_domain_hash($hashref)) {	if (&untie_domain_hash($hashref)) {
chop($qresult);	chop($qresult);
&Reply($client, "$qresult\n", $userinput);	&Reply($client, \$qresult, $userinput);
} else {	} else {
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".	&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
"while attempting domrolesdump\n", $userinput);	"while attempting domrolesdump\n", $userinput);
Line 3976 sub tmp_put_handler {	Line 4322 sub tmp_put_handler {
if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) {	if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) {
print $store $record;	print $store $record;
close $store;	close $store;
&Reply($client, "$id\n", $userinput);	&Reply($client, \$id, $userinput);
} else {	} else {
&Failure( $client, "error: ".($!+0)."IO::File->new Failed ".	&Failure( $client, "error: ".($!+0)."IO::File->new Failed ".
"while attempting tmpput\n", $userinput);	"while attempting tmpput\n", $userinput);
Line 4010 sub tmp_get_handler {	Line 4356 sub tmp_get_handler {
my $execdir=$perlvar{'lonDaemons'};	my $execdir=$perlvar{'lonDaemons'};
if ($store=IO::File->new("$execdir/tmp/$id.tmp")) {	if ($store=IO::File->new("$execdir/tmp/$id.tmp")) {
my $reply=<$store>;	my $reply=<$store>;
&Reply( $client, "$reply\n", $userinput);	&Reply( $client, \$reply, $userinput);
close $store;	close $store;
} else {	} else {
&Failure( $client, "error: ".($!+0)."IO::File->new Failed ".	&Failure( $client, "error: ".($!+0)."IO::File->new Failed ".
Line 4194 sub enrollment_enabled_handler {	Line 4540 sub enrollment_enabled_handler {
my ($cdom) = split(/:/, $tail, 2); # Domain we're asking about.	my ($cdom) = split(/:/, $tail, 2); # Domain we're asking about.

my $outcome = &localenroll::run($cdom);	my $outcome = &localenroll::run($cdom);
&Reply($client, "$outcome\n", $userinput);	&Reply($client, \$outcome, $userinput);

return 1;	return 1;
}	}
Line 4221 sub get_sections_handler {	Line 4567 sub get_sections_handler {
my @secs = &localenroll::get_sections($coursecode,$cdom);	my @secs = &localenroll::get_sections($coursecode,$cdom);
my $seclist = &escape(join(':',@secs));	my $seclist = &escape(join(':',@secs));

&Reply($client, "$seclist\n", $userinput);	&Reply($client, \$seclist, $userinput);


return 1;	return 1;
Line 4250 sub validate_course_owner_handler {	Line 4596 sub validate_course_owner_handler {

$owner = &unescape($owner);	$owner = &unescape($owner);
my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom);	my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom);
&Reply($client, "$outcome\n", $userinput);	&Reply($client, \$outcome, $userinput);



Line 4281 sub validate_course_section_handler {	Line 4627 sub validate_course_section_handler {
my ($inst_course_id, $cdom) = split(/:/, $tail);	my ($inst_course_id, $cdom) = split(/:/, $tail);

my $outcome=&localenroll::validate_courseID($inst_course_id,$cdom);	my $outcome=&localenroll::validate_courseID($inst_course_id,$cdom);
&Reply($client, "$outcome\n", $userinput);	&Reply($client, \$outcome, $userinput);


return 1;	return 1;
Line 4308 sub validate_course_section_handler {	Line 4654 sub validate_course_section_handler {
sub validate_class_access_handler {	sub validate_class_access_handler {
my ($cmd, $tail, $client) = @_;	my ($cmd, $tail, $client) = @_;
my $userinput = "$cmd:$tail";	my $userinput = "$cmd:$tail";
my ($inst_class,$courseowner,$cdom) = split(/:/, $tail);	my ($inst_class,$ownerlist,$cdom) = split(/:/, $tail);
$courseowner = &unescape($courseowner);	my $owners = &unescape($ownerlist);
my $outcome;	my $outcome;
eval {	eval {
local($SIG{__DIE__})='DEFAULT';	local($SIG{__DIE__})='DEFAULT';
$outcome=&localenroll::check_section($inst_class,$courseowner,$cdom);	$outcome=&localenroll::check_section($inst_class,$owners,$cdom);
};	};
&Reply($client,"$outcome\n", $userinput);	&Reply($client,\$outcome, $userinput);

return 1;	return 1;
}	}
Line 4476 sub get_institutional_defaults_handler {	Line 4822 sub get_institutional_defaults_handler {
$result.=&escape($key).'='.&escape($value).'&';	$result.=&escape($key).'='.&escape($value).'&';
}	}
$result .= 'code_order='.&escape(join('&',@code_order));	$result .= 'code_order='.&escape(join('&',@code_order));
&Reply($client,$result."\n",$userinput);	&Reply($client,\$result,$userinput);
} else {	} else {
&Reply($client,"error\n", $userinput);	&Reply($client,"error\n", $userinput);
}	}
Line 4487 sub get_institutional_defaults_handler {	Line 4833 sub get_institutional_defaults_handler {
&register_handler("autoinstcodedefaults",	&register_handler("autoinstcodedefaults",
\&get_institutional_defaults_handler,0,1,0);	\&get_institutional_defaults_handler,0,1,0);

	sub get_institutional_user_rules {
	my ($cmd, $tail, $client) = @_;
	my $userinput = "$cmd:$tail";
	my $dom = &unescape($tail);
	my (%rules_hash,@rules_order);
	my $outcome;
	eval {
	local($SIG{__DIE__})='DEFAULT';
	$outcome = &localenroll::username_rules($dom,\%rules_hash,\@rules_order);
	};
	if (!$@) {
	if ($outcome eq 'ok') {
	my $result;
	foreach my $key (keys(%rules_hash)) {
	$result .= &escape($key).'='.&Apache::lonnet::freeze_escape($rules_hash{$key}).'&';
	}
	$result =~ s/\&$//;
	$result .= ':';
	if (@rules_order > 0) {
	foreach my $item (@rules_order) {
	$result .= &escape($item).'&';
	}
	}
	$result =~ s/\&$//;
	&Reply($client,\$result,$userinput);
	} else {
	&Reply($client,"error\n", $userinput);
	}
	} else {
	&Failure($client,"unknown_cmd\n",$userinput);
	}
	}
	&register_handler("instuserrules",\&get_institutional_user_rules,0,1,0);

	sub get_institutional_id_rules {
	my ($cmd, $tail, $client) = @_;
	my $userinput = "$cmd:$tail";
	my $dom = &unescape($tail);
	my (%rules_hash,@rules_order);
	my $outcome;
	eval {
	local($SIG{__DIE__})='DEFAULT';
	$outcome = &localenroll::id_rules($dom,\%rules_hash,\@rules_order);
	};
	if (!$@) {
	if ($outcome eq 'ok') {
	my $result;
	foreach my $key (keys(%rules_hash)) {
	$result .= &escape($key).'='.&Apache::lonnet::freeze_escape($rules_hash{$key}).'&';
	}
	$result =~ s/\&$//;
	$result .= ':';
	if (@rules_order > 0) {
	foreach my $item (@rules_order) {
	$result .= &escape($item).'&';
	}
	}
	$result =~ s/\&$//;
	&Reply($client,\$result,$userinput);
	} else {
	&Reply($client,"error\n", $userinput);
	}
	} else {
	&Failure($client,"unknown_cmd\n",$userinput);
	}
	}
	&register_handler("instidrules",\&get_institutional_id_rules,0,1,0);

	sub get_institutional_selfcreate_rules {
	my ($cmd, $tail, $client) = @_;
	my $userinput = "$cmd:$tail";
	my $dom = &unescape($tail);
	my (%rules_hash,@rules_order);
	my $outcome;
	eval {
	local($SIG{__DIE__})='DEFAULT';
	$outcome = &localenroll::selfcreate_rules($dom,\%rules_hash,\@rules_order);
	};
	if (!$@) {
	if ($outcome eq 'ok') {
	my $result;
	foreach my $key (keys(%rules_hash)) {
	$result .= &escape($key).'='.&Apache::lonnet::freeze_escape($rules_hash{$key}).'&';
	}
	$result =~ s/\&$//;
	$result .= ':';
	if (@rules_order > 0) {
	foreach my $item (@rules_order) {
	$result .= &escape($item).'&';
	}
	}
	$result =~ s/\&$//;
	&Reply($client,\$result,$userinput);
	} else {
	&Reply($client,"error\n", $userinput);
	}
	} else {
	&Failure($client,"unknown_cmd\n",$userinput);
	}
	}
	&register_handler("instemailrules",\&get_institutional_selfcreate_rules,0,1,0);


	sub institutional_username_check {
	my ($cmd, $tail, $client) = @_;
	my $userinput = "$cmd:$tail";
	my %rulecheck;
	my $outcome;
	my ($udom,$uname,@rules) = split(/:/,$tail);
	$udom = &unescape($udom);
	$uname = &unescape($uname);
	@rules = map {&unescape($_);} (@rules);
	eval {
	local($SIG{__DIE__})='DEFAULT';
	$outcome = &localenroll::username_check($udom,$uname,\@rules,\%rulecheck);
	};
	if (!$@) {
	if ($outcome eq 'ok') {
	my $result='';
	foreach my $key (keys(%rulecheck)) {
	$result.=&escape($key).'='.&Apache::lonnet::freeze_escape($rulecheck{$key}).'&';
	}
	&Reply($client,\$result,$userinput);
	} else {
	&Reply($client,"error\n", $userinput);
	}
	} else {
	&Failure($client,"unknown_cmd\n",$userinput);
	}
	}
	&register_handler("instrulecheck",\&institutional_username_check,0,1,0);

	sub institutional_id_check {
	my ($cmd, $tail, $client) = @_;
	my $userinput = "$cmd:$tail";
	my %rulecheck;
	my $outcome;
	my ($udom,$id,@rules) = split(/:/,$tail);
	$udom = &unescape($udom);
	$id = &unescape($id);
	@rules = map {&unescape($_);} (@rules);
	eval {
	local($SIG{__DIE__})='DEFAULT';
	$outcome = &localenroll::id_check($udom,$id,\@rules,\%rulecheck);
	};
	if (!$@) {
	if ($outcome eq 'ok') {
	my $result='';
	foreach my $key (keys(%rulecheck)) {
	$result.=&escape($key).'='.&Apache::lonnet::freeze_escape($rulecheck{$key}).'&';
	}
	&Reply($client,\$result,$userinput);
	} else {
	&Reply($client,"error\n", $userinput);
	}
	} else {
	&Failure($client,"unknown_cmd\n",$userinput);
	}
	}
	&register_handler("instidrulecheck",\&institutional_id_check,0,1,0);

	sub institutional_selfcreate_check {
	my ($cmd, $tail, $client) = @_;
	my $userinput = "$cmd:$tail";
	my %rulecheck;
	my $outcome;
	my ($udom,$email,@rules) = split(/:/,$tail);
	$udom = &unescape($udom);
	$email = &unescape($email);
	@rules = map {&unescape($_);} (@rules);
	eval {
	local($SIG{__DIE__})='DEFAULT';
	$outcome = &localenroll::selfcreate_check($udom,$email,\@rules,\%rulecheck);
	};
	if (!$@) {
	if ($outcome eq 'ok') {
	my $result='';
	foreach my $key (keys(%rulecheck)) {
	$result.=&escape($key).'='.&Apache::lonnet::freeze_escape($rulecheck{$key}).'&';
	}
	&Reply($client,\$result,$userinput);
	} else {
	&Reply($client,"error\n", $userinput);
	}
	} else {
	&Failure($client,"unknown_cmd\n",$userinput);
	}
	}
	&register_handler("instselfcreatecheck",\&institutional_selfcreate_check,0,1,0);

# Get domain specific conditions for import of student photographs to a course	# Get domain specific conditions for import of student photographs to a course
#	#
Line 4639 sub inst_usertypes_handler {	Line 5174 sub inst_usertypes_handler {
}	}
$res=~s/\&$//;	$res=~s/\&$//;
}	}
&Reply($client, "$res\n", $userinput);	&Reply($client, \$res, $userinput);
return 1;	return 1;
}	}
&register_handler("inst_usertypes", \&inst_usertypes_handler, 0, 1, 0);	&register_handler("inst_usertypes", \&inst_usertypes_handler, 0, 1, 0);
Line 4907 sub catchexception {	Line 5442 sub catchexception {
$SIG{__DIE__}='DEFAULT';	$SIG{__DIE__}='DEFAULT';
&status("Catching exception");	&status("Catching exception");
&logthis("<font color='red'>CRITICAL: "	&logthis("<font color='red'>CRITICAL: "
."ABNORMAL EXIT. Child $$ for server $thisserver died through "	."ABNORMAL EXIT. Child $$ for server ".$perlvar{'lonHostID'}." died through "
."a crash with this error msg->[$error]</font>");	."a crash with this error msg->[$error]</font>");
&logthis('Famous last words: '.$status.' - '.$lastlog);	&logthis('Famous last words: '.$status.' - '.$lastlog);
if ($client) { print $client "error: $error\n"; }	if ($client) { print $client "error: $error\n"; }
Line 5052 sub UpdateHosts {	Line 5587 sub UpdateHosts {

foreach my $child (keys(%children)) {	foreach my $child (keys(%children)) {
my $childip = $children{$child};	my $childip = $children{$child};
if (!defined(&Apache::lonnet::get_hosts_from_ip($childip))) {	if ($childip ne '127.0.0.1'
	&& !defined(&Apache::lonnet::get_hosts_from_ip($childip))) {
logthis('<font color="blue"> UpdateHosts killing child '	logthis('<font color="blue"> UpdateHosts killing child '
." $child for ip $childip </font>");	." $child for ip $childip </font>");
kill('INT', $child);	kill('INT', $child);
Line 5137 sub Debug {	Line 5673 sub Debug {
#	#
sub Reply {	sub Reply {
my ($fd, $reply, $request) = @_;	my ($fd, $reply, $request) = @_;
print $fd $reply;	if (ref($reply)) {
Debug("Request was $request Reply was $reply");	print $fd $$reply;
	print $fd "\n";
	if ($DEBUG) { Debug("Request was $request Reply was $$reply"); }
	} else {
	print $fd $reply;
	if ($DEBUG) { Debug("Request was $request Reply was $reply"); }
	}
$Transactions++;	$Transactions++;
}	}

Line 5489 sub make_new_child {	Line 6030 sub make_new_child {
# ---------------- New known client connecting, could mean machine online again	# ---------------- New known client connecting, could mean machine online again
if (&Apache::lonnet::get_host_ip($currenthostid) ne $clientip	if (&Apache::lonnet::get_host_ip($currenthostid) ne $clientip
&& $clientip ne '127.0.0.1') {	&& $clientip ne '127.0.0.1') {
&Apache::lonnet::reconlonc();	&Apache::lonnet::reconlonc($clientname);
}	}
&logthis("<font color='green'>Established connection: $clientname</font>");	&logthis("<font color='green'>Established connection: $clientname</font>");
&status('Will listen to '.$clientname);	&status('Will listen to '.$clientname);
Line 5692 sub get_auth_type	Line 6233 sub get_auth_type
# 0 - The domain,user,password triplet is not a valid user.	# 0 - The domain,user,password triplet is not a valid user.
#	#
sub validate_user {	sub validate_user {
my ($domain, $user, $password) = @_;	my ($domain, $user, $password, $checkdefauth) = @_;


# Why negative ~pi you may well ask? Well this function is about	# Why negative ~pi you may well ask? Well this function is about
# authentication, and therefore very important to get right.	# authentication, and therefore very important to get right.
Line 5716 sub validate_user {	Line 6256 sub validate_user {

my $null = pack("C",0); # Used by kerberos auth types.	my $null = pack("C",0); # Used by kerberos auth types.

	if ($howpwd eq 'nouser') {
	if ($checkdefauth) {
	my %domdefaults = &Apache::lonnet::get_domain_defaults($domain);
	if ($domdefaults{'auth_def'} eq 'localauth') {
	$howpwd = $domdefaults{'auth_def'};
	$contentpwd = $domdefaults{'auth_arg_def'};
	} elsif ((($domdefaults{'auth_def'} eq 'krb4') \|\|
	($domdefaults{'auth_def'} eq 'krb5')) &&
	($domdefaults{'auth_arg_def'} ne '')) {
	$howpwd = $domdefaults{'auth_def'};
	$contentpwd = $domdefaults{'auth_arg_def'};
	}
	}
	}
if ($howpwd ne 'nouser') {	if ($howpwd ne 'nouser') {

if($howpwd eq "internal") { # Encrypted is in local password file.	if($howpwd eq "internal") { # Encrypted is in local password file.
$validated = (crypt($password, $contentpwd) eq $contentpwd);	$validated = (crypt($password, $contentpwd) eq $contentpwd);
}	}
Line 5768 sub validate_user {	Line 6321 sub validate_user {
my $credentials= &Authen::Krb5::cc_default();	my $credentials= &Authen::Krb5::cc_default();
$credentials->initialize(&Authen::Krb5::parse_name($user.'@'	$credentials->initialize(&Authen::Krb5::parse_name($user.'@'
.$contentpwd));	.$contentpwd));
my $krbreturn = &Authen::Krb5::get_in_tkt_with_password($krbclient,	my $krbreturn;
$krbserver,	if (exists(&Authen::Krb5::get_init_creds_password)) {
$password,	$krbreturn =
$credentials);	&Authen::Krb5::get_init_creds_password($krbclient,$password,
$validated = ($krbreturn == 1);	$krbservice);
	$validated = (ref($krbreturn) eq 'Authen::Krb5::Creds');
	} else {
	$krbreturn =
	&Authen::Krb5::get_in_tkt_with_password($krbclient,$krbserver,
	$password,$credentials);
	$validated = ($krbreturn == 1);
	}
	if (!$validated) {
	&logthis('krb5: '.$user.', '.$contentpwd.', '.
	&Authen::Krb5::error());
	}
} else {	} else {
$validated = 0;	$validated = 0;
}	}
Line 6018 sub subscribe {	Line 6582 sub subscribe {
# the metadata	# the metadata
unless ($fname=~/\.meta$/) { &unsub("$fname.meta",$clientip); }	unless ($fname=~/\.meta$/) { &unsub("$fname.meta",$clientip); }
$fname=~s/\/home\/httpd\/html\/res/raw/;	$fname=~s/\/home\/httpd\/html\/res/raw/;
$fname="http://$thisserver/".$fname;	$fname="http://".&Apache::lonnet::hostname($perlvar{'lonHostID'})."/".$fname;
$result="$fname\n";	$result="$fname\n";
}	}
} else {	} else {
Line 6061 sub change_unix_password {	Line 6625 sub change_unix_password {

sub make_passwd_file {	sub make_passwd_file {
my ($uname, $umode,$npass,$passfilename)=@_;	my ($uname, $umode,$npass,$passfilename)=@_;
my $result="ok\n";	my $result="ok";
if ($umode eq 'krb4' or $umode eq 'krb5') {	if ($umode eq 'krb4' or $umode eq 'krb5') {
{	{
my $pf = IO::File->new(">$passfilename");	my $pf = IO::File->new(">$passfilename");
Line 6129 sub make_passwd_file {	Line 6693 sub make_passwd_file {
if($useraddok > 0) {	if($useraddok > 0) {
my $error_text = &lcuseraddstrerror($useraddok);	my $error_text = &lcuseraddstrerror($useraddok);
&logthis("Failed lcuseradd: $error_text");	&logthis("Failed lcuseradd: $error_text");
$result = "lcuseradd_failed:$error_text\n";	$result = "lcuseradd_failed:$error_text";
} else {	} else {
my $pf = IO::File->new(">$passfilename");	my $pf = IO::File->new(">$passfilename");
if($pf) {	if($pf) {
Line 6153 sub make_passwd_file {	Line 6717 sub make_passwd_file {
}	}
}	}
} else {	} else {
$result="auth_mode_error\n";	$result="auth_mode_error";
}	}
return $result;	return $result;
}	}

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

Removed from v.1.372
changed lines
	Added in v.1.401