[LON-CAPA-cvs] cvs: loncom / lond
albertel
lon-capa-cvs@mail.lon-capa.org
Tue, 12 Aug 2003 03:28:31 -0000
This is a MIME encoded message
--albertel1060658911
Content-Type: text/plain
albertel Mon Aug 11 23:28:31 2003 EDT
Modified files:
/loncom lond
Log:
- as if by magic, now has use strict; (BUG#1998)
- this entailed a lot of my addition, some global decleration, and removal of some dead code
- also a couple of latent bugs have been fixed
--albertel1060658911
Content-Type: text/plain
Content-Disposition: attachment; filename="albertel-20030811232831.txt"
Index: loncom/lond
diff -u loncom/lond:1.133 loncom/lond:1.134
--- loncom/lond:1.133 Mon Aug 11 17:15:26 2003
+++ loncom/lond Mon Aug 11 23:28:31 2003
@@ -2,7 +2,7 @@
# The LearningOnline Network
# lond "LON Daemon" Server (port "LOND" 5663)
#
-# $Id: lond,v 1.133 2003/08/11 21:15:26 www Exp $
+# $Id: lond,v 1.134 2003/08/12 03:28:31 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -52,6 +52,7 @@
# preforking is not really needed.
###
+use strict;
use lib '/home/httpd/lib/perl/';
use LONCAPA::Configuration;
@@ -73,10 +74,19 @@
my $status='';
my $lastlog='';
-my $VERSION='$Revision: 1.133 $'; #' stupid emacs
+my $VERSION='$Revision: 1.134 $'; #' stupid emacs
my $remoteVERSION;
my $currenthostid;
my $currentdomainid;
+
+my $client;
+my $server;
+my $thisserver;
+
+my %hostid;
+my %hostdom;
+my %hostip;
+
#
# The array below are password error strings."
#
@@ -145,7 +155,7 @@
$SIG{'QUIT'}='DEFAULT';
$SIG{__DIE__}='DEFAULT';
&logthis("<font color=red>CRITICAL: "
- ."ABNORMAL EXIT. Child $$ for server $wasserver died through "
+ ."ABNORMAL EXIT. Child $$ for server $thisserver died through "
."a crash with this error msg->[$error]</font>");
&logthis('Famous last words: '.$status.' - '.$lastlog);
if ($client) { print $client "error: $error\n"; }
@@ -171,8 +181,8 @@
# ----------------------------- Make sure this process is running from user=www
my $wwwid=getpwnam('www');
if ($wwwid!=$<) {
- $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
- $subj="LON: $currenthostid User ID mismatch";
+ my $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
+ my $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;
@@ -189,20 +199,17 @@
if (kill 0 => $pide) { die "already running"; }
}
-$PREFORK=4; # number of children to maintain, at least four spare
-
# ------------------------------------------------------------- Read hosts file
open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";
-while ($configline=<CONFIG>) {
+while (my $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++;
}
close(CONFIG);
@@ -218,10 +225,8 @@
# global variables
-$MAX_CLIENTS_PER_CHILD = 50; # number of clients each child should
- # process
-%children = (); # keys are current child process IDs
-$children = 0; # current number of children
+my %children = (); # keys are current child process IDs
+my $children = 0; # current number of children
sub REAPER { # takes care of dead children
$SIG{CHLD} = \&REAPER;
@@ -250,8 +255,8 @@
kill 'INT' => keys %children;
&logthis("Free socket: ".shutdown($server,2)); # free up socket
&logthis("<font color=red>CRITICAL: Restarting</font>");
- unlink("$execdir/logs/lond.pid");
my $execdir=$perlvar{'lonDaemons'};
+ unlink("$execdir/logs/lond.pid");
exec("$execdir/lond"); # here we go again
}
@@ -259,7 +264,7 @@
&initnewstatus();
&logstatus();
&logthis('Going to check on the children');
- $docdir=$perlvar{'lonDocRoot'};
+ my $docdir=$perlvar{'lonDocRoot'};
foreach (sort keys %children) {
sleep 1;
unless (kill 'USR1' => $_) {
@@ -331,7 +336,7 @@
my $local=localtime($now);
print $fh "LOND status $local - parent $$\n\n";
opendir(DIR,"$docdir/lon-status/londchld");
- while ($filename=readdir(DIR)) {
+ while (my $filename=readdir(DIR)) {
unlink("$docdir/lon-status/londchld/$filename");
}
closedir(DIR);
@@ -473,7 +478,7 @@
# ======================================================= Continue main program
# ---------------------------------------------------- Fork once and dissociate
-$fpid=fork;
+my $fpid=fork;
exit if $fpid;
die "Couldn't fork: $!" unless defined ($fpid);
@@ -481,7 +486,7 @@
# ------------------------------------------------------- Write our PID on disk
-$execdir=$perlvar{'lonDaemons'};
+my $execdir=$perlvar{'lonDaemons'};
open (PIDSAVE,">$execdir/logs/lond.pid");
print PIDSAVE "$$\n";
close(PIDSAVE);
@@ -511,7 +516,6 @@
}
sub make_new_child {
- my $client;
my $pid;
my $cipher;
my $sigset;
@@ -522,7 +526,8 @@
$sigset = POSIX::SigSet->new(SIGINT);
sigprocmask(SIG_BLOCK, $sigset)
or die "Can't block SIGINT for fork: $!\n";
-
+
+ my $clientip;
die "fork: $!" unless defined ($pid = fork);
if ($pid) {
@@ -547,7 +552,7 @@
sigprocmask(SIG_UNBLOCK, $sigset)
or die "Can't unblock SIGINT for fork: $!\n";
- $tmpsnum=0;
+ my $tmpsnum=0;
#---------------------------------------------------- kerberos 5 initialization
&Authen::Krb5::init_context();
&Authen::Krb5::init_ets();
@@ -561,7 +566,7 @@
# see if we know client and check for spoof IP by challenge
my $caller = getpeername($client);
my ($port,$iaddr)=unpack_sockaddr_in($caller);
- my $clientip=inet_ntoa($iaddr);
+ $clientip=inet_ntoa($iaddr);
my $clientrec=($hostid{$clientip} ne undef);
&logthis(
"<font color=yellow>INFO: Connection, $clientip ($hostid{$clientip})</font>"
@@ -641,7 +646,7 @@
print $client "$currenthostid\n";
# ------------------------------------------------------------------------ pong
} elsif ($userinput =~ /^pong/) {
- $reply=reply("ping",$hostid{$clientip});
+ my $reply=&reply("ping",$hostid{$clientip});
print $client "$currenthostid:$reply\n";
# ------------------------------------------------------------------------ ekey
} elsif ($userinput =~ /^ekey/) {
@@ -725,7 +730,7 @@
}
}
} elsif ($howpwd eq 'krb4') {
- $null=pack("C",0);
+ my $null=pack("C",0);
unless ($upass=~/$null/) {
my $krb4_error = &Authen::Krb4::get_pw_in_tkt
($uname,"",$contentpwd,'krbtgt',
@@ -742,7 +747,7 @@
}
}
} elsif ($howpwd eq 'krb5') {
- $null=pack("C",0);
+ my $null=pack("C",0);
unless ($upass=~/$null/) {
my $krbclient=&Authen::Krb5::parse_name($uname.'@'.$contentpwd);
my $krbservice="krbtgt/".$contentpwd."\@".$contentpwd;
@@ -867,10 +872,10 @@
} elsif ($udom ne $currentdomainid) {
print $client "not_right_domain\n";
} else {
- @fpparts=split(/\//,$proname);
- $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2];
- $fperror='';
- for ($i=3;$i<=$#fpparts;$i++) {
+ my @fpparts=split(/\//,$proname);
+ my $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2];
+ my $fperror='';
+ for (my $i=3;$i<=$#fpparts;$i++) {
$fpnow.='/'.$fpparts[$i];
unless (-e $fpnow) {
unless (mkdir($fpnow,0777)) {
@@ -934,11 +939,11 @@
$uid,$gid,$rdev,$size,
$atime,$mtime,$ctime,
$blksize,$blocks)=stat($fname);
- $now=time;
- $since=$now-$atime;
+ my $now=time;
+ my $since=$now-$atime;
if ($since>$perlvar{'lonExpire'}) {
- $reply=
- reply("unsub:$fname","$hostid{$clientip}");
+ my $reply=
+ &reply("unsub:$fname","$hostid{$clientip}");
unlink("$fname");
} else {
my $transname="$fname.in.transfer";
@@ -1009,16 +1014,16 @@
} elsif ($userinput =~ /^tokenauthuserfile/) {
my ($cmd,$fname,$session)=split(/:/,$userinput);
chomp($session);
- $reply='non_auth';
+ my $reply='non_auth';
if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.
- $session.'.id')) {
- while ($line=<ENVIN>) {
- if ($line=~/userfile\.$fname\=/) { $reply='ok'; }
- }
- close(ENVIN);
- print $client $reply."\n";
+ $session.'.id')) {
+ while (my $line=<ENVIN>) {
+ if ($line=~/userfile\.$fname\=/) { $reply='ok'; }
+ }
+ close(ENVIN);
+ print $client $reply."\n";
} else {
- print $client "invalid_token\n";
+ print $client "invalid_token\n";
}
# ----------------------------------------------------------------- unsubscribe
} elsif ($userinput =~ /^unsub/) {
@@ -1069,9 +1074,10 @@
) { print $hfh "P:$now:$what\n"; }
}
my @pairs=split(/\&/,$what);
- if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
- foreach $pair (@pairs) {
- ($key,$value)=split(/=/,$pair);
+ my %hash;
+ if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
+ foreach my $pair (@pairs) {
+ my ($key,$value)=split(/=/,$pair);
$hash{$key}=$value;
}
if (untie(%hash)) {
@@ -1111,14 +1117,14 @@
}
}
my @pairs=split(/\&/,$what);
- if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
- foreach $pair (@pairs) {
- ($key,$value)=split(/=/,$pair);
+ my %hash;
+ if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
+ foreach my $pair (@pairs) {
+ my ($key,$value)=split(/=/,$pair);
&ManagePermissions($key, $udom, $uname,
&GetAuthType( $udom,
$uname));
$hash{$key}=$value;
-
}
if (untie(%hash)) {
print $client "ok\n";
@@ -1157,10 +1163,10 @@
}
}
my @rolekeys=split(/\&/,$what);
- if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
- foreach $key (@rolekeys) {
+ my %hash;
+ if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
+ foreach my $key (@rolekeys) {
delete $hash{$key};
-
}
if (untie(%hash)) {
print $client "ok\n";
@@ -1187,8 +1193,9 @@
my @queries=split(/\&/,$what);
my $proname=propath($udom,$uname);
my $qresult='';
- if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
- for ($i=0;$i<=$#queries;$i++) {
+ my %hash;
+ if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
+ for (my $i=0;$i<=$#queries;$i++) {
$qresult.="$hash{$queries[$i]}&";
}
if (untie(%hash)) {
@@ -1219,8 +1226,9 @@
my @queries=split(/\&/,$what);
my $proname=propath($udom,$uname);
my $qresult='';
- if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
- for ($i=0;$i<=$#queries;$i++) {
+ my %hash;
+ if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
+ for (my $i=0;$i<=$#queries;$i++) {
$qresult.="$hash{$queries[$i]}&";
}
if (untie(%hash)) {
@@ -1265,8 +1273,9 @@
) { print $hfh "D:$now:$what\n"; }
}
my @keys=split(/\&/,$what);
- if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
- foreach $key (@keys) {
+ my %hash;
+ if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
+ foreach my $key (@keys) {
delete($hash{$key});
}
if (untie(%hash)) {
@@ -1289,8 +1298,9 @@
$namespace=~s/\W//g;
my $proname=propath($udom,$uname);
my $qresult='';
- if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
- foreach $key (keys %hash) {
+ my %hash;
+ if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
+ foreach my $key (keys %hash) {
$qresult.="$key&";
}
if (untie(%hash)) {
@@ -1314,6 +1324,7 @@
$namespace=~s/\W//g;
my $qresult='';
my $proname=propath($udom,$uname);
+ my %hash;
if (tie(%hash,'GDBM_File',
"$proname/$namespace.db",
&GDBM_READER(),0640)) {
@@ -1364,9 +1375,10 @@
}
my $qresult='';
my $proname=propath($udom,$uname);
- if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
+ my %hash;
+ if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
study($regexp);
- while (($key,$value) = each(%hash)) {
+ while (my ($key,$value) = each(%hash)) {
if ($regexp eq '.') {
$qresult.=$key.'='.$value.'&';
} else {
@@ -1406,15 +1418,15 @@
) { print $hfh "P:$now:$rid:$what\n"; }
}
my @pairs=split(/\&/,$what);
-
- if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
+ my %hash;
+ if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
my @previouskeys=split(/&/,$hash{"keys:$rid"});
my $key;
$hash{"version:$rid"}++;
my $version=$hash{"version:$rid"};
my $allkeys='';
- foreach $pair (@pairs) {
- ($key,$value)=split(/=/,$pair);
+ foreach my $pair (@pairs) {
+ my ($key,$value)=split(/=/,$pair);
$allkeys.=$key.':';
$hash{"$version:$rid:$key"}=$value;
}
@@ -1445,7 +1457,8 @@
chomp($rid);
my $proname=propath($udom,$uname);
my $qresult='';
- if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
+ my %hash;
+ if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
my $version=$hash{"version:$rid"};
$qresult.="version=$version&";
my $scope;
@@ -1522,9 +1535,10 @@
"$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);
+ my %hash;
+ if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {
+ foreach my $pair (@pairs) {
+ my ($key,$value)=split(/=/,$pair);
$hash{$key}=$value.':'.$now;
}
if (untie(%hash)) {
@@ -1552,8 +1566,9 @@
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 %hash;
+ if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {
+ while (my ($key,$value) = each(%hash)) {
my ($descr,$lasttime)=split(/\:/,$value);
if ($lasttime<$since) { next; }
if ($description eq '.') {
@@ -1592,9 +1607,10 @@
) { print $hfh "P:$now:$what\n"; }
}
my @pairs=split(/\&/,$what);
- if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {
- foreach $pair (@pairs) {
- ($key,$value)=split(/=/,$pair);
+ my %hash;
+ if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {
+ foreach my $pair (@pairs) {
+ my ($key,$value)=split(/=/,$pair);
$hash{$key}=$value;
}
if (untie(%hash)) {
@@ -1617,17 +1633,18 @@
my $proname="$perlvar{'lonUsersDir'}/$udom/ids";
my @queries=split(/\&/,$what);
my $qresult='';
- if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {
- for ($i=0;$i<=$#queries;$i++) {
+ my %hash;
+ if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {
+ for (my $i=0;$i<=$#queries;$i++) {
$qresult.="$hash{$queries[$i]}&";
}
if (untie(%hash)) {
- $qresult=~s/\&$//;
- print $client "$qresult\n";
+ $qresult=~s/\&$//;
+ print $client "$qresult\n";
} else {
- print $client "error: ".($!+0)
- ." untie(GDBM) Failed ".
- "while attempting idget\n";
+ print $client "error: ".($!+0)
+ ." untie(GDBM) Failed ".
+ "while attempting idget\n";
}
} else {
print $client "error: ".($!+0)
@@ -1772,11 +1789,11 @@
my $authtype= shift;
# See if the request is of the form /$domain/_au
-
+ &logthis("ruequest is $request");
if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...
my $execdir = $perlvar{'lonDaemons'};
my $userhome= "/home/$user" ;
- Debug("system $execdir/lchtmldir $userhome $system $authtype");
+ &logthis("system $execdir/lchtmldir $userhome $user $authtype");
system("$execdir/lchtmldir $userhome $user $authtype");
}
}
@@ -1819,6 +1836,7 @@
my $found=0;
my $expr='^'.$hostid.':'.$ip.':';
$expr =~ s/\./\\\./g;
+ my $sh;
if ($sh=IO::File->new("$fname.subscription")) {
while (my $subline=<$sh>) {
if ($subline !~ /$expr/) {$contents.= $subline;} else {$found=1;}
@@ -1843,7 +1861,7 @@
untie %hash;
}
my @participants=();
- $cutoff=time-60;
+ my $cutoff=time-60;
if (tie(%hash,'GDBM_File',"$proname/nohist_inchatroom.db",
&GDBM_WRCREAT(),0640)) {
$hash{$uname.':'.$udom}=time;
@@ -1921,24 +1939,24 @@
}
if (-e $fname) { $version=1; }
if (-e $ulsdir) {
- if(-d $ulsdir) {
- if (opendir(LSDIR,$ulsdir)) {
-
- while ($ulsfn=readdir(LSDIR)) {
+ if(-d $ulsdir) {
+ if (opendir(LSDIR,$ulsdir)) {
+ my $ulsfn;
+ while ($ulsfn=readdir(LSDIR)) {
# see if this is a regular file (ignore links produced earlier)
- my $thisfile=$ulsdir.'/'.$ulsfn;
- unless (-l $thisfile) {
- if ($thisfile=~/\Q$fnamere1\E(\d+)\Q$fnamere2\E/) {
- if ($1>$version) { $version=$1; }
- }
- }
- }
- closedir(LSDIR);
- $version++;
- }
- }
- }
- return $version;
+ my $thisfile=$ulsdir.'/'.$ulsfn;
+ unless (-l $thisfile) {
+ if ($thisfile=~/\Q$fnamere1\E(\d+)\Q$fnamere2\E/) {
+ if ($1>$version) { $version=$1; }
+ }
+ }
+ }
+ closedir(LSDIR);
+ $version++;
+ }
+ }
+ }
+ return $version;
}
sub thisversion {
@@ -1977,7 +1995,7 @@
$result="directory\n";
} else {
if (-e "$fname.$hostid{$clientip}") {&unsub($fname,$clientip);}
- $now=time;
+ my $now=time;
my $found=&addline($fname,$hostid{$clientip},$clientip,
"$hostid{$clientip}:$clientip:$now\n");
if ($found) { $result="$fname\n"; }
--albertel1060658911--