loncom/lond - diff

Return to lond CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.106 and 1.151

version 1.106, 2003/01/15 04:43:14	version 1.151, 2003/10/03 15:11:03
Line 31	Line 31
# 10/7,10/8,10/9,10/11,10/13,10/15,11/4,11/16,	# 10/7,10/8,10/9,10/11,10/13,10/15,11/4,11/16,
# 12/7,12/15,01/06,01/11,01/12,01/14,2/8,	# 12/7,12/15,01/06,01/11,01/12,01/14,2/8,
# 03/07,05/31 Gerd Kortemeyer	# 03/07,05/31 Gerd Kortemeyer
# 06/26 Scott Harrison
# 06/29,06/30,07/14,07/15,07/17,07/20,07/25,09/18 Gerd Kortemeyer	# 06/29,06/30,07/14,07/15,07/17,07/20,07/25,09/18 Gerd Kortemeyer
# 12/05 Scott Harrison
# 12/05,12/13,12/29 Gerd Kortemeyer	# 12/05,12/13,12/29 Gerd Kortemeyer
# YEAR=2001	# YEAR=2001
# Jan 01 Scott Harrison
# 02/12 Gerd Kortemeyer	# 02/12 Gerd Kortemeyer
# 03/15 Scott Harrison
# 03/24 Gerd Kortemeyer	# 03/24 Gerd Kortemeyer
# 04/02 Scott Harrison
# 05/11,05/28,08/30 Gerd Kortemeyer	# 05/11,05/28,08/30 Gerd Kortemeyer
# 9/30,10/22,11/13,11/15,11/16 Scott Harrison
# 11/26,11/27 Gerd Kortemeyer	# 11/26,11/27 Gerd Kortemeyer
# 12/20 Scott Harrison
# 12/22 Gerd Kortemeyer	# 12/22 Gerd Kortemeyer
# YEAR=2002	# YEAR=2002
# 01/20/02,02/05 Gerd Kortemeyer	# 01/20/02,02/05 Gerd Kortemeyer
# 02/05 Guy Albertelli	# 02/05 Guy Albertelli
# 02/07 Scott Harrison
# 02/12 Gerd Kortemeyer	# 02/12 Gerd Kortemeyer
# 02/19 Matthew Hall	# 02/19 Matthew Hall
# 02/25 Gerd Kortemeyer	# 02/25 Gerd Kortemeyer
# 05/11 Scott Harrison
# 01/xx/2003 Ron Fox.. Remove preforking. This makes the general daemon	# 01/xx/2003 Ron Fox.. Remove preforking. This makes the general daemon
# logic simpler (and there were problems maintaining the preforked	# logic simpler (and there were problems maintaining the preforked
# population). Since the time averaged connection rate is close to zero	# population). Since the time averaged connection rate is close to zero
# because lonc's purpose is to maintain near continuous connnections,	# because lonc's purpose is to maintain near continuous connnections,
# preforking is not really needed.	# preforking is not really needed.
###	# 08/xx/2003 Ron Fox: Add management requests. Management requests
	# will be validated via a call to ValidateManager. At present, this
	# is done by simple host verification. In the future we can modify
	# this function to do a certificate check.
	# Management functions supported include:
	# - pushing /home/httpd/lonTabs/hosts.tab
	# - pushing /home/httpd/lonTabs/domain.tab
	# 09/08/2003 Ron Fox: Told lond to take care of change logging so we
	# don't have to remember it:
	# $Log$
	# Revision 1.151 2003/10/03 15:11:03 albertel
	# - if we fail to fetch an update to the file, don't blow away the old one
	# (this was the BUG that blew away that one default.sequence that Matthew
	# ended up restoring from data.)
	#
	# Revision 1.150 2003/09/30 10:16:06 foxr
	# Added invocation of apachereload in ReloadApache sub.
	# This completes the addtion of the reinit functionality.
	#
	# Revision 1.149 2003/09/30 09:44:13 foxr
	# Tested UpdateHosts ability to
	# - Remove live children for hosts that are no longer in the hosts.tab
	# - Remove live children for hosts whose IPs have changed in the hosts.tab
	#
	# Revision 1.148 2003/09/29 10:09:18 foxr
	# Put in logic to reinit lond itself (except for apache reload). I don't believe
	# this logic works correctly yet, however lond still does everything it used to doso I'll do the commit anyway.
	#
	# Revision 1.147 2003/09/23 11:23:31 foxr
	# Comlplete implementation of reinit functionality. Must still implement
	# the actual initialization functionality, but the process can now
	# receive the request and either invoke the appropriate internal function or
	# signal the correct lonc.
	#
	# Revision 1.146 2003/09/16 10:28:14 foxr
	# ReinitProcess - decode the process selector and produce the associated pid
	# filename. Note: While it is possible to test that valid process selectors are
	# handled properly I am not able to test that invalid process selectors produce
	# the appropriate error as lonManage also blocks the use of invalid process selectors.
	#
	# Revision 1.145 2003/09/16 10:13:20 foxr
	# Added ReinitProcess function to oversee the parsing and processing of the
	# reinit:<process> client request.
	#
	# Revision 1.144 2003/09/16 09:47:01 foxr
	# Added skeletal support for SIGUSR2 (update hosts.tab)
	#
	# Revision 1.143 2003/09/15 10:03:52 foxr
	# Completed and tested code for pushfile.
	#
	# Revision 1.142 2003/09/09 20:47:46 www
	# Permanently store chatroom entries in chatroom.log
	#
	# Revision 1.141 2003/09/08 10:32:07 foxr
	# Added PushFile sub This sub oversees the push of a new configuration table file
	# Currently supported files are:
	# - hosts.tab (transaction pushfile:hosts:contents)
	# - domain.tab (transaction pushfile:domain:contents)
	#


	use strict;
use lib '/home/httpd/lib/perl/';	use lib '/home/httpd/lib/perl/';
use LONCAPA::Configuration;	use LONCAPA::Configuration;

use IO::Socket;	use IO::Socket;
use IO::File;	use IO::File;
use Apache::File;	#use Apache::File;
use Symbol;	use Symbol;
use POSIX;	use POSIX;
use Crypt::IDEA;	use Crypt::IDEA;
Line 77 use Authen::Krb4;	Line 127 use Authen::Krb4;
use Authen::Krb5;	use Authen::Krb5;
use lib '/home/httpd/lib/perl/';	use lib '/home/httpd/lib/perl/';
use localauth;	use localauth;
	use File::Copy;

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

my $status='';	my $status='';
my $lastlog='';	my $lastlog='';

	my $VERSION='$Revision$'; #' stupid emacs
	my $remoteVERSION;
	my $currenthostid;
	my $currentdomainid;

	my $client;
	my $clientip;

	my $server;
	my $thisserver;

	my %hostid;
	my %hostdom;
	my %hostip;
	my %perlvar; # Will have the apache conf defined perl vars.

