--- loncom/lond 2003/08/11 21:15:26 1.133 +++ loncom/lond 2003/08/12 03:28:31 1.134 @@ -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 $DEBUG = 0; # Non zero to ena 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 @@ sub catchexception { $SIG{'QUIT'}='DEFAULT'; $SIG{__DIE__}='DEFAULT'; &logthis("CRITICAL: " - ."ABNORMAL EXIT. Child $$ for server $wasserver died through " + ."ABNORMAL EXIT. Child $$ for server $thisserver died through " ."a crash with this error msg->[$error]"); &logthis('Famous last words: '.$status.' - '.$lastlog); if ($client) { print $client "error: $error\n"; } @@ -171,8 +181,8 @@ undef $perlvarref; # ----------------------------- 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 (-e $pidfile) { 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=) { +while (my $configline=) { 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 @@ $server = IO::Socket::INET->new(LocalPor # 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 @@ sub HUPSMAN { # sig kill 'INT' => keys %children; &logthis("Free socket: ".shutdown($server,2)); # free up socket &logthis("CRITICAL: Restarting"); - 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 @@ sub checkchildren { &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 @@ sub initnewstatus { 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 @@ sub ishome { # ======================================================= 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 @@ POSIX::setsid() or die "Can't start new # ------------------------------------------------------- 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 @@ while (1) { } sub make_new_child { - my $client; my $pid; my $cipher; my $sigset; @@ -522,7 +526,8 @@ sub make_new_child { $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 @@ sub make_new_child { 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 @@ sub make_new_child { # 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( "INFO: Connection, $clientip ($hostid{$clientip})" @@ -641,7 +646,7 @@ sub make_new_child { 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 @@ sub make_new_child { } } } 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 @@ sub make_new_child { } } } 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 @@ sub make_new_child { } 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 @@ sub make_new_child { $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 @@ sub make_new_child { } 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=) { - if ($line=~/userfile\.$fname\=/) { $reply='ok'; } - } - close(ENVIN); - print $client $reply."\n"; + $session.'.id')) { + while (my $line=) { + 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 @@ 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)) { - 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 @@ sub make_new_child { } } 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 @@ sub make_new_child { } } 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 @@ 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)) { - 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 @@ 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)) { - 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 @@ 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)) { - 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 @@ 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)) { - 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 @@ sub make_new_child { $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 @@ sub make_new_child { } 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 @@ sub make_new_child { ) { 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 @@ sub make_new_child { 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 @@ sub make_new_child { "$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 @@ sub make_new_child { 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 @@ sub make_new_child { ) { 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 @@ 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)) { - 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 @@ sub ManagePermissions 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 @@ sub addline { 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 @@ sub getchat { 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 @@ sub currentversion { } 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 @@ sub subscribe { $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"; }