Return to lond CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.444 and 1.472

version 1.444, 2010/06/18 19:19:33	version 1.472, 2011/05/13 02:58:02
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 52 use LONCAPA::lonlocal;	Line 53 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 66 my $currentdomainid;	Line 68 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 $clientversion; # LonCAPA version running on client.
	my $clienthomedom; # LonCAPA domain of homeID for client.
	# primary library server.

my $server;	my $server;

Line 417 sub ReadManagerTable {	Line 421 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>');	if (&loncapa_dns_server()) {
return;	&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 449 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 511 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 600 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 614 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 644 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 676 sub PushFile {	Line 678 sub PushFile {
} else {	} else {
&logthis('<font color="green"> Installed new '.$tablefile	&logthis('<font color="green"> Installed new '.$tablefile
."</font>");	."</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;
	my $senderaddress = $perlvar{'lonSysEMail'};
	$msg->to($adminmail);
	$msg->subject('LON-CAPA DNS update on '.$perlvar{'lonHostID'});
	if ($senderaddress) {
	$msg->add('From',$senderaddress);
	}
	$msg->add('Content-type','text/plain; charset=UTF-8');
	if (my $fh = $msg->open()) {
	print $fh 'Update to '.$tablefile.' from Cluster Manager '.
	$client."\n";
	$fh->close;
	}
	}
}	}


# Indicate success:	# Indicate success:

return "ok";	return "ok";

}	}

	sub loncapa_dns_server {
	my $lonhost = &Apache::lonnet::get_host_ip($perlvar{'lonHostID'});
	my $hoststable = "$perlvar{'lonTabDir'}/hosts.tab";
	my $is_dns_server;
	if (!open(HOSTS,"<$hoststable")) {
	&logthis('<font color="yellow">Could not open hosts.tab to check for LON-CAPA DNS servers.</font>');
	while (my $host = <HOSTS>) {
	chomp($host);
	$host =~ s/(^\s+\|\s+$)//g;
	if ($host =~ /^\Q^$lonhost\E/) {
	$is_dns_server = 1;
	last;
	}
	}
	close(HOSTS);
	}
	return $is_dns_server;
	}

