loncom/lond - diff

Return to lond CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.375 and 1.403

version 1.375, 2007/06/18 22:49:52	version 1.403, 2008/05/30 21:33:21
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 135 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 996 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 1066 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 1103 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 1133 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 1176 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 1212 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 1221 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 1264 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 1272 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.
	#
	# du2 - list the disk usage of a directory recursively.
#	#
# The ls_handler routine should be considered obosolete and is retained	# Parameters:
# for communication with legacy servers. Please see the ls2_handler.	# $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 1333 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 1402 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 1430 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 1514 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 1605 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 1666 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 1735 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 1756 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 2095 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 2110 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 2187 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 2551 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 2694 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 2764 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 2847 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 3055 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 3136 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 3273 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 3289 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 3303 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 3335 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 3342 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 3386 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);
	if ($hashref->{$lasttime_key} eq '') {
	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 3451 sub dump_course_id_handler {	Line 3783 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 3484 sub dump_course_id_handler {	Line 3838 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 3568 sub get_domain_handler {	Line 3920 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 3666 sub get_id_handler {	Line 4018 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 3790 sub dump_dcmail_handler {	Line 4142 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 3908 sub dump_domainroles_handler {	Line 4260 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 3918 sub dump_domainroles_handler {	Line 4270 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 3972 sub tmp_put_handler {	Line 4324 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 4006 sub tmp_get_handler {	Line 4358 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 4190 sub enrollment_enabled_handler {	Line 4542 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 4217 sub get_sections_handler {	Line 4569 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 4246 sub validate_course_owner_handler {	Line 4598 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 4277 sub validate_course_section_handler {	Line 4629 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 4304 sub validate_course_section_handler {	Line 4656 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 4472 sub get_institutional_defaults_handler {	Line 4824 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 4483 sub get_institutional_defaults_handler {	Line 4835 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 4635 sub inst_usertypes_handler {	Line 5176 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 5134 sub Debug {	Line 5675 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 5689 sub get_auth_type	Line 6235 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 5713 sub validate_user {	Line 6258 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 5765 sub validate_user {	Line 6323 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 6058 sub change_unix_password {	Line 6627 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 6126 sub make_passwd_file {	Line 6695 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 6150 sub make_passwd_file {	Line 6719 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.375
changed lines
	Added in v.1.403