loncom/lond - diff

Return to lond CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.362 and 1.399

version 1.362, 2007/03/12 22:24:58	version 1.399, 2008/04/16 22:51:21
Line 49 use localenroll;	Line 49 use localenroll;
use localstudentphoto;	use localstudentphoto;
use File::Copy;	use File::Copy;
use File::Find;	use File::Find;
use LONCAPA::ConfigFileEdit;
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 85 my $tmpsnum = 0; # Id of tmpputs.	Line 84 my $tmpsnum = 0; # Id of tmpputs.

my $ConnectionType;	my $ConnectionType;

my %hostid; # ID's for hosts in cluster by ip.
my %hostdom; # LonCAPA domain for hosts in cluster.
my %hostname; # DNSname -> ID's mapping.
my %hostip; # IPs for hosts in cluster.
my %hostdns; # ID's of hosts looked up by DNS name.

my %managers; # Ip -> manager names	my %managers; # Ip -> manager names

my %perlvar; # Will have the apache conf defined perl vars.	my %perlvar; # Will have the apache conf defined perl vars.
Line 142 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 178 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 424 sub ReadManagerTable {	Line 414 sub ReadManagerTable {
if ($host =~ "^#") { # Comment line.	if ($host =~ "^#") { # Comment line.
next;	next;
}	}
if (!defined $hostip{$host}) { # This is a non cluster member	if (!defined &Apache::lonnet::get_host_ip($host)) { # This is a non cluster member
# The entry is of the form:	# The entry is of the form:
# cluname:hostname	# cluname:hostname
# cluname - A 'cluster hostname' is needed in order to negotiate	# cluname - A 'cluster hostname' is needed in order to negotiate
Line 442 sub ReadManagerTable {	Line 432 sub ReadManagerTable {
}	}
} else {	} else {
logthis('<font color="green"> existing host'." $host</font>\n");	logthis('<font color="green"> existing host'." $host</font>\n");
$managers{$hostip{$host}} = $host; # Use info from cluster tab if clumemeber	$managers{&Apache::lonnet::get_host_ip($host)} = $host; # Use info from cluster tab if clumemeber
}	}
}	}
}	}
Line 1006 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 1032 sub ping_handler {	Line 1022 sub ping_handler {
sub pong_handler {	sub pong_handler {
my ($cmd, $tail, $replyfd) = @_;	my ($cmd, $tail, $replyfd) = @_;

my $reply=&reply("ping",$clientname);	my $reply=&Apache::lonnet::reply("ping",$clientname);
&Reply( $replyfd, "$currenthostid:$reply\n", "$cmd:$tail");	&Reply( $replyfd, "$currenthostid:$reply\n", "$cmd:$tail");
return 1;	return 1;
}	}
Line 1076 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 1113 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 1142 sub load_handler {	Line 1132 sub load_handler {
sub user_load_handler {	sub user_load_handler {
my ($cmd, $tail, $replyfd) = @_;	my ($cmd, $tail, $replyfd) = @_;

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

return 1;	return 1;
}	}
Line 1186 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 1222 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 1231 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 1274 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 1282 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.
	#
	# 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 obosolete and is retained	# The ls_handler routine should be considered obsolete and is retained
# for communication with legacy servers. Please see the ls2_handler.	# 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 1343 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 1412 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 (defined($alternate_root)) {
	$dir_root = $alternate_root;
	}
	if (defined($dir_root)) {
	$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 1440 sub reinit_process_handler {	Line 1606 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 1524 sub authenticate_handler {	Line 1690 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 1615 sub change_password_handler {	Line 1783 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 1676 sub add_user_handler {	Line 1844 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 1745 sub change_authentication_handler {	Line 1913 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 1766 sub change_authentication_handler {	Line 1934 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 1850 sub update_resource_handler {	Line 2018 sub update_resource_handler {
my $now=time;	my $now=time;
my $since=$now-$atime;	my $since=$now-$atime;
if ($since>$perlvar{'lonExpire'}) {	if ($since>$perlvar{'lonExpire'}) {
my $reply=&reply("unsub:$fname","$clientname");	my $reply=&Apache::lonnet::reply("unsub:$fname","$clientname");
&devalidate_meta_cache($fname);	&devalidate_meta_cache($fname);
unlink("$fname");	unlink("$fname");
unlink("$fname.meta");	unlink("$fname.meta");
} else {	} else {
my $transname="$fname.in.transfer";	my $transname="$fname.in.transfer";
my $remoteurl=&reply("sub:$fname","$clientname");	my $remoteurl=&Apache::lonnet::reply("sub:$fname","$clientname");
my $response;	my $response;
alarm(120);	alarm(120);
{	{
Line 1901 sub devalidate_meta_cache {	Line 2069 sub devalidate_meta_cache {
my ($url) = @_;	my ($url) = @_;
use Cache::Memcached;	use Cache::Memcached;
my $memcache = new Cache::Memcached({'servers'=>['127.0.0.1:11211']});	my $memcache = new Cache::Memcached({'servers'=>['127.0.0.1:11211']});
$url = &declutter($url);	$url = &Apache::lonnet::declutter($url);
$url =~ s-\.meta$--;	$url =~ s-\.meta$--;
my $id = &escape('meta:'.$url);	my $id = &escape('meta:'.$url);
$memcache->delete($id);	$memcache->delete($id);
}	}

sub declutter {
my $thisfn=shift;
$thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//;
$thisfn=~s/^\///;
$thisfn=~s\|^adm/wrapper/\|\|;
$thisfn=~s\|^adm/coursedocs/showdoc/\|\|;
$thisfn=~s/^res\///;
$thisfn=~s/\?.+$//;
return $thisfn;
}
#	#
# Fetch a user file from a remote server to the user's home directory	# Fetch a user file from a remote server to the user's home directory
# userfiles subdir.	# userfiles subdir.
Line 2115 sub rename_user_file_handler {	Line 2273 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 2130 sub token_auth_user_file_handler {	Line 2319 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 2207 sub subscribe_handler {	Line 2396 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 2571 sub get_profile_entry {	Line 2760 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 2714 sub get_profile_keys {	Line 2904 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 2784 sub dump_profile_database {	Line 2974 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 2867 sub dump_with_regexp {	Line 3057 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 3075 sub restore_handler {	Line 3265 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 3156 sub retrieve_chat_handler {	Line 3346 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 3293 sub put_course_id_handler {	Line 3483 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 3309 sub put_course_id_handler {	Line 3515 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 3323 sub put_course_id_handler {	Line 3529 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 3355 sub put_course_id_handler {	Line 3603 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 3362 sub put_course_id_handler {	Line 3619 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) =split(/:/,$tail);
	my $now = time;
if (defined($description)) {	if (defined($description)) {
$description=&unescape($description);	$description=&unescape($description);
} else {	} else {
Line 3406 sub dump_course_id_handler {	Line 3663 sub dump_course_id_handler {
if (defined($regexp_ok)) {	if (defined($regexp_ok)) {
$regexp_ok=&unescape($regexp_ok);	$regexp_ok=&unescape($regexp_ok);
}	}
	my $unpack = 1;
unless (defined($since)) { $since=0; }	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;
	}
	}
	}
	} else {
	$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 3471 sub dump_course_id_handler {	Line 3769 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 3504 sub dump_course_id_handler {	Line 3824 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 3588 sub get_domain_handler {	Line 3906 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 3686 sub get_id_handler {	Line 4004 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 3810 sub dump_dcmail_handler {	Line 4128 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 3928 sub dump_domainroles_handler {	Line 4246 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 3938 sub dump_domainroles_handler {	Line 4256 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 3992 sub tmp_put_handler {	Line 4310 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 4026 sub tmp_get_handler {	Line 4344 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 4210 sub enrollment_enabled_handler {	Line 4528 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 4237 sub get_sections_handler {	Line 4555 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 4266 sub validate_course_owner_handler {	Line 4584 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 4297 sub validate_course_section_handler {	Line 4615 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 4324 sub validate_course_section_handler {	Line 4642 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 4452 sub get_institutional_code_format_handle	Line 4770 sub get_institutional_code_format_handle
\%cat_titles,	\%cat_titles,
\%cat_order);	\%cat_order);
if ($formatreply eq 'ok') {	if ($formatreply eq 'ok') {
my $codes_str = &hash2str(%codes);	my $codes_str = &Apache::lonnet::hash2str(%codes);
my $codetitles_str = &array2str(@codetitles);	my $codetitles_str = &Apache::lonnet::array2str(@codetitles);
my $cat_titles_str = &hash2str(%cat_titles);	my $cat_titles_str = &Apache::lonnet::hash2str(%cat_titles);
my $cat_order_str = &hash2str(%cat_order);	my $cat_order_str = &Apache::lonnet::hash2str(%cat_order);
&Reply($client,	&Reply($client,
$codes_str.':'.$codetitles_str.':'.$cat_titles_str.':'	$codes_str.':'.$codetitles_str.':'.$cat_titles_str.':'
.$cat_order_str."\n",	.$cat_order_str."\n",
Line 4492 sub get_institutional_defaults_handler {	Line 4810 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 4503 sub get_institutional_defaults_handler {	Line 4821 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 5142 sub inst_usertypes_handler {
my ($cmd, $domain, $client) = @_;	my ($cmd, $domain, $client) = @_;
my $res;	my $res;
my $userinput = $cmd.":".$domain; # For logging purposes.	my $userinput = $cmd.":".$domain; # For logging purposes.
my (%typeshash,@order);	my (%typeshash,@order,$result);
if (&localenroll::inst_usertypes($domain,\%typeshash,\@order) eq 'ok') {	eval {
	local($SIG{__DIE__})='DEFAULT';
	$result=&localenroll::inst_usertypes($domain,\%typeshash,\@order);
	};
	if ($result eq 'ok') {
if (keys(%typeshash) > 0) {	if (keys(%typeshash) > 0) {
foreach my $key (keys(%typeshash)) {	foreach my $key (keys(%typeshash)) {
$res.=&escape($key).'='.&escape($typeshash{$key}).'&';	$res.=&escape($key).'='.&escape($typeshash{$key}).'&';
Line 4651 sub inst_usertypes_handler {	Line 5162 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 4919 sub catchexception {	Line 5430 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 5030 sub HUPSMAN { # sig	Line 5541 sub HUPSMAN { # sig
}	}

#	#
# Kill off hashes that describe the host table prior to re-reading it.
# Hashes affected are:
# %hostid, %hostdom %hostip %hostdns.
#
sub KillHostHashes {
foreach my $key (keys %hostid) {
delete $hostid{$key};
}
foreach my $key (keys %hostdom) {
delete $hostdom{$key};
}
foreach my $key (keys %hostip) {
delete $hostip{$key};
}
foreach my $key (keys %hostdns) {
delete $hostdns{$key};
}
}
#
# Read in the host table from file and distribute it into the various hashes:
#
# - %hostid - Indexed by IP, the loncapa hostname.
# - %hostdom - Indexed by loncapa hostname, the domain.
# - %hostip - Indexed by hostid, the Ip address of the host.
sub ReadHostTable {

open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") \|\| die "Can't read host file";
my $myloncapaname = $perlvar{'lonHostID'};
Debug("My loncapa name is : $myloncapaname");
my %name_to_ip;
while (my $configline=<CONFIG>) {
if ($configline !~ /^\s\#/ && $configline !~ /^\s$/ ) {
my ($id,$domain,$role,$name)=split(/:/,$configline);
$name=~s/\s//g;
my $ip;
if (!exists($name_to_ip{$name})) {
$ip = gethostbyname($name);
if (!$ip \|\| length($ip) ne 4) {
&logthis("Skipping host $id name $name no IP found\n");
next;
}
$ip=inet_ntoa($ip);
$name_to_ip{$name} = $ip;
} else {
$ip = $name_to_ip{$name};
}
$hostid{$ip}=$id; # LonCAPA name of host by IP.
$hostdom{$id}=$domain; # LonCAPA domain name of host.
$hostname{$id}=$name; # LonCAPA name -> DNS name
$hostip{$id}=$ip; # IP address of host.
$hostdns{$name} = $id; # LonCAPA name of host by DNS.

if ($id eq $perlvar{'lonHostID'}) {
Debug("Found me in the host table: $name");
$thisserver=$name;
}
}
}
close(CONFIG);
}
#
# Reload the Apache daemon's state.	# Reload the Apache daemon's state.
# This is done by invoking /home/httpd/perl/apachereload	# This is done by invoking /home/httpd/perl/apachereload
# a setuid perl script that can be root for us to do this job.	# a setuid perl script that can be root for us to do this job.
Line 5121 sub UpdateHosts {	Line 5571 sub UpdateHosts {
# either dropped or changed hosts. Note that the re-read of the table	# either dropped or changed hosts. Note that the re-read of the table
# will take care of new and changed hosts as connections come into being.	# will take care of new and changed hosts as connections come into being.

	&Apache::lonnet::reset_hosts_info();

KillHostHashes;	foreach my $child (keys(%children)) {
ReadHostTable;

foreach my $child (keys %children) {
my $childip = $children{$child};	my $childip = $children{$child};
if(!$hostid{$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 5212 sub Debug {	Line 5661 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 5287 sub status {	Line 5741 sub status {
$0='lond: '.$what.' '.$local;	$0='lond: '.$what.' '.$local;
}	}

# ----------------------------------------------------------- Send USR1 to lonc

sub reconlonc {
my $peerfile=shift;
&logthis("Trying to reconnect for $peerfile");
my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
if (my $fh=IO::File->new("$loncfile")) {
my $loncpid=<$fh>;
chomp($loncpid);
if (kill 0 => $loncpid) {
&logthis("lonc at pid $loncpid responding, sending USR1");
kill USR1 => $loncpid;
} else {
&logthis(
"<font color='red'>CRITICAL: "
."lonc at pid $loncpid not responding, giving up</font>");
}
} else {
&logthis('<font color="red">CRITICAL: lonc not running, giving up</font>');
}
}

# -------------------------------------------------- Non-critical communication

sub subreply {
my ($cmd,$server)=@_;
my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$server};
my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile",
Type => SOCK_STREAM,
Timeout => 10)
or return "con_lost";
print $sclient "sethost:$server:$cmd\n";
my $answer=<$sclient>;
chomp($answer);
if (!$answer) { $answer="con_lost"; }
return $answer;
}

sub reply {
my ($cmd,$server)=@_;
my $answer;
if ($server ne $currenthostid) {
$answer=subreply($cmd,$server);
if ($answer eq 'con_lost') {
$answer=subreply("ping",$server);
if ($answer ne $server) {
&logthis("sub reply: answer != server answer is $answer, server is $server");
&reconlonc("$perlvar{'lonSockDir'}/".$hostname{$server});
}
$answer=subreply($cmd,$server);
}
} else {
$answer='self_reply';
}
return $answer;
}

# -------------------------------------------------------------- Talk to lonsql	# -------------------------------------------------------------- Talk to lonsql

sub sql_reply {	sub sql_reply {
Line 5412 $SIG{USR1} = \&checkchildren;	Line 5809 $SIG{USR1} = \&checkchildren;
$SIG{USR2} = \&UpdateHosts;	$SIG{USR2} = \&UpdateHosts;

# Read the host hashes:	# Read the host hashes:
	&Apache::lonnet::load_hosts_tab();
ReadHostTable;

my $dist=`$perlvar{'lonDaemons'}/distprobe`;	my $dist=`$perlvar{'lonDaemons'}/distprobe`;

Line 5503 sub make_new_child {	Line 5899 sub make_new_child {
# -----------------------------------------------------------------------------	# -----------------------------------------------------------------------------
# see if we know client and 'check' for spoof IP by ineffective challenge	# see if we know client and 'check' for spoof IP by ineffective challenge

ReadManagerTable; # May also be a manager!!

my $outsideip=$clientip;	my $outsideip=$clientip;
if ($clientip eq '127.0.0.1') {	if ($clientip eq '127.0.0.1') {
$outsideip=$hostip{$perlvar{'lonHostID'}};	$outsideip=&Apache::lonnet::get_host_ip($perlvar{'lonHostID'});
}	}

my $clientrec=($hostid{$outsideip} ne undef);	my $clientrec=defined(&Apache::lonnet::get_hosts_from_ip($outsideip));
my $ismanager=($managers{$outsideip} ne undef);	my $ismanager=($managers{$outsideip} ne undef);
$clientname = "[unknonwn]";	$clientname = "[unknonwn]";
if($clientrec) { # Establish client type.	if($clientrec) { # Establish client type.
$ConnectionType = "client";	$ConnectionType = "client";
$clientname = $hostid{$outsideip};	$clientname = (&Apache::lonnet::get_hosts_from_ip($outsideip))[-1];
if($ismanager) {	if($ismanager) {
$ConnectionType = "both";	$ConnectionType = "both";
}	}
Line 5622 sub make_new_child {	Line 6016 sub make_new_child {

if ($clientok) {	if ($clientok) {
# ---------------- 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
foreach my $id (keys(%hostip)) {	&& $clientip ne '127.0.0.1') {
if ($hostip{$id} ne $clientip \|\|	&Apache::lonnet::reconlonc($clientname);
$hostip{$currenthostid} eq $clientip) {
# no need to try to do recon's to myself
next;
}
&reconlonc("$perlvar{'lonSockDir'}/".$hostname{$id});
}	}
&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 5832 sub get_auth_type	Line 6221 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 5856 sub validate_user {	Line 6244 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 5908 sub validate_user {	Line 6309 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 6158 sub subscribe {	Line 6570 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 6201 sub change_unix_password {	Line 6613 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 6269 sub make_passwd_file {	Line 6681 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 6293 sub make_passwd_file {	Line 6705 sub make_passwd_file {
}	}
}	}
} else {	} else {
$result="auth_mode_error\n";	$result="auth_mode_error";
}	}
return $result;	return $result;
}	}
Line 6312 sub sethost {	Line 6724 sub sethost {
}	}

if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; }	if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; }
if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) {	if (&Apache::lonnet::get_host_ip($perlvar{'lonHostID'})
	eq &Apache::lonnet::get_host_ip($hostid)) {
$currenthostid =$hostid;	$currenthostid =$hostid;
$currentdomainid=$hostdom{$hostid};	$currentdomainid=&Apache::lonnet::host_domain($hostid);
&logthis("Setting hostid to $hostid, and domain to $currentdomainid");	&logthis("Setting hostid to $hostid, and domain to $currentdomainid");
} else {	} else {
&logthis("Requested host id $hostid not an alias of ".	&logthis("Requested host id $hostid not an alias of ".
Line 6330 sub version {	Line 6743 sub version {
return "version:$VERSION";	return "version:$VERSION";
}	}

#There is a copy of this in lonnet.pm
sub userload {
my $numusers=0;
{
opendir(LONIDS,$perlvar{'lonIDsDir'});
my $filename;
my $curtime=time;
while ($filename=readdir(LONIDS)) {
if ($filename eq '.' \|\| $filename eq '..') {next;}
my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];
if ($curtime-$mtime < 1800) { $numusers++; }
}
closedir(LONIDS);
}
my $userloadpercent=0;
my $maxuserload=$perlvar{'lonUserLoadLim'};
if ($maxuserload) {
$userloadpercent=100*$numusers/$maxuserload;
}
$userloadpercent=sprintf("%.2f",$userloadpercent);
return $userloadpercent;
}

# Routines for serializing arrays and hashes (copies from lonnet)

sub array2str {
my (@array) = @_;
my $result=&arrayref2str(\@array);
$result=~s/^__ARRAY_REF__//;
$result=~s/__END_ARRAY_REF__$//;
return $result;
}

sub arrayref2str {
my ($arrayref) = @_;
my $result='__ARRAY_REF__';
foreach my $elem (@$arrayref) {
if(ref($elem) eq 'ARRAY') {
$result.=&arrayref2str($elem).'&';
} elsif(ref($elem) eq 'HASH') {
$result.=&hashref2str($elem).'&';
} elsif(ref($elem)) {
#print("Got a ref of ".(ref($elem))." skipping.");
} else {
$result.=&escape($elem).'&';
}
}
$result=~s/\&$//;
$result .= '__END_ARRAY_REF__';
return $result;
}

sub hash2str {
my (%hash) = @_;
my $result=&hashref2str(\%hash);
$result=~s/^__HASH_REF__//;
$result=~s/__END_HASH_REF__$//;
return $result;
}

sub hashref2str {
my ($hashref)=@_;
my $result='__HASH_REF__';
foreach (sort(keys(%$hashref))) {
if (ref($_) eq 'ARRAY') {
$result.=&arrayref2str($_).'=';
} elsif (ref($_) eq 'HASH') {
$result.=&hashref2str($_).'=';
} elsif (ref($_)) {
$result.='=';
#print("Got a ref of ".(ref($_))." skipping.");
} else {
if ($_) {$result.=&escape($_).'=';} else { last; }
}

if(ref($hashref->{$_}) eq 'ARRAY') {
$result.=&arrayref2str($hashref->{$_}).'&';
} elsif(ref($hashref->{$_}) eq 'HASH') {
$result.=&hashref2str($hashref->{$_}).'&';
} elsif(ref($hashref->{$_})) {
$result.='&';
#print("Got a ref of ".(ref($hashref->{$_}))." skipping.");
} else {
$result.=&escape($hashref->{$_}).'&';
}
}
$result=~s/\&$//;
$result .= '__END_HASH_REF__';
return $result;
}

# ----------------------------------- POD (plain old documentation, CPAN style)	# ----------------------------------- POD (plain old documentation, CPAN style)

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

Removed from v.1.362
changed lines
	Added in v.1.399