#	#
# The array below are password error strings."	# The array below are password error strings."
#	#
Line 122 my @adderrors = ("ok",	Line 189 my @adderrors = ("ok",


#	#
	# GetCertificate: Given a transaction that requires a certificate,
	# this function will extract the certificate from the transaction
	# request. Note that at this point, the only concept of a certificate
	# is the hostname to which we are connected.
	#
	# Parameter:
	# request - The request sent by our client (this parameterization may
	# need to change when we really use a certificate granting
	# authority.
	#
	sub GetCertificate {
	my $request = shift;

	return $clientip;
	}


	#
	# ValidManager: Determines if a given certificate represents a valid manager.
	# in this primitive implementation, the 'certificate' is
	# just the connecting loncapa client name. This is checked
	# against a valid client list in the configuration.
	#
	#
	sub ValidManager {
	my $certificate = shift;

	my $hostentry = $hostid{$certificate};
	if ($hostentry ne undef) {
	&logthis('<font color="yellow">Authenticating manager'.
	" $hostentry</font>");
	return 1;
	} else {
	&logthis('<font color="red"> Failed manager authentication '.
	"$certificate </font>");
	}
	}
	#
	# CopyFile: Called as part of the process of installing a
	# new configuration file. This function copies an existing
	# file to a backup file.
	# Parameters:
	# oldfile - Name of the file to backup.
	# newfile - Name of the backup file.
	# Return:
	# 0 - Failure (errno has failure reason).
	# 1 - Success.
	#
	sub CopyFile {
	my $oldfile = shift;
	my $newfile = shift;

	# The file must exist:

	if(-e $oldfile) {

	# Read the old file.

	my $oldfh = IO::File->new("< $oldfile");
	if(!$oldfh) {
	return 0;
	}
	my @contents = <$oldfh>; # Suck in the entire file.

	# write the backup file:

	my $newfh = IO::File->new("> $newfile");
	if(!(defined $newfh)){
	return 0;
	}
	my $lines = scalar @contents;
	for (my $i =0; $i < $lines; $i++) {
	print $newfh ($contents[$i]);
	}

	$oldfh->close;
	$newfh->close;

	chmod(0660, $newfile);

	return 1;

	} else {
	return 0;
	}
	}

	#
	# InstallFile: Called to install an administrative file:
	# - The file is created with <name>.tmp
	# - The <name>.tmp file is then mv'd to <name>
	# This lugubrious procedure is done to ensure that we are never without
	# a valid, even if dated, version of the file regardless of who crashes
	# and when the crash occurs.
	#
	# Parameters:
	# Name of the file
	# File Contents.
	# Return:
	# nonzero - success.
	# 0 - failure and $! has an errno.
	#
	sub InstallFile {
	my $Filename = shift;
	my $Contents = shift;
	my $TempFile = $Filename.".tmp";

	# Open the file for write:

	my $fh = IO::File->new("> $TempFile"); # Write to temp.
	if(!(defined $fh)) {
	&logthis('<font color="red"> Unable to create '.$TempFile."</font>");
	return 0;
	}
	# write the contents of the file:

	print $fh ($Contents);
	$fh->close; # In case we ever have a filesystem w. locking

	chmod(0660, $TempFile);

	# Now we can move install the file in position.

	move($TempFile, $Filename);

	return 1;
	}

	#
	# PushFile: Called to do an administrative push of a file.
	# - Ensure the file being pushed is one we support.
	# - Backup the old file to <filename.saved>
	# - Separate the contents of the new file out from the
	# rest of the request.
	# - Write the new file.
	# Parameter:
	# Request - The entire user request. This consists of a : separated
	# string pushfile:tablename:contents.
	# NOTE: The contents may have :'s in it as well making things a bit
	# more interesting... but not much.
	# Returns:
	# String to send to client ("ok" or "refused" if bad file).
	#
	sub PushFile {
	my $request = shift;
	my ($command, $filename, $contents) = split(":", $request, 3);

	# At this point in time, pushes for only the following tables are
	# supported:
	# hosts.tab ($filename eq host).
	# domain.tab ($filename eq domain).
	# Construct the destination filename or reject the request.
	#
	# lonManage is supposed to ensure this, however this session could be
	# part of some elaborate spoof that managed somehow to authenticate.
	#

	my $tablefile = $perlvar{'lonTabDir'}.'/'; # need to precede with dir.
	if ($filename eq "host") {
	$tablefile .= "hosts.tab";
	} elsif ($filename eq "domain") {
	$tablefile .= "domain.tab";
	} else {
	return "refused";
	}
	#
	# >copy< the old table to the backup table
	# don't rename in case system crashes/reboots etc. in the time
	# window between a rename and write.
	#
	my $backupfile = $tablefile;
	$backupfile =~ s/\.tab$/.old/;
	if(!CopyFile($tablefile, $backupfile)) {
	&logthis('<font color="green"> CopyFile from '.$tablefile." to ".$backupfile." failed </font>");
	return "error:$!";
	}
	&logthis('<font color="green"> Pushfile: backed up '
	.$tablefile." to $backupfile</font>");

	# Install the new file:

	if(!InstallFile($tablefile, $contents)) {
	&logthis('<font color="red"> Pushfile: unable to install '
	.$tablefile." $! </font>");
	return "error:$!";
	}
	else {
	&logthis('<font color="green"> Installed new '.$tablefile
	."</font>");

	}


	# Indicate success:

	return "ok";

	}

	#
	# Called to re-init either lonc or lond.
	#
	# Parameters:
	# request - The full request by the client. This is of the form
	# reinit:<process>
	# where <process> is allowed to be either of
	# lonc or lond
	#
	# Returns:
	# The string to be sent back to the client either:
	# ok - Everything worked just fine.
	# error:why - There was a failure and why describes the reason.
	#
	#
	sub ReinitProcess {
	my $request = shift;


	# separate the request (reinit) from the process identifier and
	# validate it producing the name of the .pid file for the process.
	#
	#
	my ($junk, $process) = split(":", $request);
	my $processpidfile = $perlvar{'lonDaemons'}.'/logs/';
	if($process eq 'lonc') {
	$processpidfile = $processpidfile."lonc.pid";
	if (!open(PIDFILE, "< $processpidfile")) {
	return "error:Open failed for $processpidfile";
	}
	my $loncpid = <PIDFILE>;
	close(PIDFILE);
	logthis('<font color="red"> Reinitializing lonc pid='.$loncpid
	."</font>");
	kill("USR2", $loncpid);
	} elsif ($process eq 'lond') {
	logthis('<font color="red"> Reinitializing self (lond) </font>');
	&UpdateHosts; # Lond is us!!
	} else {
	&logthis('<font color="yellow" Invalid reinit request for '.$process
	."</font>");
	return "error:Invalid process identifier $process";
	}
	return 'ok';
	}

	#
# Convert an error return code from lcpasswd to a string value.	# Convert an error return code from lcpasswd to a string value.
#	#
sub lcpasswdstrerror {	sub lcpasswdstrerror {
Line 151 sub catchexception {	Line 464 sub catchexception {
$SIG{'QUIT'}='DEFAULT';	$SIG{'QUIT'}='DEFAULT';
$SIG{__DIE__}='DEFAULT';	$SIG{__DIE__}='DEFAULT';
&logthis("<font color=red>CRITICAL: "	&logthis("<font color=red>CRITICAL: "
."ABNORMAL EXIT. Child $$ for server $wasserver died through "	."ABNORMAL EXIT. Child $$ for server $thisserver 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 171 $SIG{__DIE__}=\&catchexception;	Line 484 $SIG{__DIE__}=\&catchexception;
# ---------------------------------- Read loncapa_apache.conf and loncapa.conf	# ---------------------------------- Read loncapa_apache.conf and loncapa.conf
&status("Read loncapa.conf and loncapa_apache.conf");	&status("Read loncapa.conf and loncapa_apache.conf");
my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf');	my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf');
my %perlvar=%{$perlvarref};	%perlvar=%{$perlvarref};
undef $perlvarref;	undef $perlvarref;

# ----------------------------- Make sure this process is running from user=www	# ----------------------------- Make sure this process is running from user=www
my $wwwid=getpwnam('www');	my $wwwid=getpwnam('www');
if ($wwwid!=$<) {	if ($wwwid!=$<) {
$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";	my $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
$subj="LON: $perlvar{'lonHostID'} User ID mismatch";	my $subj="LON: $currenthostid User ID mismatch";
system("echo 'User ID mismatch. lond must be run as user www.' \|\	system("echo 'User ID mismatch. lond must be run as user www.' \|\
mailto $emailto -s '$subj' > /dev/null");	mailto $emailto -s '$subj' > /dev/null");
exit 1;	exit 1;
Line 195 if (-e $pidfile) {	Line 508 if (-e $pidfile) {
if (kill 0 => $pide) { die "already running"; }	if (kill 0 => $pide) { die "already running"; }
}	}

$PREFORK=4; # number of children to maintain, at least four spare

# ------------------------------------------------------------- Read hosts file	# ------------------------------------------------------------- Read hosts file

open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") \|\| die "Can't read host file";

while ($configline=<CONFIG>) {
my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
chomp($ip); $ip=~s/\D+$//;
$hostid{$ip}=$id;
if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }
$PREFORK++;
}
close(CONFIG);

# establish SERVER socket, bind and listen.	# establish SERVER socket, bind and listen.
$server = IO::Socket::INET->new(LocalPort => $perlvar{'londPort'},	$server = IO::Socket::INET->new(LocalPort => $perlvar{'londPort'},
Line 222 $server = IO::Socket::INET->new(LocalPor	Line 524 $server = IO::Socket::INET->new(LocalPor

# global variables	# global variables

$MAX_CLIENTS_PER_CHILD = 50; # number of clients each child should	my %children = (); # keys are current child process IDs
# process	my $children = 0; # current number of children
%children = (); # keys are current child process IDs
$children = 0; # current number of children

sub REAPER { # takes care of dead children	sub REAPER { # takes care of dead children
$SIG{CHLD} = \&REAPER;	$SIG{CHLD} = \&REAPER;
Line 254 sub HUPSMAN { # sig	Line 554 sub HUPSMAN { # sig
kill 'INT' => keys %children;	kill 'INT' => keys %children;
&logthis("Free socket: ".shutdown($server,2)); # free up socket	&logthis("Free socket: ".shutdown($server,2)); # free up socket
&logthis("<font color=red>CRITICAL: Restarting</font>");	&logthis("<font color=red>CRITICAL: Restarting</font>");
unlink("$execdir/logs/lond.pid");
my $execdir=$perlvar{'lonDaemons'};	my $execdir=$perlvar{'lonDaemons'};
	unlink("$execdir/logs/lond.pid");
exec("$execdir/lond"); # here we go again	exec("$execdir/lond"); # here we go again
}	}

	#
	# Kill off hashes that describe the host table prior to re-reading it.
	# Hashes affected are:
	# %hostid, %hostdom %hostip
	#
	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};
	}
	}
	#
	# 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";

	while (my $configline=<CONFIG>) {
	my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
	chomp($ip); $ip=~s/\D+$//;
	$hostid{$ip}=$id;
	$hostdom{$id}=$domain;
	$hostip{$id}=$ip;
	if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }
	}
	close(CONFIG);
	}
	#
	# Reload the Apache daemon's state.
	# This is done by invoking /home/httpd/perl/apachereload
	# a setuid perl script that can be root for us to do this job.
	#
	sub ReloadApache {
	my $execdir = $perlvar{'lonDaemons'};
	my $script = $execdir."/apachereload";
	system($script);
	}

	#
	# Called in response to a USR2 signal.
	# - Reread hosts.tab
	# - All children connected to hosts that were removed from hosts.tab
	# are killed via SIGINT
	# - All children connected to previously existing hosts are sent SIGUSR1
	# - Our internal hosts hash is updated to reflect the new contents of
	# hosts.tab causing connections from hosts added to hosts.tab to
	# now be honored.
	#
	sub UpdateHosts {
	logthis('<font color="blue"> Updating connections </font>');
	#
	# The %children hash has the set of IP's we currently have children
	# on. These need to be matched against records in the hosts.tab
	# Any ip's no longer in the table get killed off they correspond to
	# 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.


	KillHostHashes;
	ReadHostTable;

	foreach my $child (keys %children) {
	my $childip = $children{$child};
	if(!$hostid{$childip}) {
	logthis('<font color="blue"> UpdateHosts killing child '
	." $child for ip $childip </font>");
	kill('INT', $child);
	} else {
	logthis('<font color="green"> keeping child for ip '
	." $childip (pid=$child) </font>");
	}
	}
	ReloadApache;
	}


sub checkchildren {	sub checkchildren {
&initnewstatus();	&initnewstatus();
&logstatus();	&logstatus();
&logthis('Going to check on the children');	&logthis('Going to check on the children');
$docdir=$perlvar{'lonDocRoot'};	my $docdir=$perlvar{'lonDocRoot'};
foreach (sort keys %children) {	foreach (sort keys %children) {
sleep 1;	sleep 1;
unless (kill 'USR1' => $_) {	unless (kill 'USR1' => $_) {
Line 272 sub checkchildren {	Line 657 sub checkchildren {
}	}
}	}
sleep 5;	sleep 5;
	$SIG{ALRM} = sub { die "timeout" };
	$SIG{__DIE__} = 'DEFAULT';
foreach (sort keys %children) {	foreach (sort keys %children) {
unless (-e "$docdir/lon-status/londchld/$_.txt") {	unless (-e "$docdir/lon-status/londchld/$_.txt") {
	eval {
	alarm(300);
&logthis('Child '.$_.' did not respond');	&logthis('Child '.$_.' did not respond');
kill 9 => $_;	kill 9 => $_;
$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";	#$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
$subj="LON: $perlvar{'lonHostID'} killed lond process $_";	#$subj="LON: $currenthostid killed lond process $_";
my $result=`echo 'Killed lond process $_.' \| mailto $emailto -s '$subj' > /dev/null`;	#my $result=`echo 'Killed lond process $_.' \| mailto $emailto -s '$subj' > /dev/null`;
$execdir=$perlvar{'lonDaemons'};	#$execdir=$perlvar{'lonDaemons'};
$result=`/bin/cp $execdir/logs/lond.log $execdir/logs/lond.log.$_`	#$result=`/bin/cp $execdir/logs/lond.log $execdir/logs/lond.log.$_`;
	alarm(0);
	}
}	}
}	}
	$SIG{ALRM} = 'DEFAULT';
	$SIG{__DIE__} = \&cathcexception;
}	}

# --------------------------------------------------------------------- Logging	# --------------------------------------------------------------------- Logging
Line 310 sub logstatus {	Line 703 sub logstatus {
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");
print $fh $$."\t".$status."\t".$lastlog."\n";	print $fh $$."\t".$currenthostid."\t".$status."\t".$lastlog."\n";
$fh->close();	$fh->close();
}	}
{	{
Line 327 sub initnewstatus {	Line 720 sub initnewstatus {
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");
while ($filename=readdir(DIR)) {	while (my $filename=readdir(DIR)) {
unlink("$docdir/lon-status/londchld/$filename");	unlink("$docdir/lon-status/londchld/$filename");
}	}
closedir(DIR);	closedir(DIR);
Line 371 sub reconlonc {	Line 764 sub reconlonc {
if (kill 0 => $loncpid) {	if (kill 0 => $loncpid) {
&logthis("lonc at pid $loncpid responding, sending USR1");	&logthis("lonc at pid $loncpid responding, sending USR1");
kill USR1 => $loncpid;	kill USR1 => $loncpid;
sleep 5;
if (-e "$peerfile") { return; }
&logthis("$peerfile still not there, give it another try");
sleep 10;
if (-e "$peerfile") { return; }
&logthis(
"<font color=blue>WARNING: $peerfile still not there, giving up</font>");
} else {	} else {
&logthis(	&logthis(
"<font color=red>CRITICAL: "	"<font color=red>CRITICAL: "
Line 407 sub subreply {	Line 793 sub subreply {
sub reply {	sub reply {
my ($cmd,$server)=@_;	my ($cmd,$server)=@_;
my $answer;	my $answer;
if ($server ne $perlvar{'lonHostID'}) {	if ($server ne $currenthostid) {
$answer=subreply($cmd,$server);	$answer=subreply($cmd,$server);
if ($answer eq 'con_lost') {	if ($answer eq 'con_lost') {
$answer=subreply("ping",$server);	$answer=subreply("ping",$server);
if ($answer ne $server) {	if ($answer ne $server) {
&logthis("sub reply: answer != server");	&logthis("sub reply: answer != server answer is $answer, server is $server");
&reconlonc("$perlvar{'lonSockDir'}/$server");	&reconlonc("$perlvar{'lonSockDir'}/$server");
}	}
$answer=subreply($cmd,$server);	$answer=subreply($cmd,$server);
Line 476 sub ishome {	Line 862 sub ishome {
# ======================================================= Continue main program	# ======================================================= Continue main program
# ---------------------------------------------------- Fork once and dissociate	# ---------------------------------------------------- Fork once and dissociate

$fpid=fork;	my $fpid=fork;
exit if $fpid;	exit if $fpid;
die "Couldn't fork: $!" unless defined ($fpid);	die "Couldn't fork: $!" unless defined ($fpid);

Line 484 POSIX::setsid() or die "Can't start new	Line 870 POSIX::setsid() or die "Can't start new

# ------------------------------------------------------- Write our PID on disk	# ------------------------------------------------------- Write our PID on disk

$execdir=$perlvar{'lonDaemons'};	my $execdir=$perlvar{'lonDaemons'};
open (PIDSAVE,">$execdir/logs/lond.pid");	open (PIDSAVE,">$execdir/logs/lond.pid");
print PIDSAVE "$$\n";	print PIDSAVE "$$\n";
close(PIDSAVE);	close(PIDSAVE);
Line 500 $SIG{CHLD} = \&REAPER;	Line 886 $SIG{CHLD} = \&REAPER;
$SIG{INT} = $SIG{TERM} = \&HUNTSMAN;	$SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
$SIG{HUP} = \&HUPSMAN;	$SIG{HUP} = \&HUPSMAN;
$SIG{USR1} = \&checkchildren;	$SIG{USR1} = \&checkchildren;
	$SIG{USR2} = \&UpdateHosts;

	# Read the host hashes:

	ReadHostTable;

# --------------------------------------------------------------	# --------------------------------------------------------------
# Accept connections. When a connection comes in, it is validated	# Accept connections. When a connection comes in, it is validated
Line 514 while (1) {	Line 903 while (1) {
}	}

sub make_new_child {	sub make_new_child {
my $client;
my $pid;	my $pid;
my $cipher;	my $cipher;
my $sigset;	my $sigset;
Line 525 sub make_new_child {	Line 913 sub make_new_child {
$sigset = POSIX::SigSet->new(SIGINT);	$sigset = POSIX::SigSet->new(SIGINT);
sigprocmask(SIG_BLOCK, $sigset)	sigprocmask(SIG_BLOCK, $sigset)
or die "Can't block SIGINT for fork: $!\n";	or die "Can't block SIGINT for fork: $!\n";

die "fork: $!" unless defined ($pid = fork);	die "fork: $!" unless defined ($pid = fork);

	$client->sockopt(SO_KEEPALIVE, 1); # Enable monitoring of
	# connection liveness.

	#
	# Figure out who we're talking to so we can record the peer in
	# the pid hash.
	#
	my $caller = getpeername($client);
	my ($port,$iaddr)=unpack_sockaddr_in($caller);
	$clientip=inet_ntoa($iaddr);

if ($pid) {	if ($pid) {
# Parent records the child's birth and returns.	# Parent records the child's birth and returns.
sigprocmask(SIG_UNBLOCK, $sigset)	sigprocmask(SIG_UNBLOCK, $sigset)
or die "Can't unblock SIGINT for fork: $!\n";	or die "Can't unblock SIGINT for fork: $!\n";
$children{$pid} = 1;	$children{$pid} = $clientip;
$children++;	$children++;
&status('Started child '.$pid);	&status('Started child '.$pid);
return;	return;
} else {	} else {
# Child can not return from this subroutine.	# Child can not return from this subroutine.
$SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before	$SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before
	$SIG{CHLD} = 'DEFAULT'; #make this default so that pwauth returns
	#don't get intercepted
$SIG{USR1}= \&logstatus;	$SIG{USR1}= \&logstatus;
$SIG{ALRM}= \&timeout;	$SIG{ALRM}= \&timeout;
$lastlog='Forked ';	$lastlog='Forked ';
Line 548 sub make_new_child {	Line 949 sub make_new_child {
sigprocmask(SIG_UNBLOCK, $sigset)	sigprocmask(SIG_UNBLOCK, $sigset)
or die "Can't unblock SIGINT for fork: $!\n";	or die "Can't unblock SIGINT for fork: $!\n";

$tmpsnum=0;	my $tmpsnum=0;
#---------------------------------------------------- kerberos 5 initialization	#---------------------------------------------------- kerberos 5 initialization
&Authen::Krb5::init_context();	&Authen::Krb5::init_context();
&Authen::Krb5::init_ets();	&Authen::Krb5::init_ets();
Line 557 sub make_new_child {	Line 958 sub make_new_child {
# =============================================================================	# =============================================================================
# do something with the connection	# do something with the connection
# -----------------------------------------------------------------------------	# -----------------------------------------------------------------------------
$client->sockopt(SO_KEEPALIVE, 1);# Enable monitoring of	# see if we know client and check for spoof IP by challenge
# connection liveness.
# see if we know client and check for spoof IP by challenge
my $caller = getpeername($client);
my ($port,$iaddr)=unpack_sockaddr_in($caller);
my $clientip=inet_ntoa($iaddr);
my $clientrec=($hostid{$clientip} ne undef);	my $clientrec=($hostid{$clientip} ne undef);
&logthis(	&logthis(
"<font color=yellow>INFO: Connection $i, $clientip ($hostid{$clientip})</font>"	"<font color=yellow>INFO: Connection, $clientip ($hostid{$clientip})</font>"
);	);
&status("Connecting $clientip ($hostid{$clientip})");	&status("Connecting $clientip ($hostid{$clientip})");
my $clientok;	my $clientok;
if ($clientrec) {	if ($clientrec) {
&status("Waiting for init from $clientip ($hostid{$clientip})");	&status("Waiting for init from $clientip ($hostid{$clientip})");
my $remotereq=<$client>;	my $remotereq=<$client>;
$remotereq=~s/\W//g;	$remotereq=~s/[^\w:]//g;
if ($remotereq eq 'init') {	if ($remotereq =~ /^init/) {
	&sethost("sethost:$perlvar{'lonHostID'}");
my $challenge="$$".time;	my $challenge="$$".time;
print $client "$challenge\n";	print $client "$challenge\n";
&status(	&status(
Line 602 sub make_new_child {	Line 1000 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

&reconlonc("$perlvar{'lonSockDir'}/$hostid{$clientip}");	foreach my $id (keys(%hostip)) {
&logthis(	if ($hostip{$id} ne $clientip \|\|
"<font color=green>Established connection: $hostid{$clientip}</font>");	$hostip{$currenthostid} eq $clientip) {
	# no need to try to do recon's to myself
	next;
	}
	&reconlonc("$perlvar{'lonSockDir'}/$id");
	}
	&logthis("<font color=green>Established connection: $hostid{$clientip}</font>");
&status('Will listen to '.$hostid{$clientip});	&status('Will listen to '.$hostid{$clientip});
# ------------------------------------------------------------ Process requests	# ------------------------------------------------------------ Process requests
while (my $userinput=<$client>) {	while (my $userinput=<$client>) {
Line 632 sub make_new_child {	Line 1036 sub make_new_child {
# ------------------------------------------------------------- Normal commands	# ------------------------------------------------------------- Normal commands
# ------------------------------------------------------------------------ ping	# ------------------------------------------------------------------------ ping
if ($userinput =~ /^ping/) {	if ($userinput =~ /^ping/) {
print $client "$perlvar{'lonHostID'}\n";	print $client "$currenthostid\n";
# ------------------------------------------------------------------------ pong	# ------------------------------------------------------------------------ pong
} elsif ($userinput =~ /^pong/) {	}elsif ($userinput =~ /^pong/) {
$reply=reply("ping",$hostid{$clientip});	my $reply=&reply("ping",$hostid{$clientip});
print $client "$perlvar{'lonHostID'}:$reply\n";	print $client "$currenthostid:$reply\n";
# ------------------------------------------------------------------------ ekey	# ------------------------------------------------------------------------ ekey
} elsif ($userinput =~ /^ekey/) {	} elsif ($userinput =~ /^ekey/) {
my $buildkey=time.$$.int(rand 100000);	my $buildkey=time.$$.int(rand 100000);
$buildkey=~tr/1-6/A-F/;	$buildkey=~tr/1-6/A-F/;
$buildkey=int(rand 100000).$buildkey.int(rand 100000);	$buildkey=int(rand 100000).$buildkey.int(rand 100000);
my $key=$perlvar{'lonHostID'}.$hostid{$clientip};	my $key=$currenthostid.$hostid{$clientip};
$key=~tr/a-z/A-Z/;	$key=~tr/a-z/A-Z/;
$key=~tr/G-P/0-9/;	$key=~tr/G-P/0-9/;
$key=~tr/Q-Z/0-9/;	$key=~tr/Q-Z/0-9/;
Line 659 sub make_new_child {	Line 1063 sub make_new_child {
$loadavg=<$loadfile>;	$loadavg=<$loadfile>;
}	}
$loadavg =~ s/\s.*//g;	$loadavg =~ s/\s.*//g;
my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'};	my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'};
print $client "$loadpercent\n";	print $client "$loadpercent\n";
	# -------------------------------------------------------------------- userload
	} elsif ($userinput =~ /^userload/) {
	my $userloadpercent=&userload();
	print $client "$userloadpercent\n";

	#
	# Transactions requiring encryption:
	#
# ----------------------------------------------------------------- currentauth	# ----------------------------------------------------------------- currentauth
} elsif ($userinput =~ /^currentauth/) {	} elsif ($userinput =~ /^currentauth/) {
if ($wasenc==1) {	if ($wasenc==1) {
Line 675 sub make_new_child {	Line 1087 sub make_new_child {
} else {	} else {
print $client "refused\n";	print $client "refused\n";
}	}
	#--------------------------------------------------------------------- pushfile
	} elsif($userinput =~ /^pushfile/) {
	if($wasenc == 1) {
	my $cert = GetCertificate($userinput);
	if(ValidManager($cert)) {
	my $reply = PushFile($userinput);
	print $client "$reply\n";
	} else {
	print $client "refused\n";
	}
	} else {
	print $client "refused\n";
	}
	#--------------------------------------------------------------------- reinit
	} elsif($userinput =~ /^reinit/) {
	if ($wasenc == 1) {
	my $cert = GetCertificate($userinput);
	if(ValidManager($cert)) {
	chomp($userinput);
	my $reply = ReinitProcess($userinput);
	print $client "$reply\n";
	} else {
	print $client "refused\n";
	}
	} else {
	print $client "refused\n";
	}
# ------------------------------------------------------------------------ auth	# ------------------------------------------------------------------------ auth
} elsif ($userinput =~ /^auth/) {	} elsif ($userinput =~ /^auth/) {
if ($wasenc==1) {	if ($wasenc==1) {
Line 715 sub make_new_child {	Line 1154 sub make_new_child {
}	}
}	}
} elsif ($howpwd eq 'krb4') {	} elsif ($howpwd eq 'krb4') {
$null=pack("C",0);	my $null=pack("C",0);
unless ($upass=~/$null/) {	unless ($upass=~/$null/) {
my $krb4_error = &Authen::Krb4::get_pw_in_tkt	my $krb4_error = &Authen::Krb4::get_pw_in_tkt
($uname,"",$contentpwd,'krbtgt',	($uname,"",$contentpwd,'krbtgt',
Line 732 sub make_new_child {	Line 1171 sub make_new_child {
}	}
}	}
} elsif ($howpwd eq 'krb5') {	} elsif ($howpwd eq 'krb5') {
$null=pack("C",0);	my $null=pack("C",0);
unless ($upass=~/$null/) {	unless ($upass=~/$null/) {
my $krbclient=&Authen::Krb5::parse_name($uname.'@'.$contentpwd);	my $krbclient=&Authen::Krb5::parse_name($uname.'@'.$contentpwd);
my $krbservice="krbtgt/".$contentpwd."\@".$contentpwd;	my $krbservice="krbtgt/".$contentpwd."\@".$contentpwd;
Line 786 sub make_new_child {	Line 1225 sub make_new_child {
my $salt=time;	my $salt=time;
$salt=substr($salt,6,2);	$salt=substr($salt,6,2);
my $ncpass=crypt($npass,$salt);	my $ncpass=crypt($npass,$salt);
{ my $pf = IO::File->new(">$passfilename");	{
print $pf "internal:$ncpass\n"; }	my $pf;
&logthis("Result of password change for $uname: pwchange_success");	if ($pf = IO::File->new(">$passfilename")) {
print $client "ok\n";	print $pf "internal:$ncpass\n";
	&logthis("Result of password change for $uname: pwchange_success");
	print $client "ok\n";
	} else {
	&logthis("Unable to open $uname passwd to change password");
	print $client "non_authorized\n";
	}
	}

} else {	} else {
print $client "non_authorized\n";	print $client "non_authorized\n";
}	}
Line 816 sub make_new_child {	Line 1263 sub make_new_child {
if ($pwdcorrect) {	if ($pwdcorrect) {
my $execdir=$perlvar{'lonDaemons'};	my $execdir=$perlvar{'lonDaemons'};
&Debug("Opening lcpasswd pipeline");	&Debug("Opening lcpasswd pipeline");
my $pf = IO::File->new("\|$execdir/lcpasswd > /home/www/lcpasswd.log");	my $pf = IO::File->new("\|$execdir/lcpasswd > $perlvar{'lonDaemons'}/logs/lcpasswd.log");
print $pf "$uname\n$npass\n$npass\n";	print $pf "$uname\n$npass\n$npass\n";
close $pf;	close $pf;
my $err = $?;	my $err = $?;
Line 854 sub make_new_child {	Line 1301 sub make_new_child {
$passfilename);	$passfilename);
if (-e $passfilename) {	if (-e $passfilename) {
print $client "already_exists\n";	print $client "already_exists\n";
} elsif ($udom ne $perlvar{'lonDefDomain'}) {	} elsif ($udom ne $currentdomainid) {
print $client "not_right_domain\n";	print $client "not_right_domain\n";
} else {	} else {
@fpparts=split(/\//,$proname);	my @fpparts=split(/\//,$proname);
$fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2];	my $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2];
$fperror='';	my $fperror='';
for ($i=3;$i<=$#fpparts;$i++) {	for (my $i=3;$i<=$#fpparts;$i++) {
$fpnow.='/'.$fpparts[$i];	$fpnow.='/'.$fpparts[$i];
unless (-e $fpnow) {	unless (-e $fpnow) {
unless (mkdir($fpnow,0777)) {	unless (mkdir($fpnow,0777)) {
$fperror="error:$!";	$fperror="error: ".($!+0)
	." mkdir failed while attempting "
	."makeuser\n";
}	}
}	}
}	}
Line 892 sub make_new_child {	Line 1341 sub make_new_child {
$npass=&unescape($npass);	$npass=&unescape($npass);
my $proname=&propath($udom,$uname);	my $proname=&propath($udom,$uname);
my $passfilename="$proname/passwd";	my $passfilename="$proname/passwd";
if ($udom ne $perlvar{'lonDefDomain'}) {	if ($udom ne $currentdomainid) {
print $client "not_right_domain\n";	print $client "not_right_domain\n";
} else {	} else {
my $result=&make_passwd_file($uname, $umode,$npass,	my $result=&make_passwd_file($uname, $umode,$npass,
Line 922 sub make_new_child {	Line 1371 sub make_new_child {
$uid,$gid,$rdev,$size,	$uid,$gid,$rdev,$size,
$atime,$mtime,$ctime,	$atime,$mtime,$ctime,
$blksize,$blocks)=stat($fname);	$blksize,$blocks)=stat($fname);
$now=time;	my $now=time;
$since=$now-$atime;	my $since=$now-$atime;
if ($since>$perlvar{'lonExpire'}) {	if ($since>$perlvar{'lonExpire'}) {
$reply=	my $reply=
reply("unsub:$fname","$hostid{$clientip}");	&reply("unsub:$fname","$hostid{$clientip}");
unlink("$fname");	unlink("$fname");
} else {	} else {
my $transname="$fname.in.transfer";	my $transname="$fname.in.transfer";
Line 966 sub make_new_child {	Line 1415 sub make_new_child {
}	}
# -------------------------------------- fetch a user file from a remote server	# -------------------------------------- fetch a user file from a remote server
} elsif ($userinput =~ /^fetchuserfile/) {	} elsif ($userinput =~ /^fetchuserfile/) {
my ($cmd,$fname)=split(/:/,$userinput);	my ($cmd,$fname)=split(/:/,$userinput);
my ($udom,$uname,$ufile)=split(/\//,$fname);	my ($udom,$uname,$ufile)=split(/\//,$fname);
my $udir=propath($udom,$uname).'/userfiles';	my $udir=propath($udom,$uname).'/userfiles';
unless (-e $udir) { mkdir($udir,0770); }	unless (-e $udir) { mkdir($udir,0770); }
if (-e $udir) {	if (-e $udir) {
$ufile=~s/^[\.\~]+//;	$ufile=~s/^[\.\~]+//;
$ufile=~s/\///g;	$ufile=~s/\///g;
my $transname=$udir.'/'.$ufile;	my $destname=$udir.'/'.$ufile;
my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;	my $transname=$udir.'/'.$ufile.'.in.transit';
my $response;	my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;
{	my $response;
my $ua=new LWP::UserAgent;	{
my $request=new HTTP::Request('GET',"$remoteurl");	my $ua=new LWP::UserAgent;
$response=$ua->request($request,$transname);	my $request=new HTTP::Request('GET',"$remoteurl");
}	$response=$ua->request($request,$transname);
if ($response->is_error()) {	}
unlink($transname);	if ($response->is_error()) {
my $message=$response->status_line;	unlink($transname);
&logthis(	my $message=$response->status_line;
"LWP GET: $message for $fname ($remoteurl)");	&logthis("LWP GET: $message for $fname ($remoteurl)");
print $client "failed\n";	print $client "failed\n";
} else {	} else {
print $client "ok\n";	if (!rename($transname,$destname)) {
}	&logthis("Unable to move $transname to $destname");
} else {	unlink($transname);
print $client "not_home\n";	print $client "failed\n";
}	} else {
	print $client "ok\n";
	}
	}
	} else {
	print $client "not_home\n";
	}
# ------------------------------------------ authenticate access to a user file	# ------------------------------------------ authenticate access to a user file
} elsif ($userinput =~ /^tokenauthuserfile/) {	} elsif ($userinput =~ /^tokenauthuserfile/) {
my ($cmd,$fname,$session)=split(/:/,$userinput);	my ($cmd,$fname,$session)=split(/:/,$userinput);
chomp($session);	chomp($session);
$reply='non_auth';	my $reply='non_auth';
if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.	if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.
$session.'.id')) {	$session.'.id')) {
while ($line=<ENVIN>) {	while (my $line=<ENVIN>) {
if ($line=~/userfile\.$fname\=/) { $reply='ok'; }	if ($line=~/userfile\.$fname\=/) { $reply='ok'; }
}	}
close(ENVIN);	close(ENVIN);
print $client $reply."\n";	print $client $reply."\n";
} else {	} else {
print $client "invalid_token\n";	print $client "invalid_token\n";
}	}
# ----------------------------------------------------------------- unsubscribe	# ----------------------------------------------------------------- unsubscribe
} elsif ($userinput =~ /^unsub/) {	} elsif ($userinput =~ /^unsub/) {
Line 1035 sub make_new_child {	Line 1490 sub make_new_child {
print $hfh "$now:$hostid{$clientip}:$what\n";	print $hfh "$now:$hostid{$clientip}:$what\n";
print $client "ok\n";	print $client "ok\n";
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." IO::File->new Failed "
	."while attempting log\n";
}	}
}	}
# ------------------------------------------------------------------------- put	# ------------------------------------------------------------------------- put
Line 1055 sub make_new_child {	Line 1512 sub make_new_child {
) { print $hfh "P:$now:$what\n"; }	) { print $hfh "P:$now:$what\n"; }
}	}
my @pairs=split(/\&/,$what);	my @pairs=split(/\&/,$what);
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {	my %hash;
foreach $pair (@pairs) {	if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
($key,$value)=split(/=/,$pair);	foreach my $pair (@pairs) {
	my ($key,$value)=split(/=/,$pair);
$hash{$key}=$value;	$hash{$key}=$value;
}	}
if (untie(%hash)) {	if (untie(%hash)) {
print $client "ok\n";	print $client "ok\n";
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." untie(GDBM) failed ".
	"while attempting put\n";
}	}
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!)
	." tie(GDBM) Failed ".
	"while attempting put\n";
}	}
} else {	} else {
print $client "refused\n";	print $client "refused\n";
Line 1093 sub make_new_child {	Line 1555 sub make_new_child {
}	}
}	}
my @pairs=split(/\&/,$what);	my @pairs=split(/\&/,$what);
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {	my %hash;
foreach $pair (@pairs) {	if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
($key,$value)=split(/=/,$pair);	foreach my $pair (@pairs) {
	my ($key,$value)=split(/=/,$pair);
&ManagePermissions($key, $udom, $uname,	&ManagePermissions($key, $udom, $uname,
&GetAuthType( $udom,	&GetAuthType( $udom,
$uname));	$uname));
$hash{$key}=$value;	$hash{$key}=$value;

}	}
if (untie(%hash)) {	if (untie(%hash)) {
print $client "ok\n";	print $client "ok\n";
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." untie(GDBM) Failed ".
	"while attempting rolesput\n";
	}
	} else {
	print $client "error: ".($!+0)
	." tie(GDBM) Failed ".
	"while attempting rolesput\n";
	}
	} else {
	print $client "refused\n";
	}
	# -------------------------------------------------------------------- rolesdel
	} elsif ($userinput =~ /^rolesdel/) {
	&Debug("rolesdel");
	if ($wasenc==1) {
	my ($cmd,$exedom,$exeuser,$udom,$uname,$what)
	=split(/:/,$userinput);
	&Debug("cmd = ".$cmd." exedom= ".$exedom.
	"user = ".$exeuser." udom=".$udom.
	"what = ".$what);
	my $namespace='roles';
	chomp($what);
	my $proname=propath($udom,$uname);
	my $now=time;
	{
	my $hfh;
	if (
	$hfh=IO::File->new(">>$proname/$namespace.hist")
	) {
	print $hfh "D:$now:$exedom:$exeuser:$what\n";
	}
	}
	my @rolekeys=split(/\&/,$what);
	my %hash;
	if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
	foreach my $key (@rolekeys) {
	delete $hash{$key};
	}
	if (untie(%hash)) {
	print $client "ok\n";
	} else {
	print $client "error: ".($!+0)
	." untie(GDBM) Failed ".
	"while attempting rolesdel\n";
}	}
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." tie(GDBM) Failed ".
	"while attempting rolesdel\n";
}	}
} else {	} else {
print $client "refused\n";	print $client "refused\n";
Line 1123 sub make_new_child {	Line 1631 sub make_new_child {
my @queries=split(/\&/,$what);	my @queries=split(/\&/,$what);
my $proname=propath($udom,$uname);	my $proname=propath($udom,$uname);
my $qresult='';	my $qresult='';
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {	my %hash;
for ($i=0;$i<=$#queries;$i++) {	if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
	for (my $i=0;$i<=$#queries;$i++) {
$qresult.="$hash{$queries[$i]}&";	$qresult.="$hash{$queries[$i]}&";
}	}
if (untie(%hash)) {	if (untie(%hash)) {
$qresult=~s/\&$//;	$qresult=~s/\&$//;
print $client "$qresult\n";	print $client "$qresult\n";
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." untie(GDBM) Failed ".
	"while attempting get\n";
}	}
} else {	} else {
print $client "error:$!\n";	if ($!+0 == 2) {
	print $client "error:No such file or ".
	"GDBM reported bad block error\n";
	} else {
	print $client "error: ".($!+0)
	." tie(GDBM) Failed ".
	"while attempting get\n";
	}
}	}
# ------------------------------------------------------------------------ eget	# ------------------------------------------------------------------------ eget
} elsif ($userinput =~ /^eget/) {	} elsif ($userinput =~ /^eget/) {
Line 1146 sub make_new_child {	Line 1664 sub make_new_child {
my @queries=split(/\&/,$what);	my @queries=split(/\&/,$what);
my $proname=propath($udom,$uname);	my $proname=propath($udom,$uname);
my $qresult='';	my $qresult='';
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {	my %hash;
for ($i=0;$i<=$#queries;$i++) {	if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
	for (my $i=0;$i<=$#queries;$i++) {
$qresult.="$hash{$queries[$i]}&";	$qresult.="$hash{$queries[$i]}&";
}	}
if (untie(%hash)) {	if (untie(%hash)) {
Line 1167 sub make_new_child {	Line 1686 sub make_new_child {
print $client "error:no_key\n";	print $client "error:no_key\n";
}	}
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." untie(GDBM) Failed ".
	"while attempting eget\n";
}	}
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." tie(GDBM) Failed ".
	"while attempting eget\n";
}	}
# ------------------------------------------------------------------------- del	# ------------------------------------------------------------------------- del
} elsif ($userinput =~ /^del/) {	} elsif ($userinput =~ /^del/) {
Line 1188 sub make_new_child {	Line 1711 sub make_new_child {
) { print $hfh "D:$now:$what\n"; }	) { print $hfh "D:$now:$what\n"; }
}	}
my @keys=split(/\&/,$what);	my @keys=split(/\&/,$what);
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {	my %hash;
foreach $key (@keys) {	if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
	foreach my $key (@keys) {
delete($hash{$key});	delete($hash{$key});
}	}
if (untie(%hash)) {	if (untie(%hash)) {
print $client "ok\n";	print $client "ok\n";
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." untie(GDBM) Failed ".
	"while attempting del\n";
}	}
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." tie(GDBM) Failed ".
	"while attempting del\n";
}	}
# ------------------------------------------------------------------------ keys	# ------------------------------------------------------------------------ keys
} elsif ($userinput =~ /^keys/) {	} elsif ($userinput =~ /^keys/) {
Line 1208 sub make_new_child {	Line 1736 sub make_new_child {
$namespace=~s/\W//g;	$namespace=~s/\W//g;
my $proname=propath($udom,$uname);	my $proname=propath($udom,$uname);
my $qresult='';	my $qresult='';
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {	my %hash;
foreach $key (keys %hash) {	if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
	foreach my $key (keys %hash) {
$qresult.="$key&";	$qresult.="$key&";
}	}
if (untie(%hash)) {	if (untie(%hash)) {
$qresult=~s/\&$//;	$qresult=~s/\&$//;
print $client "$qresult\n";	print $client "$qresult\n";
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." untie(GDBM) Failed ".
	"while attempting keys\n";
}	}
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." tie(GDBM) Failed ".
	"while attempting keys\n";
}	}
# ----------------------------------------------------------------- dumpcurrent	# ----------------------------------------------------------------- dumpcurrent
} elsif ($userinput =~ /^dumpcurrent/) {	} elsif ($userinput =~ /^currentdump/) {
my ($cmd,$udom,$uname,$namespace)	my ($cmd,$udom,$uname,$namespace)
=split(/:/,$userinput);	=split(/:/,$userinput);
$namespace=~s/\//\_/g;	$namespace=~s/\//\_/g;
$namespace=~s/\W//g;	$namespace=~s/\W//g;
my $qresult='';	my $qresult='';
my $proname=propath($udom,$uname);	my $proname=propath($udom,$uname);
	my %hash;
if (tie(%hash,'GDBM_File',	if (tie(%hash,'GDBM_File',
"$proname/$namespace.db",	"$proname/$namespace.db",
&GDBM_READER(),0640)) {	&GDBM_READER(),0640)) {
Line 1244 sub make_new_child {	Line 1778 sub make_new_child {
next if (exists($data{$symb}) &&	next if (exists($data{$symb}) &&
exists($data{$symb}->{$param}) &&	exists($data{$symb}->{$param}) &&
$data{$symb}->{'v.'.$param} > $v);	$data{$symb}->{'v.'.$param} > $v);
#&logthis("v = ".$v." p = ".$param." s = ".$symb);
$data{$symb}->{$param}=$value;	$data{$symb}->{$param}=$value;
$data{$symb}->{'v.'.$param}=$value;	$data{$symb}->{'v.'.$param}=$v;
}	}
if (untie(%hash)) {	if (untie(%hash)) {
while (my ($symb,$param_hash) = each(%data)) {	while (my ($symb,$param_hash) = each(%data)) {
Line 1258 sub make_new_child {	Line 1791 sub make_new_child {
chop($qresult);	chop($qresult);
print $client "$qresult\n";	print $client "$qresult\n";
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." untie(GDBM) Failed ".
	"while attempting currentdump\n";
}	}
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." tie(GDBM) Failed ".
	"while attempting currentdump\n";
}	}
# ------------------------------------------------------------------------ dump	# ------------------------------------------------------------------------ dump
} elsif ($userinput =~ /^dump/) {	} elsif ($userinput =~ /^dump/) {
Line 1276 sub make_new_child {	Line 1813 sub make_new_child {
}	}
my $qresult='';	my $qresult='';
my $proname=propath($udom,$uname);	my $proname=propath($udom,$uname);
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {	my %hash;
	if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
study($regexp);	study($regexp);
while (($key,$value) = each(%hash)) {	while (my ($key,$value) = each(%hash)) {
if ($regexp eq '.') {	if ($regexp eq '.') {
$qresult.=$key.'='.$value.'&';	$qresult.=$key.'='.$value.'&';
} else {	} else {
Line 1292 sub make_new_child {	Line 1830 sub make_new_child {
chop($qresult);	chop($qresult);
print $client "$qresult\n";	print $client "$qresult\n";
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." untie(GDBM) Failed ".
	"while attempting dump\n";
}	}
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." tie(GDBM) Failed ".
	"while attempting dump\n";
}	}
# ----------------------------------------------------------------------- store	# ----------------------------------------------------------------------- store
} elsif ($userinput =~ /^store/) {	} elsif ($userinput =~ /^store/) {
Line 1314 sub make_new_child {	Line 1856 sub make_new_child {
) { print $hfh "P:$now:$rid:$what\n"; }	) { print $hfh "P:$now:$rid:$what\n"; }
}	}
my @pairs=split(/\&/,$what);	my @pairs=split(/\&/,$what);
	my %hash;
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {	if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
my @previouskeys=split(/&/,$hash{"keys:$rid"});	my @previouskeys=split(/&/,$hash{"keys:$rid"});
my $key;	my $key;
$hash{"version:$rid"}++;	$hash{"version:$rid"}++;
my $version=$hash{"version:$rid"};	my $version=$hash{"version:$rid"};
my $allkeys='';	my $allkeys='';
foreach $pair (@pairs) {	foreach my $pair (@pairs) {
($key,$value)=split(/=/,$pair);	my ($key,$value)=split(/=/,$pair);
$allkeys.=$key.':';	$allkeys.=$key.':';
$hash{"$version:$rid:$key"}=$value;	$hash{"$version:$rid:$key"}=$value;
}	}
Line 1332 sub make_new_child {	Line 1874 sub make_new_child {
if (untie(%hash)) {	if (untie(%hash)) {
print $client "ok\n";	print $client "ok\n";
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." untie(GDBM) Failed ".
	"while attempting store\n";
}	}
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." tie(GDBM) Failed ".
	"while attempting store\n";
}	}
} else {	} else {
print $client "refused\n";	print $client "refused\n";
Line 1349 sub make_new_child {	Line 1895 sub make_new_child {
chomp($rid);	chomp($rid);
my $proname=propath($udom,$uname);	my $proname=propath($udom,$uname);
my $qresult='';	my $qresult='';
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {	my %hash;
	if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
my $version=$hash{"version:$rid"};	my $version=$hash{"version:$rid"};
$qresult.="version=$version&";	$qresult.="version=$version&";
my $scope;	my $scope;
Line 1366 sub make_new_child {	Line 1913 sub make_new_child {
$qresult=~s/\&$//;	$qresult=~s/\&$//;
print $client "$qresult\n";	print $client "$qresult\n";
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." untie(GDBM) Failed ".
	"while attempting restore\n";
}	}
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." tie(GDBM) Failed ".
	"while attempting restore\n";
}	}
# -------------------------------------------------------------------- chatsend	# -------------------------------------------------------------------- chatsend
} elsif ($userinput =~ /^chatsend/) {	} elsif ($userinput =~ /^chatsend/) {
Line 1378 sub make_new_child {	Line 1929 sub make_new_child {
print $client "ok\n";	print $client "ok\n";
# -------------------------------------------------------------------- chatretr	# -------------------------------------------------------------------- chatretr
} elsif ($userinput =~ /^chatretr/) {	} elsif ($userinput =~ /^chatretr/) {
my ($cmd,$cdom,$cnum)=split(/\:/,$userinput);	my
	($cmd,$cdom,$cnum,$udom,$uname)=split(/\:/,$userinput);
my $reply='';	my $reply='';
foreach (&getchat($cdom,$cnum)) {	foreach (&getchat($cdom,$cnum,$udom,$uname)) {
$reply.=&escape($_).':';	$reply.=&escape($_).':';
}	}
$reply=~s/\:$//;	$reply=~s/\:$//;
Line 1408 sub make_new_child {	Line 1960 sub make_new_child {
print $client "ok\n";	print $client "ok\n";
}	}
else {	else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." IO::File->new Failed ".
	"while attempting queryreply\n";
	}
	# ----------------------------------------------------------------- courseidput
	} elsif ($userinput =~ /^courseidput/) {
	my ($cmd,$udom,$what)=split(/:/,$userinput);
	chomp($what);
	$udom=~s/\W//g;
	my $proname=
	"$perlvar{'lonUsersDir'}/$udom/nohist_courseids";
	my $now=time;
	my @pairs=split(/\&/,$what);
	my %hash;
	if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {
	foreach my $pair (@pairs) {
	my ($key,$value)=split(/=/,$pair);
	$hash{$key}=$value.':'.$now;
	}
	if (untie(%hash)) {
	print $client "ok\n";
	} else {
	print $client "error: ".($!+0)
	." untie(GDBM) Failed ".
	"while attempting courseidput\n";
	}
	} else {
	print $client "error: ".($!+0)
	." tie(GDBM) Failed ".
	"while attempting courseidput\n";
	}
	# ---------------------------------------------------------------- courseiddump
	} elsif ($userinput =~ /^courseiddump/) {
	my ($cmd,$udom,$since,$description)
	=split(/:/,$userinput);
	if (defined($description)) {
	$description=&unescape($description);
	} else {
	$description='.';
}	}
	unless (defined($since)) { $since=0; }
	my $qresult='';
	my $proname=
	"$perlvar{'lonUsersDir'}/$udom/nohist_courseids";
	my %hash;
	if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {
	while (my ($key,$value) = each(%hash)) {
	my ($descr,$lasttime)=split(/\:/,$value);
	if ($lasttime<$since) { next; }
	if ($description eq '.') {
	$qresult.=$key.'='.$descr.'&';
	} else {
	my $unescapeVal = &unescape($descr);
	if (eval('$unescapeVal=~/$description/i')) {
	$qresult.="$key=$descr&";
	}
	}
	}
	if (untie(%hash)) {
	chop($qresult);
	print $client "$qresult\n";
	} else {
	print $client "error: ".($!+0)
	." untie(GDBM) Failed ".
	"while attempting courseiddump\n";
	}
	} else {
	print $client "error: ".($!+0)
	." tie(GDBM) Failed ".
	"while attempting courseiddump\n";
	}
# ----------------------------------------------------------------------- idput	# ----------------------------------------------------------------------- idput
} elsif ($userinput =~ /^idput/) {	} elsif ($userinput =~ /^idput/) {
my ($cmd,$udom,$what)=split(/:/,$userinput);	my ($cmd,$udom,$what)=split(/:/,$userinput);
Line 1424 sub make_new_child {	Line 2045 sub make_new_child {
) { print $hfh "P:$now:$what\n"; }	) { print $hfh "P:$now:$what\n"; }
}	}
my @pairs=split(/\&/,$what);	my @pairs=split(/\&/,$what);
if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT,0640)) {	my %hash;
foreach $pair (@pairs) {	if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {
($key,$value)=split(/=/,$pair);	foreach my $pair (@pairs) {
	my ($key,$value)=split(/=/,$pair);
$hash{$key}=$value;	$hash{$key}=$value;
}	}
if (untie(%hash)) {	if (untie(%hash)) {
print $client "ok\n";	print $client "ok\n";
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." untie(GDBM) Failed ".
	"while attempting idput\n";
}	}
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." tie(GDBM) Failed ".
	"while attempting idput\n";
}	}
# ----------------------------------------------------------------------- idget	# ----------------------------------------------------------------------- idget
} elsif ($userinput =~ /^idget/) {	} elsif ($userinput =~ /^idget/) {
Line 1445 sub make_new_child {	Line 2071 sub make_new_child {
my $proname="$perlvar{'lonUsersDir'}/$udom/ids";	my $proname="$perlvar{'lonUsersDir'}/$udom/ids";
my @queries=split(/\&/,$what);	my @queries=split(/\&/,$what);
my $qresult='';	my $qresult='';
if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER,0640)) {	my %hash;
for ($i=0;$i<=$#queries;$i++) {	if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {
	for (my $i=0;$i<=$#queries;$i++) {
$qresult.="$hash{$queries[$i]}&";	$qresult.="$hash{$queries[$i]}&";
}	}
if (untie(%hash)) {	if (untie(%hash)) {
$qresult=~s/\&$//;	$qresult=~s/\&$//;
print $client "$qresult\n";	print $client "$qresult\n";
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." untie(GDBM) Failed ".
	"while attempting idget\n";
}	}
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." tie(GDBM) Failed ".
	"while attempting idget\n";
}	}
# ---------------------------------------------------------------------- tmpput	# ---------------------------------------------------------------------- tmpput
} elsif ($userinput =~ /^tmpput/) {	} elsif ($userinput =~ /^tmpput/) {
Line 1473 sub make_new_child {	Line 2104 sub make_new_child {
print $client "$id\n";	print $client "$id\n";
}	}
else {	else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	."IO::File->new Failed ".
	"while attempting tmpput\n";
}	}

# ---------------------------------------------------------------------- tmpget	# ---------------------------------------------------------------------- tmpget
Line 1489 sub make_new_child {	Line 2122 sub make_new_child {
close $store;	close $store;
}	}
else {	else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	."IO::File->new Failed ".
	"while attempting tmpget\n";
}	}

	# ---------------------------------------------------------------------- tmpdel
	} elsif ($userinput =~ /^tmpdel/) {
	my ($cmd,$id)=split(/:/,$userinput);
	chomp($id);
	$id=~s/\W/\_/g;
	my $execdir=$perlvar{'lonDaemons'};
	if (unlink("$execdir/tmp/$id.tmp")) {
	print $client "ok\n";
	} else {
	print $client "error: ".($!+0)
	."Unlink tmp Failed ".
	"while attempting tmpdel\n";
	}
# -------------------------------------------------------------------------- ls	# -------------------------------------------------------------------------- ls
} elsif ($userinput =~ /^ls/) {	} elsif ($userinput =~ /^ls/) {
my ($cmd,$ulsdir)=split(/:/,$userinput);	my ($cmd,$ulsdir)=split(/:/,$userinput);
Line 1516 sub make_new_child {	Line 2164 sub make_new_child {
}	}
if ($ulsout eq '') { $ulsout='empty'; }	if ($ulsout eq '') { $ulsout='empty'; }
print $client "$ulsout\n";	print $client "$ulsout\n";
	# ----------------------------------------------------------------- setannounce
	} elsif ($userinput =~ /^setannounce/) {
	my ($cmd,$announcement)=split(/:/,$userinput);
	chomp($announcement);
	$announcement=&unescape($announcement);
	if (my $store=IO::File->new('>'.$perlvar{'lonDocRoot'}.
	'/announcement.txt')) {
	print $store $announcement;
	close $store;
	print $client "ok\n";
	} else {
	print $client "error: ".($!+0)."\n";
	}
# ------------------------------------------------------------------ Hanging up	# ------------------------------------------------------------------ Hanging up
} elsif (($userinput =~ /^exit/) \|\|	} elsif (($userinput =~ /^exit/) \|\|
($userinput =~ /^init/)) {	($userinput =~ /^init/)) {
Line 1525 sub make_new_child {	Line 2186 sub make_new_child {
$client->close();	$client->close();
last;	last;
# ------------------------------------------------------------- unknown command	# ------------------------------------------------------------- unknown command
	} elsif ($userinput =~ /^sethost:/) {
	print $client &sethost($userinput)."\n";
	} elsif ($userinput =~/^version:/) {
	print $client &version($userinput)."\n";
} else {	} else {
# unknown command	# unknown command
print $client "unknown_cmd\n";	print $client "unknown_cmd\n";
Line 1575 sub ManagePermissions	Line 2240 sub ManagePermissions
my $authtype= shift;	my $authtype= shift;

# See if the request is of the form /$domain/_au	# See if the request is of the form /$domain/_au
	&logthis("ruequest is $request");
if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...	if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...
my $execdir = $perlvar{'lonDaemons'};	my $execdir = $perlvar{'lonDaemons'};
my $userhome= "/home/$user" ;	my $userhome= "/home/$user" ;
Debug("system $execdir/lchtmldir $userhome $system $authtype");	&logthis("system $execdir/lchtmldir $userhome $user $authtype");
system("$execdir/lchtmldir $userhome $user $authtype");	system("$execdir/lchtmldir $userhome $user $authtype");
}	}
}	}
Line 1622 sub addline {	Line 2287 sub addline {
my $found=0;	my $found=0;
my $expr='^'.$hostid.':'.$ip.':';	my $expr='^'.$hostid.':'.$ip.':';
$expr =~ s/\./\\\./g;	$expr =~ s/\./\\\./g;
	my $sh;
if ($sh=IO::File->new("$fname.subscription")) {	if ($sh=IO::File->new("$fname.subscription")) {
while (my $subline=<$sh>) {	while (my $subline=<$sh>) {
if ($subline !~ /$expr/) {$contents.= $subline;} else {$found=1;}	if ($subline !~ /$expr/) {$contents.= $subline;} else {$found=1;}
Line 1636 sub addline {	Line 2302 sub addline {
}	}

sub getchat {	sub getchat {
my ($cdom,$cname)=@_;	my ($cdom,$cname,$udom,$uname)=@_;
my %hash;	my %hash;
my $proname=&propath($cdom,$cname);	my $proname=&propath($cdom,$cname);
my @entries=();	my @entries=();
Line 1645 sub getchat {	Line 2311 sub getchat {
@entries=map { $_.':'.$hash{$_} } sort keys %hash;	@entries=map { $_.':'.$hash{$_} } sort keys %hash;
untie %hash;	untie %hash;
}	}
return @entries;	my @participants=();
	my $cutoff=time-60;
	if (tie(%hash,'GDBM_File',"$proname/nohist_inchatroom.db",
	&GDBM_WRCREAT(),0640)) {
	$hash{$uname.':'.$udom}=time;
	foreach (sort keys %hash) {
	if ($hash{$_}>$cutoff) {
	$participants[$#participants+1]='active_participant:'.$_;
	}
	}
	untie %hash;
	}
	return (@participants,@entries);
}	}

sub chatadd {	sub chatadd {
Line 1653 sub chatadd {	Line 2331 sub chatadd {
my %hash;	my %hash;
my $proname=&propath($cdom,$cname);	my $proname=&propath($cdom,$cname);
my @entries=();	my @entries=();
	my $time=time;
if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db",	if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db",
&GDBM_WRCREAT(),0640)) {	&GDBM_WRCREAT(),0640)) {
@entries=map { $_.':'.$hash{$_} } sort keys %hash;	@entries=map { $_.':'.$hash{$_} } sort keys %hash;
my $time=time;
my ($lastid)=($entries[$#entries]=~/^(\w+)\:/);	my ($lastid)=($entries[$#entries]=~/^(\w+)\:/);
my ($thentime,$idnum)=split(/\_/,$lastid);	my ($thentime,$idnum)=split(/\_/,$lastid);
my $newid=$time.'_000000';	my $newid=$time.'_000000';
Line 1676 sub chatadd {	Line 2354 sub chatadd {
}	}
untie %hash;	untie %hash;
}	}
	{
	my $hfh;
	if ($hfh=IO::File->new(">>$proname/chatroom.log")) {
	print $hfh "$time:".&unescape($newchat)."\n";
	}
	}
}	}

sub unsub {	sub unsub {
Line 1702 sub currentversion {	Line 2386 sub currentversion {
if ($fname=~/^(.+)\/[^\/]+$/) {	if ($fname=~/^(.+)\/[^\/]+$/) {
$ulsdir=$1;	$ulsdir=$1;
}	}
	my ($fnamere1,$fnamere2);
	# remove version if already specified
$fname=~s/\.\d+\.(\w+(?:\.meta)*)$/\.$1/;	$fname=~s/\.\d+\.(\w+(?:\.meta)*)$/\.$1/;
$fname=~s/\.(\w+(?:\.meta)*)$/\.$\\d\+$\.$1\$/;	# get the bits that go before and after the version number
	if ( $fname=~/^(.\.)(\w+(?:\.meta))$/ ) {
	$fnamere1=$1;
	$fnamere2='.'.$2;
	}
if (-e $fname) { $version=1; }	if (-e $fname) { $version=1; }
if (-e $ulsdir) {	if (-e $ulsdir) {
if(-d $ulsdir) {	if(-d $ulsdir) {
if (opendir(LSDIR,$ulsdir)) {	if (opendir(LSDIR,$ulsdir)) {
while ($ulsfn=readdir(LSDIR)) {	my $ulsfn;
	while ($ulsfn=readdir(LSDIR)) {
# see if this is a regular file (ignore links produced earlier)	# see if this is a regular file (ignore links produced earlier)
my $thisfile=$ulsdir.'/'.$ulsfn;	my $thisfile=$ulsdir.'/'.$ulsfn;
unless (-l $thisfile) {	unless (-l $thisfile) {
if ($thisfile=~/$fname/) {	if ($thisfile=~/\Q$fnamere1\E(\d+)\Q$fnamere2\E/) {
if ($1>$version) { $version=$1; }	if ($1>$version) { $version=$1; }
}	}
}	}
}	}
closedir(LSDIR);	closedir(LSDIR);
$version++;	$version++;
}	}
}	}
}	}
return $version;	return $version;
}	}

sub thisversion {	sub thisversion {
Line 1762 sub subscribe {	Line 2452 sub subscribe {
$result="directory\n";	$result="directory\n";
} else {	} else {
if (-e "$fname.$hostid{$clientip}") {&unsub($fname,$clientip);}	if (-e "$fname.$hostid{$clientip}") {&unsub($fname,$clientip);}
$now=time;	my $now=time;
my $found=&addline($fname,$hostid{$clientip},$clientip,	my $found=&addline($fname,$hostid{$clientip},$clientip,
"$hostid{$clientip}:$clientip:$now\n");	"$hostid{$clientip}:$clientip:$now\n");
if ($found) { $result="$fname\n"; }	if ($found) { $result="$fname\n"; }
Line 1811 sub make_passwd_file {	Line 2501 sub make_passwd_file {
{	{
&Debug("Executing external: ".$execpath);	&Debug("Executing external: ".$execpath);
&Debug("user = ".$uname.", Password =". $npass);	&Debug("user = ".$uname.", Password =". $npass);
my $se = IO::File->new("\|$execpath > /home/www/lcuseradd.log");	my $se = IO::File->new("\|$execpath > $perlvar{'lonDaemons'}/logs/lcuseradd.log");
print $se "$uname\n";	print $se "$uname\n";
print $se "$npass\n";	print $se "$npass\n";
print $se "$npass\n";	print $se "$npass\n";
Line 1834 sub make_passwd_file {	Line 2524 sub make_passwd_file {
return $result;	return $result;
}	}

	sub sethost {
	my ($remotereq) = @_;
	my (undef,$hostid)=split(/:/,$remotereq);
	if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; }
	if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) {
	$currenthostid=$hostid;
	$currentdomainid=$hostdom{$hostid};
	&logthis("Setting hostid to $hostid, and domain to $currentdomainid");
	} else {
	&logthis("Requested host id $hostid not an alias of ".
	$perlvar{'lonHostID'}." refusing connection");
	return 'unable_to_set';
	}
	return 'ok';
	}

	sub version {
	my ($userinput)=@_;
	$remoteVERSION=(split(/:/,$userinput))[1];
	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 < 3600) { $numusers++; }
	}
	closedir(LONIDS);
	}
	my $userloadpercent=0;
	my $maxuserload=$perlvar{'lonUserLoadLim'};
	if ($maxuserload) {
	$userloadpercent=100*$numusers/$maxuserload;
	}
	$userloadpercent=sprintf("%.2f",$userloadpercent);
	return $userloadpercent;
	}

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

=head1 NAME	=head1 NAME
Line 1943 each connection is logged.	Line 2678 each connection is logged.

=item *	=item *

	SIGUSR2

	Parent Signal assignment:
	$SIG{USR2} = \&UpdateHosts

	Child signal assignment:
	NONE


	=item *

SIGCHLD	SIGCHLD

Parent signal assignment:	Parent signal assignment:
Line 2103 Send along temporarily stored informatio	Line 2849 Send along temporarily stored informatio

List part of a user's directory.	List part of a user's directory.

	=item pushtable

	Pushes a file in /home/httpd/lonTab directory. Currently limited to:
	hosts.tab and domain.tab. The old file is copied to *.tab.backup but
	must be restored manually in case of a problem with the new table file.
	pushtable requires that the request be encrypted and validated via
	ValidateManager. The form of the command is:
	enc:pushtable tablename <tablecontents> \n
	where pushtable, tablename and <tablecontents> will be encrypted, but \n is a
	cleartext newline.

=item Hanging up (exit or init)	=item Hanging up (exit or init)

What to do when a client tells the server that they (the client)	What to do when a client tells the server that they (the client)
Line 2113 are leaving the network.	Line 2870 are leaving the network.
If B<lond> is sent an unknown command (not in the list above),	If B<lond> is sent an unknown command (not in the list above),
it replys to the client "unknown_cmd".	it replys to the client "unknown_cmd".


=item UNKNOWN CLIENT	=item UNKNOWN CLIENT

If the anti-spoofing algorithm cannot verify the client,	If the anti-spoofing algorithm cannot verify the client,

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

Removed from v.1.106
changed lines
	Added in v.1.151