version 1.111, 2003/03/04 22:32:20
|
version 1.123, 2003/03/28 20:40:52
|
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 $VERSION='$Revision$'; #' stupid emacs |
|
my $remoteVERSION; |
|
my $currenthostid; |
|
my $currentdomainid; |
# |
# |
# The array below are password error strings." |
# The array below are password error strings." |
# |
# |
Line 169 undef $perlvarref;
|
Line 172 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 199 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 268 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 314 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 411 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 556 sub make_new_child {
|
Line 569 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/) { |
|
&sethost("sethost:$perlvar{'lonHostID'}"); |
my $challenge="$$".time; |
my $challenge="$$".time; |
print $client "$challenge\n"; |
print $client "$challenge\n"; |
&status( |
&status( |
Line 593 sub make_new_child {
|
Line 607 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 643 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 865 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 885 sub make_new_child {
|
Line 905 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 1050 sub make_new_child {
|
Line 1070 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 1092 sub make_new_child {
|
Line 1112 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 1116 sub make_new_child {
|
Line 1136 sub make_new_child {
|
} else { |
} else { |
print $client "refused\n"; |
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 { |
|
print $client "refused\n"; |
|
} |
# ------------------------------------------------------------------------- get |
# ------------------------------------------------------------------------- get |
} elsif ($userinput =~ /^get/) { |
} elsif ($userinput =~ /^get/) { |
my ($cmd,$udom,$uname,$namespace,$what) |
my ($cmd,$udom,$uname,$namespace,$what) |
Line 1126 sub make_new_child {
|
Line 1188 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 1139 sub make_new_child {
|
Line 1201 sub make_new_child {
|
"while attempting get\n"; |
"while attempting get\n"; |
} |
} |
} else { |
} else { |
print $client "error: ".($!+0) |
if ($!+0 == 2) { |
." tie(GDBM) Failed ". |
print $client "error:No such file or ". |
"while attempting get\n"; |
"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 1153 sub make_new_child {
|
Line 1220 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 1199 sub make_new_child {
|
Line 1266 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 1223 sub make_new_child {
|
Line 1290 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 1341 sub make_new_child {
|
Line 1408 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 1379 sub make_new_child {
|
Line 1446 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 1412 sub make_new_child {
|
Line 1479 sub make_new_child {
|
print $client "ok\n"; |
print $client "ok\n"; |
# -------------------------------------------------------------------- chatretr |
# -------------------------------------------------------------------- chatretr |
} elsif ($userinput =~ /^chatretr/) { |
} elsif ($userinput =~ /^chatretr/) { |
my ($cmd,$cdom,$cnum)=split(/\:/,$userinput); |
my |
|
($cmd,$cdom,$cnum,$udom,$uname)=split(/\:/,$userinput); |
my $reply=''; |
my $reply=''; |
foreach (&getchat($cdom,$cnum)) { |
foreach (&getchat($cdom,$cnum,$udom,$uname)) { |
$reply.=&escape($_).':'; |
$reply.=&escape($_).':'; |
} |
} |
$reply=~s/\:$//; |
$reply=~s/\:$//; |
Line 1446 sub make_new_child {
|
Line 1514 sub make_new_child {
|
." IO::File->new Failed ". |
." IO::File->new Failed ". |
"while attempting queryreply\n"; |
"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/i')) { |
|
$qresult.="$key=$descr&"; |
|
} |
|
} |
|
} |
|
if (untie(%hash)) { |
|
chop($qresult); |
|
print $client "$qresult\n"; |
|
} else { |
|
print $client "error: ".($!+0) |
|
." untie(GDBM) Failed ". |
|
"while attempting courseiddump\n"; |
|
} |
|
} else { |
|
print $client "error: ".($!+0) |
|
." tie(GDBM) Failed ". |
|
"while attempting courseiddump\n"; |
|
} |
# ----------------------------------------------------------------------- idput |
# ----------------------------------------------------------------------- idput |
} elsif ($userinput =~ /^idput/) { |
} elsif ($userinput =~ /^idput/) { |
my ($cmd,$udom,$what)=split(/:/,$userinput); |
my ($cmd,$udom,$what)=split(/:/,$userinput); |
Line 1460 sub make_new_child {
|
Line 1593 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 1485 sub make_new_child {
|
Line 1618 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 1586 sub make_new_child {
|
Line 1719 sub make_new_child {
|
$client->close(); |
$client->close(); |
last; |
last; |
# ------------------------------------------------------------- unknown command |
# ------------------------------------------------------------- unknown command |
|
} elsif ($userinput =~ /^sethost:/) { |
|
print $client &sethost($userinput)."\n"; |
|
} elsif ($userinput =~/^version:/) { |
|
print $client &version($userinput)."\n"; |
} else { |
} else { |
# unknown command |
# unknown command |
print $client "unknown_cmd\n"; |
print $client "unknown_cmd\n"; |
Line 1697 sub addline {
|
Line 1834 sub addline {
|
} |
} |
|
|
sub getchat { |
sub getchat { |
my ($cdom,$cname)=@_; |
my ($cdom,$cname,$udom,$uname)=@_; |
my %hash; |
my %hash; |
my $proname=&propath($cdom,$cname); |
my $proname=&propath($cdom,$cname); |
my @entries=(); |
my @entries=(); |
Line 1706 sub getchat {
|
Line 1843 sub getchat {
|
@entries=map { $_.':'.$hash{$_} } sort keys %hash; |
@entries=map { $_.':'.$hash{$_} } sort keys %hash; |
untie %hash; |
untie %hash; |
} |
} |
|
$cutoff=time-60; |
|
if (tie(%hash,'GDBM_File',"$proname/nohist_inchatroom.db", |
|
&GDBM_READER(),0640)) { |
|
$hash{$uname.':'.$undom}=time; |
|
foreach (sort keys %hash) { |
|
if ($hash{$_}>$cutoff) { |
|
$entries[$#entries+1]='active_participant:'.$_; |
|
} |
|
} |
|
untie %hash; |
|
} |
return @entries; |
return @entries; |
} |
} |
|
|
Line 1763 sub currentversion {
|
Line 1911 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); |
Line 1895 sub make_passwd_file {
|
Line 2049 sub make_passwd_file {
|
return $result; |
return $result; |
} |
} |
|
|
|
sub sethost { |
|
my ($remotereq) = @_; |
|
my (undef,$hostid)=split(/:/,$remotereq); |
|
if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; } |
|
if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) { |
|
$currenthostid=$hostid; |
|
$currentdomainid=$hostdom{$hostid}; |
|
&logthis("Setting hostid to $hostid, and domain to $currentdomainid"); |
|
} else { |
|
&logthis("Requested host id $hostid not an alias of ". |
|
$perlvar{'lonHostID'}." refusing connection"); |
|
return 'unable_to_set'; |
|
} |
|
return 'ok'; |
|
} |
|
|
|
sub version { |
|
my ($userinput)=@_; |
|
$remoteVERSION=(split(/:/,$userinput))[1]; |
|
return "version:$VERSION"; |
|
} |
|
|
# ----------------------------------- POD (plain old documentation, CPAN style) |
# ----------------------------------- POD (plain old documentation, CPAN style) |
|
|
=head1 NAME |
=head1 NAME |