loncom/lond - diff

Return to lond CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.416 and 1.491

version 1.416, 2009/06/11 19:19:51	version 1.491, 2012/04/25 21:22:28
Line 15	Line 15
#	#
# LON-CAPA is distributed in the hope that it will be useful,	# LON-CAPA is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of	# but WITHOUT ANY WARRANTY; without even the implied warranty of

# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.	# GNU General Public License for more details.
#	#
Line 33 use strict;	Line 34 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 LONCAPA::Lond;

use IO::Socket;	use IO::Socket;
use IO::File;	use IO::File;
Line 42 use Crypt::IDEA;	Line 44 use Crypt::IDEA;
use LWP::UserAgent();	use LWP::UserAgent();
use Digest::MD5 qw(md5_hex);	use Digest::MD5 qw(md5_hex);
use GDBM_File;	use GDBM_File;
use Authen::Krb4;
use Authen::Krb5;	use Authen::Krb5;
use localauth;	use localauth;
use localenroll;	use localenroll;
Line 53 use LONCAPA::lonlocal;	Line 54 use LONCAPA::lonlocal;
use LONCAPA::lonssl;	use LONCAPA::lonssl;
use Fcntl qw(:flock);	use Fcntl qw(:flock);
use Apache::lonnet;	use Apache::lonnet;
	use Mail::Send;

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

Line 67 my $currentdomainid;	Line 69 my $currentdomainid;
my $client;	my $client;
my $clientip; # IP address of client.	my $clientip; # IP address of client.
my $clientname; # LonCAPA name of client.	my $clientname; # LonCAPA name of client.
	my $clientversion; # LonCAPA version running on client.
	my $clienthomedom; # LonCAPA domain of homeID for client.
	# primary library server.

my $server;	my $server;

Line 88 my %managers; # Ip -> manager names	Line 93 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.

	my $dist;

