loncom/lond - diff

Return to lond CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.98 and 1.117

version 1.98, 2002/09/19 21:16:24	version 1.117, 2003/03/24 19:46:52
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
	# logic simpler (and there were problems maintaining the preforked
	# population). Since the time averaged connection rate is close to zero
	# because lonc's purpose is to maintain near continuous connnections,
	# preforking is not really needed.
###	###

# based on "Perl Cookbook" ISBN 1-56592-243-3
# preforker - server who forks first
# runs as a daemon
# HUPs
# uses IDEA encryption

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

Line 83 my $DEBUG = 0; # Non zero to ena	Line 73 my $DEBUG = 0; # Non zero to ena
my $status='';	my $status='';
my $lastlog='';	my $lastlog='';

	my $currenthostid;
	my $currentdomainid;
#	#
# The array below are password error strings."	# The array below are password error strings."
#	#
Line 178 undef $perlvarref;	Line 170 undef $perlvarref;
my $wwwid=getpwnam('www');	my $wwwid=getpwnam('www');
if ($wwwid!=$<) {	if ($wwwid!=$<) {
$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";	$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
$subj="LON: $perlvar{'lonHostID'} User ID mismatch";	$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 205 while ($configline=<CONFIG>) {	Line 197 while ($configline=<CONFIG>) {
my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);	my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
chomp($ip); $ip=~s/\D+$//;	chomp($ip); $ip=~s/\D+$//;
$hostid{$ip}=$id;	$hostid{$ip}=$id;
	$hostdom{$id}=$domain;
	$hostip{$id}=$ip;
if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }	if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }
$PREFORK++;	$PREFORK++;
}	}
Line 272 sub checkchildren {	Line 266 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 312 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 340 sub status {	Line 342 sub status {
my $now=time;	my $now=time;
my $local=localtime($now);	my $local=localtime($now);
$status=$local.': '.$what;	$status=$local.': '.$what;
	$0='lond: '.$what.' '.$local;
}	}

# -------------------------------------------------------- Escape Special Chars	# -------------------------------------------------------- Escape Special Chars
Line 406 sub subreply {	Line 409 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 490 close(PIDSAVE);	Line 493 close(PIDSAVE);
&logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>");	&logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>");
&status('Starting');	&status('Starting');

# ------------------------------------------------------- Now we are on our own

# Fork off our children.
for (1 .. $PREFORK) {
make_new_child();
}

# ----------------------------------------------------- Install signal handlers	# ----------------------------------------------------- Install signal handlers

&status('Forked children');

$SIG{CHLD} = \&REAPER;	$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;

# And maintain the population.

	# --------------------------------------------------------------
	# Accept connections. When a connection comes in, it is validated
	# and if good, a child process is created to process transactions
	# along the connection.

while (1) {	while (1) {
&status('Sleeping');	$client = $server->accept() or next;
sleep; # wait for a signal (i.e., child's death)	make_new_child($client);
&logthis('Woke up');	}
&status('Woke up');
for ($i = $children; $i < $PREFORK; $i++) {	sub init_host_and_domain {
make_new_child(); # top up the child pool	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 0;
}	}
	return 1;
}	}

