--- loncom/lond 2004/02/04 17:17:26 1.173 +++ loncom/lond 2004/03/09 16:12:26 1.182 @@ -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.182 2004/03/09 16:12:26 raeburn 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.182 $'; #' 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}); + } else { + &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 { @@ -1808,16 +1827,27 @@ sub make_new_child { # -------------------------------------- fetch a user file from a remote server } elsif ($userinput =~ /^fetchuserfile/) { # Client clear or enc. if(isClient) { - my ($cmd,$fname)=split(/:/,$userinput); + my ($cmd,$fname,$fpath)=split(/:/,$userinput); my ($udom,$uname,$ufile)=split(/\//,$fname); my $udir=propath($udom,$uname).'/userfiles'; unless (-e $udir) { mkdir($udir,0770); } if (-e $udir) { + unless ($fpath eq '') { + my $filepath = $udir; + my @parts=split(/\//,$fpath); + my $count; + for ($count=0;$count<=$#parts;$count++) { + $filepath .="/$parts[$count]"; + if ((-e $filepath)!=1) { + mkdir($filepath,0770); + } + } + } $ufile=~s/^[\.\~]+//; $ufile=~s/\///g; - my $destname=$udir.'/'.$ufile; - my $transname=$udir.'/'.$ufile.'.in.transit'; - my $remoteurl='http://'.$clientip.'/userfiles/'.$fname; + my $destname=$udir.'/'.$fpath.$ufile; + my $transname=$udir.'/'.$fpath.$ufile.'.in.transit'; + my $remoteurl='http://'.$clientip.'/userfiles/'.$udom.'/'.$uname.'/'.$fpath.$ufile; my $response; { my $ua=new LWP::UserAgent; @@ -1827,7 +1857,7 @@ sub make_new_child { if ($response->is_error()) { unlink($transname); my $message=$response->status_line; - &logthis("LWP GET: $message for $fname ($remoteurl)"); + &logthis("LWP GET: $message for $fpath $fname ($remoteurl)"); print $client "failed\n"; } else { if (!rename($transname,$destname)) { @@ -1997,12 +2027,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 +2358,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 +2754,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 +2762,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 +2770,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);