#	#
# The hash below is used for command dispatching, and is therefore keyed on the request keyword.	# The hash below is used for command dispatching, and is therefore keyed on the request keyword.
# Each element of the hash contains a reference to an array that contains:	# Each element of the hash contains a reference to an array that contains:
Line 417 sub ReadManagerTable {	Line 424 sub ReadManagerTable {

my $tablename = $perlvar{'lonTabDir'}."/managers.tab";	my $tablename = $perlvar{'lonTabDir'}."/managers.tab";
if (!open (MANAGERS, $tablename)) {	if (!open (MANAGERS, $tablename)) {
logthis('<font color="red">No manager table. Nobody can manage!!</font>');	my $hostname = &Apache::lonnet::hostname($perlvar{'lonHostID'});
return;	if (&Apache::lonnet::is_LC_dns($hostname)) {
	&logthis('<font color="red">No manager table. Nobody can manage!!</font>');
	}
	return;
}	}
while(my $host = <MANAGERS>) {	while(my $host = <MANAGERS>) {
chomp($host);	chomp($host);
Line 443 sub ReadManagerTable {	Line 453 sub ReadManagerTable {
}	}
} else {	} else {
logthis('<font color="green"> existing host'." $host</font>\n");	logthis('<font color="green"> existing host'." $host</font>\n");
$managers{&Apache::lonnet::get_host_ip($host)} = $host; # Use info from cluster tab if clumemeber	$managers{&Apache::lonnet::get_host_ip($host)} = $host; # Use info from cluster tab if cluster memeber
}	}
}	}
}	}
Line 505 sub AdjustHostContents {	Line 515 sub AdjustHostContents {
my $me = $perlvar{'lonHostID'};	my $me = $perlvar{'lonHostID'};

foreach my $line (split(/\n/,$contents)) {	foreach my $line (split(/\n/,$contents)) {
if(!(($line eq "") \|\| ($line =~ /^ \#/) \|\| ($line =~ /^ $/))) {	if(!(($line eq "") \|\| ($line =~ /^ \#/) \|\| ($line =~ /^ $/) \|\|
	($line =~ /^\s*\^/))) {
chomp($line);	chomp($line);
my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon)=split(/:/,$line);	my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon)=split(/:/,$line);
if ($id eq $me) {	if ($id eq $me) {
Line 593 sub InstallFile {	Line 604 sub InstallFile {
#	#
# ConfigFileFromSelector: converts a configuration file selector	# ConfigFileFromSelector: converts a configuration file selector
# into a configuration file pathname.	# into a configuration file pathname.
# It's probably no longer necessary to preserve	# Supports the following file selectors:
# special handling of hosts or domain as those	# hosts, domain, dns_hosts, dns_domain
# files have been superceded by dns_hosts, dns_domain.
# The default action is just to prepend the directory
# and append .tab
#	#
#	#
# Parameters:	# Parameters:
Line 610 sub ConfigFileFromSelector {	Line 618 sub ConfigFileFromSelector {
my $tablefile;	my $tablefile;

my $tabledir = $perlvar{'lonTabDir'}.'/';	my $tabledir = $perlvar{'lonTabDir'}.'/';
if ($selector eq "hosts") {	if (($selector eq "hosts") \|\| ($selector eq "domain") \|\|
$tablefile = $tabledir."hosts.tab";	($selector eq "dns_hosts") \|\| ($selector eq "dns_domain")) {
} elsif ($selector eq "domain") {
$tablefile = $tabledir."domain.tab";
} else {
$tablefile = $tabledir.$selector.'.tab';	$tablefile = $tabledir.$selector.'.tab';
}	}
return $tablefile;	return $tablefile;

}	}
#	#
# PushFile: Called to do an administrative push of a file.	# PushFile: Called to do an administrative push of a file.
Line 644 sub PushFile {	Line 648 sub PushFile {
# supported:	# supported:
# hosts.tab ($filename eq host).	# hosts.tab ($filename eq host).
# domain.tab ($filename eq domain).	# domain.tab ($filename eq domain).
	# dns_hosts.tab ($filename eq dns_host).
	# dns_domain.tab ($filename eq dns_domain).
# Construct the destination filename or reject the request.	# Construct the destination filename or reject the request.
#	#
# lonManage is supposed to ensure this, however this session could be	# lonManage is supposed to ensure this, however this session could be
Line 675 sub PushFile {	Line 681 sub PushFile {
return "error:$!";	return "error:$!";
} else {	} else {
&logthis('<font color="green"> Installed new '.$tablefile	&logthis('<font color="green"> Installed new '.$tablefile
."</font>");	." - transaction by: $clientname ($clientip)</font>");
	my $adminmail = $perlvar{'lonAdmEMail'};
	my $admindom = &Apache::lonnet::host_domain($perlvar{'lonHostID'});
	if ($admindom ne '') {
	my %domconfig =
	&Apache::lonnet::get_dom('configuration',['contacts'],$admindom);
	if (ref($domconfig{'contacts'}) eq 'HASH') {
	if ($domconfig{'contacts'}{'adminemail'} ne '') {
	$adminmail = $domconfig{'contacts'}{'adminemail'};
	}
	}
	}
	if ($adminmail =~ /^[^\@]+\@[^\@]+$/) {
	my $msg = new Mail::Send;
	$msg->to($adminmail);
	$msg->subject('LON-CAPA DNS update on '.$perlvar{'lonHostID'});
	$msg->add('Content-type','text/plain; charset=UTF-8');
	if (my $fh = $msg->open()) {
	print $fh 'Update to '.$tablefile.' from Cluster Manager '.
	"$clientname ($clientip)\n";
	$fh->close;
	}
	}
}	}


# Indicate success:	# Indicate success:

return "ok";	return "ok";
Line 975 sub read_profile {	Line 1001 sub read_profile {
&GDBM_READER());	&GDBM_READER());
if ($hashref) {	if ($hashref) {
my @queries=split(/\&/,$what);	my @queries=split(/\&/,$what);
	if ($namespace eq 'roles') {
	@queries = map { &unescape($_); } @queries;
	}
my $qresult='';	my $qresult='';

for (my $i=0;$i<=$#queries;$i++) {	for (my $i=0;$i<=$#queries;$i++) {
Line 1068 sub pong_handler {	Line 1097 sub pong_handler {
# Implicit Inputs:	# Implicit Inputs:
# $currenthostid - Global variable that carries the name of the host	# $currenthostid - Global variable that carries the name of the host
# known as.	# known as.
# $clientname - Global variable that carries the name of the hsot we're connected to.	# $clientname - Global variable that carries the name of the host we're connected to.
# Returns:	# Returns:
# 1 - Ok to continue processing.	# 1 - Ok to continue processing.
# 0 - Program should exit.	# 0 - Program should exit.
Line 1107 sub establish_key_handler {	Line 1136 sub establish_key_handler {
# Implicit Inputs:	# Implicit Inputs:
# $currenthostid - Global variable that carries the name of the host	# $currenthostid - Global variable that carries the name of the host
# known as.	# known as.
# $clientname - Global variable that carries the name of the hsot we're connected to.	# $clientname - Global variable that carries the name of the host we're connected to.
# Returns:	# Returns:
# 1 - Ok to continue processing.	# 1 - Ok to continue processing.
# 0 - Program should exit.	# 0 - Program should exit.
Line 1116 sub establish_key_handler {	Line 1145 sub establish_key_handler {
sub load_handler {	sub load_handler {
my ($cmd, $tail, $replyfd) = @_;	my ($cmd, $tail, $replyfd) = @_;



# Get the load average from /proc/loadavg and calculate it as a percentage of	# Get the load average from /proc/loadavg and calculate it as a percentage of
# the allowed load limit as set by the perl global variable lonLoadLim	# the allowed load limit as set by the perl global variable lonLoadLim

Line 1144 sub load_handler {	Line 1175 sub load_handler {
# Implicit Inputs:	# Implicit Inputs:
# $currenthostid - Global variable that carries the name of the host	# $currenthostid - Global variable that carries the name of the host
# known as.	# known as.
# $clientname - Global variable that carries the name of the hsot we're connected to.	# $clientname - Global variable that carries the name of the host we're connected to.
# Returns:	# Returns:
# 1 - Ok to continue processing.	# 1 - Ok to continue processing.
# 0 - Program should exit	# 0 - Program should exit
Line 1613 sub ls3_handler {	Line 1644 sub ls3_handler {
}	}
&register_handler("ls3", \&ls3_handler, 0, 1, 0);	&register_handler("ls3", \&ls3_handler, 0, 1, 0);

	sub read_lonnet_global {
	my ($cmd,$tail,$client) = @_;
	my $userinput = "$cmd:$tail";
	my $requested = &Apache::lonnet::thaw_unescape($tail);
	my $result;
	my %packagevars = (
	spareid => \%Apache::lonnet::spareid,
	perlvar => \%Apache::lonnet::perlvar,
	);
	my %limit_to = (
	perlvar => {
	lonOtherAuthen => 1,
	lonBalancer => 1,
	lonVersion => 1,
	lonSysEMail => 1,
	lonHostID => 1,
	lonRole => 1,
	lonDefDomain => 1,
	lonLoadLim => 1,
	lonUserLoadLim => 1,
	}
	);
	if (ref($requested) eq 'HASH') {
	foreach my $what (keys(%{$requested})) {
	my $response;
	my $items = {};
	if (exists($packagevars{$what})) {
	if (ref($limit_to{$what}) eq 'HASH') {
	foreach my $varname (keys(%{$packagevars{$what}})) {
	if ($limit_to{$what}{$varname}) {
	$items->{$varname} = $packagevars{$what}{$varname};
	}
	}
	} else {
	$items = $packagevars{$what};
	}
	if ($what eq 'perlvar') {
	if (!exists($packagevars{$what}{'lonBalancer'})) {
	if ($dist =~ /^(centos\|rhes\|fedora\|scientific)/) {
	my $othervarref=LONCAPA::Configuration::read_conf('httpd.conf');
	if (ref($othervarref) eq 'HASH') {
	$items->{'lonBalancer'} = $othervarref->{'lonBalancer'};
	}
	}
	}
	}
	$response = &Apache::lonnet::freeze_escape($items);
	}
	$result .= &escape($what).'='.$response.'&';
	}
	}
	$result =~ s/\&$//;
	&Reply($client,\$result,$userinput);
	return 1;
	}
	&register_handler("readlonnetglobal", \&read_lonnet_global, 0, 1, 0);

	sub server_devalidatecache_handler {
	my ($cmd,$tail,$client) = @_;
	my $userinput = "$cmd:$tail";
	my ($name,$id) = map { &unescape($_); } split(/:/,$tail);
	&Apache::lonnet::devalidate_cache_new($name,$id);
	my $result = 'ok';
	&Reply($client,\$result,$userinput);
	return 1;
	}
	&register_handler("devalidatecache", \&server_devalidatecache_handler, 0, 1, 0);

sub server_timezone_handler {	sub server_timezone_handler {
my ($cmd,$tail,$client) = @_;	my ($cmd,$tail,$client) = @_;
my $userinput = "$cmd:$tail";	my $userinput = "$cmd:$tail";
Line 1653 sub server_loncaparev_handler {	Line 1752 sub server_loncaparev_handler {
}	}
&register_handler("serverloncaparev", \&server_loncaparev_handler, 0, 1, 0);	&register_handler("serverloncaparev", \&server_loncaparev_handler, 0, 1, 0);

	sub server_homeID_handler {
	my ($cmd,$tail,$client) = @_;
	my $userinput = "$cmd:$tail";
	&Reply($client,\$perlvar{'lonHostID'},$userinput);
	return 1;
	}
	&register_handler("serverhomeID", \&server_homeID_handler, 0, 1, 0);

	sub server_distarch_handler {
	my ($cmd,$tail,$client) = @_;
	my $userinput = "$cmd:$tail";
	my $reply = &distro_and_arch();
	&Reply($client,\$reply,$userinput);
	return 1;
	}
	&register_handler("serverdistarch", \&server_distarch_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
# host.tab or domain.tab can be processed.	# host.tab or domain.tab can be processed.
Line 1762 sub authenticate_handler {	Line 1878 sub authenticate_handler {
# upass - User's password.	# upass - User's password.
# checkdefauth - Pass to validate_user() to try authentication	# checkdefauth - Pass to validate_user() to try authentication
# with default auth type(s) if no user account.	# with default auth type(s) if no user account.
	# clientcancheckhost - Passed by clients with functionality in lonauth.pm
	# to check if session can be hosted.

my ($udom, $uname, $upass, $checkdefauth)=split(/:/,$tail);	my ($udom, $uname, $upass, $checkdefauth, $clientcancheckhost)=split(/:/,$tail);
&Debug(" Authenticate domain = $udom, user = $uname, password = $upass, checkdefauth = $checkdefauth");	&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,$checkdefauth);	my $pwdcorrect = &validate_user($udom,$uname,$upass,$checkdefauth);
if($pwdcorrect) {	if($pwdcorrect) {
&Reply( $client, "authorized\n", $userinput);	my $canhost = 1;
	unless ($clientcancheckhost) {
	my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
	my $uint_dom = &Apache::lonnet::internet_dom($uprimary_id);
	my @intdoms;
	my $internet_names = &Apache::lonnet::get_internet_names($clientname);
	if (ref($internet_names) eq 'ARRAY') {
	@intdoms = @{$internet_names};
	}
	unless ($uint_dom ne '' && grep(/^\Q$uint_dom\E$/,@intdoms)) {
	my ($remote,$hosted);
	my $remotesession = &get_usersession_config($udom,'remotesession');
	if (ref($remotesession) eq 'HASH') {
	$remote = $remotesession->{'remote'}
	}
	my $hostedsession = &get_usersession_config($clienthomedom,'hostedsession');
	if (ref($hostedsession) eq 'HASH') {
	$hosted = $hostedsession->{'hosted'};
	}
	my $loncaparev = $clientversion;
	if ($loncaparev eq '') {
	$loncaparev = $Apache::lonnet::loncaparevs{$clientname};
	}
	$canhost = &Apache::lonnet::can_host_session($udom,$clientname,
	$loncaparev,
	$remote,$hosted);
	}
	}
	if ($canhost) {
	&Reply( $client, "authorized\n", $userinput);
	} else {
	&Reply( $client, "not_allowed_to_host\n", $userinput);
	}
#	#
# Bad credentials: Failed to authorize	# Bad credentials: Failed to authorize
#	#
Line 1815 sub change_password_handler {	Line 1965 sub change_password_handler {
# npass - New password.	# npass - New password.
# context - Context in which this was called	# context - Context in which this was called
# (preferences or reset_by_email).	# (preferences or reset_by_email).
	# lonhost - HostID of server where request originated

my ($udom,$uname,$upass,$npass,$context)=split(/:/,$tail);	my ($udom,$uname,$upass,$npass,$context,$lonhost)=split(/:/,$tail);

$upass=&unescape($upass);	$upass=&unescape($upass);
$npass=&unescape($npass);	$npass=&unescape($npass);
Line 1825 sub change_password_handler {	Line 1976 sub change_password_handler {
# First require that the user can be authenticated with their	# First require that the user can be authenticated with their
# old password unless context was 'reset_by_email':	# old password unless context was 'reset_by_email':

my $validated;	my ($validated,$failure);
if ($context eq 'reset_by_email') {	if ($context eq 'reset_by_email') {
$validated = 1;	if ($lonhost eq '') {
	$failure = 'invalid_client';
	} else {
	$validated = 1;
	}
} else {	} else {
$validated = &validate_user($udom, $uname, $upass);	$validated = &validate_user($udom, $uname, $upass);
}	}
Line 1841 sub change_password_handler {	Line 1996 sub change_password_handler {
$salt=substr($salt,6,2);	$salt=substr($salt,6,2);
my $ncpass=crypt($npass,$salt);	my $ncpass=crypt($npass,$salt);
if(&rewrite_password_file($udom, $uname, "internal:$ncpass")) {	if(&rewrite_password_file($udom, $uname, "internal:$ncpass")) {
&logthis("Result of password change for "	my $msg="Result of password change for $uname: pwchange_success";
."$uname: pwchange_success");	if ($lonhost) {
	$msg .= " - request originated from: $lonhost";
	}
	&logthis($msg);
&Reply($client, "ok\n", $userinput);	&Reply($client, "ok\n", $userinput);
} else {	} else {
&logthis("Unable to open $uname passwd "	&logthis("Unable to open $uname passwd "
Line 1863 sub change_password_handler {	Line 2021 sub change_password_handler {
}	}

} else {	} else {
&Failure( $client, "non_authorized\n", $userinput);	if ($failure eq '') {
	$failure = 'non_authorized';
	}
	&Failure( $client, "$failure\n", $userinput);
}	}

return 1;	return 1;
Line 1913 sub add_user_handler {	Line 2074 sub add_user_handler {
."makeuser";	."makeuser";
}	}
unless ($fperror) {	unless ($fperror) {
my $result=&make_passwd_file($uname, $umode,$npass, $passfilename);	my $result=&make_passwd_file($uname,$udom,$umode,$npass, $passfilename);
&Reply($client,\$result, $userinput); #BUGBUG - could be fail	&Reply($client,\$result, $userinput); #BUGBUG - could be fail
} else {	} else {
&Failure($client, \$fperror, $userinput);	&Failure($client, \$fperror, $userinput);
Line 1988 sub change_authentication_handler {	Line 2149 sub change_authentication_handler {
&Failure($client, \$result);	&Failure($client, \$result);
}	}
} else {	} else {
my $result=&make_passwd_file($uname, $umode,$npass,$passfilename);	my $result=&make_passwd_file($uname,$udom,$umode,$npass,$passfilename);
#	#
# If the current auth mode is internal, and the old auth mode was	# If the current auth mode is internal, and the old auth mode was
# unix, or krb*, and the user is an author for this domain,	# unix, or krb*, and the user is an author for this domain,
Line 2050 sub is_home_handler {	Line 2211 sub is_home_handler {
&register_handler("home", \&is_home_handler, 0,1,0);	&register_handler("home", \&is_home_handler, 0,1,0);

#	#
# Process an update request for a resource?? I think what's going on here is	# Process an update request for a resource.
# that a resource has been modified that we hold a subscription to.	# A resource has been modified that we hold a subscription to.
# If the resource is not local, then we must update, or at least invalidate our	# If the resource is not local, then we must update, or at least invalidate our
# cached copy of the resource.	# cached copy of the resource.
# FUTURE WORK:
# I need to look at this logic carefully. My druthers would be to follow
# typical caching logic, and simple invalidate the cache, drop any subscription
# an let the next fetch start the ball rolling again... however that may
# actually be more difficult than it looks given the complex web of
# proxy servers.
# 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).
Line 2083 sub update_resource_handler {	Line 2238 sub update_resource_handler {
my $ownership=ishome($fname);	my $ownership=ishome($fname);
if ($ownership eq 'not_owner') {	if ($ownership eq 'not_owner') {
if (-e $fname) {	if (-e $fname) {
	# Delete preview file, if exists
	unlink("$fname.tmp");
	# Get usage stats
my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,	my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
$atime,$mtime,$ctime,$blksize,$blocks)=stat($fname);	$atime,$mtime,$ctime,$blksize,$blocks)=stat($fname);
my $now=time;	my $now=time;
my $since=$now-$atime;	my $since=$now-$atime;
	# If the file has not been used within lonExpire seconds,
	# unsubscribe from it and delete local copy
if ($since>$perlvar{'lonExpire'}) {	if ($since>$perlvar{'lonExpire'}) {
my $reply=&Apache::lonnet::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 {
	# Yes, this is in active use. Get a fresh copy. Since it might be in
	# very active use and huge (like a movie), copy it to "in.transfer" filename first.
my $transname="$fname.in.transfer";	my $transname="$fname.in.transfer";
my $remoteurl=&Apache::lonnet::reply("sub:$fname","$clientname");	my $remoteurl=&Apache::lonnet::reply("sub:$fname","$clientname");
my $response;	my $response;
alarm(120);	# FIXME: cannot replicate files that take more than two minutes to transfer?
	# alarm(120);
	# FIXME: this should use the LWP mechanism, not internal alarms.
	alarm(1200);
{	{
my $ua=new LWP::UserAgent;	my $ua=new LWP::UserAgent;
my $request=new HTTP::Request('GET',"$remoteurl");	my $request=new HTTP::Request('GET',"$remoteurl");
Line 2104 sub update_resource_handler {	Line 2269 sub update_resource_handler {
}	}
alarm(0);	alarm(0);
if ($response->is_error()) {	if ($response->is_error()) {
	# FIXME: we should probably clean up here instead of just whine
unlink($transname);	unlink($transname);
my $message=$response->status_line;	my $message=$response->status_line;
&logthis("LWP GET: $message for $fname ($remoteurl)");	&logthis("LWP GET: $message for $fname ($remoteurl)");
} else {	} else {
if ($remoteurl!~/\.meta$/) {	if ($remoteurl!~/\.meta$/) {
	# FIXME: isn't there an internal LWP mechanism for this?
alarm(120);	alarm(120);
{	{
my $ua=new LWP::UserAgent;	my $ua=new LWP::UserAgent;
Line 2120 sub update_resource_handler {	Line 2287 sub update_resource_handler {
}	}
alarm(0);	alarm(0);
}	}
	# we successfully transfered, copy file over to real name
rename($transname,$fname);	rename($transname,$fname);
&devalidate_meta_cache($fname);	&devalidate_meta_cache($fname);
}	}
Line 2181 sub fetch_user_file_handler {	Line 2349 sub fetch_user_file_handler {

my $destname=$udir.'/'.$ufile;	my $destname=$udir.'/'.$ufile;
my $transname=$udir.'/'.$ufile.'.in.transit';	my $transname=$udir.'/'.$ufile.'.in.transit';
my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;	my $clientprotocol=$Apache::lonnet::protocol{$clientname};
	$clientprotocol = 'http' if ($clientprotocol ne 'https');
	my $clienthost = &Apache::lonnet::hostname($clientname);
	my $remoteurl=$clientprotocol.'://'.$clienthost.'/userfiles/'.$fname;
my $response;	my $response;
Debug("Remote URL : $remoteurl Transfername $transname Destname: $destname");	Debug("Remote URL : $remoteurl Transfername $transname Destname: $destname");
alarm(120);	alarm(120);
Line 2357 sub user_has_session_handler {	Line 2528 sub user_has_session_handler {

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

&logthis("Looking for $udom $uname");
opendir(DIR,$perlvar{'lonIDsDir'});	opendir(DIR,$perlvar{'lonIDsDir'});
my $filename;	my $filename;
while ($filename=readdir(DIR)) {	while ($filename=readdir(DIR)) {
Line 3076 sub dump_profile_database {	Line 3246 sub dump_profile_database {
# that is matched against	# that is matched against
# database keywords to do	# database keywords to do
# selective dumps.	# selective dumps.
	# range - optional range of entries
	# e.g., 10-20 would return the
	# 10th to 19th items, etc.
# $client - Channel open on the client.	# $client - Channel open on the client.
# Returns:	# Returns:
# 1 - Continue processing.	# 1 - Continue processing.
Line 3085 sub dump_profile_database {	Line 3258 sub dump_profile_database {
sub dump_with_regexp {	sub dump_with_regexp {
my ($cmd, $tail, $client) = @_;	my ($cmd, $tail, $client) = @_;

	#TODO encapsulate $clientname and $clientversion in a object.
	my $res = LONCAPA::Lond::dump_with_regexp($cmd, $tail, $clientname, $clientversion);

	if ($res =~ /^error:/) {
	Failure($client, \$res, "$cmd:$tail");
	} else {
	Reply($client, \$res, "$cmd:$tail");
	}
	return 1;

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

Line 3109 sub dump_with_regexp {	Line 3291 sub dump_with_regexp {
if ($hashref) {	if ($hashref) {
my $qresult='';	my $qresult='';
my $count=0;	my $count=0;
	#
	# When dump is for roles.db, determine if LON-CAPA version checking is needed.
	# Sessions on 2.10 and later do not require version checking, as that occurs
	# on the server hosting the user session, when constructing the roles/courses
	# screen).
	#
	my $skipcheck;
	my @ids = &Apache::lonnet::current_machine_ids();
	my (%homecourses,$major,$minor,$now);
	#
	# If dump is for roles.db from a pre-2.10 server, determine the LON-CAPA
	# version on the server which requested the data. For LON-CAPA 2.9, the
	# client session will have sent its LON-CAPA version when initiating the
	# connection. For LON-CAPA 2.8 and older, the version is retrieved from
	# the global %loncaparevs in lonnet.pm.
	#
	if ($namespace eq 'roles') {
	my $loncaparev = $clientversion;
	if ($loncaparev eq '') {
	$loncaparev = $Apache::lonnet::loncaparevs{$clientname};
	}
	if ($loncaparev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?/) {
	$major = $1;
	$minor = $2;
	}
	if (($major > 2) \|\| (($major == 2) && ($minor > 9))) {
	$skipcheck = 1;
	}
	$now = time;
	}
while (my ($key,$value) = each(%$hashref)) {	while (my ($key,$value) = each(%$hashref)) {
	if (($namespace eq 'roles') && (!$skipcheck)) {
	if ($key =~ m{^/($LONCAPA::match_domain)/($LONCAPA::match_courseid)(/?[^_]*)_(cc\|co\|in\|ta\|ep\|ad\|st\|cr)$}) {
	my $cdom = $1;
	my $cnum = $2;
	my ($role,$roleend,$rolestart) = split(/\_/,$value);
	if (!$roleend \|\| $roleend > $now) {
	#
	# For active course roles, check that requesting server is running a LON-CAPA
	# version which meets any version requirements for the course. Do not include
	# the role amongst the results returned if the requesting server's version is
	# too old.
	#
	# This determination is handled differently depending on whether the course's
	# homeserver is the current server, or whether it is a different server.
	# In both cases, the course's version requirement needs to be retrieved.
	#
	next unless (&releasereqd_check($cnum,$cdom,$key,$value,$major,
	$minor,\%homecourses,\@ids));
	}
	}
	}
if ($regexp eq '.') {	if ($regexp eq '.') {
$count++;	$count++;
if (defined($range) && $count >= $end) { last; }	if (defined($range) && $count >= $end) { last; }
Line 3126 sub dump_with_regexp {	Line 3359 sub dump_with_regexp {
}	}
}	}
if (&untie_user_hash($hashref)) {	if (&untie_user_hash($hashref)) {
	#
	# If dump is for roles.db from a pre-2.10 server, check if the LON-CAPA
	# version requirements for courses for which the current server is the home
	# server permit course roles to be usable on the client server hosting the
	# user's session. If so, include those role results in the data returned to
	# the client server.
	#
	if (($namespace eq 'roles') && (!$skipcheck)) {
	if (keys(%homecourses) > 0) {
	$qresult .= &check_homecourses(\%homecourses,$regexp,$count,
	$range,$start,$end,$major,$minor);
	}
	}
chop($qresult);	chop($qresult);
&Reply($client, \$qresult, $userinput);	&Reply($client, \$qresult, $userinput);
} else {	} else {
Line 3674 sub put_course_id_hash_handler {	Line 3920 sub put_course_id_hash_handler {
# 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	# type - optional parameter for selection
# regexp_ok - if true, allow the supplied institutional code	# regexp_ok - if 1 or -1 allow the supplied institutional code
# filter to behave as a regular expression.	# filter to behave as a regular expression:
	# 1 will not exclude the course if the instcode matches the RE
	# -1 will exclude the course if the instcode matches the RE
# rtn_as_hash - whether to return the information available for	# rtn_as_hash - whether to return the information available for
# each matched item as a frozen hash of all	# each matched item as a frozen hash of all
# key, value pairs in the item's hash, or as a	# key, value pairs in the item's hash, or as a
Line 3691 sub put_course_id_hash_handler {	Line 3939 sub put_course_id_hash_handler {
# caller - if set to 'coursecatalog', courses set to be hidden	# caller - if set to 'coursecatalog', courses set to be hidden
# from course catalog will be excluded from results (unless	# from course catalog will be excluded from results (unless
# overridden by "showhidden".	# overridden by "showhidden".
	# cloner - escaped username:domain of course cloner (if picking course to
	# clone).
	# cc_clone_list - escaped comma separated list of courses for which
	# course cloner has active CC role (and so can clone
	# automatically).
	# cloneonly - filter by courses for which cloner has rights to clone.
	# createdbefore - include courses for which creation date preceeded this date.
	# createdafter - include courses for which creation date followed this date.
	# creationcontext - include courses created in specified context
	#
	# domcloner - flag to indicate if user can create CCs in course's domain.
	# If so, ability to clone course is automatic.
#	#
# $client - The socket open on the client.	# $client - The socket open on the client.
# Returns:	# Returns:
Line 3703 sub dump_course_id_handler {	Line 3963 sub dump_course_id_handler {

my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter,	my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter,
$typefilter,$regexp_ok,$rtn_as_hash,$selfenrollonly,$catfilter,$showhidden,	$typefilter,$regexp_ok,$rtn_as_hash,$selfenrollonly,$catfilter,$showhidden,
$caller) =split(/:/,$tail);	$caller,$cloner,$cc_clone_list,$cloneonly,$createdbefore,$createdafter,
	$creationcontext,$domcloner) =split(/:/,$tail);
my $now = time;	my $now = time;
	my ($cloneruname,$clonerudom,%cc_clone);
if (defined($description)) {	if (defined($description)) {
$description=&unescape($description);	$description=&unescape($description);
} else {	} else {
Line 3747 sub dump_course_id_handler {	Line 4009 sub dump_course_id_handler {
if (defined($catfilter)) {	if (defined($catfilter)) {
$catfilter=&unescape($catfilter);	$catfilter=&unescape($catfilter);
}	}
	if (defined($cloner)) {
	$cloner = &unescape($cloner);
	($cloneruname,$clonerudom) = ($cloner =~ /^($LONCAPA::match_username):($LONCAPA::match_domain)$/);
	}
	if (defined($cc_clone_list)) {
	$cc_clone_list = &unescape($cc_clone_list);
	my @cc_cloners = split('&',$cc_clone_list);
	foreach my $cid (@cc_cloners) {
	my ($clonedom,$clonenum) = split(':',$cid);
	next if ($clonedom ne $udom);
	$cc_clone{$clonedom.'_'.$clonenum} = 1;
	}
	}
	if ($createdbefore ne '') {
	$createdbefore = &unescape($createdbefore);
	} else {
	$createdbefore = 0;
	}
	if ($createdafter ne '') {
	$createdafter = &unescape($createdafter);
	} else {
	$createdafter = 0;
	}
	if ($creationcontext ne '') {
	$creationcontext = &unescape($creationcontext);
	} else {
	$creationcontext = '.';
	}
my $unpack = 1;	my $unpack = 1;
if ($description eq '.' && $instcodefilter eq '.' && $coursefilter eq '.' &&	if ($description eq '.' && $instcodefilter eq '.' && $ownerfilter eq '.' &&
$typefilter eq '.') {	$typefilter eq '.') {
$unpack = 0;	$unpack = 0;
}	}
Line 3758 sub dump_course_id_handler {	Line 4048 sub dump_course_id_handler {
if ($hashref) {	if ($hashref) {
while (my ($key,$value) = each(%$hashref)) {	while (my ($key,$value) = each(%$hashref)) {
my ($unesc_key,$lasttime_key,$lasttime,$is_hash,%val,	my ($unesc_key,$lasttime_key,$lasttime,$is_hash,%val,
%unesc_val,$selfenroll_end,$selfenroll_types);	%unesc_val,$selfenroll_end,$selfenroll_types,$created,
	$context);
$unesc_key = &unescape($key);	$unesc_key = &unescape($key);
if ($unesc_key =~ /^lasttime:/) {	if ($unesc_key =~ /^lasttime:/) {
next;	next;
Line 3769 sub dump_course_id_handler {	Line 4060 sub dump_course_id_handler {
$lasttime = $hashref->{$lasttime_key};	$lasttime = $hashref->{$lasttime_key};
next if ($lasttime<$since);	next if ($lasttime<$since);
}	}
	my ($canclone,$valchange);
my $items = &Apache::lonnet::thaw_unescape($value);	my $items = &Apache::lonnet::thaw_unescape($value);
if (ref($items) eq 'HASH') {	if (ref($items) eq 'HASH') {
	if ($hashref->{$lasttime_key} eq '') {
	next if ($since > 1);
	}
$is_hash = 1;	$is_hash = 1;
	if ($domcloner) {
	$canclone = 1;
	} elsif (defined($clonerudom)) {
	if ($items->{'cloners'}) {
	my @cloneable = split(',',$items->{'cloners'});
	if (@cloneable) {
	if (grep(/^\*$/,@cloneable)) {
	$canclone = 1;
	} elsif (grep(/^\*:\Q$clonerudom\E$/,@cloneable)) {
	$canclone = 1;
	} elsif (grep(/^\Q$cloneruname\E:\Q$clonerudom\E$/,@cloneable)) {
	$canclone = 1;
	}
	}
	unless ($canclone) {
	if ($cloneruname ne '' && $clonerudom ne '') {
	if ($cc_clone{$unesc_key}) {
	$canclone = 1;
	$items->{'cloners'} .= ','.$cloneruname.':'.
	$clonerudom;
	$valchange = 1;
	}
	}
	}
	} elsif (defined($cloneruname)) {
	if ($cc_clone{$unesc_key}) {
	$canclone = 1;
	$items->{'cloners'} = $cloneruname.':'.$clonerudom;
	$valchange = 1;
	}
	unless ($canclone) {
	if ($items->{'owner'} =~ /:/) {
	if ($items->{'owner'} eq $cloner) {
	$canclone = 1;
	}
	} elsif ($cloner eq $items->{'owner'}.':'.$udom) {
	$canclone = 1;
	}
	if ($canclone) {
	$items->{'cloners'} = $cloneruname.':'.$clonerudom;
	$valchange = 1;
	}
	}
	}
	}
if ($unpack \|\| !$rtn_as_hash) {	if ($unpack \|\| !$rtn_as_hash) {
$unesc_val{'descr'} = $items->{'description'};	$unesc_val{'descr'} = $items->{'description'};
$unesc_val{'inst_code'} = $items->{'inst_code'};	$unesc_val{'inst_code'} = $items->{'inst_code'};
$unesc_val{'owner'} = $items->{'owner'};	$unesc_val{'owner'} = $items->{'owner'};
$unesc_val{'type'} = $items->{'type'};	$unesc_val{'type'} = $items->{'type'};
	$unesc_val{'cloners'} = $items->{'cloners'};
	$unesc_val{'created'} = $items->{'created'};
	$unesc_val{'context'} = $items->{'context'};
}	}
$selfenroll_types = $items->{'selfenroll_types'};	$selfenroll_types = $items->{'selfenroll_types'};
$selfenroll_end = $items->{'selfenroll_end_date'};	$selfenroll_end = $items->{'selfenroll_end_date'};
	$created = $items->{'created'};
	$context = $items->{'context'};
if ($selfenrollonly) {	if ($selfenrollonly) {
next if (!$selfenroll_types);	next if (!$selfenroll_types);
if (($selfenroll_end > 0) && ($selfenroll_end <= $now)) {	if (($selfenroll_end > 0) && ($selfenroll_end <= $now)) {
next;	next;
}	}
}	}
	if ($creationcontext ne '.') {
	next if (($context ne '') && ($context ne $creationcontext));
	}
	if ($createdbefore > 0) {
	next if (($created eq '') \|\| ($created > $createdbefore));
	}
	if ($createdafter > 0) {
	next if (($created eq '') \|\| ($created <= $createdafter));
	}
if ($catfilter ne '') {	if ($catfilter ne '') {
next if ($items->{'categories'} eq '');	next if ($items->{'categories'} eq '');
my @categories = split('&',$items->{'categories'});	my @categories = split('&',$items->{'categories'});
Line 3807 sub dump_course_id_handler {	Line 4161 sub dump_course_id_handler {
}	}
} else {	} else {
next if ($catfilter ne '');	next if ($catfilter ne '');
next if ($selfenrollonly);	next if ($selfenrollonly);
	next if ($createdbefore \|\| $createdafter);
	next if ($creationcontext ne '.');
	if ((defined($clonerudom)) && (defined($cloneruname))) {
	if ($cc_clone{$unesc_key}) {
	$canclone = 1;
	$val{'cloners'} = &escape($cloneruname.':'.$clonerudom);
	}
	}
$is_hash = 0;	$is_hash = 0;
my @courseitems = split(/:/,$value);	my @courseitems = split(/:/,$value);
$lasttime = pop(@courseitems);	$lasttime = pop(@courseitems);
Line 3816 sub dump_course_id_handler {	Line 4178 sub dump_course_id_handler {
}	}
($val{'descr'},$val{'inst_code'},$val{'owner'},$val{'type'}) = @courseitems;	($val{'descr'},$val{'inst_code'},$val{'owner'},$val{'type'}) = @courseitems;
}	}
	if ($cloneonly) {
	next unless ($canclone);
	}
my $match = 1;	my $match = 1;
if ($description ne '.') {	if ($description ne '.') {
if (!$is_hash) {	if (!$is_hash) {
Line 3829 sub dump_course_id_handler {	Line 4194 sub dump_course_id_handler {
if (!$is_hash) {	if (!$is_hash) {
$unesc_val{'inst_code'} = &unescape($val{'inst_code'});	$unesc_val{'inst_code'} = &unescape($val{'inst_code'});
}	}
if ($regexp_ok) {	if ($regexp_ok == 1) {
if (eval{$unesc_val{'inst_code'} !~ /$instcodefilter/}) {	if (eval{$unesc_val{'inst_code'} !~ /$instcodefilter/}) {
$match = 0;	$match = 0;
}	}
	} elsif ($regexp_ok == -1) {
	if (eval{$unesc_val{'inst_code'} =~ /$instcodefilter/}) {
	$match = 0;
	}
} else {	} else {
if (eval{$unesc_val{'inst_code'} !~ /\Q$instcodefilter\E/i}) {	if (eval{$unesc_val{'inst_code'} !~ /\Q$instcodefilter\E/i}) {
$match = 0;	$match = 0;
Line 3898 sub dump_course_id_handler {	Line 4267 sub dump_course_id_handler {
if ($match == 1) {	if ($match == 1) {
if ($rtn_as_hash) {	if ($rtn_as_hash) {
if ($is_hash) {	if ($is_hash) {
$qresult.=$key.'='.$value.'&';	if ($valchange) {
	my $newvalue = &Apache::lonnet::freeze_escape($items);
	$qresult.=$key.'='.$newvalue.'&';
	} else {
	$qresult.=$key.'='.$value.'&';
	}
} else {	} else {
my %rtnhash = ( 'description' => &unescape($val{'descr'}),	my %rtnhash = ( 'description' => &unescape($val{'descr'}),
'inst_code' => &unescape($val{'inst_code'}),	'inst_code' => &unescape($val{'inst_code'}),
'owner' => &unescape($val{'owner'}),	'owner' => &unescape($val{'owner'}),
'type' => &unescape($val{'type'}),	'type' => &unescape($val{'type'}),
	'cloners' => &unescape($val{'cloners'}),
);	);
my $items = &Apache::lonnet::freeze_escape(\%rtnhash);	my $items = &Apache::lonnet::freeze_escape(\%rtnhash);
$qresult.=$key.'='.$items.'&';	$qresult.=$key.'='.$items.'&';
Line 3935 sub dump_course_id_handler {	Line 4310 sub dump_course_id_handler {
}	}
&register_handler("courseiddump", \&dump_course_id_handler, 0, 1, 0);	&register_handler("courseiddump", \&dump_course_id_handler, 0, 1, 0);

	sub course_lastaccess_handler {
	my ($cmd, $tail, $client) = @_;
	my $userinput = "$cmd:$tail";
	my ($cdom,$cnum) = split(':',$tail);
	my (%lastaccess,$qresult);
	my $hashref = &tie_domain_hash($cdom, "nohist_courseids", &GDBM_WRCREAT());
	if ($hashref) {
	while (my ($key,$value) = each(%$hashref)) {
	my ($unesc_key,$lasttime);
	$unesc_key = &unescape($key);
	if ($cnum) {
	next unless ($unesc_key =~ /\Q$cdom\E_\Q$cnum\E$/);
	}
	if ($unesc_key =~ /^lasttime:($LONCAPA::match_domain\_$LONCAPA::match_courseid)/) {
	$lastaccess{$1} = $value;
	} else {
	my $items = &Apache::lonnet::thaw_unescape($value);
	if (ref($items) eq 'HASH') {
	unless ($lastaccess{$unesc_key}) {
	$lastaccess{$unesc_key} = '';
	}
	} else {
	my @courseitems = split(':',$value);
	$lastaccess{$unesc_key} = pop(@courseitems);
	}
	}
	}
	foreach my $cid (sort(keys(%lastaccess))) {
	$qresult.=&escape($cid).'='.$lastaccess{$cid}.'&';
	}
	if (&untie_domain_hash($hashref)) {
	if ($qresult) {
	chop($qresult);
	}
	&Reply($client, \$qresult, $userinput);
	} else {
	&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
	"while attempting lastacourseaccess\n", $userinput);
	}
	} else {
	&Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
	"while attempting lastcourseaccess\n", $userinput);
	}
	return 1;
	}
	&register_handler("courselastaccess",\&course_lastaccess_handler, 0, 1, 0);

#	#
# Puts an unencrypted entry in a namespace db file at the domain level	# Puts an unencrypted entry in a namespace db file at the domain level
#	#
Line 4000 sub put_domain_handler {	Line 4422 sub put_domain_handler {
sub get_domain_handler {	sub get_domain_handler {
my ($cmd, $tail, $client) = @_;	my ($cmd, $tail, $client) = @_;


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

my ($udom,$namespace,$what)=split(/:/,$tail,3);	my ($udom,$namespace,$what)=split(/:/,$tail,3);
Line 4027 sub get_domain_handler {	Line 4450 sub get_domain_handler {
}	}
&register_handler("getdom", \&get_domain_handler, 0, 1, 0);	&register_handler("getdom", \&get_domain_handler, 0, 1, 0);


#	#
# Puts an id to a domains id database.	# Puts an id to a domains id database.
#	#
Line 4145 sub get_id_handler {	Line 4567 sub get_id_handler {
sub put_dcmail_handler {	sub put_dcmail_handler {
my ($cmd,$tail,$client) = @_;	my ($cmd,$tail,$client) = @_;
my $userinput = "$cmd:$tail";	my $userinput = "$cmd:$tail";


my ($udom,$what)=split(/:/,$tail);	my ($udom,$what)=split(/:/,$tail);
chomp($what);	chomp($what);
my $hashref = &tie_domain_hash($udom, "nohist_dcmail", &GDBM_WRCREAT());	my $hashref = &tie_domain_hash($udom, "nohist_dcmail", &GDBM_WRCREAT());
Line 4334 sub dump_domainroles_handler {	Line 4757 sub dump_domainroles_handler {
$rolesfilter=&unescape($rolesfilter);	$rolesfilter=&unescape($rolesfilter);
@roles = split(/\&/,$rolesfilter);	@roles = split(/\&/,$rolesfilter);
}	}

my $hashref = &tie_domain_hash($udom, "nohist_domainroles", &GDBM_WRCREAT());	my $hashref = &tie_domain_hash($udom, "nohist_domainroles", &GDBM_WRCREAT());
if ($hashref) {	if ($hashref) {
my $qresult = '';	my $qresult = '';
while (my ($key,$value) = each(%$hashref)) {	while (my ($key,$value) = each(%$hashref)) {
my $match = 1;	my $match = 1;
my ($start,$end) = split(/:/,&unescape($value));	my ($end,$start) = split(/:/,&unescape($value));
my ($trole,$uname,$udom,$runame,$rudom,$rsec) = split(/:/,&unescape($key));	my ($trole,$uname,$udom,$runame,$rudom,$rsec) = split(/:/,&unescape($key));
unless ($startfilter eq '.' \|\| !defined($startfilter)) {	unless (@roles < 1) {
if ((defined($start)) && ($start >= $startfilter)) {	unless (grep/^\Q$trole\E$/,@roles) {
$match = 0;	$match = 0;
	next;
}	}
}	}
unless ($endfilter eq '.' \|\| !defined($endfilter)) {	unless ($startfilter eq '.' \|\| !defined($startfilter)) {
if ((defined($end)) && ($end <= $endfilter)) {	if ((defined($start)) && ($start >= $startfilter)) {
$match = 0;	$match = 0;
	next;
}	}
}	}
unless (@roles < 1) {	unless ($endfilter eq '.' \|\| !defined($endfilter)) {
unless (grep/^\Q$trole\E$/,@roles) {	if ((defined($end)) && (($end > 0) && ($end <= $endfilter))) {
$match = 0;	$match = 0;
	next;
}	}
}	}
if ($match == 1) {	if ($match == 1) {
Line 4406 sub tmp_put_handler {	Line 4832 sub tmp_put_handler {
}	}
my ($id,$store);	my ($id,$store);
$tmpsnum++;	$tmpsnum++;
if ($context eq 'resetpw') {	if (($context eq 'resetpw') \|\| ($context eq 'createaccount')) {
$id = &md5_hex(&md5_hex(time.{}.rand().$$));	$id = &md5_hex(&md5_hex(time.{}.rand().$$));
} else {	} else {
$id = $$.'_'.$clientip.'_'.$tmpsnum;	$id = $$.'_'.$clientip.'_'.$tmpsnum;
Line 4641 sub enrollment_enabled_handler {	Line 5067 sub enrollment_enabled_handler {
}	}
&register_handler("autorun", \&enrollment_enabled_handler, 0, 1, 0);	&register_handler("autorun", \&enrollment_enabled_handler, 0, 1, 0);

	#
	# Validate an institutional code used for a LON-CAPA course.
	#
	# Formal Parameters:
	# $cmd - The command request that got us dispatched.
	# $tail - The tail of the command. In this case,
	# this is a colon separated set of words that will be split
	# into:
	# $dom - The domain for which the check of
	# institutional course code will occur.
	#
	# $instcode - The institutional code for the course
	# being requested, or validated for rights
	# to request.
	#
	# $owner - The course requestor (who will be the
	# course owner, in the form username:domain
	#
	# $client - Socket open on the client.
	# Returns:
	# 1 - Indicating processing should continue.
	#
	sub validate_instcode_handler {
	my ($cmd, $tail, $client) = @_;
	my $userinput = "$cmd:$tail";
	my ($dom,$instcode,$owner) = split(/:/, $tail);
	$instcode = &unescape($instcode);
	$owner = &unescape($owner);
	my ($outcome,$description) =
	&localenroll::validate_instcode($dom,$instcode,$owner);
	my $result = &escape($outcome).'&'.&escape($description);
	&Reply($client, \$result, $userinput);

	return 1;
	}
	&register_handler("autovalidateinstcode", \&validate_instcode_handler, 0, 1, 0);

# Get the official sections for which auto-enrollment is possible.	# Get the official sections for which auto-enrollment is possible.
# Since the admin people won't know about 'unofficial sections'	# Since the admin people won't know about 'unofficial sections'
# we cannot auto-enroll on them.	# we cannot auto-enroll on them.
Line 4687 sub get_sections_handler {	Line 5150 sub get_sections_handler {
sub validate_course_owner_handler {	sub validate_course_owner_handler {
my ($cmd, $tail, $client) = @_;	my ($cmd, $tail, $client) = @_;
my $userinput = "$cmd:$tail";	my $userinput = "$cmd:$tail";
my ($inst_course_id, $owner, $cdom) = split(/:/, $tail);	my ($inst_course_id, $owner, $cdom, $coowners) = split(/:/, $tail);

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


Line 4844 sub retrieve_auto_file_handler {	Line 5308 sub retrieve_auto_file_handler {
}	}
&register_handler("autoretrieve", \&retrieve_auto_file_handler, 0,1,0);	&register_handler("autoretrieve", \&retrieve_auto_file_handler, 0,1,0);

	sub crsreq_checks_handler {
	my ($cmd, $tail, $client) = @_;
	my $userinput = "$cmd:$tail";
	my $dom = $tail;
	my $result;
	my @reqtypes = ('official','unofficial','community');
	eval {
	local($SIG{__DIE__})='DEFAULT';
	my %validations;
	my $response = &localenroll::crsreq_checks($dom,\@reqtypes,
	\%validations);
	if ($response eq 'ok') {
	foreach my $key (keys(%validations)) {
	$result .= &escape($key).'='.&Apache::lonnet::freeze_escape($validations{$key}).'&';
	}
	$result =~ s/\&$//;
	} else {
	$result = 'error';
	}
	};
	if (!$@) {
	&Reply($client, \$result, $userinput);
	} else {
	&Failure($client,"unknown_cmd\n",$userinput);
	}
	return 1;
	}
	&register_handler("autocrsreqchecks", \&crsreq_checks_handler, 0, 1, 0);

	sub validate_crsreq_handler {
	my ($cmd, $tail, $client) = @_;
	my $userinput = "$cmd:$tail";
	my ($dom,$owner,$crstype,$inststatuslist,$instcode,$instseclist) = split(/:/, $tail);
	$instcode = &unescape($instcode);
	$owner = &unescape($owner);
	$crstype = &unescape($crstype);
	$inststatuslist = &unescape($inststatuslist);
	$instcode = &unescape($instcode);
	$instseclist = &unescape($instseclist);
	my $outcome;
	eval {
	local($SIG{__DIE__})='DEFAULT';
	$outcome = &localenroll::validate_crsreq($dom,$owner,$crstype,
	$inststatuslist,$instcode,
	$instseclist);
	};
	if (!$@) {
	&Reply($client, \$outcome, $userinput);
	} else {
	&Failure($client,"unknown_cmd\n",$userinput);
	}
	return 1;
	}
	&register_handler("autocrsreqvalidation", \&validate_crsreq_handler, 0, 1, 0);

#	#
# Read and retrieve institutional code format (for support form).	# Read and retrieve institutional code format (for support form).
# Formal Parameters:	# Formal Parameters:
Line 4934 sub get_possible_instcodes_handler {	Line 5453 sub get_possible_instcodes_handler {

my $reply;	my $reply;
my $cdom = $tail;	my $cdom = $tail;
my (@codetitles,%cat_titles,%cat_order);	my (@codetitles,%cat_titles,%cat_order,@code_order);
my $formatreply = &localenroll::possible_instcodes($cdom,	my $formatreply = &localenroll::possible_instcodes($cdom,
\@codetitles,	\@codetitles,
\%cat_titles,	\%cat_titles,
\%cat_order);	\%cat_order,
	\@code_order);
if ($formatreply eq 'ok') {	if ($formatreply eq 'ok') {
my $result = join('&',map {&escape($_);} (@codetitles)).':';	my $result = join('&',map {&escape($_);} (@codetitles)).':';
	$result .= join('&',map {&escape($_);} (@code_order)).':';
foreach my $key (keys(%cat_titles)) {	foreach my $key (keys(%cat_titles)) {
$result .= &escape($key).'='.&Apache::lonnet::freeze_escape($cat_titles{$key}).'&';	$result .= &escape($key).'='.&Apache::lonnet::freeze_escape($cat_titles{$key}).'&';
}	}
Line 5621 if (-e $pidfile) {	Line 6142 if (-e $pidfile) {
$server = IO::Socket::INET->new(LocalPort => $perlvar{'londPort'},	$server = IO::Socket::INET->new(LocalPort => $perlvar{'londPort'},
Type => SOCK_STREAM,	Type => SOCK_STREAM,
Proto => 'tcp',	Proto => 'tcp',
Reuse => 1,	ReuseAddr => 1,
Listen => 10 )	Listen => 10 )
or die "making socket: $@\n";	or die "making socket: $@\n";

Line 5684 sub HUPSMAN { # sig	Line 6205 sub HUPSMAN { # sig
# 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.
#	#
sub ReloadApache {	sub ReloadApache {
my $execdir = $perlvar{'lonDaemons'};	# --------------------------- Handle case of another apachereload process (locking)
my $script = $execdir."/apachereload";	if (&LONCAPA::try_to_lock('/tmp/lock_apachereload')) {
system($script);	my $execdir = $perlvar{'lonDaemons'};
	my $script = $execdir."/apachereload";
	system($script);
	unlink('/tmp/lock_apachereload'); # Remove the lock file.
	}
}	}

#	#
Line 5797 sub Debug {	Line 6322 sub Debug {
# reply - Text to send to client.	# reply - Text to send to client.
# request - Original request from client.	# request - Original request from client.
#	#
	#NOTE $reply must be terminated by exactly one \n. If $reply is a reference
	#this is done automatically ($$reply must not contain any \n in this case).
	#If $reply is a string the caller has to ensure this.
sub Reply {	sub Reply {
my ($fd, $reply, $request) = @_;	my ($fd, $reply, $request) = @_;
if (ref($reply)) {	if (ref($reply)) {
Line 5859 sub logstatus {	Line 6387 sub logstatus {
sub initnewstatus {	sub initnewstatus {
my $docdir=$perlvar{'lonDocRoot'};	my $docdir=$perlvar{'lonDocRoot'};
my $fh=IO::File->new(">$docdir/lon-status/londstatus.txt");	my $fh=IO::File->new(">$docdir/lon-status/londstatus.txt");
my $now=time;	my $now=time();
my $local=localtime($now);	my $local=localtime($now);
print $fh "LOND status $local - parent $$\n\n";	print $fh "LOND status $local - parent $$\n\n";
opendir(DIR,"$docdir/lon-status/londchld");	opendir(DIR,"$docdir/lon-status/londchld");
Line 5948 $SIG{USR2} = \&UpdateHosts;	Line 6476 $SIG{USR2} = \&UpdateHosts;

# Read the host hashes:	# Read the host hashes:
&Apache::lonnet::load_hosts_tab();	&Apache::lonnet::load_hosts_tab();
	my %iphost = &Apache::lonnet::get_iphost(1);

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

	my $arch = `uname -i`;
	chomp($arch);
	if ($arch eq 'unknown') {
	$arch = `uname -m`;
	chomp($arch);
	}

# --------------------------------------------------------------	# --------------------------------------------------------------
# Accept connections. When a connection comes in, it is validated	# Accept connections. When a connection comes in, it is validated
Line 6008 sub make_new_child {	Line 6544 sub make_new_child {
or die "Can't unblock SIGINT for fork: $!\n";	or die "Can't unblock SIGINT for fork: $!\n";
$children{$pid} = $clientip;	$children{$pid} = $clientip;
&status('Started child '.$pid);	&status('Started child '.$pid);
	close($client);
return;	return;
} else {	} else {
# Child can not return from this subroutine.	# Child can not return from this subroutine.
Line 6016 sub make_new_child {	Line 6553 sub make_new_child {
#don't get intercepted	#don't get intercepted
$SIG{USR1}= \&logstatus;	$SIG{USR1}= \&logstatus;
$SIG{ALRM}= \&timeout;	$SIG{ALRM}= \&timeout;
	#
	# Block sigpipe as it gets thrownon socket disconnect and we want to
	# deal with that as a read faiure instead.
	#
	my $blockset = POSIX::SigSet->new(SIGPIPE);
	sigprocmask(SIG_BLOCK, $blockset);

$lastlog='Forked ';	$lastlog='Forked ';
$status='Forked';	$status='Forked';

Line 6044 sub make_new_child {	Line 6588 sub make_new_child {
&ReadManagerTable();	&ReadManagerTable();
my $clientrec=defined(&Apache::lonnet::get_hosts_from_ip($outsideip));	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 = "[unknown]";
if($clientrec) { # Establish client type.	if($clientrec) { # Establish client type.
$ConnectionType = "client";	$ConnectionType = "client";
$clientname = (&Apache::lonnet::get_hosts_from_ip($outsideip))[-1];	$clientname = (&Apache::lonnet::get_hosts_from_ip($outsideip))[-1];
Line 6072 sub make_new_child {	Line 6616 sub make_new_child {
#	#
# If the remote is attempting a local init... give that a try:	# If the remote is attempting a local init... give that a try:
#	#
my ($i, $inittype) = split(/:/, $remotereq);	(my $i, my $inittype, $clientversion) = split(/:/, $remotereq);

# If the connection type is ssl, but I didn't get my	# If the connection type is ssl, but I didn't get my
# certificate files yet, then I'll drop back to	# certificate files yet, then I'll drop back to
Line 6092 sub make_new_child {	Line 6636 sub make_new_child {
}	}

if($inittype eq "local") {	if($inittype eq "local") {
	$clientversion = $perlvar{'lonVersion'};
my $key = LocalConnection($client, $remotereq);	my $key = LocalConnection($client, $remotereq);
if($key) {	if($key) {
Debug("Got local key $key");	Debug("Got local key $key");
Line 6099 sub make_new_child {	Line 6644 sub make_new_child {
my $cipherkey = pack("H32", $key);	my $cipherkey = pack("H32", $key);
$cipher = new IDEA($cipherkey);	$cipher = new IDEA($cipherkey);
print $client "ok:local\n";	print $client "ok:local\n";
&logthis('<font color="green"'	&logthis('<font color="green">'
. "Successful local authentication </font>");	. "Successful local authentication </font>");
$keymode = "local"	$keymode = "local"
} else {	} else {
Line 6163 sub make_new_child {	Line 6708 sub make_new_child {
# ------------------------------------------------------------ Process requests	# ------------------------------------------------------------ Process requests
my $keep_going = 1;	my $keep_going = 1;
my $user_input;	my $user_input;
	my $clienthost = &Apache::lonnet::hostname($clientname);
	my $clientserverhomeID = &Apache::lonnet::get_server_homeID($clienthost);
	$clienthomedom = &Apache::lonnet::host_domain($clientserverhomeID);
while(($user_input = get_request) && $keep_going) {	while(($user_input = get_request) && $keep_going) {
alarm(120);	alarm(120);
Debug("Main: Got $user_input\n");	Debug("Main: Got $user_input\n");
Line 6212 sub is_author {	Line 6760 sub is_author {

# Author role should show up as a key /domain/_au	# Author role should show up as a key /domain/_au

my $key = "/$domain/_au";
my $value;	my $value;
if (defined($hashref)) {	if ($hashref) {
$value = $hashref->{$key};
}

if(defined($value)) {	my $key = "/$domain/_au";
&Debug("$user @ $domain is an author");	if (defined($hashref)) {
	$value = $hashref->{$key};
	if(!untie_user_hash($hashref)) {
	return 'error: ' . ($!+0)." untie (GDBM) Failed";
	}
	}

	if(defined($value)) {
	&Debug("$user @ $domain is an author");
	}
	} else {
	return 'error: '.($!+0)." tie (GDBM) Failed";
}	}

return defined($value);	return defined($value);
}	}
#	#
# Checks to see if the input roleput request was to set	# Checks to see if the input roleput request was to set
# an author role. If so, invokes the lchtmldir script to set	# an author role. If so, creates construction space
# up a correct public_html
# Parameters:	# Parameters:
# request - The request sent to the rolesput subchunk.	# request - The request sent to the rolesput subchunk.
# We're looking for /domain/_au	# We're looking for /domain/_au
Line 6237 sub is_author {	Line 6792 sub is_author {
#	#
sub manage_permissions {	sub manage_permissions {
my ($request, $domain, $user, $authtype) = @_;	my ($request, $domain, $user, $authtype) = @_;

&Debug("manage_permissions: $request $domain $user $authtype");

# See if the request is of the form /$domain/_au	# See if the request is of the form /$domain/_au
if($request =~ /^(\/\Q$domain\E\/_au)$/) { # It's an author rolesput...	if($request =~ /^(\/\Q$domain\E\/_au)$/) { # It's an author rolesput...
my $execdir = $perlvar{'lonDaemons'};	my $path=$perlvar{'lonDocRoot'}."/priv/$domain";
my $userhome= "/home/$user" ;	unless (-e $path) {
&logthis("system $execdir/lchtmldir $userhome $user $authtype");	mkdir($path);
&Debug("Setting homedir permissions for $userhome");	}
system("$execdir/lchtmldir $userhome $user $authtype");	unless (-e $path.'/'.$user) {
	mkdir($path.'/'.$user);
	}
}	}
}	}

Line 6321 sub rewrite_password_file {	Line 6875 sub rewrite_password_file {

# Returns the authorization type or nouser if there is no such user.	# Returns the authorization type or nouser if there is no such user.
#	#
sub get_auth_type	sub get_auth_type {
{

my ($domain, $user) = @_;	my ($domain, $user) = @_;

Debug("get_auth_type( $domain, $user ) \n");	Debug("get_auth_type( $domain, $user ) \n");
Line 6418 sub validate_user {	Line 6970 sub validate_user {
} else {	} else {
$validated = 0;	$validated = 0;
}	}
}	} elsif ($howpwd eq "krb4") { # user is in kerberos 4 auth. domain.
elsif ($howpwd eq "krb4") { # user is in kerberos 4 auth. domain.	my $checkwithkrb5 = 0;
if(! ($password =~ /$null/) ) {	if ($dist =~/^fedora(\d+)$/) {
my $k4error = &Authen::Krb4::get_pw_in_tkt($user,	if ($1 > 11) {
"",	$checkwithkrb5 = 1;
$contentpwd,,	}
'krbtgt',	} elsif ($dist =~ /^suse([\d.]+)$/) {
$contentpwd,	if ($1 > 11.1) {
1,	$checkwithkrb5 = 1;
$password);	}
if(!$k4error) {	}
$validated = 1;	if ($checkwithkrb5) {
} else {	$validated = &krb5_authen($password,$null,$user,$contentpwd);
$validated = 0;	} else {
&logthis('krb4: '.$user.', '.$contentpwd.', '.	$validated = &krb4_authen($password,$null,$user,$contentpwd);
&Authen::Krb4::get_err_txt($Authen::Krb4::error));	}
}
} else {
$validated = 0; # Password has a match with null.
}
} elsif ($howpwd eq "krb5") { # User is in kerberos 5 auth. domain.	} elsif ($howpwd eq "krb5") { # User is in kerberos 5 auth. domain.
if(!($password =~ /$null/)) { # Null password not allowed.	$validated = &krb5_authen($password,$null,$user,$contentpwd);
my $krbclient = &Authen::Krb5::parse_name($user.'@'
.$contentpwd);
my $krbservice = "krbtgt/".$contentpwd."\@".$contentpwd;
my $krbserver = &Authen::Krb5::parse_name($krbservice);
my $credentials= &Authen::Krb5::cc_default();
$credentials->initialize(&Authen::Krb5::parse_name($user.'@'
.$contentpwd));
my $krbreturn;
if (exists(&Authen::Krb5::get_init_creds_password)) {
$krbreturn =
&Authen::Krb5::get_init_creds_password($krbclient,$password,
$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 {
$validated = 0;
}
} elsif ($howpwd eq "localauth") {	} elsif ($howpwd eq "localauth") {
# Authenticate via installation specific authentcation method:	# Authenticate via installation specific authentcation method:
$validated = &localauth::localauth($user,	$validated = &localauth::localauth($user,
Line 6496 sub validate_user {	Line 7018 sub validate_user {
return $validated;	return $validated;
}	}

	sub krb4_authen {
	my ($password,$null,$user,$contentpwd) = @_;
	my $validated = 0;
	if (!($password =~ /$null/) ) { # Null password not allowed.
	eval {
	require Authen::Krb4;
	};
	if (!$@) {
	my $k4error = &Authen::Krb4::get_pw_in_tkt($user,
	"",
	$contentpwd,,
	'krbtgt',
	$contentpwd,
	1,
	$password);
	if(!$k4error) {
	$validated = 1;
	} else {
	$validated = 0;
	&logthis('krb4: '.$user.', '.$contentpwd.', '.
	&Authen::Krb4::get_err_txt($Authen::Krb4::error));
	}
	} else {
	$validated = krb5_authen($password,$null,$user,$contentpwd);
	}
	}
	return $validated;
	}

	sub krb5_authen {
	my ($password,$null,$user,$contentpwd) = @_;
	my $validated = 0;
	if(!($password =~ /$null/)) { # Null password not allowed.
	my $krbclient = &Authen::Krb5::parse_name($user.'@'
	.$contentpwd);
	my $krbservice = "krbtgt/".$contentpwd."\@".$contentpwd;
	my $krbserver = &Authen::Krb5::parse_name($krbservice);
	my $credentials= &Authen::Krb5::cc_default();
	$credentials->initialize(&Authen::Krb5::parse_name($user.'@'
	.$contentpwd));
	my $krbreturn;
	if (exists(&Authen::Krb5::get_init_creds_password)) {
	$krbreturn =
	&Authen::Krb5::get_init_creds_password($krbclient,$password,
	$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());
	}
	}
	return $validated;
	}

sub addline {	sub addline {
my ($fname,$hostid,$ip,$newline)=@_;	my ($fname,$hostid,$ip,$newline)=@_;
Line 6708 sub subscribe {	Line 7289 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://".&Apache::lonnet::hostname($perlvar{'lonHostID'})."/".$fname;	my $protocol = $Apache::lonnet::protocol{$perlvar{'lonHostID'}};
	$protocol = 'http' if ($protocol ne 'https');
	$fname=$protocol.'://'.&Apache::lonnet::hostname($perlvar{'lonHostID'})."/".$fname;
$result="$fname\n";	$result="$fname\n";
}	}
} else {	} else {
Line 6750 sub change_unix_password {	Line 7333 sub change_unix_password {


sub make_passwd_file {	sub make_passwd_file {
my ($uname, $umode,$npass,$passfilename)=@_;	my ($uname,$udom,$umode,$npass,$passfilename)=@_;
my $result="ok";	my $result="ok";
if ($umode eq 'krb4' or $umode eq 'krb5') {	if ($umode eq 'krb4' or $umode eq 'krb5') {
{	{
Line 6791 sub make_passwd_file {	Line 7374 sub make_passwd_file {
#	#
my $uid = getpwnam($uname);	my $uid = getpwnam($uname);
if((defined $uid) && ($uid == 0)) {	if((defined $uid) && ($uid == 0)) {
&logthis(">>>Attempted to create privilged account blocked");	&logthis(">>>Attempt to create privileged account blocked");
return "no_priv_account_error\n";	return "no_priv_account_error\n";
}	}

Line 6803 sub make_passwd_file {	Line 7386 sub make_passwd_file {
&Debug("user = ".$uname.", Password =". $npass);	&Debug("user = ".$uname.", Password =". $npass);
my $se = IO::File->new("\|$execpath > $perlvar{'lonDaemons'}/logs/lcuseradd.log");	my $se = IO::File->new("\|$execpath > $perlvar{'lonDaemons'}/logs/lcuseradd.log");
print $se "$uname\n";	print $se "$uname\n";
	print $se "$udom\n";
print $se "$npass\n";	print $se "$npass\n";
print $se "$npass\n";	print $se "$npass\n";
print $se "$lc_error_file\n"; # Status -> unique file.	print $se "$lc_error_file\n"; # Status -> unique file.
Line 6866 sub sethost {	Line 7450 sub sethost {
eq &Apache::lonnet::get_host_ip($hostid)) {	eq &Apache::lonnet::get_host_ip($hostid)) {
$currenthostid =$hostid;	$currenthostid =$hostid;
$currentdomainid=&Apache::lonnet::host_domain($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 ".
$perlvar{'lonHostID'}." refusing connection");	$perlvar{'lonHostID'}." refusing connection");
Line 6881 sub version {	Line 7465 sub version {
return "version:$VERSION";	return "version:$VERSION";
}	}

	sub get_usersession_config {
	my ($dom,$name) = @_;
	my ($usersessionconf,$cached)=&Apache::lonnet::is_cached_new($name,$dom);
	if (defined($cached)) {
	return $usersessionconf;
	} else {
	my %domconfig = &Apache::lonnet::get_dom('configuration',['usersessions'],$dom);
	if (ref($domconfig{'usersessions'}) eq 'HASH') {
	&Apache::lonnet::do_cache_new($name,$dom,$domconfig{'usersessions'},3600);
	return $domconfig{'usersessions'};
	}
	}
	return;
	}

	#
	# releasereqd_check() will determine if a LON-CAPA version (defined in the
	# $major,$minor args passed) is not too old to allow use of a role in a
	# course ($cnum,$cdom args passed), if at least one of the following applies:
	# (a) the course is a Community, (b) the course's home server is not the
	# current server, or (c) cached course information is not stale.
	#
	# For the case where none of these apply, the course is added to the
	# $homecourse hash ref (keys = courseIDs, values = array of a hash of roles).
	# The $homecourse hash ref is for courses for which the current server is the
	# home server. LON-CAPA version requirements are checked elsewhere for the
	# items in $homecourse.
	#

	sub releasereqd_check {
	my ($cnum,$cdom,$key,$value,$major,$minor,$homecourses,$ids) = @_;
	my $home = &Apache::lonnet::homeserver($cnum,$cdom);
	return if ($home eq 'no_host');
	my ($reqdmajor,$reqdminor,$displayrole);
	if ($cnum =~ /$LONCAPA::match_community/) {
	if ($major eq '' && $minor eq '') {
	return unless ((ref($ids) eq 'ARRAY') &&
	(grep(/^\Q$home\E$/,@{$ids})));
	} else {
	$reqdmajor = 2;
	$reqdminor = 9;
	return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor));
	}
	}
	my $hashid = $cdom.':'.$cnum;
	my ($courseinfo,$cached) =
	&Apache::lonnet::is_cached_new('courseinfo',$hashid);
	if (defined($cached)) {
	if (ref($courseinfo) eq 'HASH') {
	if (exists($courseinfo->{'releaserequired'})) {
	my ($reqdmajor,$reqdminor) = split(/\./,$courseinfo->{'releaserequired'});
	return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor));
	}
	}
	} else {
	if (ref($ids) eq 'ARRAY') {
	if (grep(/^\Q$home\E$/,@{$ids})) {
	if (ref($homecourses) eq 'HASH') {
	if (ref($homecourses->{$cdom}) eq 'HASH') {
	if (ref($homecourses->{$cdom}{$cnum}) eq 'HASH') {
	if (ref($homecourses->{$cdom}{$cnum}) eq 'ARRAY') {
	push(@{$homecourses->{$cdom}{$cnum}},{$key=>$value});
	} else {
	$homecourses->{$cdom}{$cnum} = [{$key=>$value}];
	}
	} else {
	$homecourses->{$cdom}{$cnum} = [{$key=>$value}];
	}
	} else {
	$homecourses->{$cdom}{$cnum} = [{$key=>$value}];
	}
	}
	return;
	}
	}
	my $courseinfo = &get_courseinfo_hash($cnum,$cdom,$home);
	if (ref($courseinfo) eq 'HASH') {
	if (exists($courseinfo->{'releaserequired'})) {
	my ($reqdmajor,$reqdminor) = split(/\./,$courseinfo->{'releaserequired'});
	return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor));
	}
	} else {
	return;
	}
	}
	return 1;
	}

	#
	# get_courseinfo_hash() is used to retrieve course information from the db
	# file: nohist_courseids.db for a course for which the current server is not
	# the home server.
	#
	# A hash of a hash will be retrieved. The outer hash contains a single key --
	# courseID -- for the course for which the data are being requested.
	# The contents of the inner hash, for that single item in the outer hash
	# are returned (and cached in memcache for 10 minutes).
	#

	sub get_courseinfo_hash {
	my ($cnum,$cdom,$home) = @_;
	my %info;
	eval {
	local($SIG{ALRM}) = sub { die "timeout\n"; };
	local($SIG{__DIE__})='DEFAULT';
	alarm(3);
	%info = &Apache::lonnet::courseiddump($cdom,'.',1,'.','.',$cnum,1,[$home],'.');
	alarm(0);
	};
	if ($@) {
	if ($@ eq "timeout\n") {
	&logthis("<font color='blue'>WARNING courseiddump for $cnum:$cdom from $home timedout</font>");
	} else {
	&logthis("<font color='yellow'>WARNING unexpected error during eval of call for courseiddump from $home</font>");
	}
	} else {
	if (ref($info{$cdom.'_'.$cnum}) eq 'HASH') {
	my $hashid = $cdom.':'.$cnum;
	return &Apache::lonnet::do_cache_new('courseinfo',$hashid,$info{$cdom.'_'.$cnum},600);
	}
	}
	return;
	}

	#
	# check_homecourses() will retrieve course information for those courses which
	# are keys of the $homecourses hash ref (first arg). The nohist_courseids.db
	# GDBM file is tied and course information for each course retrieved. Last
	# visit (lasttime key) is also retrieved for each, and cached values updated
	# for any courses last visited less than 24 hours ago. Cached values are also
	# updated for any courses included in the $homecourses hash ref.
	#
	# The reason for the 24 hours constraint is that the cron entry in
	# /etc/cron.d/loncapa for /home/httpd/perl/refresh_courseids_db.pl causes
	# cached course information to be updated nightly for courses with activity
	# within the past 24 hours.
	#
	# Role information for the user (included in a ref to an array of hashes as the
	# value for each key in $homecourses) is appended to the result returned by the
	# routine, which will in turn be appended to the string returned to the client
	# hosting the user's session.
	#

	sub check_homecourses {
	my ($homecourses,$regexp,$count,$range,$start,$end,$major,$minor) = @_;
	my ($result,%addtocache);
	my $yesterday = time - 24*3600;
	if (ref($homecourses) eq 'HASH') {
	my (%okcourses,%courseinfo,%recent);
	foreach my $domain (keys(%{$homecourses})) {
	my $hashref =
	&tie_domain_hash($domain, "nohist_courseids", &GDBM_WRCREAT());
	if (ref($hashref) eq 'HASH') {
	while (my ($key,$value) = each(%$hashref)) {
	my $unesc_key = &unescape($key);
	if ($unesc_key =~ /^lasttime:(\w+)$/) {
	my $cid = $1;
	$cid =~ s/_/:/;
	if ($value > $yesterday ) {
	$recent{$cid} = 1;
	}
	next;
	}
	my $items = &Apache::lonnet::thaw_unescape($value);
	if (ref($items) eq 'HASH') {
	my ($cdom,$cnum) = split(/_/,$unesc_key);
	my $hashid = $cdom.':'.$cnum;
	$courseinfo{$hashid} = $items;
	if (ref($homecourses->{$cdom}{$cnum}) eq 'ARRAY') {
	my ($reqdmajor,$reqdminor) = split(/\./,$items->{'releaserequired'});
	if (&useable_role($reqdmajor,$reqdminor,$major,$minor)) {
	$okcourses{$hashid} = 1;
	}
	}
	}
	}
	unless (&untie_domain_hash($hashref)) {
	&logthis("Failed to untie tied hash for nohist_courseids.db for $domain");
	}
	} else {
	&logthis("Failed to tie hash for nohist_courseids.db for $domain");
	}
	}
	foreach my $hashid (keys(%recent)) {
	my ($result,$cached)=&Apache::lonnet::is_cached_new('courseinfo',$hashid);
	unless ($cached) {
	&Apache::lonnet::do_cache_new('courseinfo',$hashid,$courseinfo{$hashid},600);
	}
	}
	foreach my $cdom (keys(%{$homecourses})) {
	if (ref($homecourses->{$cdom}) eq 'HASH') {
	foreach my $cnum (keys(%{$homecourses->{$cdom}})) {
	my $hashid = $cdom.':'.$cnum;
	next if ($recent{$hashid});
	&Apache::lonnet::do_cache_new('courseinfo',$hashid,$courseinfo{$hashid},600);
	}
	}
	}
	foreach my $hashid (keys(%okcourses)) {
	my ($cdom,$cnum) = split(/:/,$hashid);
	if ((ref($homecourses->{$cdom}) eq 'HASH') &&
	(ref($homecourses->{$cdom}{$cnum}) eq 'ARRAY')) {
	foreach my $role (@{$homecourses->{$cdom}{$cnum}}) {
	if (ref($role) eq 'HASH') {
	while (my ($key,$value) = each(%{$role})) {
	if ($regexp eq '.') {
	$count++;
	if (defined($range) && $count >= $end) { last; }
	if (defined($range) && $count < $start) { next; }
	$result.=$key.'='.$value.'&';
	} else {
	my $unescapeKey = &unescape($key);
	if (eval('$unescapeKey=~/$regexp/')) {
	$count++;
	if (defined($range) && $count >= $end) { last; }
	if (defined($range) && $count < $start) { next; }
	$result.="$key=$value&";
	}
	}
	}
	}
	}
	}
	}
	}
	return $result;
	}

	#
	# useable_role() will compare the LON-CAPA version required by a course with
	# the version available on the client server. If the client server's version
	# is compatible, 1 will be returned.
	#

	sub useable_role {
	my ($reqdmajor,$reqdminor,$major,$minor) = @_;
	if ($reqdmajor ne '' && $reqdminor ne '') {
	return if (($major eq '' && $minor eq '') \|\|
	($major < $reqdmajor) \|\|
	(($major == $reqdmajor) && ($minor < $reqdminor)));
	}
	return 1;
	}

	sub distro_and_arch {
	return $dist.':'.$arch;
	}

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

Line 7206 Authen::Krb5	Line 8037 Authen::Krb5

=head1 COREQUISITES	=head1 COREQUISITES

	none

=head1 OSNAMES	=head1 OSNAMES

linux	linux
Line 7293 or the CA's certificate in the call to l	Line 8126 or the CA's certificate in the call to l
<error> is the textual reason this failed. Usual reasons:	<error> is the textual reason this failed. Usual reasons:

=over 2	=over 2

=item Apache config file for loncapa incorrect:	=item Apache config file for loncapa incorrect:

one of the variables	one of the variables
lonCertificateDirectory, lonnetCertificateAuthority, or lonnetCertificate	lonCertificateDirectory, lonnetCertificateAuthority, or lonnetCertificate
undefined or incorrect	undefined or incorrect
Line 7414 Could not rewrite the	Line 8247 Could not rewrite the
internal password file for a user	internal password file for a user

=item Result of password change for <user> : <result>	=item Result of password change for <user> : <result>

A unix password change for <user> was attempted	A unix password change for <user> was attempted
and the pipe returned <result>	and the pipe returned <result>

Line 7443 lond has been asked to exit by its clien	Line 8276 lond has been asked to exit by its clien
client systemand <input> is the full exit command sent to the server.	client systemand <input> is the full exit command sent to the server.

=item Red CRITICAL: ABNORMAL EXIT. child <pid> for server <hostname> died through a crass with this error->[<message>].	=item Red CRITICAL: ABNORMAL EXIT. child <pid> for server <hostname> died through a crass with this error->[<message>].

A lond child terminated. NOte that this termination can also occur when the	A lond child terminated. NOte that this termination can also occur when the
child receives the QUIT or DIE signals. <pid> is the process id of the child,	child receives the QUIT or DIE signals. <pid> is the process id of the child,
<hostname> the host lond is working for, and <message> the reason the child died	<hostname> the host lond is working for, and <message> the reason the child died
Line 7527 file when sent it's USR1 signal. That p	Line 8360 file when sent it's USR1 signal. That p
assumed to be hung in some un-fixable way.	assumed to be hung in some un-fixable way.

=item Finished checking children	=item Finished checking children

Master processs's USR1 processing is cojmplete.	Master processs's USR1 processing is cojmplete.

=item (Red) CRITICAL: ------- Starting ------	=item (Red) CRITICAL: ------- Starting ------
Line 7541 Started a new child process for <client>	Line 8374 Started a new child process for <client>
connected to the child. This was as a result of a TCP/IP connection from a client.	connected to the child. This was as a result of a TCP/IP connection from a client.

=item Unable to determine who caller was, getpeername returned nothing	=item Unable to determine who caller was, getpeername returned nothing

In child process initialization. either getpeername returned undef or	In child process initialization. either getpeername returned undef or
a zero sized object was returned. Processing continues, but in my opinion,	a zero sized object was returned. Processing continues, but in my opinion,
this should be cause for the child to exit.	this should be cause for the child to exit.
Line 7552 In child process initialization. The pe	Line 8385 In child process initialization. The pe
The client address is stored as "Unavailable" and processing continues.	The client address is stored as "Unavailable" and processing continues.

=item (Yellow) INFO: Connection <ip> <name> connection type = <type>	=item (Yellow) INFO: Connection <ip> <name> connection type = <type>

In child initialization. A good connectionw as received from <ip>.	In child initialization. A good connectionw as received from <ip>.

=over 2	=over 2
Line 7602 The client (<client> is the peer's name	Line 8435 The client (<client> is the peer's name
negotiated an SSL connection with this child process.	negotiated an SSL connection with this child process.

=item (Green) Successful insecure authentication with <client>	=item (Green) Successful insecure authentication with <client>


The client has successfully negotiated an insecure connection withthe child process.	The client has successfully negotiated an insecure connection withthe child process.

Line 7616 string.	Line 8449 string.

=back	=back

	=back


=cut	=cut

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

Removed from v.1.416
changed lines
	Added in v.1.491