--- loncom/lond	2000/07/21 00:40:37	1.18
+++ loncom/lond	2000/12/05 18:02:14	1.24
@@ -7,7 +7,7 @@
 # 12/7,12/15,01/06,01/11,01/12,01/14,2/8,
 # 03/07,05/31 Gerd Kortemeyer
 # 06/26 Scott Harrison
-# 06/29,06/30,07/14,07/15,07/17,07/20 Gerd Kortemeyer
+# 06/29,06/30,07/14,07/15,07/17,07/20,07/25,09/18 Gerd Kortemeyer
 #
 # based on "Perl Cookbook" ISBN 1-56592-243-3
 # preforker - server who forks first
@@ -25,9 +25,36 @@ use LWP::UserAgent();
 use GDBM_File;
 use Authen::Krb4;
 
+# grabs exception and records it to log before exiting
+sub catchexception {
+    my ($signal)=@_;
+    &logthis("<font color=red>CRITICAL: "
+     ."ABNORMAL EXIT. Child $$ for server $wasserver died through "
+     ."$signal with this parameter->[$@]</font>");
+    die($@);
+}
+
+# grabs exception and records it to log before exiting
+# NOTE: we must NOT use the regular (non-overrided) die function in
+# the code because a handler CANNOT be attached to it
+# (despite what some of the documentation says about SIG{__DIE__}.
+sub catchdie {
+    my ($message)=@_;
+    &logthis("<font color=red>CRITICAL: "
+     ."ABNORMAL EXIT. Child $$ for server $wasserver died through "
+     ."\_\_DIE\_\_ with this parameter->[$message]</font>");
+    die($message);
+}
+
+# -------------------------------- Set signal handlers to record abnormal exits
+
+$SIG{'QUIT'}=\&catchexception;
+$SIG{__DIE__}=\&catchexception;
+
 # ------------------------------------ Read httpd access.conf and get variables
 
-open (CONFIG,"/etc/httpd/conf/access.conf") || die "Can't read access.conf";
+open (CONFIG,"/etc/httpd/conf/access.conf")
+    || catchdie "Can't read access.conf";
 
 while ($configline=<CONFIG>) {
     if ($configline =~ /PerlSetVar/) {
@@ -38,11 +65,23 @@ while ($configline=<CONFIG>) {
 }
 close(CONFIG);
 
+# --------------------------------------------- Check if other instance running
+
+my $pidfile="$perlvar{'lonDaemons'}/logs/lond.pid";
+
+if (-e $pidfile) {
+   my $lfh=IO::File->new("$pidfile");
+   my $pide=<$lfh>;
+   chomp($pide);
+   if (kill 0 => $pide) { catchdie "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";
+open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab")
+    || catchdie "Can't read host file";
 
 while ($configline=<CONFIG>) {
     my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
@@ -59,7 +98,7 @@ $server = IO::Socket::INET->new(LocalPor
                                 Proto     => 'tcp',
                                 Reuse     => 1,
                                 Listen    => 10 )
-  or die "making socket: $@\n";
+  or catchdie "making socket: $@\n";
 
 # --------------------------------------------------------- Do global variables
 
@@ -242,9 +281,9 @@ sub ishome {
 
 $fpid=fork;
 exit if $fpid;
-die "Couldn't fork: $!" unless defined ($fpid);
+catchdie "Couldn't fork: $!" unless defined ($fpid);
 
-POSIX::setsid() or die "Can't start new session: $!";
+POSIX::setsid() or catchdie "Can't start new session: $!";
 
 # ------------------------------------------------------- Write our PID on disk
 
@@ -283,14 +322,14 @@ sub make_new_child {
     # block signal for fork
     $sigset = POSIX::SigSet->new(SIGINT);
     sigprocmask(SIG_BLOCK, $sigset)
-        or die "Can't block SIGINT for fork: $!\n";
+        or catchdie "Can't block SIGINT for fork: $!\n";
     
-    die "fork: $!" unless defined ($pid = fork);
+    catchdie "fork: $!" unless defined ($pid = fork);
     
     if ($pid) {
         # Parent records the child's birth and returns.
         sigprocmask(SIG_UNBLOCK, $sigset)
-            or die "Can't unblock SIGINT for fork: $!\n";
+            or catchdie "Can't unblock SIGINT for fork: $!\n";
         $children{$pid} = 1;
         $children++;
         return;
@@ -300,7 +339,7 @@ sub make_new_child {
     
         # unblock signals
         sigprocmask(SIG_UNBLOCK, $sigset)
-            or die "Can't unblock SIGINT for fork: $!\n";
+            or catchdie "Can't unblock SIGINT for fork: $!\n";
 
         $tmpsnum=0;
     
@@ -511,7 +550,7 @@ sub make_new_child {
                              $response=$ua->request($request,$transname);
 			      }
                              if ($response->is_error()) {
-				 unline($transname);
+				 unlink($transname);
                                  my $message=$response->status_line;
                                  &logthis(
                                   "LWP GET: $message for $fname ($remoteurl)");
@@ -663,7 +702,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_WRCREAT,0640)) {
+      if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
                            for ($i=0;$i<=$#queries;$i++) {
                                $qresult.="$hash{$queries[$i]}&";
                            }
@@ -686,7 +725,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_WRCREAT,0640)) {
+      if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
                            for ($i=0;$i<=$#queries;$i++) {
                                $qresult.="$hash{$queries[$i]}&";
                            }
@@ -748,7 +787,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_WRCREAT,0640)) {
+      if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
                            foreach $key (keys %hash) {
                                $qresult.="$key&";
                            }
@@ -769,7 +808,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_WRCREAT,0640)) {
+      if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
                            foreach $key (keys %hash) {
                                $qresult.="$key=$hash{$key}&";
                            }
@@ -833,7 +872,7 @@ sub make_new_child {
                        chomp($rid);
                        my $proname=propath($udom,$uname);
                        my $qresult='';
-      if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {
+      if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
                 	   my $version=$hash{"version:$rid"};
                            $qresult.="version=$version&";
                            my $scope;
@@ -843,7 +882,7 @@ sub make_new_child {
                               my $key;
                               $qresult.="$scope:keys=$vkeys&";
                               foreach $key (@keys) {
-	     $qresult.="$version:$key=".$hash{"$scope:$rid:$key"}."&";
+	     $qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&";
                               }                                  
                            }
 			   if (untie(%hash)) {
@@ -908,7 +947,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_WRCREAT,0640)) {
+                 if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER,0640)) {
                            for ($i=0;$i<=$#queries;$i++) {
                                $qresult.="$hash{$queries[$i]}&";
                            }