loncom/lond - diff

Return to lond CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.352 and 1.380.2.1

version 1.352, 2006/11/27 23:10:27	version 1.380.2.1, 2007/09/29 04:05:29
Line 33 use strict;	Line 33 use strict;
use lib '/home/httpd/lib/perl/';	use lib '/home/httpd/lib/perl/';
use LONCAPA;	use LONCAPA;
use LONCAPA::Configuration;	use LONCAPA::Configuration;
	use Apache::lonnet;

use IO::Socket;	use IO::Socket;
use IO::File;	use IO::File;
Line 44 use Digest::MD5 qw(md5_hex);	Line 45 use Digest::MD5 qw(md5_hex);
use GDBM_File;	use GDBM_File;
use Authen::Krb4;	use Authen::Krb4;
use Authen::Krb5;	use Authen::Krb5;
use lib '/home/httpd/lib/perl/';
use localauth;	use localauth;
use localenroll;	use localenroll;
use localstudentphoto;	use localstudentphoto;
use File::Copy;	use File::Copy;
use File::Find;	use File::Find;
use LONCAPA::ConfigFileEdit;
use LONCAPA::lonlocal;	use LONCAPA::lonlocal;
use LONCAPA::lonssl;	use LONCAPA::lonssl;
use Fcntl qw(:flock);	use Fcntl qw(:flock);
Line 70 my $clientip; # IP address of client.	Line 69 my $clientip; # IP address of client.
my $clientname; # LonCAPA name of client.	my $clientname; # LonCAPA name of client.

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

my $keymode;	my $keymode;

Line 86 my $tmpsnum = 0; # Id of tmpputs.	Line 84 my $tmpsnum = 0; # Id of tmpputs.

my $ConnectionType;	my $ConnectionType;

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

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