sub make_new_child {	sub make_new_child {
	my $client;
my $pid;	my $pid;
my $cipher;	my $cipher;
my $sigset;	my $sigset;

	$client = shift;
&logthis("Attempting to start child");	&logthis("Attempting to start child");
# block signal for fork	# block signal for fork
$sigset = POSIX::SigSet->new(SIGINT);	$sigset = POSIX::SigSet->new(SIGINT);
Line 554 sub make_new_child {	Line 571 sub make_new_child {
&Authen::Krb5::init_context();	&Authen::Krb5::init_context();
&Authen::Krb5::init_ets();	&Authen::Krb5::init_ets();

# handle connections until we've reached $MAX_CLIENTS_PER_CHILD
for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) {
&status('Idle, waiting for connection');
$client = $server->accept() or last;
&status('Accepted connection');	&status('Accepted connection');
# =============================================================================	# =============================================================================
# do something with the connection	# do something with the connection
Line 565 sub make_new_child {	Line 578 sub make_new_child {
$client->sockopt(SO_KEEPALIVE, 1);# Enable monitoring of	$client->sockopt(SO_KEEPALIVE, 1);# Enable monitoring of
# connection liveness.	# connection liveness.
# see if we know client and check for spoof IP by challenge	# see if we know client and check for spoof IP by challenge
my $caller=getpeername($client);	my $caller = getpeername($client);
my ($port,$iaddr)=unpack_sockaddr_in($caller);	my ($port,$iaddr)=unpack_sockaddr_in($caller);
my $clientip=inet_ntoa($iaddr);	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/) {
	if (!&init_host_and_domain($remotereq)) {
	&status("Got bad init message, exiting");
	print $client "refused\n";
	$client->close();
	&logthis("<font color=blue>WARNING: "
	."Bad init message $remotereq, closing connection</font>");
	exit;
	}
my $challenge="$$".time;	my $challenge="$$".time;
print $client "$challenge\n";	print $client "$challenge\n";
&status(	&status(
Line 607 sub make_new_child {	Line 628 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 637 sub make_new_child {	Line 664 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});	$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 695 sub make_new_child {	Line 722 sub make_new_child {
my ($howpwd,$contentpwd)=split(/:/,$realpasswd);	my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
my $pwdcorrect=0;	my $pwdcorrect=0;
if ($howpwd eq 'internal') {	if ($howpwd eq 'internal') {
	&Debug("Internal auth");
$pwdcorrect=	$pwdcorrect=
(crypt($upass,$contentpwd) eq $contentpwd);	(crypt($upass,$contentpwd) eq $contentpwd);
} elsif ($howpwd eq 'unix') {	} elsif ($howpwd eq 'unix') {
$contentpwd=(getpwnam($uname))[1];	&Debug("Unix auth");
my $pwauth_path="/usr/local/sbin/pwauth";	if((getpwnam($uname))[1] eq "") { #no such user!
unless ($contentpwd eq 'x') {	$pwdcorrect = 0;
$pwdcorrect=	} else {
(crypt($upass,$contentpwd) eq $contentpwd);	$contentpwd=(getpwnam($uname))[1];
}	my $pwauth_path="/usr/local/sbin/pwauth";
	unless ($contentpwd eq 'x') {
	$pwdcorrect=
	(crypt($upass,$contentpwd) eq
	$contentpwd);
	}

elsif (-e $pwauth_path) {	elsif (-e $pwauth_path) {
open PWAUTH, "\|$pwauth_path" or	open PWAUTH, "\|$pwauth_path" or
die "Cannot invoke authentication";	die "Cannot invoke authentication";
Line 711 sub make_new_child {	Line 745 sub make_new_child {
close PWAUTH;	close PWAUTH;
$pwdcorrect=!$?;	$pwdcorrect=!$?;
}	}
	}
} elsif ($howpwd eq 'krb4') {	} elsif ($howpwd eq 'krb4') {
$null=pack("C",0);	$null=pack("C",0);
unless ($upass=~/$null/) {	unless ($upass=~/$null/) {
$pwdcorrect=(	my $krb4_error = &Authen::Krb4::get_pw_in_tkt
Authen::Krb4::get_pw_in_tkt($uname,"",	($uname,"",$contentpwd,'krbtgt',
$contentpwd,'krbtgt',$contentpwd,1,	$contentpwd,1,$upass);
$upass) == 0);	if (!$krb4_error) {
} else { $pwdcorrect=0; }	$pwdcorrect = 1;
	} else {
	$pwdcorrect=0;
	# log error if it is not a bad password
	if ($krb4_error != 62) {
	&logthis('krb4:'.$uname.','.$contentpwd.','.
	&Authen::Krb4::get_err_txt($Authen::Krb4::error));
	}
	}
	}
} elsif ($howpwd eq 'krb5') {	} elsif ($howpwd eq 'krb5') {
$null=pack("C",0);	$null=pack("C",0);
unless ($upass=~/$null/) {	unless ($upass=~/$null/) {
Line 842 sub make_new_child {	Line 886 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);	@fpparts=split(/\//,$proname);
Line 852 sub make_new_child {	Line 896 sub make_new_child {
$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 880 sub make_new_child {	Line 926 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 1007 sub make_new_child {	Line 1053 sub make_new_child {
# ------------------------------------------------------------------- subscribe	# ------------------------------------------------------------------- subscribe
} elsif ($userinput =~ /^sub/) {	} elsif ($userinput =~ /^sub/) {
print $client &subscribe($userinput,$clientip);	print $client &subscribe($userinput,$clientip);
	# ------------------------------------------------------------- current version
	} elsif ($userinput =~ /^currentversion/) {
	my ($cmd,$fname)=split(/:/,$userinput);
	print $client &currentversion($fname)."\n";
# ------------------------------------------------------------------------- log	# ------------------------------------------------------------------------- log
} elsif ($userinput =~ /^log/) {	} elsif ($userinput =~ /^log/) {
my ($cmd,$udom,$uname,$what)=split(/:/,$userinput);	my ($cmd,$udom,$uname,$what)=split(/:/,$userinput);
Line 1019 sub make_new_child {	Line 1069 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 1047 sub make_new_child {	Line 1099 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 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 1089 sub make_new_child {	Line 1145 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 rolesput\n";
}	}
} else {	} else {
print $client "error:$!\n";	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);
	if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {
	foreach $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 {
	print $client "error: ".($!+0)
	." tie(GDBM) Failed ".
	"while attempting rolesdel\n";
}	}
} else {	} else {
print $client "refused\n";	print $client "refused\n";
Line 1115 sub make_new_child {	Line 1217 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 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 1151 sub make_new_child {	Line 1262 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 1179 sub make_new_child {	Line 1294 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 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 1200 sub make_new_child {	Line 1319 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 keys\n";
	}
	} else {
	print $client "error: ".($!+0)
	." tie(GDBM) Failed ".
	"while attempting keys\n";
	}
	# ----------------------------------------------------------------- dumpcurrent
	} elsif ($userinput =~ /^currentdump/) {
	my ($cmd,$udom,$uname,$namespace)
	=split(/:/,$userinput);
	$namespace=~s/\//\_/g;
	$namespace=~s/\W//g;
	my $qresult='';
	my $proname=propath($udom,$uname);
	if (tie(%hash,'GDBM_File',
	"$proname/$namespace.db",
	&GDBM_READER(),0640)) {
	# Structure of %data:
	# $data{$symb}->{$parameter}=$value;
	# $data{$symb}->{'v.'.$parameter}=$version;
	# since $parameter will be unescaped, we do not
	# have to worry about silly parameter names...
	my %data = ();
	while (my ($key,$value) = each(%hash)) {
	my ($v,$symb,$param) = split(/:/,$key);
	next if ($v eq 'version' \|\| $symb eq 'keys');
	next if (exists($data{$symb}) &&
	exists($data{$symb}->{$param}) &&
	$data{$symb}->{'v.'.$param} > $v);
	$data{$symb}->{$param}=$value;
	$data{$symb}->{'v.'.$param}=$v;
	}
	if (untie(%hash)) {
	while (my ($symb,$param_hash) = each(%data)) {
	while(my ($param,$value) = each (%$param_hash)){
	next if ($param =~ /^v\./);
	$qresult.=$symb.':'.$param.'='.$value.'&';
	}
	}
	chop($qresult);
	print $client "$qresult\n";
	} else {
	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 1216 sub make_new_child {	Line 1384 sub make_new_child {
} else {	} else {
$regexp='.';	$regexp='.';
}	}
my $proname=propath($udom,$uname);
my $qresult='';	my $qresult='';
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {	my $proname=propath($udom,$uname);
	if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
study($regexp);	study($regexp);
foreach $key (keys %hash) {	while (($key,$value) = each(%hash)) {
my $unescapeKey = &unescape($key);	if ($regexp eq '.') {
if (eval('$unescapeKey=~/$regexp/')) {	$qresult.=$key.'='.$value.'&';
$qresult.="$key=$hash{$key}&";	} else {
}	my $unescapeKey = &unescape($key);
	if (eval('$unescapeKey=~/$regexp/')) {
	$qresult.="$key=$value&";
	}
	}
}	}
if (untie(%hash)) {	if (untie(%hash)) {
$qresult=~s/\&$//;	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 1270 sub make_new_child {	Line 1446 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 1304 sub make_new_child {	Line 1484 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 1346 sub make_new_child {	Line 1530 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";
}	}
# ----------------------------------------------------------------------- idput	# ----------------------------------------------------------------------- idput
} elsif ($userinput =~ /^idput/) {	} elsif ($userinput =~ /^idput/) {
Line 1370 sub make_new_child {	Line 1556 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 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 1391 sub make_new_child {	Line 1581 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 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 1411 sub make_new_child {	Line 1605 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 1427 sub make_new_child {	Line 1623 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 1478 sub make_new_child {	Line 1689 sub make_new_child {
&logthis("<font color=blue>WARNING: "	&logthis("<font color=blue>WARNING: "
."Rejected client $clientip, closing connection</font>");	."Rejected client $clientip, closing connection</font>");
}	}
}	}

# =============================================================================	# =============================================================================

&logthis("<font color=red>CRITICAL: "	&logthis("<font color=red>CRITICAL: "
."Disconnect from $clientip ($hostid{$clientip})</font>");	."Disconnect from $clientip ($hostid{$clientip})</font>");
# tidy up gracefully and finish

$server->close();

# this exit is VERY important, otherwise the child will become	# this exit is VERY important, otherwise the child will become
# a producer of more and more children, forking yourself into	# a producer of more and more children, forking yourself into
# process death.	# process death.
exit;	exit;
}
}	}


Line 1635 sub unsub {	Line 1844 sub unsub {
return $result;	return $result;
}	}

	sub currentversion {
	my $fname=shift;
	my $version=-1;
	my $ulsdir='';
	if ($fname=~/^(.+)\/[^\/]+$/) {
	$ulsdir=$1;
	}
	my ($fnamere1,$fnamere2);
	# remove version if already specified
	$fname=~s/\.\d+\.(\w+(?:\.meta)*)$/\.$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 $ulsdir) {
	if(-d $ulsdir) {
	if (opendir(LSDIR,$ulsdir)) {

	while ($ulsfn=readdir(LSDIR)) {
	# see if this is a regular file (ignore links produced earlier)
	my $thisfile=$ulsdir.'/'.$ulsfn;
	unless (-l $thisfile) {
	if ($thisfile=~/\Q$fnamere1\E(\d+)\Q$fnamere2\E/) {
	if ($1>$version) { $version=$1; }
	}
	}
	}
	closedir(LSDIR);
	$version++;
	}
	}
	}
	return $version;
	}

	sub thisversion {
	my $fname=shift;
	my $version=-1;
	if ($fname=~/\.(\d+)\.\w+(?:\.meta)*$/) {
	$version=$1;
	}
	return $version;
	}

sub subscribe {	sub subscribe {
my ($userinput,$clientip)=@_;	my ($userinput,$clientip)=@_;
my $result;	my $result;
my ($cmd,$fname)=split(/:/,$userinput);	my ($cmd,$fname)=split(/:/,$userinput);
my $ownership=&ishome($fname);	my $ownership=&ishome($fname);
if ($ownership eq 'owner') {	if ($ownership eq 'owner') {
	# explitly asking for the current version?
	unless (-e $fname) {
	my $currentversion=&currentversion($fname);
	if (&thisversion($fname)==$currentversion) {
	if ($fname=~/^(.+)\.\d+\.(\w+(?:\.meta)*)$/) {
	my $root=$1;
	my $extension=$2;
	symlink($root.'.'.$extension,
	$root.'.'.$currentversion.'.'.$extension);
	unless ($extension=~/\.meta$/) {
	symlink($root.'.'.$extension.'.meta',
	$root.'.'.$currentversion.'.'.$extension.'.meta');
	}
	}
	}
	}
if (-e $fname) {	if (-e $fname) {
if (-d $fname) {	if (-d $fname) {
$result="directory\n";	$result="directory\n";

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

Removed from v.1.98
changed lines
	Added in v.1.117