--- loncom/lond 2003/03/02 03:58:55 1.110
+++ loncom/lond 2003/05/06 21:36:42 1.126
@@ -2,7 +2,7 @@
# The LearningOnline Network
# lond "LON Daemon" Server (port "LOND" 5663)
#
-# $Id: lond,v 1.110 2003/03/02 03:58:55 www Exp $
+# $Id: lond,v 1.126 2003/05/06 21:36:42 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -52,13 +52,12 @@
# preforking is not really needed.
###
-
use lib '/home/httpd/lib/perl/';
use LONCAPA::Configuration;
use IO::Socket;
use IO::File;
-use Apache::File;
+#use Apache::File;
use Symbol;
use POSIX;
use Crypt::IDEA;
@@ -74,6 +73,10 @@ my $DEBUG = 0; # Non zero to ena
my $status='';
my $lastlog='';
+my $VERSION='$Revision: 1.126 $'; #' stupid emacs
+my $remoteVERSION;
+my $currenthostid;
+my $currentdomainid;
#
# The array below are password error strings."
#
@@ -169,7 +172,7 @@ undef $perlvarref;
my $wwwid=getpwnam('www');
if ($wwwid!=$<) {
$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.' |\
mailto $emailto -s '$subj' > /dev/null");
exit 1;
@@ -196,6 +199,8 @@ while ($configline=<CONFIG>) {
my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
chomp($ip); $ip=~s/\D+$//;
$hostid{$ip}=$id;
+ $hostdom{$id}=$domain;
+ $hostip{$id}=$ip;
if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }
$PREFORK++;
}
@@ -263,17 +268,25 @@ sub checkchildren {
}
}
sleep 5;
+ $SIG{ALRM} = sub { die "timeout" };
+ $SIG{__DIE__} = 'DEFAULT';
foreach (sort keys %children) {
unless (-e "$docdir/lon-status/londchld/$_.txt") {
+ eval {
+ alarm(300);
&logthis('Child '.$_.' did not respond');
kill 9 => $_;
$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`;
$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
@@ -301,7 +314,7 @@ sub logstatus {
my $docdir=$perlvar{'lonDocRoot'};
{
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();
}
{
@@ -362,13 +375,6 @@ sub reconlonc {
if (kill 0 => $loncpid) {
&logthis("lonc at pid $loncpid responding, sending USR1");
kill USR1 => $loncpid;
- sleep 5;
- if (-e "$peerfile") { return; }
- &logthis("$peerfile still not there, give it another try");
- sleep 10;
- if (-e "$peerfile") { return; }
- &logthis(
- "<font color=blue>WARNING: $peerfile still not there, giving up</font>");
} else {
&logthis(
"<font color=red>CRITICAL: "
@@ -398,12 +404,12 @@ sub subreply {
sub reply {
my ($cmd,$server)=@_;
my $answer;
- if ($server ne $perlvar{'lonHostID'}) {
+ if ($server ne $currenthostid) {
$answer=subreply($cmd,$server);
if ($answer eq 'con_lost') {
$answer=subreply("ping",$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");
}
$answer=subreply($cmd,$server);
@@ -530,6 +536,8 @@ sub make_new_child {
} else {
# Child can *not* return from this subroutine.
$SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before
+ $SIG{CHLD} = 'DEFAULT'; #make this default so that pwauth returns
+ #don't get intercepted
$SIG{USR1}= \&logstatus;
$SIG{ALRM}= \&timeout;
$lastlog='Forked ';
@@ -556,15 +564,16 @@ sub make_new_child {
my $clientip=inet_ntoa($iaddr);
my $clientrec=($hostid{$clientip} ne undef);
&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})");
my $clientok;
if ($clientrec) {
&status("Waiting for init from $clientip ($hostid{$clientip})");
my $remotereq=<$client>;
- $remotereq=~s/\W//g;
- if ($remotereq eq 'init') {
+ $remotereq=~s/[^\w:]//g;
+ if ($remotereq =~ /^init/) {
+ &sethost("sethost:$perlvar{'lonHostID'}");
my $challenge="$$".time;
print $client "$challenge\n";
&status(
@@ -593,9 +602,15 @@ sub make_new_child {
if ($clientok) {
# ---------------- New known client connecting, could mean machine online again
- &reconlonc("$perlvar{'lonSockDir'}/$hostid{$clientip}");
- &logthis(
- "<font color=green>Established connection: $hostid{$clientip}</font>");
+ foreach my $id (keys(%hostip)) {
+ if ($hostip{$id} ne $clientip ||
+ $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});
# ------------------------------------------------------------ Process requests
while (my $userinput=<$client>) {
@@ -623,17 +638,17 @@ sub make_new_child {
# ------------------------------------------------------------- Normal commands
# ------------------------------------------------------------------------ ping
if ($userinput =~ /^ping/) {
- print $client "$perlvar{'lonHostID'}\n";
+ print $client "$currenthostid\n";
# ------------------------------------------------------------------------ pong
} elsif ($userinput =~ /^pong/) {
$reply=reply("ping",$hostid{$clientip});
- print $client "$perlvar{'lonHostID'}:$reply\n";
+ print $client "$currenthostid:$reply\n";
# ------------------------------------------------------------------------ ekey
} elsif ($userinput =~ /^ekey/) {
my $buildkey=time.$$.int(rand 100000);
$buildkey=~tr/1-6/A-F/;
$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/G-P/0-9/;
$key=~tr/Q-Z/0-9/;
@@ -845,7 +860,7 @@ sub make_new_child {
$passfilename);
if (-e $passfilename) {
print $client "already_exists\n";
- } elsif ($udom ne $perlvar{'lonDefDomain'}) {
+ } elsif ($udom ne $currentdomainid) {
print $client "not_right_domain\n";
} else {
@fpparts=split(/\//,$proname);
@@ -856,7 +871,8 @@ sub make_new_child {
unless (-e $fpnow) {
unless (mkdir($fpnow,0777)) {
$fperror="error: ".($!+0)
- ." mkdir failed\n";
+ ." mkdir failed while attempting "
+ ."makeuser\n";
}
}
}
@@ -884,7 +900,7 @@ sub make_new_child {
$npass=&unescape($npass);
my $proname=&propath($udom,$uname);
my $passfilename="$proname/passwd";
- if ($udom ne $perlvar{'lonDefDomain'}) {
+ if ($udom ne $currentdomainid) {
print $client "not_right_domain\n";
} else {
my $result=&make_passwd_file($uname, $umode,$npass,
@@ -1028,7 +1044,8 @@ sub make_new_child {
print $client "ok\n";
} else {
print $client "error: ".($!+0)
- ." IO::File->new Failed\n";
+ ." IO::File->new Failed "
+ ."while attempting log\n";
}
}
# ------------------------------------------------------------------------- put
@@ -1048,7 +1065,7 @@ sub make_new_child {
) { print $hfh "P:$now:$what\n"; }
}
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) {
($key,$value)=split(/=/,$pair);
$hash{$key}=$value;
@@ -1057,11 +1074,13 @@ sub make_new_child {
print $client "ok\n";
} else {
print $client "error: ".($!+0)
- ." untie(GDBM) failed\n";
+ ." untie(GDBM) failed ".
+ "while attempting put\n";
}
} else {
print $client "error: ".($!)
- ." tie(GDBM) Failed\n";
+ ." tie(GDBM) Failed ".
+ "while attempting put\n";
}
} else {
print $client "refused\n";
@@ -1088,7 +1107,7 @@ sub make_new_child {
}
}
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) {
($key,$value)=split(/=/,$pair);
&ManagePermissions($key, $udom, $uname,
@@ -1101,11 +1120,55 @@ sub make_new_child {
print $client "ok\n";
} else {
print $client "error: ".($!+0)
- ." untie(GDBM) Failed\n";
+ ." untie(GDBM) Failed ".
+ "while attempting rolesput\n";
}
} else {
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 {
print $client "refused\n";
@@ -1120,7 +1183,7 @@ sub make_new_child {
my @queries=split(/\&/,$what);
my $proname=propath($udom,$uname);
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++) {
$qresult.="$hash{$queries[$i]}&";
}
@@ -1129,11 +1192,18 @@ sub make_new_child {
print $client "$qresult\n";
} else {
print $client "error: ".($!+0)
- ." untie(GDBM) Failed\n";
+ ." untie(GDBM) Failed ".
+ "while attempting get\n";
}
} else {
- print $client "error: ".($!+0)
- ." tie(GDBM) Failed\n";
+ if ($!+0 == 2) {
+ print $client "error:No such file or ".
+ "GDBM reported bad block error\n";
+ } else {
+ print $client "error: ".($!+0)
+ ." tie(GDBM) Failed ".
+ "while attempting get\n";
+ }
}
# ------------------------------------------------------------------------ eget
} elsif ($userinput =~ /^eget/) {
@@ -1145,7 +1215,7 @@ sub make_new_child {
my @queries=split(/\&/,$what);
my $proname=propath($udom,$uname);
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++) {
$qresult.="$hash{$queries[$i]}&";
}
@@ -1167,11 +1237,13 @@ sub make_new_child {
}
} else {
print $client "error: ".($!+0)
- ." untie(GDBM) Failed\n";
+ ." untie(GDBM) Failed ".
+ "while attempting eget\n";
}
} else {
print $client "error: ".($!+0)
- ." tie(GDBM) Failed\n";
+ ." tie(GDBM) Failed ".
+ "while attempting eget\n";
}
# ------------------------------------------------------------------------- del
} elsif ($userinput =~ /^del/) {
@@ -1189,7 +1261,7 @@ sub make_new_child {
) { print $hfh "D:$now:$what\n"; }
}
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) {
delete($hash{$key});
}
@@ -1197,11 +1269,13 @@ sub make_new_child {
print $client "ok\n";
} else {
print $client "error: ".($!+0)
- ." untie(GDBM) Failed\n";
+ ." untie(GDBM) Failed ".
+ "while attempting del\n";
}
} else {
print $client "error: ".($!+0)
- ." tie(GDBM) Failed\n";
+ ." tie(GDBM) Failed ".
+ "while attempting del\n";
}
# ------------------------------------------------------------------------ keys
} elsif ($userinput =~ /^keys/) {
@@ -1211,7 +1285,7 @@ sub make_new_child {
$namespace=~s/\W//g;
my $proname=propath($udom,$uname);
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) {
$qresult.="$key&";
}
@@ -1220,11 +1294,13 @@ sub make_new_child {
print $client "$qresult\n";
} else {
print $client "error: ".($!+0)
- ." untie(GDBM) Failed\n";
+ ." untie(GDBM) Failed ".
+ "while attempting keys\n";
}
} else {
print $client "error: ".($!+0)
- ." tie(GDBM) Failed\n";
+ ." tie(GDBM) Failed ".
+ "while attempting keys\n";
}
# ----------------------------------------------------------------- dumpcurrent
} elsif ($userinput =~ /^currentdump/) {
@@ -1263,11 +1339,13 @@ sub make_new_child {
print $client "$qresult\n";
} else {
print $client "error: ".($!+0)
- ." untie(GDBM) Failed\n";
+ ." untie(GDBM) Failed ".
+ "while attempting currentdump\n";
}
} else {
print $client "error: ".($!+0)
- ." tie(GDBM) Failed\n";
+ ." tie(GDBM) Failed ".
+ "while attempting currentdump\n";
}
# ------------------------------------------------------------------------ dump
} elsif ($userinput =~ /^dump/) {
@@ -1299,11 +1377,13 @@ sub make_new_child {
print $client "$qresult\n";
} else {
print $client "error: ".($!+0)
- ." untie(GDBM) Failed\n";
+ ." untie(GDBM) Failed ".
+ "while attempting dump\n";
}
} else {
print $client "error: ".($!+0)
- ." tie(GDBM) Failed\n";
+ ." tie(GDBM) Failed ".
+ "while attempting dump\n";
}
# ----------------------------------------------------------------------- store
} elsif ($userinput =~ /^store/) {
@@ -1323,7 +1403,7 @@ sub make_new_child {
}
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 $key;
$hash{"version:$rid"}++;
@@ -1341,11 +1421,13 @@ sub make_new_child {
print $client "ok\n";
} else {
print $client "error: ".($!+0)
- ." untie(GDBM) Failed\n";
+ ." untie(GDBM) Failed ".
+ "while attempting store\n";
}
} else {
print $client "error: ".($!+0)
- ." tie(GDBM) Failed\n";
+ ." tie(GDBM) Failed ".
+ "while attempting store\n";
}
} else {
print $client "refused\n";
@@ -1359,7 +1441,7 @@ sub make_new_child {
chomp($rid);
my $proname=propath($udom,$uname);
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"};
$qresult.="version=$version&";
my $scope;
@@ -1377,11 +1459,13 @@ sub make_new_child {
print $client "$qresult\n";
} else {
print $client "error: ".($!+0)
- ." untie(GDBM) Failed\n";
+ ." untie(GDBM) Failed ".
+ "while attempting restore\n";
}
} else {
print $client "error: ".($!+0)
- ." tie(GDBM) Failed\n";
+ ." tie(GDBM) Failed ".
+ "while attempting restore\n";
}
# -------------------------------------------------------------------- chatsend
} elsif ($userinput =~ /^chatsend/) {
@@ -1390,9 +1474,10 @@ sub make_new_child {
print $client "ok\n";
# -------------------------------------------------------------------- chatretr
} elsif ($userinput =~ /^chatretr/) {
- my ($cmd,$cdom,$cnum)=split(/\:/,$userinput);
+ my
+ ($cmd,$cdom,$cnum,$udom,$uname)=split(/\:/,$userinput);
my $reply='';
- foreach (&getchat($cdom,$cnum)) {
+ foreach (&getchat($cdom,$cnum,$udom,$uname)) {
$reply.=&escape($_).':';
}
$reply=~s/\:$//;
@@ -1421,8 +1506,74 @@ sub make_new_child {
}
else {
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/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
} elsif ($userinput =~ /^idput/) {
my ($cmd,$udom,$what)=split(/:/,$userinput);
@@ -1437,7 +1588,7 @@ sub make_new_child {
) { print $hfh "P:$now:$what\n"; }
}
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) {
($key,$value)=split(/=/,$pair);
$hash{$key}=$value;
@@ -1446,11 +1597,13 @@ sub make_new_child {
print $client "ok\n";
} else {
print $client "error: ".($!+0)
- ." untie(GDBM) Failed\n";
+ ." untie(GDBM) Failed ".
+ "while attempting idput\n";
}
} else {
print $client "error: ".($!+0)
- ." tie(GDBM) Failed\n";
+ ." tie(GDBM) Failed ".
+ "while attempting idput\n";
}
# ----------------------------------------------------------------------- idget
} elsif ($userinput =~ /^idget/) {
@@ -1460,7 +1613,7 @@ sub make_new_child {
my $proname="$perlvar{'lonUsersDir'}/$udom/ids";
my @queries=split(/\&/,$what);
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++) {
$qresult.="$hash{$queries[$i]}&";
}
@@ -1469,11 +1622,13 @@ sub make_new_child {
print $client "$qresult\n";
} else {
print $client "error: ".($!+0)
- ." untie(GDBM) Failed\n";
+ ." untie(GDBM) Failed ".
+ "while attempting idget\n";
}
} else {
print $client "error: ".($!+0)
- ." tie(GDBM) Failed\n";
+ ." tie(GDBM) Failed ".
+ "while attempting idget\n";
}
# ---------------------------------------------------------------------- tmpput
} elsif ($userinput =~ /^tmpput/) {
@@ -1491,7 +1646,8 @@ sub make_new_child {
}
else {
print $client "error: ".($!+0)
- ."IO::File->new Failed\n";
+ ."IO::File->new Failed ".
+ "while attempting tmpput\n";
}
# ---------------------------------------------------------------------- tmpget
@@ -1508,7 +1664,8 @@ sub make_new_child {
}
else {
print $client "error: ".($!+0)
- ."IO::File->new Failed\n";
+ ."IO::File->new Failed ".
+ "while attempting tmpget\n";
}
# ---------------------------------------------------------------------- tmpdel
@@ -1521,7 +1678,8 @@ sub make_new_child {
print $client "ok\n";
} else {
print $client "error: ".($!+0)
- ."Unlink tmp Failed\n";
+ ."Unlink tmp Failed ".
+ "while attempting tmpdel\n";
}
# -------------------------------------------------------------------------- ls
} elsif ($userinput =~ /^ls/) {
@@ -1556,6 +1714,10 @@ sub make_new_child {
$client->close();
last;
# ------------------------------------------------------------- unknown command
+ } elsif ($userinput =~ /^sethost:/) {
+ print $client &sethost($userinput)."\n";
+ } elsif ($userinput =~/^version:/) {
+ print $client &version($userinput)."\n";
} else {
# unknown command
print $client "unknown_cmd\n";
@@ -1667,7 +1829,7 @@ sub addline {
}
sub getchat {
- my ($cdom,$cname)=@_;
+ my ($cdom,$cname,$udom,$uname)=@_;
my %hash;
my $proname=&propath($cdom,$cname);
my @entries=();
@@ -1676,7 +1838,19 @@ sub getchat {
@entries=map { $_.':'.$hash{$_} } sort keys %hash;
untie %hash;
}
- return @entries;
+ my @participants=();
+ $cutoff=time-60;
+ if (tie(%hash,'GDBM_File',"$proname/nohist_inchatroom.db",
+ &GDBM_WRCREAT(),0640)) {
+ $hash{$uname.':'.$udom}=time;
+ foreach (sort keys %hash) {
+ if ($hash{$_}>$cutoff) {
+ $participants[$#participants+1]='active_participant:'.$_;
+ }
+ }
+ untie %hash;
+ }
+ return (@participants,@entries);
}
sub chatadd {
@@ -1733,20 +1907,26 @@ sub currentversion {
if ($fname=~/^(.+)\/[^\/]+$/) {
$ulsdir=$1;
}
+ my ($fnamere1,$fnamere2);
+ # remove version if already specified
$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 $ulsdir) {
if(-d $ulsdir) {
if (opendir(LSDIR,$ulsdir)) {
+
while ($ulsfn=readdir(LSDIR)) {
# see if this is a regular file (ignore links produced earlier)
my $thisfile=$ulsdir.'/'.$ulsfn;
unless (-l $thisfile) {
- if ($thisfile=~/$fname/) {
- if ($1>$version) { $version=$1; }
- }
+ if ($thisfile=~/\Q$fnamere1\E(\d+)\Q$fnamere2\E/) {
+ if ($1>$version) { $version=$1; }
+ }
}
}
closedir(LSDIR);
@@ -1865,6 +2045,28 @@ sub make_passwd_file {
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)
=head1 NAME