Return to lond CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.110 and 1.119

version 1.110, 2003/03/02 03:58:55	version 1.119, 2003/03/26 00:17:04
Line 52	Line 52
# preforking is not really needed.	# preforking is not really needed.
###	###


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

Line 74 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 169 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 196 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 263 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 301 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 398 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 504 while (1) {	Line 515 while (1) {
make_new_child($client);	make_new_child($client);
}	}

	sub init_host_and_domain {
	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 $client;
my $pid;	my $pid;
Line 556 sub make_new_child {	Line 583 sub make_new_child {
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 593 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 623 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 845 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 856 sub make_new_child {	Line 897 sub make_new_child {
unless (-e $fpnow) {	unless (-e $fpnow) {
unless (mkdir($fpnow,0777)) {	unless (mkdir($fpnow,0777)) {
$fperror="error: ".($!+0)	$fperror="error: ".($!+0)
." mkdir failed\n";	." mkdir failed while attempting "
	."makeuser\n";
}	}
}	}
}	}
Line 884 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 1028 sub make_new_child {	Line 1070 sub make_new_child {
print $client "ok\n";	print $client "ok\n";
} else {	} else {
print $client "error: ".($!+0)	print $client "error: ".($!+0)
." IO::File->new Failed\n";	." IO::File->new Failed "
	."while attempting log\n";
}	}
}	}
# ------------------------------------------------------------------------- put	# ------------------------------------------------------------------------- put
Line 1048 sub make_new_child {	Line 1091 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)) {	if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
foreach $pair (@pairs) {	foreach $pair (@pairs) {
($key,$value)=split(/=/,$pair);	($key,$value)=split(/=/,$pair);
$hash{$key}=$value;	$hash{$key}=$value;
Line 1057 sub make_new_child {	Line 1100 sub make_new_child {
print $client "ok\n";	print $client "ok\n";
} else {	} else {
print $client "error: ".($!+0)	print $client "error: ".($!+0)
." untie(GDBM) failed\n";	." untie(GDBM) failed ".
	"while attempting put\n";
}	}
} else {	} else {
print $client "error: ".($!)	print $client "error: ".($!)
." tie(GDBM) Failed\n";	." tie(GDBM) Failed ".
	"while attempting put\n";
}	}
} else {	} else {
print $client "refused\n";	print $client "refused\n";
Line 1088 sub make_new_child {	Line 1133 sub make_new_child {
}	}
}	}
my @pairs=split(/\&/,$what);	my @pairs=split(/\&/,$what);
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {	if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
foreach $pair (@pairs) {	foreach $pair (@pairs) {
($key,$value)=split(/=/,$pair);	($key,$value)=split(/=/,$pair);
&ManagePermissions($key, $udom, $uname,	&ManagePermissions($key, $udom, $uname,
Line 1101 sub make_new_child {	Line 1146 sub make_new_child {
print $client "ok\n";	print $client "ok\n";
} else {	} else {
print $client "error: ".($!+0)	print $client "error: ".($!+0)
." untie(GDBM) Failed\n";	." untie(GDBM) Failed ".
	"while attempting rolesput\n";
}	}
} else {	} else {
print $client "error: ".($!+0)	print $client "error: ".($!+0)
." tie(GDBM) Failed\n";	." 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 1120 sub make_new_child {	Line 1209 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)) {	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 1129 sub make_new_child {	Line 1218 sub make_new_child {
print $client "$qresult\n";	print $client "$qresult\n";
} else {	} else {
print $client "error: ".($!+0)	print $client "error: ".($!+0)
." untie(GDBM) Failed\n";	." untie(GDBM) Failed ".
	"while attempting get\n";
}	}
} else {	} else {
print $client "error: ".($!+0)	if ($!+0 == 2) {
." tie(GDBM) Failed\n";	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 1145 sub make_new_child {	Line 1241 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)) {	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 1167 sub make_new_child {	Line 1263 sub make_new_child {
}	}
} else {	} else {
print $client "error: ".($!+0)	print $client "error: ".($!+0)
." untie(GDBM) Failed\n";	." untie(GDBM) Failed ".
	"while attempting eget\n";
}	}
} else {	} else {
print $client "error: ".($!+0)	print $client "error: ".($!+0)
." tie(GDBM) Failed\n";	." tie(GDBM) Failed ".
	"while attempting eget\n";
}	}
# ------------------------------------------------------------------------- del	# ------------------------------------------------------------------------- del
} elsif ($userinput =~ /^del/) {	} elsif ($userinput =~ /^del/) {
Line 1189 sub make_new_child {	Line 1287 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)) {	if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
foreach $key (@keys) {	foreach $key (@keys) {
delete($hash{$key});	delete($hash{$key});
}	}
Line 1197 sub make_new_child {	Line 1295 sub make_new_child {
print $client "ok\n";	print $client "ok\n";
} else {	} else {
print $client "error: ".($!+0)	print $client "error: ".($!+0)
." untie(GDBM) Failed\n";	." untie(GDBM) Failed ".
	"while attempting del\n";
}	}
} else {	} else {
print $client "error: ".($!+0)	print $client "error: ".($!+0)
." tie(GDBM) Failed\n";	." tie(GDBM) Failed ".
	"while attempting del\n";
}	}
# ------------------------------------------------------------------------ keys	# ------------------------------------------------------------------------ keys
} elsif ($userinput =~ /^keys/) {	} elsif ($userinput =~ /^keys/) {
Line 1211 sub make_new_child {	Line 1311 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)) {	if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
foreach $key (keys %hash) {	foreach $key (keys %hash) {
$qresult.="$key&";	$qresult.="$key&";
}	}
Line 1220 sub make_new_child {	Line 1320 sub make_new_child {
print $client "$qresult\n";	print $client "$qresult\n";
} else {	} else {
print $client "error: ".($!+0)	print $client "error: ".($!+0)
." untie(GDBM) Failed\n";	." untie(GDBM) Failed ".
	"while attempting keys\n";
}	}
} else {	} else {
print $client "error: ".($!+0)	print $client "error: ".($!+0)
." tie(GDBM) Failed\n";	." tie(GDBM) Failed ".
	"while attempting keys\n";
}	}
# ----------------------------------------------------------------- dumpcurrent	# ----------------------------------------------------------------- dumpcurrent
} elsif ($userinput =~ /^currentdump/) {	} elsif ($userinput =~ /^currentdump/) {
Line 1263 sub make_new_child {	Line 1365 sub make_new_child {
print $client "$qresult\n";	print $client "$qresult\n";
} else {	} else {
print $client "error: ".($!+0)	print $client "error: ".($!+0)
." untie(GDBM) Failed\n";	." untie(GDBM) Failed ".
	"while attempting currentdump\n";
}	}
} else {	} else {
print $client "error: ".($!+0)	print $client "error: ".($!+0)
." tie(GDBM) Failed\n";	." tie(GDBM) Failed ".
	"while attempting currentdump\n";
}	}
# ------------------------------------------------------------------------ dump	# ------------------------------------------------------------------------ dump
} elsif ($userinput =~ /^dump/) {	} elsif ($userinput =~ /^dump/) {
Line 1299 sub make_new_child {	Line 1403 sub make_new_child {
print $client "$qresult\n";	print $client "$qresult\n";
} else {	} else {
print $client "error: ".($!+0)	print $client "error: ".($!+0)
." untie(GDBM) Failed\n";	." untie(GDBM) Failed ".
	"while attempting dump\n";
}	}
} else {	} else {
print $client "error: ".($!+0)	print $client "error: ".($!+0)
." tie(GDBM) Failed\n";	." tie(GDBM) Failed ".
	"while attempting dump\n";
}	}
# ----------------------------------------------------------------------- store	# ----------------------------------------------------------------------- store
} elsif ($userinput =~ /^store/) {	} elsif ($userinput =~ /^store/) {
Line 1323 sub make_new_child {	Line 1429 sub make_new_child {
}	}
my @pairs=split(/\&/,$what);	my @pairs=split(/\&/,$what);

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"}++;
Line 1341 sub make_new_child {	Line 1447 sub make_new_child {
print $client "ok\n";	print $client "ok\n";
} else {	} else {
print $client "error: ".($!+0)	print $client "error: ".($!+0)
." untie(GDBM) Failed\n";	." untie(GDBM) Failed ".
	"while attempting store\n";
}	}
} else {	} else {
print $client "error: ".($!+0)	print $client "error: ".($!+0)
." tie(GDBM) Failed\n";	." tie(GDBM) Failed ".
	"while attempting store\n";
}	}
} else {	} else {
print $client "refused\n";	print $client "refused\n";
Line 1359 sub make_new_child {	Line 1467 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)) {	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 1377 sub make_new_child {	Line 1485 sub make_new_child {
print $client "$qresult\n";	print $client "$qresult\n";
} else {	} else {
print $client "error: ".($!+0)	print $client "error: ".($!+0)
." untie(GDBM) Failed\n";	." untie(GDBM) Failed ".
	"while attempting restore\n";
}	}
} else {	} else {
print $client "error: ".($!+0)	print $client "error: ".($!+0)
." tie(GDBM) Failed\n";	." tie(GDBM) Failed ".
	"while attempting restore\n";
}	}
# -------------------------------------------------------------------- chatsend	# -------------------------------------------------------------------- chatsend
} elsif ($userinput =~ /^chatsend/) {	} elsif ($userinput =~ /^chatsend/) {
Line 1421 sub make_new_child {	Line 1531 sub make_new_child {
}	}
else {	else {
print $client "error: ".($!+0)	print $client "error: ".($!+0)
." IO::File->new Failed\n";	." 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);
	if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {
	foreach $pair (@pairs) {
	($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";
	if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {
	while (($key,$value) = each(%hash)) {
	my ($descr,$lasttime)=split(/\:/,$value);
	if ($lasttime<$since) { next; }
	if ($regexp eq '.') {
	$qresult.=$key.'='.$descr.'&';
	} else {
	my $unescapeVal = &unescape($descr);
	if (eval('$unescapeVal=~/$description/')) {
	$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 1437 sub make_new_child {	Line 1613 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)) {	if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {
foreach $pair (@pairs) {	foreach $pair (@pairs) {
($key,$value)=split(/=/,$pair);	($key,$value)=split(/=/,$pair);
$hash{$key}=$value;	$hash{$key}=$value;
Line 1446 sub make_new_child {	Line 1622 sub make_new_child {
print $client "ok\n";	print $client "ok\n";
} else {	} else {
print $client "error: ".($!+0)	print $client "error: ".($!+0)
." untie(GDBM) Failed\n";	." untie(GDBM) Failed ".
	"while attempting idput\n";
}	}
} else {	} else {
print $client "error: ".($!+0)	print $client "error: ".($!+0)
." tie(GDBM) Failed\n";	." tie(GDBM) Failed ".
	"while attempting idput\n";
}	}
# ----------------------------------------------------------------------- idget	# ----------------------------------------------------------------------- idget
} elsif ($userinput =~ /^idget/) {	} elsif ($userinput =~ /^idget/) {
Line 1460 sub make_new_child {	Line 1638 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)) {	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 1469 sub make_new_child {	Line 1647 sub make_new_child {
print $client "$qresult\n";	print $client "$qresult\n";
} else {	} else {
print $client "error: ".($!+0)	print $client "error: ".($!+0)
." untie(GDBM) Failed\n";	." untie(GDBM) Failed ".
	"while attempting idget\n";
}	}
} else {	} else {
print $client "error: ".($!+0)	print $client "error: ".($!+0)
." tie(GDBM) Failed\n";	." tie(GDBM) Failed ".
	"while attempting idget\n";
}	}
# ---------------------------------------------------------------------- tmpput	# ---------------------------------------------------------------------- tmpput
} elsif ($userinput =~ /^tmpput/) {	} elsif ($userinput =~ /^tmpput/) {
Line 1491 sub make_new_child {	Line 1671 sub make_new_child {
}	}
else {	else {
print $client "error: ".($!+0)	print $client "error: ".($!+0)
."IO::File->new Failed\n";	."IO::File->new Failed ".
	"while attempting tmpput\n";
}	}

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

# ---------------------------------------------------------------------- tmpdel	# ---------------------------------------------------------------------- tmpdel
Line 1521 sub make_new_child {	Line 1703 sub make_new_child {
print $client "ok\n";	print $client "ok\n";
} else {	} else {
print $client "error: ".($!+0)	print $client "error: ".($!+0)
."Unlink tmp Failed\n";	."Unlink tmp Failed ".
	"while attempting tmpdel\n";
}	}
# -------------------------------------------------------------------------- ls	# -------------------------------------------------------------------------- ls
} elsif ($userinput =~ /^ls/) {	} elsif ($userinput =~ /^ls/) {
Line 1733 sub currentversion {	Line 1916 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)) {	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);

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.110
changed lines
	Added in v.1.119