my %perlvar; # Will have the apache conf defined perl vars.	my %perlvar; # Will have the apache conf defined perl vars.
Line 143 my @adderrors = ("ok",	Line 135 my @adderrors = ("ok",
"lcuseradd Unable to make www member of users's group",	"lcuseradd Unable to make www member of users's group",
"lcuseradd Unable to su to root",	"lcuseradd Unable to su to root",
"lcuseradd Unable to set password",	"lcuseradd Unable to set password",
"lcuseradd Usrname has invalid characters",	"lcuseradd Username has invalid characters",
"lcuseradd Password has an invalid character",	"lcuseradd Password has an invalid character",
"lcuseradd User already exists",	"lcuseradd User already exists",
"lcuseradd Could not add user.",	"lcuseradd Could not add user.",
Line 179 sub ResetStatistics {	Line 171 sub ResetStatistics {
# $Socket - Socket open on client.	# $Socket - Socket open on client.
# $initcmd - The full text of the init command.	# $initcmd - The full text of the init command.
#	#
# Implicit inputs:
# $thisserver - Our DNS name.
#
# Returns:	# Returns:
# IDEA session key on success.	# IDEA session key on success.
# undef on failure.	# undef on failure.
#	#
sub LocalConnection {	sub LocalConnection {
my ($Socket, $initcmd) = @_;	my ($Socket, $initcmd) = @_;
Debug("Attempting local connection: $initcmd client: $clientip me: $thisserver");	Debug("Attempting local connection: $initcmd client: $clientip");
if($clientip ne "127.0.0.1") {	if($clientip ne "127.0.0.1") {
&logthis('<font color="red"> LocalConnection rejecting non local: '	&logthis('<font color="red"> LocalConnection rejecting non local: '
."$clientip ne $thisserver </font>");	."$clientip ne 127.0.0.1 </font>");
close $Socket;	close $Socket;
return undef;	return undef;
} else {	} else {
Line 425 sub ReadManagerTable {	Line 414 sub ReadManagerTable {
if ($host =~ "^#") { # Comment line.	if ($host =~ "^#") { # Comment line.
next;	next;
}	}
if (!defined $hostip{$host}) { # This is a non cluster member	if (!defined &Apache::lonnet::get_host_ip($host)) { # This is a non cluster member
# The entry is of the form:	# The entry is of the form:
# cluname:hostname	# cluname:hostname
# cluname - A 'cluster hostname' is needed in order to negotiate	# cluname - A 'cluster hostname' is needed in order to negotiate
Line 443 sub ReadManagerTable {	Line 432 sub ReadManagerTable {
}	}
} else {	} else {
logthis('<font color="green"> existing host'." $host</font>\n");	logthis('<font color="green"> existing host'." $host</font>\n");
$managers{$hostip{$host}} = $host; # Use info from cluster tab if clumemeber	$managers{&Apache::lonnet::get_host_ip($host)} = $host; # Use info from cluster tab if clumemeber
}	}
}	}
}	}
Line 504 sub AdjustHostContents {	Line 493 sub AdjustHostContents {
my $adjusted;	my $adjusted;
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 =~ /^ $/))) {
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) {
my $ip = gethostbyname($name);	my $ip = gethostbyname($name);
my $ipnew = inet_ntoa($ip);	my $ipnew = inet_ntoa($ip);
$ip = $ipnew;	$ip = $ipnew;
# Reconstruct the host line and append to adjusted:	# Reconstruct the host line and append to adjusted:

my $newline = "$id:$domain:$role:$name:$ip";	my $newline = "$id:$domain:$role:$name:$ip";
if($maxcon ne "") { # Not all hosts have loncnew tuning params	if($maxcon ne "") { # Not all hosts have loncnew tuning params
$newline .= ":$maxcon:$idleto:$mincon";	$newline .= ":$maxcon:$idleto:$mincon";
}	}
$adjusted .= $newline."\n";	$adjusted .= $newline."\n";

} else { # Not me, pass unmodified.	} else { # Not me, pass unmodified.
$adjusted .= $line."\n";	$adjusted .= $line."\n";
}	}
} else { # Blank or comment never re-written.	} else { # Blank or comment never re-written.
$adjusted .= $line."\n"; # Pass blanks and comments as is.	$adjusted .= $line."\n"; # Pass blanks and comments as is.
}	}
}	}
return $adjusted;	return $adjusted;
}	}
#	#
# InstallFile: Called to install an administrative file:	# InstallFile: Called to install an administrative file:
Line 1033 sub ping_handler {	Line 1022 sub ping_handler {
sub pong_handler {	sub pong_handler {
my ($cmd, $tail, $replyfd) = @_;	my ($cmd, $tail, $replyfd) = @_;

my $reply=&reply("ping",$clientname);	my $reply=&Apache::lonnet::reply("ping",$clientname);
&Reply( $replyfd, "$currenthostid:$reply\n", "$cmd:$tail");	&Reply( $replyfd, "$currenthostid:$reply\n", "$cmd:$tail");
return 1;	return 1;
}	}
Line 1143 sub load_handler {	Line 1132 sub load_handler {
sub user_load_handler {	sub user_load_handler {
my ($cmd, $tail, $replyfd) = @_;	my ($cmd, $tail, $replyfd) = @_;

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

return 1;	return 1;
Line 1269 sub du_handler {	Line 1258 sub du_handler {
my $code=sub {	my $code=sub {
if ($_=~/\.\d+\./) { return;}	if ($_=~/\.\d+\./) { return;}
if ($_=~/\.meta$/) { return;}	if ($_=~/\.meta$/) { return;}
	if (-d $_) { return;}
$total_size+=(stat($_))[7];	$total_size+=(stat($_))[7];
};	};
chdir($ududir);	chdir($ududir);
Line 1850 sub update_resource_handler {	Line 1840 sub update_resource_handler {
my $now=time;	my $now=time;
my $since=$now-$atime;	my $since=$now-$atime;
if ($since>$perlvar{'lonExpire'}) {	if ($since>$perlvar{'lonExpire'}) {
my $reply=&reply("unsub:$fname","$clientname");	my $reply=&Apache::lonnet::reply("unsub:$fname","$clientname");
&devalidate_meta_cache($fname);	&devalidate_meta_cache($fname);
unlink("$fname");	unlink("$fname");
unlink("$fname.meta");	unlink("$fname.meta");
} else {	} else {
my $transname="$fname.in.transfer";	my $transname="$fname.in.transfer";
my $remoteurl=&reply("sub:$fname","$clientname");	my $remoteurl=&Apache::lonnet::reply("sub:$fname","$clientname");
my $response;	my $response;
alarm(120);	alarm(120);
{	{
Line 1901 sub devalidate_meta_cache {	Line 1891 sub devalidate_meta_cache {
my ($url) = @_;	my ($url) = @_;
use Cache::Memcached;	use Cache::Memcached;
my $memcache = new Cache::Memcached({'servers'=>['127.0.0.1:11211']});	my $memcache = new Cache::Memcached({'servers'=>['127.0.0.1:11211']});
$url = &declutter($url);	$url = &Apache::lonnet::declutter($url);
$url =~ s-\.meta$--;	$url =~ s-\.meta$--;
my $id = &escape('meta:'.$url);	my $id = &escape('meta:'.$url);
$memcache->delete($id);	$memcache->delete($id);
}	}

sub declutter {
my $thisfn=shift;
$thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//;
$thisfn=~s/^\///;
$thisfn=~s\|^adm/wrapper/\|\|;
$thisfn=~s\|^adm/coursedocs/showdoc/\|\|;
$thisfn=~s/^res\///;
$thisfn=~s/\?.+$//;
return $thisfn;
}
#	#
# Fetch a user file from a remote server to the user's home directory	# Fetch a user file from a remote server to the user's home directory
# userfiles subdir.	# userfiles subdir.
Line 2115 sub rename_user_file_handler {	Line 2095 sub rename_user_file_handler {
&register_handler("renameuserfile", \&rename_user_file_handler, 0,1,0);	&register_handler("renameuserfile", \&rename_user_file_handler, 0,1,0);

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

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

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

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

	#
# Authenticate access to a user file by checking that the token the user's	# Authenticate access to a user file by checking that the token the user's
# passed also exists in their session file	# passed also exists in their session file
#	#
Line 2207 sub subscribe_handler {	Line 2218 sub subscribe_handler {
&register_handler("sub", \&subscribe_handler, 0, 1, 0);	&register_handler("sub", \&subscribe_handler, 0, 1, 0);

#	#
# Determine the version of a resource (?) Or is it return	# Determine the latest version of a resource (it looks for the highest
# the top version of the resource? Not yet clear from the	# past version and then returns that +1)
# code in currentversion.
#	#
# Parameters:	# Parameters:
# $cmd - The command that got us here.	# $cmd - The command that got us here.
# $tail - Tail of the command (remaining parameters).	# $tail - Tail of the command (remaining parameters).
	# (Should consist of an absolute path to a file)
# $client - File descriptor connected to client.	# $client - File descriptor connected to client.
# Returns	# Returns
# 0 - Requested to exit, caller should shut down.	# 0 - Requested to exit, caller should shut down.
Line 3293 sub put_course_id_handler {	Line 3304 sub put_course_id_handler {
foreach my $pair (@pairs) {	foreach my $pair (@pairs) {
my ($key,$courseinfo) = split(/=/,$pair,2);	my ($key,$courseinfo) = split(/=/,$pair,2);
$courseinfo =~ s/=/:/g;	$courseinfo =~ s/=/:/g;
	my @current_items = split(/:/,$hashref->{$key},-1);
my @current_items = split(/:/,$hashref->{$key});
shift(@current_items); # remove description	shift(@current_items); # remove description
pop(@current_items); # remove last access	pop(@current_items); # remove last access
my $numcurrent = scalar(@current_items);	my $numcurrent = scalar(@current_items);
	if ($numcurrent > 3) {
my @new_items = split(/:/,$courseinfo);	$numcurrent = 3;
	}
	my @new_items = split(/:/,$courseinfo,-1);
my $numnew = scalar(@new_items);	my $numnew = scalar(@new_items);
if ($numcurrent > 0) {	if ($numcurrent > 0) {
if ($numnew <= $numcurrent) { # flushcourselogs() from pre 2.2	if ($numnew <= $numcurrent) { # flushcourselogs() from pre 2.2
Line 3599 sub get_domain_handler {	Line 3611 sub get_domain_handler {

return 1;	return 1;
}	}
&register_handler("getdom", \&get_id_handler, 0, 1, 0);	&register_handler("getdom", \&get_domain_handler, 0, 1, 0);


#	#
Line 4451 sub get_institutional_code_format_handle	Line 4463 sub get_institutional_code_format_handle
\%cat_titles,	\%cat_titles,
\%cat_order);	\%cat_order);
if ($formatreply eq 'ok') {	if ($formatreply eq 'ok') {
my $codes_str = &hash2str(%codes);	my $codes_str = &Apache::lonnet::hash2str(%codes);
my $codetitles_str = &array2str(@codetitles);	my $codetitles_str = &Apache::lonnet::array2str(@codetitles);
my $cat_titles_str = &hash2str(%cat_titles);	my $cat_titles_str = &Apache::lonnet::hash2str(%cat_titles);
my $cat_order_str = &hash2str(%cat_order);	my $cat_order_str = &Apache::lonnet::hash2str(%cat_order);
&Reply($client,	&Reply($client,
$codes_str.':'.$codetitles_str.':'.$cat_titles_str.':'	$codes_str.':'.$codetitles_str.':'.$cat_titles_str.':'
.$cat_order_str."\n",	.$cat_order_str."\n",
Line 4630 sub student_photo_handler {	Line 4642 sub student_photo_handler {
}	}
&register_handler("studentphoto", \&student_photo_handler, 0, 1, 0);	&register_handler("studentphoto", \&student_photo_handler, 0, 1, 0);

	sub inst_usertypes_handler {
	my ($cmd, $domain, $client) = @_;
	my $res;
	my $userinput = $cmd.":".$domain; # For logging purposes.
	my (%typeshash,@order,$result);
	eval {
	local($SIG{__DIE__})='DEFAULT';
	$result=&localenroll::inst_usertypes($domain,\%typeshash,\@order);
	};
	if ($result eq 'ok') {
	if (keys(%typeshash) > 0) {
	foreach my $key (keys(%typeshash)) {
	$res.=&escape($key).'='.&escape($typeshash{$key}).'&';
	}
	}
	$res=~s/\&$//;
	$res .= ':';
	if (@order > 0) {
	foreach my $item (@order) {
	$res .= &escape($item).'&';
	}
	}
	$res=~s/\&$//;
	}
	&Reply($client, "$res\n", $userinput);
	return 1;
	}
	&register_handler("inst_usertypes", \&inst_usertypes_handler, 0, 1, 0);

# mkpath makes all directories for a file, expects an absolute path with a	# mkpath makes all directories for a file, expects an absolute path with a
# file or a trailing / if just a dir is passed	# file or a trailing / if just a dir is passed
# returns 1 on success 0 on failure	# returns 1 on success 0 on failure
Line 4893 sub catchexception {	Line 4934 sub catchexception {
$SIG{__DIE__}='DEFAULT';	$SIG{__DIE__}='DEFAULT';
&status("Catching exception");	&status("Catching exception");
&logthis("<font color='red'>CRITICAL: "	&logthis("<font color='red'>CRITICAL: "
."ABNORMAL EXIT. Child $$ for server $thisserver died through "	."ABNORMAL EXIT. Child $$ for server ".$perlvar{'lonHostID'}." died through "
."a crash with this error msg->[$error]</font>");	."a crash with this error msg->[$error]</font>");
&logthis('Famous last words: '.$status.' - '.$lastlog);	&logthis('Famous last words: '.$status.' - '.$lastlog);
if ($client) { print $client "error: $error\n"; }	if ($client) { print $client "error: $error\n"; }
Line 5004 sub HUPSMAN { # sig	Line 5045 sub HUPSMAN { # sig
}	}

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

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

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

	&Apache::lonnet::reset_hosts_info();

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

foreach my $child (keys %children) {
my $childip = $children{$child};	my $childip = $children{$child};
if(!$hostid{$childip}) {	if ($childip ne '127.0.0.1'
	&& !defined(&Apache::lonnet::get_hosts_from_ip($childip))) {
logthis('<font color="blue"> UpdateHosts killing child '	logthis('<font color="blue"> UpdateHosts killing child '
." $child for ip $childip </font>");	." $child for ip $childip </font>");
kill('INT', $child);	kill('INT', $child);
Line 5261 sub status {	Line 5240 sub status {
$0='lond: '.$what.' '.$local;	$0='lond: '.$what.' '.$local;
}	}

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

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

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

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

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

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

sub sql_reply {	sub sql_reply {
Line 5386 $SIG{USR1} = \&checkchildren;	Line 5308 $SIG{USR1} = \&checkchildren;
$SIG{USR2} = \&UpdateHosts;	$SIG{USR2} = \&UpdateHosts;

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

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

Line 5466 sub make_new_child {	Line 5387 sub make_new_child {
# my $tmpsnum=0; # Now global	# my $tmpsnum=0; # Now global
#---------------------------------------------------- kerberos 5 initialization	#---------------------------------------------------- kerberos 5 initialization
&Authen::Krb5::init_context();	&Authen::Krb5::init_context();
unless (($dist eq 'fedora5') \|\| ($dist eq 'fedora4')	unless (($dist eq 'fedora5') \|\| ($dist eq 'fedora4') \|\|
\|\| ($dist eq 'suse9.3')) {	($dist eq 'fedora6') \|\| ($dist eq 'suse9.3')) {
&Authen::Krb5::init_ets();	&Authen::Krb5::init_ets();
}	}

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

ReadManagerTable; # May also be a manager!!

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

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

if ($clientok) {	if ($clientok) {
# ---------------- New known client connecting, could mean machine online again	# ---------------- New known client connecting, could mean machine online again
	if (&Apache::lonnet::get_host_ip($currenthostid) ne $clientip
foreach my $id (keys(%hostip)) {	&& $clientip ne '127.0.0.1') {
if ($hostip{$id} ne $clientip \|\|	&Apache::lonnet::reconlonc($clientname);
$hostip{$currenthostid} eq $clientip) {
# no need to try to do recon's to myself
next;
}
&reconlonc("$perlvar{'lonSockDir'}/".$hostname{$id});
}	}
&logthis("<font color='green'>Established connection: $clientname</font>");	&logthis("<font color='green'>Established connection: $clientname</font>");
&status('Will listen to '.$clientname);	&status('Will listen to '.$clientname);
Line 5880 sub validate_user {	Line 5794 sub validate_user {
my $krbservice = "krbtgt/".$contentpwd."\@".$contentpwd;	my $krbservice = "krbtgt/".$contentpwd."\@".$contentpwd;
my $krbserver = &Authen::Krb5::parse_name($krbservice);	my $krbserver = &Authen::Krb5::parse_name($krbservice);
my $credentials= &Authen::Krb5::cc_default();	my $credentials= &Authen::Krb5::cc_default();
$credentials->initialize($krbclient);	$credentials->initialize(&Authen::Krb5::parse_name($user.'@'
	.$contentpwd));
my $krbreturn = &Authen::Krb5::get_in_tkt_with_password($krbclient,	my $krbreturn = &Authen::Krb5::get_in_tkt_with_password($krbclient,
$krbserver,	$krbserver,
$password,	$password,
$credentials);	$credentials);
$validated = ($krbreturn == 1);	$validated = ($krbreturn == 1);
	if (!$validated) {
	&logthis('krb5: '.$user.', '.$contentpwd.', '.
	&Authen::Krb5::error());
	}
} else {	} else {
$validated = 0;	$validated = 0;
}	}
Line 5893 sub validate_user {	Line 5812 sub validate_user {
# Authenticate via installation specific authentcation method:	# Authenticate via installation specific authentcation method:
$validated = &localauth::localauth($user,	$validated = &localauth::localauth($user,
$password,	$password,
$contentpwd);	$contentpwd,
	$domain);
	if ($validated < 0) {
	&logthis("localauth for $contentpwd $user:$domain returned a $validated");
	$validated = 0;
	}
} else { # Unrecognized auth is also bad.	} else { # Unrecognized auth is also bad.
$validated = 0;	$validated = 0;
}	}
Line 5919 sub addline {	Line 5843 sub addline {
my ($fname,$hostid,$ip,$newline)=@_;	my ($fname,$hostid,$ip,$newline)=@_;
my $contents;	my $contents;
my $found=0;	my $found=0;
my $expr='^'.$hostid.':'.$ip.':';	my $expr='^'.quotemeta($hostid).':'.quotemeta($ip).':';
$expr =~ s/\./\\\./g;
my $sh;	my $sh;
if ($sh=IO::File->new("$fname.subscription")) {	if ($sh=IO::File->new("$fname.subscription")) {
while (my $subline=<$sh>) {	while (my $subline=<$sh>) {
Line 6127 sub subscribe {	Line 6050 sub subscribe {
# the metadata	# the metadata
unless ($fname=~/\.meta$/) { &unsub("$fname.meta",$clientip); }	unless ($fname=~/\.meta$/) { &unsub("$fname.meta",$clientip); }
$fname=~s/\/home\/httpd\/html\/res/raw/;	$fname=~s/\/home\/httpd\/html\/res/raw/;
$fname="http://$thisserver/".$fname;	$fname="http://".&Apache::lonnet::hostname($perlvar{'lonHostID'})."/".$fname;
$result="$fname\n";	$result="$fname\n";
}	}
} else {	} else {
Line 6281 sub sethost {	Line 6204 sub sethost {
}	}

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

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

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

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

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

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

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

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

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

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

Removed from v.1.352
changed lines
	Added in v.1.380.2.1