--- loncom/lond 2004/02/04 17:17:26 1.173 +++ loncom/lond 2004/03/16 20:57:49 1.185 @@ -2,7 +2,7 @@ # The LearningOnline Network # lond "LON Daemon" Server (port "LOND" 5663) # -# $Id: lond,v 1.173 2004/02/04 17:17:26 taceyjo1 Exp $ +# $Id: lond,v 1.185 2004/03/16 20:57:49 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -53,7 +53,7 @@ my $DEBUG = 0; # Non zero to ena my $status=''; my $lastlog=''; -my $VERSION='$Revision: 1.173 $'; #' stupid emacs +my $VERSION='$Revision: 1.185 $'; #' stupid emacs my $remoteVERSION; my $currenthostid; my $currentdomainid; @@ -812,18 +812,26 @@ $server = IO::Socket::INET->new(LocalPor # global variables 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; &status("Handling child death"); - my $pid = wait; - if (defined($children{$pid})) { - &logthis("Child $pid died"); - $children --; - delete $children{$pid}; - } else { - &logthis("Unknown Child $pid died"); + my $pid; + do { + $pid = waitpid(-1,&WNOHANG()); + if (defined($children{$pid})) { + &logthis("Child $pid died"); + delete($children{$pid}); + } elsif ($pid > 0) { + &logthis("Unknown Child $pid died"); + } + } while ( $pid > 0 ); + foreach my $child (keys(%children)) { + $pid = waitpid($child,&WNOHANG()); + if ($pid > 0) { + &logthis("Child $child - $pid looks like we missed it's death"); + delete($children{$pid}); + } } &status("Finished Handling child death"); } @@ -879,12 +887,14 @@ sub ReadHostTable { open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file"; 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; } + if (!($configline =~ /^\s*\#/)) { + 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; } + } } close(CONFIG); } @@ -1020,7 +1030,7 @@ sub logstatus { my $docdir=$perlvar{'lonDocRoot'}; { my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt"); - print $fh $$."\t".$currenthostid."\t".$status."\t".$lastlog."\n"; + print $fh $$."\t".$clientname."\t".$currenthostid."\t".$status."\t".$lastlog."\n"; $fh->close(); } &status("Finished londstatus.txt"); @@ -1248,15 +1258,24 @@ sub make_new_child { # the pid hash. # my $caller = getpeername($client); - my ($port,$iaddr)=unpack_sockaddr_in($caller); - $clientip=inet_ntoa($iaddr); + my ($port,$iaddr); + if (defined($caller) && length($caller) > 0) { + ($port,$iaddr)=unpack_sockaddr_in($caller); + } else { + &logthis("Unable to determine who caller was, getpeername returned nothing"); + } + if (defined($iaddr)) { + $clientip=inet_ntoa($iaddr); + } else { + &logthis("Unable to determine clinetip"); + $clientip='Unavailable'; + } if ($pid) { # Parent records the child's birth and returns. sigprocmask(SIG_UNBLOCK, $sigset) or die "Can't unblock SIGINT for fork: $!\n"; $children{$pid} = $clientip; - $children++; &status('Started child '.$pid); return; } else { @@ -1809,12 +1828,21 @@ sub make_new_child { } elsif ($userinput =~ /^fetchuserfile/) { # Client clear or enc. if(isClient) { my ($cmd,$fname)=split(/:/,$userinput); - my ($udom,$uname,$ufile)=split(/\//,$fname); + my ($udom,$uname,$ufile) = ($fname =~ m|^([^/]+)/([^/]+)/(.+)$|); my $udir=propath($udom,$uname).'/userfiles'; unless (-e $udir) { mkdir($udir,0770); } if (-e $udir) { - $ufile=~s/^[\.\~]+//; - $ufile=~s/\///g; + $ufile=~s/^[\.\~]+//; + my $path = $udir; + if ($ufile =~m|(.+)/([^/]+)$|) { + my @parts=split('/',$1); + foreach my $part (@parts) { + $path .= '/'.$part; + if ((-e $path)!=1) { + mkdir($path,0770); + } + } + } my $destname=$udir.'/'.$ufile; my $transname=$udir.'/'.$ufile.'.in.transit'; my $remoteurl='http://'.$clientip.'/userfiles/'.$fname; @@ -1843,7 +1871,6 @@ sub make_new_child { } } else { Reply($client, "refused\n", $userinput); - } # ------------------------------------------ authenticate access to a user file } elsif ($userinput =~ /^tokenauthuserfile/) { # Client only @@ -1854,7 +1881,7 @@ sub make_new_child { if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'. $session.'.id')) { while (my $line=) { - if ($line=~/userfile\.$fname\=/) { $reply='ok'; } + if ($line=~ m|userfile\.\Q$fname\E\=|) { $reply='ok'; } } close(ENVIN); print $client $reply."\n"; @@ -1997,12 +2024,12 @@ sub make_new_child { } else { print $client "error: ".($!+0) ." untie(GDBM) failed ". - "while attempting put\n"; + "while attempting inc\n"; } } else { print $client "error: ".($!) ." tie(GDBM) Failed ". - "while attempting put\n"; + "while attempting inc\n"; } } else { print $client "refused\n"; @@ -2328,7 +2355,6 @@ sub make_new_child { my $proname=propath($udom,$uname); my %hash; if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { - study($regexp); while (my ($key,$value) = each(%hash)) { if ($regexp eq '.') { $qresult.=$key.'='.$value.'&'; @@ -2725,6 +2751,7 @@ sub make_new_child { } elsif ($userinput =~ /^ls/) { if(isClient) { my $obs; + my $rights; my ($cmd,$ulsdir)=split(/:/,$userinput); my $ulsout=''; my $ulsfn; @@ -2732,7 +2759,7 @@ sub make_new_child { if(-d $ulsdir) { if (opendir(LSDIR,$ulsdir)) { while ($ulsfn=readdir(LSDIR)) { - undef $obs; + undef $obs, $rights; my @ulsstats=stat($ulsdir.'/'.$ulsfn); #We do some obsolete checking here if(-e $ulsdir.'/'.$ulsfn.".meta") { @@ -2740,10 +2767,13 @@ sub make_new_child { my @obsolete=; foreach my $obsolete (@obsolete) { if($obsolete =~ m|()(on)|) { $obs = 1; } + if($obsolete =~ m|()(default)|) { $rights = 1; } } } $ulsout.=$ulsfn.'&'.join('&',@ulsstats); - if($obs eq '1') { $ulsout.="&1:"; } + if($obs eq '1') { $ulsout.="&1"; } + else { $ulsout.="&0"; } + if($rights eq '1') { $ulsout.="&1:"; } else { $ulsout.="&0:"; } } closedir(LSDIR);