#	#
# Called to re-init either lonc or lond.	# Called to re-init either lonc or lond.
#	#
Line 1071 sub pong_handler {	Line 1116 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 1110 sub establish_key_handler {	Line 1155 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 1119 sub establish_key_handler {	Line 1164 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 1147 sub load_handler {	Line 1194 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 1656 sub server_loncaparev_handler {	Line 1703 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 1765 sub authenticate_handler {	Line 1829 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 2111 sub update_resource_handler {	Line 2209 sub update_resource_handler {
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 2119 sub update_resource_handler {	Line 2220 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 2373 sub user_has_session_handler {	Line 2476 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 3104 sub dump_with_regexp {	Line 3206 sub dump_with_regexp {

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

my ($udom,$uname,$namespace,$regexp,$range)=split(/:/,$tail);	my ($udom,$uname,$namespace,$regexp,$range,$extra)=split(/:/,$tail);
if (defined($regexp)) {	if (defined($regexp)) {
$regexp=&unescape($regexp);	$regexp=&unescape($regexp);
} else {	} else {
Line 3122 sub dump_with_regexp {	Line 3224 sub dump_with_regexp {
}	}
my $hashref = &tie_user_hash($udom, $uname, $namespace,	my $hashref = &tie_user_hash($udom, $uname, $namespace,
&GDBM_READER());	&GDBM_READER());
	my $skipcheck;
if ($hashref) {	if ($hashref) {
my $qresult='';	my $qresult='';
my $count=0;	my $count=0;
	if ($extra ne '') {
	$extra = &Apache::lonnet::thaw_unescape($extra);
	$skipcheck = $extra->{'skipcheck'};
	}
	my @ids = &Apache::lonnet::current_machine_ids();
	my (%homecourses,$major,$minor,$now);
	if (($namespace eq 'roles') && (!$skipcheck)) {
	my $loncaparev = $clientversion;
	if ($loncaparev eq '') {
	$loncaparev = $Apache::lonnet::loncaparevs{$clientname};
	}
	if ($loncaparev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?/) {
	$major = $1;
	$minor = $2;
	}
	$now = time;
	}
while (my ($key,$value) = each(%$hashref)) {	while (my ($key,$value) = each(%$hashref)) {
if ($namespace eq 'roles') {	if ($namespace eq 'roles') {
if ($key =~ /^($LONCAPA::match_domain)_($LONCAPA::match_community)_(cc\|co\|in\|ta\|ep\|ad\|st\|cr)/) {	if ($key =~ m{^/($LONCAPA::match_domain)/($LONCAPA::match_courseid)(/?[^_]*)_(cc\|co\|in\|ta\|ep\|ad\|st\|cr)$}) {
if ($clientversion =~ /^(\d+)\.(\d+)$/) {	my $cdom = $1;
my $major = $1;	my $cnum = $2;
my $minor = $2;	unless ($skipcheck) {
next if (($major < 2) \|\| (($major == 2) && ($minor < 9)));	my ($role,$end,$start) = split(/\_/,$value);
	if (!$end \|\| $end > $now) {
	next unless (&releasereqd_check($cnum,$cdom,$key,$value,$major,
	$minor,\%homecourses,\@ids));
	}
}	}
}	}
}	}
Line 3151 sub dump_with_regexp {	Line 3275 sub dump_with_regexp {
}	}
}	}
if (&untie_user_hash($hashref)) {	if (&untie_user_hash($hashref)) {
	if (($namespace eq 'roles') && (!$skipcheck)) {
	if (keys(%homecourses) > 0) {
	$qresult .= &check_homecourses(\%homecourses,$udom,$regexp,$count,
	$range,$start,$end,$major,$minor);
	}
	}
chop($qresult);	chop($qresult);
&Reply($client, \$qresult, $userinput);	&Reply($client, \$qresult, $userinput);
} else {	} else {
Line 3728 sub put_course_id_hash_handler {	Line 3858 sub put_course_id_hash_handler {
# createdafter - include courses for which creation date followed this date.	# createdafter - include courses for which creation date followed this date.
# creationcontext - include courses created in specified context	# 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:
# 1 - Continue processing.	# 1 - Continue processing.
Line 3740 sub dump_course_id_handler {	Line 3873 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,$cloner,$cc_clone_list,$cloneonly,$createdbefore,$createdafter,	$caller,$cloner,$cc_clone_list,$cloneonly,$createdbefore,$createdafter,
$creationcontext) =split(/:/,$tail);	$creationcontext,$domcloner) =split(/:/,$tail);
my $now = time;	my $now = time;
my ($cloneruname,$clonerudom,%cc_clone);	my ($cloneruname,$clonerudom,%cc_clone);
if (defined($description)) {	if (defined($description)) {
Line 3813 sub dump_course_id_handler {	Line 3946 sub dump_course_id_handler {
} else {	} else {
$creationcontext = '.';	$creationcontext = '.';
}	}

my $unpack = 1;	my $unpack = 1;
if ($description eq '.' && $instcodefilter eq '.' && $coursefilter eq '.' &&	if ($description eq '.' && $instcodefilter eq '.' && $coursefilter eq '.' &&
$typefilter eq '.') {	$typefilter eq '.') {
Line 3844 sub dump_course_id_handler {	Line 3976 sub dump_course_id_handler {
next if ($since > 1);	next if ($since > 1);
}	}
$is_hash = 1;	$is_hash = 1;
if (defined($clonerudom)) {	if ($domcloner) {
	$canclone = 1;
	} elsif (defined($clonerudom)) {
if ($items->{'cloners'}) {	if ($items->{'cloners'}) {
my @cloneable = split(',',$items->{'cloners'});	my @cloneable = split(',',$items->{'cloners'});
if (@cloneable) {	if (@cloneable) {
Line 4197 sub put_domain_handler {	Line 4331 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 4341 sub get_id_handler {	Line 4476 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 4605 sub tmp_put_handler {	Line 4741 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 4923 sub get_sections_handler {	Line 5059 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 5914 if (-e $pidfile) {	Line 6051 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 6152 sub logstatus {	Line 6289 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 6241 $SIG{USR2} = \&UpdateHosts;	Line 6378 $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`;	my $dist=`$perlvar{'lonDaemons'}/distprobe`;

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

# --------------------------------------------------------------	# --------------------------------------------------------------
# Accept connections. When a connection comes in, it is validated	# Accept connections. When a connection comes in, it is validated
# and if good, a child process is created to process transactions	# and if good, a child process is created to process transactions
Line 6301 sub make_new_child {	Line 6444 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 6309 sub make_new_child {	Line 6453 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 6457 sub make_new_child {	Line 6608 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 7202 sub version {	Line 7356 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;
	}

	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->{$hashid}) eq 'ARRAY') {
	push(@{$homecourses->{$hashid}},{$key=>$value});
	} else {
	$homecourses->{$hashid} = [{$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;
	}

	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;
	}

	sub check_homecourses {
	my ($homecourses,$udom,$regexp,$count,$range,$start,$end,$major,$minor) = @_;
	my ($result,%addtocache);
	my $yesterday = time - 24*3600;
	if (ref($homecourses) eq 'HASH') {
	my (%okcourses,%courseinfo,%recent);
	my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());
	if ($hashref) {
	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 $hashid = $unesc_key;
	$hashid =~ s/_/:/;
	$courseinfo{$hashid} = $items;
	if (ref($homecourses->{$hashid}) 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');
	}
	} else {
	&logthis('Failed to tie hash for nohist_courseids.db');
	return;
	}
	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 $hashid (keys(%{$homecourses})) {
	next if ($recent{$hashid});
	&Apache::lonnet::do_cache_new('courseinfo',$hashid,$courseinfo{$hashid},600);
	}
	foreach my $hashid (keys(%okcourses)) {
	if (ref($homecourses->{$hashid}) eq 'ARRAY') {
	foreach my $role (@{$homecourses->{$hashid}}) {
	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;
	}

	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)

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

500 Internal Server Error

Internal Server Error

The server encountered an internal error or misconfiguration and was unable to complete your request.

Please contact the server administrator at root@localhost to inform them of the time this error occurred, and the actions you performed just before this error.

More information about this error may be available in the server error log.

Removed from v.1.444
changed lines
	Added in v.1.472