Return to lond CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.7 and 1.43

version 1.7, 2000/01/12 19:30:43	version 1.43, 2001/03/27 12:49:18
Line 4	Line 4
# 5/26/99,6/4,6/10,6/11,6/14,6/15,6/26,6/28,6/30,	# 5/26/99,6/4,6/10,6/11,6/14,6/15,6/26,6/28,6/30,
# 7/8,7/9,7/10,7/12,7/17,7/19,9/21,	# 7/8,7/9,7/10,7/12,7/17,7/19,9/21,
# 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 Gerd Kortemeyer	# 12/7,12/15,01/06,01/11,01/12,01/14,2/8,
	# 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
	# 12/05 Scott Harrison
	# 12/05,12/13,12/29 Gerd Kortemeyer
	# Jan 01 Scott Harrison
	# 02/12 Gerd Kortemeyer
	# 03/15 Scott Harrison
	# 03/24 Gerd Kortemeyer
	#
# based on "Perl Cookbook" ISBN 1-56592-243-3	# based on "Perl Cookbook" ISBN 1-56592-243-3
# preforker - server who forks first	# preforker - server who forks first
# runs as a daemon	# runs as a daemon
Line 21 use LWP::UserAgent();	Line 31 use LWP::UserAgent();
use GDBM_File;	use GDBM_File;
use Authen::Krb4;	use Authen::Krb4;

	# grabs exception and records it to log before exiting
	sub catchexception {
	my ($error)=@_;
	$SIG{'QUIT'}='DEFAULT';
	$SIG{__DIE__}='DEFAULT';
	&logthis("<font color=red>CRITICAL: "
	."ABNORMAL EXIT. Child $$ for server $wasserver died through "
	."a crash with this error msg->[$error]</font>");
	if ($client) { print $client "error: $error\n"; }
	die($error);
	}

	# -------------------------------- Set signal handlers to record abnormal exits

	$SIG{'QUIT'}=\&catchexception;
	$SIG{__DIE__}=\&catchexception;

# ------------------------------------ Read httpd access.conf and get variables	# ------------------------------------ Read httpd access.conf and get variables

open (CONFIG,"/etc/httpd/conf/access.conf") \|\| die "Can't read access.conf";	open (CONFIG,"/etc/httpd/conf/access.conf") \|\| die "Can't read access.conf";
Line 34 while ($configline=<CONFIG>) {	Line 61 while ($configline=<CONFIG>) {
}	}
close(CONFIG);	close(CONFIG);

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

	# --------------------------------------------- Check if other instance running

	my $pidfile="$perlvar{'lonDaemons'}/logs/lond.pid";

	if (-e $pidfile) {
	my $lfh=IO::File->new("$pidfile");
	my $pide=<$lfh>;
	chomp($pide);
	if (kill 0 => $pide) { die "already running"; }
	}

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

# ------------------------------------------------------------- Read hosts file	# ------------------------------------------------------------- Read hosts file
Line 79 sub HUNTSMAN { # si	Line 127 sub HUNTSMAN { # si
kill 'INT' => keys %children;	kill 'INT' => keys %children;
my $execdir=$perlvar{'lonDaemons'};	my $execdir=$perlvar{'lonDaemons'};
unlink("$execdir/logs/lond.pid");	unlink("$execdir/logs/lond.pid");
&logthis("Shutting down");	&logthis("<font color=red>CRITICAL: Shutting down</font>");
exit; # clean up with dignity	exit; # clean up with dignity
}	}

Line 87 sub HUPSMAN { # sig	Line 135 sub HUPSMAN { # sig
local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children	local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
kill 'INT' => keys %children;	kill 'INT' => keys %children;
close($server); # free up socket	close($server); # free up socket
&logthis("Restarting");	&logthis("<font color=red>CRITICAL: Restarting</font>");
	unlink("$execdir/logs/lond.pid");
my $execdir=$perlvar{'lonDaemons'};	my $execdir=$perlvar{'lonDaemons'};
exec("$execdir/lond"); # here we go again	exec("$execdir/lond"); # here we go again
}	}
Line 103 sub logthis {	Line 152 sub logthis {
print $fh "$local ($$): $message\n";	print $fh "$local ($$): $message\n";
}	}


	# -------------------------------------------------------- Escape Special Chars

	sub escape {
	my $str=shift;
	$str =~ s/(\W)/"%".unpack('H2',$1)/eg;
	return $str;
	}

	# ----------------------------------------------------- Un-Escape Special Chars

	sub unescape {
	my $str=shift;
	$str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
	return $str;
	}

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

