Return to lond CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.8 and 1.47

version 1.8, 2000/01/14 14:46:57	version 1.47, 2001/05/11 19:31:25
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,01/14 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
	# 04/02 Scott Harrison
	# 05/11 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 33 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 63 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 129 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 137 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 154 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 188 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 234 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 299 $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 348 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 363 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 378 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 454 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 493 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 509 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 523 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 617 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 660 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)
Line 571 sub make_new_child {	Line 776 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_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 594 sub make_new_child {	Line 799 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_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 656 sub make_new_child {	Line 861 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_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 677 sub make_new_child {	Line 882 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_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 719 sub make_new_child {	Line 924 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 741 sub make_new_child {	Line 947 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_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 751 sub make_new_child {	Line 957 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 763 sub make_new_child {	Line 969 sub make_new_child {
} else {	} else {
print $client "error:$!\n";	print $client "error:$!\n";
}	}
	# ------------------------------------------------------------------- querysend
	} elsif ($userinput =~ /^querysend/) {
	my ($cmd,$query,
	$custom,$customshow)=split(/:/,$userinput);
	$query=~s/\n*$//g;
	unless ($custom or $customshow) {
	print $client "".
	sqlreply("$hostid{$clientip}\&$query")."\n";
	}
	else {
	print $client "".
	sqlreply("$hostid{$clientip}\&$query".
	"\&$custom"."\&$customshow")."\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;
	my $store2=IO::File->new(">$execdir/tmp/$id.end");
	print $store2 "done\n";
	close $store2;
	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 798 sub make_new_child {	Line 1035 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 811 sub make_new_child {	Line 1048 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)) {
my @ulsstats=stat($ulsfn);	while ($ulsfn=readdir(LSDIR)) {
	my @ulsstats=stat($ulsdir.'/'.$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 834 sub make_new_child {	Line 1109 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.8
changed lines
	Added in v.1.47