sub reconlonc {	sub reconlonc {
Line 120 sub reconlonc {	Line 186 sub reconlonc {
&logthis("$peerfile still not there, give it another try");	&logthis("$peerfile still not there, give it another try");
sleep 5;	sleep 5;
if (-e "$peerfile") { return; }	if (-e "$peerfile") { return; }
&logthis("$peerfile still not there, giving up");	&logthis(
	"<font color=blue>WARNING: $peerfile still not there, giving up</font>");
} else {	} else {
&logthis("lonc at pid $loncpid not responding, giving up");	&logthis(
	"<font color=red>CRITICAL: "
	."lonc at pid $loncpid not responding, giving up</font>");
}	}
} else {	} else {
&logthis('lonc not running, giving up');	&logthis('<font color=red>CRITICAL: lonc not running, giving up</font>');
}	}
}	}

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

sub subreply {	sub subreply {
my ($cmd,$server)=@_;	my ($cmd,$server)=@_;
my $peerfile="$perlvar{'lonSockDir'}/$server";	my $peerfile="$perlvar{'lonSockDir'}/$server";
Line 162 sub reply {	Line 232 sub reply {
return $answer;	return $answer;
}	}

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

	sub sqlreply {
	my ($cmd)=@_;
	my $answer=subsqlreply($cmd);
	if ($answer eq 'con_lost') { $answer=subsqlreply($cmd); }
	return $answer;
	}

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

# -------------------------------------------- Return path to profile directory	# -------------------------------------------- Return path to profile directory

sub propath {	sub propath {
my ($udom,$uname)=@_;	my ($udom,$uname)=@_;
$udom=~s/\W//g;	$udom=~s/\W//g;
$uname=~s/\W//g;	$uname=~s/\W//g;
my $subdir=$uname;	my $subdir=$uname.'__';
$subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;	$subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";	my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
return $proname;	return $proname;
}	}

# --------------------------------------- Is this the home server of an author?	# --------------------------------------- Is this the home server of an author?

sub ishome {	sub ishome {
my $author=shift;	my $author=shift;
$author=~s/\/home\/httpd\/html\/res\/([^\/])\/([^\/]).*/$1\/$2/;	$author=~s/\/home\/httpd\/html\/res\/([^\/])\/([^\/]).*/$1\/$2/;
Line 201 $execdir=$perlvar{'lonDaemons'};	Line 297 $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);
&logthis("Starting");	&logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>");

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

Line 250 sub make_new_child {	Line 346 sub make_new_child {
# unblock signals	# unblock signals
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;

# handle connections until we've reached $MAX_CLIENTS_PER_CHILD	# handle connections until we've reached $MAX_CLIENTS_PER_CHILD
for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) {	for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) {
Line 263 sub make_new_child {	Line 361 sub make_new_child {
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("Connect from $clientip ($hostid{$clientip})");	&logthis(
	"<font color=yellow>INFO: Connect from $clientip ($hostid{$clientip})</font>");
my $clientok;	my $clientok;
if ($clientrec) {	if ($clientrec) {
my $remotereq=<$client>;	my $remotereq=<$client>;
Line 277 sub make_new_child {	Line 376 sub make_new_child {
$clientok=1;	$clientok=1;
print $client "ok\n";	print $client "ok\n";
} else {	} else {
&logthis("$clientip did not reply challenge");	&logthis(
	"<font color=blue>WARNING: $clientip did not reply challenge</font>");
	print $client "bye\n";
}	}
} else {	} else {
&logthis("$clientip failed to initialize: >$remotereq<");	&logthis(
	"<font color=blue>WARNING: "
	."$clientip failed to initialize: >$remotereq< </font>");
	print $client "bye\n";
}	}
} else {	} else {
&logthis("Unknown client $clientip");	&logthis(
	"<font color=blue>WARNING: Unknown client $clientip</font>");
	print $client "bye\n";
}	}
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}");	&reconlonc("$perlvar{'lonSockDir'}/$hostid{$clientip}");
	&logthis(
	"<font color=green>Established connection: $hostid{$clientip}</font>");
# ------------------------------------------------------------ Process requests	# ------------------------------------------------------------ Process requests
while (my $userinput=<$client>) {	while (my $userinput=<$client>) {
chomp($userinput);	chomp($userinput);
Line 344 sub make_new_child {	Line 452 sub make_new_child {
if ($wasenc==1) {	if ($wasenc==1) {
my ($cmd,$udom,$uname,$upass)=split(/:/,$userinput);	my ($cmd,$udom,$uname,$upass)=split(/:/,$userinput);
chomp($upass);	chomp($upass);
	$upass=unescape($upass);
my $proname=propath($udom,$uname);	my $proname=propath($udom,$uname);
my $passfilename="$proname/passwd";	my $passfilename="$proname/passwd";
if (-e $passfilename) {	if (-e $passfilename) {
Line 382 sub make_new_child {	Line 491 sub make_new_child {
my	my
($cmd,$udom,$uname,$upass,$npass)=split(/:/,$userinput);	($cmd,$udom,$uname,$upass,$npass)=split(/:/,$userinput);
chomp($npass);	chomp($npass);
	$upass=&unescape($upass);
	$npass=&unescape($npass);
my $proname=propath($udom,$uname);	my $proname=propath($udom,$uname);
my $passfilename="$proname/passwd";	my $passfilename="$proname/passwd";
if (-e $passfilename) {	if (-e $passfilename) {
Line 396 sub make_new_child {	Line 507 sub make_new_child {
$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");	{ my $pf = IO::File->new(">$passfilename");
print $pf "internal:$ncpass\n";; }	print $pf "internal:$ncpass\n"; }
print $client "ok\n";	print $client "ok\n";
} else {	} else {
print $client "non_authorized\n";	print $client "non_authorized\n";
Line 410 sub make_new_child {	Line 521 sub make_new_child {
} else {	} else {
print $client "refused\n";	print $client "refused\n";
}	}
	# -------------------------------------------------------------------- makeuser
	} elsif ($userinput =~ /^makeuser/) {
	if ($wasenc==1) {
	my
	($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput);
	chomp($npass);
	$npass=&unescape($npass);
	my $proname=propath($udom,$uname);
	my $passfilename="$proname/passwd";
	if (-e $passfilename) {
	print $client "already_exists\n";
	} elsif ($udom ne $perlvar{'lonDefDomain'}) {
	print $client "not_right_domain\n";
	} else {
	@fpparts=split(/\//,$proname);
	$fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2];
	$fperror='';
	for ($i=3;$i<=$#fpparts;$i++) {
	$fpnow.='/'.$fpparts[$i];
	unless (-e $fpnow) {
	unless (mkdir($fpnow,0777)) {
	$fperror="error:$!\n";
	}
	}
	}
	unless ($fperror) {
	if ($umode eq 'krb4') {
	{
	my $pf = IO::File->new(">$passfilename");
	print $pf "krb4:$npass\n";
	}
	print $client "ok\n";
	} elsif ($umode eq 'internal') {
	my $salt=time;
	$salt=substr($salt,6,2);
	my $ncpass=crypt($npass,$salt);
	{
	my $pf = IO::File->new(">$passfilename");
	print $pf "internal:$ncpass\n";
	}
	print $client "ok\n";
	} elsif ($umode eq 'none') {
	{
	my $pf = IO::File->new(">$passfilename");
	print $pf "none:\n";
	}
	print $client "ok\n";
	} else {
	print $client "auth_mode_error\n";
	}
	} else {
	print $client "$fperror\n";
	}
	}
	} else {
	print $client "refused\n";
	}
# ------------------------------------------------------------------------ home	# ------------------------------------------------------------------------ home
} elsif ($userinput =~ /^home/) {	} elsif ($userinput =~ /^home/) {
my ($cmd,$udom,$uname)=split(/:/,$userinput);	my ($cmd,$udom,$uname)=split(/:/,$userinput);
Line 447 sub make_new_child {	Line 615 sub make_new_child {
$response=$ua->request($request,$transname);	$response=$ua->request($request,$transname);
}	}
if ($response->is_error()) {	if ($response->is_error()) {
unline($transname);	unlink($transname);
my $message=$response->status_line;	my $message=$response->status_line;
&logthis(	&logthis(
"LWP GET: $message for $fname ($remoteurl)");	"LWP GET: $message for $fname ($remoteurl)");
} else {	} else {
	if ($remoteurl!~/\.meta$/) {
	my $ua=new LWP::UserAgent;
	my $mrequest=
	new HTTP::Request('GET',$remoteurl.'.meta');
	my $mresponse=
	$ua->request($mrequest,$fname.'.meta');
	if ($mresponse->is_error()) {
	unlink($fname.'.meta');
	}
	}
rename($transname,$fname);	rename($transname,$fname);
}	}
}	}
Line 480 sub make_new_child {	Line 658 sub make_new_child {
my $ownership=ishome($fname);	my $ownership=ishome($fname);
if ($ownership eq 'owner') {	if ($ownership eq 'owner') {
if (-e $fname) {	if (-e $fname) {
	if (-d $fname) {
	print $client "directory\n";
	} else {
$now=time;	$now=time;
{	{
my $sh=IO::File->new(">$fname.$hostid{$clientip}");	my $sh;
print $sh "$clientip:$now\n";	if ($sh=
	IO::File->new(">$fname.$hostid{$clientip}")) {
	print $sh "$clientip:$now\n";
	}
}	}
	unless ($fname=~/\.meta$/) {
	unlink("$fname.meta.$hostid{$clientip}");
	}
$fname=~s/\/home\/httpd\/html\/res/raw/;	$fname=~s/\/home\/httpd\/html\/res/raw/;
$fname="http://$thisserver/".$fname;	$fname="http://$thisserver/".$fname;
print $client "$fname\n";	print $client "$fname\n";
	}
} else {	} else {
print $client "not_found\n";	print $client "not_found\n";
}	}
} else {	} else {
print $client "rejected\n";	print $client "rejected\n";
}	}
	# ------------------------------------------------------------------------- log
	} elsif ($userinput =~ /^log/) {
	my ($cmd,$udom,$uname,$what)=split(/:/,$userinput);
	chomp($what);
	my $proname=propath($udom,$uname);
	my $now=time;
	{
	my $hfh;
	if ($hfh=IO::File->new(">>$proname/activity.log")) {
	print $hfh "$now:$hostid{$clientip}:$what\n";
	print $client "ok\n";
	} else {
	print $client "error:$!\n";
	}
	}
# ------------------------------------------------------------------------- put	# ------------------------------------------------------------------------- put
} elsif ($userinput =~ /^put/) {	} elsif ($userinput =~ /^put/) {
my ($cmd,$udom,$uname,$namespace,$what)	my ($cmd,$udom,$uname,$namespace,$what)
=split(/:/,$userinput);	=split(/:/,$userinput);
	$namespace=~s/\//\_/g;
$namespace=~s/\W//g;	$namespace=~s/\W//g;
if ($namespace ne 'roles') {	if ($namespace ne 'roles') {
chomp($what);	chomp($what);
Line 564 sub make_new_child {	Line 768 sub make_new_child {
} elsif ($userinput =~ /^get/) {	} elsif ($userinput =~ /^get/) {
my ($cmd,$udom,$uname,$namespace,$what)	my ($cmd,$udom,$uname,$namespace,$what)
=split(/:/,$userinput);	=split(/:/,$userinput);
	$namespace=~s/\//\_/g;
$namespace=~s/\W//g;	$namespace=~s/\W//g;
chomp($what);	chomp($what);
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_WRCREAT,0640)) {	if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
for ($i=0;$i<=$#queries;$i++) {	for ($i=0;$i<=$#queries;$i++) {
$qresult.="$hash{$queries[$i]}&";	$qresult.="$hash{$queries[$i]}&";
}	}
Line 586 sub make_new_child {	Line 791 sub make_new_child {
} elsif ($userinput =~ /^eget/) {	} elsif ($userinput =~ /^eget/) {
my ($cmd,$udom,$uname,$namespace,$what)	my ($cmd,$udom,$uname,$namespace,$what)
=split(/:/,$userinput);	=split(/:/,$userinput);
	$namespace=~s/\//\_/g;
$namespace=~s/\W//g;	$namespace=~s/\W//g;
chomp($what);	chomp($what);
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_WRCREAT,0640)) {	if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
for ($i=0;$i<=$#queries;$i++) {	for ($i=0;$i<=$#queries;$i++) {
$qresult.="$hash{$queries[$i]}&";	$qresult.="$hash{$queries[$i]}&";
}	}
Line 621 sub make_new_child {	Line 827 sub make_new_child {
} elsif ($userinput =~ /^del/) {	} elsif ($userinput =~ /^del/) {
my ($cmd,$udom,$uname,$namespace,$what)	my ($cmd,$udom,$uname,$namespace,$what)
=split(/:/,$userinput);	=split(/:/,$userinput);
	$namespace=~s/\//\_/g;
$namespace=~s/\W//g;	$namespace=~s/\W//g;
chomp($what);	chomp($what);
my $proname=propath($udom,$uname);	my $proname=propath($udom,$uname);
Line 648 sub make_new_child {	Line 855 sub make_new_child {
} elsif ($userinput =~ /^keys/) {	} elsif ($userinput =~ /^keys/) {
my ($cmd,$udom,$uname,$namespace)	my ($cmd,$udom,$uname,$namespace)
=split(/:/,$userinput);	=split(/:/,$userinput);
	$namespace=~s/\//\_/g;
$namespace=~s/\W//g;	$namespace=~s/\W//g;
chomp($namespace);
my $proname=propath($udom,$uname);	my $proname=propath($udom,$uname);
my $qresult='';	my $qresult='';
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {	if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
foreach $key (keys %hash) {	foreach $key (keys %hash) {
$qresult.="$key&";	$qresult.="$key&";
}	}
Line 669 sub make_new_child {	Line 876 sub make_new_child {
} elsif ($userinput =~ /^dump/) {	} elsif ($userinput =~ /^dump/) {
my ($cmd,$udom,$uname,$namespace)	my ($cmd,$udom,$uname,$namespace)
=split(/:/,$userinput);	=split(/:/,$userinput);
	$namespace=~s/\//\_/g;
$namespace=~s/\W//g;	$namespace=~s/\W//g;
chomp($namespace);
my $proname=propath($udom,$uname);	my $proname=propath($udom,$uname);
my $qresult='';	my $qresult='';
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {	if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
foreach $key (keys %hash) {	foreach $key (keys %hash) {
$qresult.="$key=$hash{$key}&";	$qresult.="$key=$hash{$key}&";
}	}
Line 690 sub make_new_child {	Line 897 sub make_new_child {
} elsif ($userinput =~ /^store/) {	} elsif ($userinput =~ /^store/) {
my ($cmd,$udom,$uname,$namespace,$rid,$what)	my ($cmd,$udom,$uname,$namespace,$rid,$what)
=split(/:/,$userinput);	=split(/:/,$userinput);
	$namespace=~s/\//\_/g;
$namespace=~s/\W//g;	$namespace=~s/\W//g;
if ($namespace ne 'roles') {	if ($namespace ne 'roles') {
chomp($what);	chomp($what);
Line 714 sub make_new_child {	Line 922 sub make_new_child {
$allkeys.=$key.':';	$allkeys.=$key.':';
$hash{"$version:$rid:$key"}=$value;	$hash{"$version:$rid:$key"}=$value;
}	}
$allkeys=~s/:$//;	$hash{"$version:$rid:timestamp"}=$now;
	$allkeys.='timestamp';
$hash{"$version:keys:$rid"}=$allkeys;	$hash{"$version:keys:$rid"}=$allkeys;
if (untie(%hash)) {	if (untie(%hash)) {
print $client "ok\n";	print $client "ok\n";
Line 731 sub make_new_child {	Line 940 sub make_new_child {
} elsif ($userinput =~ /^restore/) {	} elsif ($userinput =~ /^restore/) {
my ($cmd,$udom,$uname,$namespace,$rid)	my ($cmd,$udom,$uname,$namespace,$rid)
=split(/:/,$userinput);	=split(/:/,$userinput);
	$namespace=~s/\//\_/g;
$namespace=~s/\W//g;	$namespace=~s/\W//g;
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_WRCREAT,0640)) {	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 745 sub make_new_child {	Line 955 sub make_new_child {
my $key;	my $key;
$qresult.="$scope:keys=$vkeys&";	$qresult.="$scope:keys=$vkeys&";
foreach $key (@keys) {	foreach $key (@keys) {
$qresult.="$version:$key=".$hash{"$scope:$rid:$key"}."&";	$qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&";
}	}
}	}
if (untie(%hash)) {	if (untie(%hash)) {
Line 757 sub make_new_child {	Line 967 sub make_new_child {
} else {	} else {
print $client "error:$!\n";	print $client "error:$!\n";
}	}
	# ------------------------------------------------------------------- querysend
	} elsif ($userinput =~ /^querysend/) {
	my ($cmd,$query,$custom)=split(/:/,$userinput);
	$query=~s/\n*$//g;
	unless ($custom) {
	print $client "".
	sqlreply("$hostid{$clientip}\&$query")."\n";
	}
	else {
	print $client "".
	sqlreply("$hostid{$clientip}\&$query".
	"\&$custom")."\n";
	}
	# ------------------------------------------------------------------ queryreply
	} elsif ($userinput =~ /^queryreply/) {
	my ($cmd,$id,$reply)=split(/:/,$userinput);
	my $store;
	my $execdir=$perlvar{'lonDaemons'};
	if ($store=IO::File->new(">$execdir/tmp/$id")) {
	$reply=~s/\&/\n/g;
	print $store $reply;
	close $store;
	print $client "ok\n";
	}
	else {
	print $client "error:$!\n";
	}
# ----------------------------------------------------------------------- idput	# ----------------------------------------------------------------------- idput
} elsif ($userinput =~ /^idput/) {	} elsif ($userinput =~ /^idput/) {
my ($cmd,$udom,$what)=split(/:/,$userinput);	my ($cmd,$udom,$what)=split(/:/,$userinput);
Line 792 sub make_new_child {	Line 1029 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_WRCREAT,0640)) {	if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER,0640)) {
for ($i=0;$i<=$#queries;$i++) {	for ($i=0;$i<=$#queries;$i++) {
$qresult.="$hash{$queries[$i]}&";	$qresult.="$hash{$queries[$i]}&";
}	}
Line 805 sub make_new_child {	Line 1042 sub make_new_child {
} else {	} else {
print $client "error:$!\n";	print $client "error:$!\n";
}	}
	# ---------------------------------------------------------------------- tmpput
	} elsif ($userinput =~ /^tmpput/) {
	my ($cmd,$what)=split(/:/,$userinput);
	my $store;
	$tmpsnum++;
	my $id=$$.'_'.$clientip.'_'.$tmpsnum;
	$id=~s/\W/\_/g;
	$what=~s/\n//g;
	my $execdir=$perlvar{'lonDaemons'};
	if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) {
	print $store $what;
	close $store;
	print $client "$id\n";
	}
	else {
	print $client "error:$!\n";
	}

	# ---------------------------------------------------------------------- tmpget
	} elsif ($userinput =~ /^tmpget/) {
	my ($cmd,$id)=split(/:/,$userinput);
	chomp($id);
	$id=~s/\W/\_/g;
	my $store;
	my $execdir=$perlvar{'lonDaemons'};
	if ($store=IO::File->new("$execdir/tmp/$id.tmp")) {
	my $reply=<$store>;
	print $client "$reply\n";
	close $store;
	}
	else {
	print $client "error:$!\n";
	}

# -------------------------------------------------------------------------- ls	# -------------------------------------------------------------------------- ls
} elsif ($userinput =~ /^ls/) {	} elsif ($userinput =~ /^ls/) {
my ($cmd,$ulsdir)=split(/:/,$userinput);	my ($cmd,$ulsdir)=split(/:/,$userinput);
my $ulsout='';	my $ulsout='';
my $ulsfn;	my $ulsfn;
if (-e $ulsdir) {	if (-e $ulsdir) {
while ($ulsfn=<$ulsdir/*>) {	if (opendir(LSDIR,$ulsdir)) {
	while ($ulsfn=readdir(LSDIR)) {
my @ulsstats=stat($ulsfn);	my @ulsstats=stat($ulsfn);
$ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';	$ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';
}	}
	closedir(LSDIR);
	}
} else {	} else {
$ulsout='no_such_dir';	$ulsout='no_such_dir';
}	}
	if ($ulsout eq '') { $ulsout='empty'; }
print $client "$ulsout\n";	print $client "$ulsout\n";
# ------------------------------------------------------------- unknown command	# ------------------------------------------------------------- unknown command
} else {	} else {
Line 828 sub make_new_child {	Line 1103 sub make_new_child {
}	}
} else {	} else {
print $client "refused\n";	print $client "refused\n";
&logthis("Rejected client $clientip, closing connection");	&logthis("<font color=blue>WARNING: "
	."Rejected client $clientip, closing connection</font>");
}	}
&logthis("Disconnect from $clientip ($hostid{$clientip})");	&logthis("<font color=red>CRITICAL: "
	."Disconnect from $clientip ($hostid{$clientip})</font>");
# =============================================================================	# =============================================================================
}	}

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

500 Internal Server Error

Internal Server Error

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

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

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

Removed from v.1.7
changed lines
	Added in v.1.43