Changeset 5479c80 for fedkit/splitter.pl

Timestamp:

Sep 29, 2007 5:45:48 PM (17 years ago)

Author:

Ted Faber <faber@…>

Branches:

axis_example, compt_changes, info-ops, master, version-1.30, version-2.00, version-3.01, version-3.02

Children:

e06b224

Parents:

d53dda5

Message:

Timeout critical sshes in setting up experiments. The commands don't seem to
terminate when partial swap-ins are accomplished, or perhaps after long
swap-ins. This provides a way to move on.

File:

• fedkit/splitter.pl (modified) (11 diffs)

fedkit/splitter.pl

@@ -30 +30 @@
 my $tclsh;                      # tclsh to call directly (changed during devel)
 my @tarfiles;                   # Tarfiles in use by this experiment
+my $timeout;                    # The timeout to use for experiment swap ins
 my %opts;                       # Parsed options
 
@@ -158 +159 @@
 # command to execute, and a prefix to be placed on a message generated if the
 # command fails.   On failure print a warning if a warning prefix was given and
-# return false.
+# return false.  If timeout is given fork a process and set an alarm of that
+# many seconds.  Timeouts also return 0;
 sub ssh_cmd {
-    my($user, $host, $cmd, $wname) = @_;
-
-    # XXX system with a relative pathname is sort of gross
-    system ("ssh $user\@$host $cmd");
-    if ($?) {
-        warn "$wname failed $?\n" if $wname;
-        return 0;
-    }
-    else { return 1; }
+    my($user, $host, $cmd, $wname, $timeout) = @_;
+    my $pid;                # Child pid
+
+    if ( $timeout ) {
+        if ( $pid = fork () ) {
+            # Parent process
+            # The eval acts as a signal catcher.  If the alarm goes off inside
+            # the eval, the die will put "alarm\n" into $@, otherwise the
+            # return value of the execution in the child process will be used.
+            my $rv = eval {
+                local $SIG{'ALRM'} = sub{ die "alarm\n"; };
+                my $rv;
+
+                alarm $timeout;
+                $rv = waitpid($pid, 0);
+                alarm 0;
+                $rv;
+            };
+
+            # If the eval succeeded, $@ will be null and we can use $rv, which
+            # is the return code from the subprocess.  If the eval timed out,
+            # print a warning and assume the best.
+            if ($@ eq "alarm\n" ) {
+                warn "$wname timed out - pid $pid still live\n";
+                return 1;
+            }
+            else {
+                return $rv;
+            }
+        }
+        else {
+            # Child process
+            # XXX system with a relative pathname is sort of gross
+            exec("ssh $user\@$host $cmd");
+            exit 0;
+        }
+    }
+    else {
+        # No timeout, do all the work here.
+        # XXX system with a relative pathname is sort of gross
+        system ("ssh $user\@$host $cmd");
+        if ($?) {
+            warn "$wname failed $?\n" if $wname;
+            return 0;
+        }
+        else { return 1; }
+    }
 }
 
@@ -220 +260 @@
 # messages are printed.
 sub start_segment {
-    my($tb, $eid, $tbparams) = @_;          # testbed, experiment ID, and 
-                                            # per-testbed parameters
+    my($tb, $eid, $tbparams, $timeout) = @_;# testbed, experiment ID, 
+                                            # per-testbed parameters and remote
+                                            # swap-in timeout
     my $host =                              # Host name of remote ops (FQDN)
         $tbparams->{$tb}->{'host'} . $tbparams->{$tb}->{'domain'};
@@ -280 +321 @@
         print "Modifying $eid in place on $tb\n" if $verbose;
         &ssh_cmd($user, $host, "/usr/testbed/bin/modexp -r -s -w $pid " . 
-            "$eid $tclfile", "modexp") || return 0;
+            "$eid $tclfile", "modexp", $timeout) || return 0;
         return 1;
     }
@@ -304 +345 @@
         # Now start up
         &ssh_cmd($user, $host, "/usr/testbed/bin/swapexp -w $pid $eid in", 
-            "swapexp") || return 0;
+            "swapexp", $timeout) || return 0;
         return 1;
     }
@@ -330 +371 @@
         print "Swapping $eid in on $tb\n" if $verbose;
         &ssh_cmd($user, $host, "/usr/testbed/bin/swapexp -w $pid $eid in", 
-            "swapexp") || return 0;
+            "swapexp", $timeout) || return 0;
         return 1;
     }
@@ -364 +405 @@
                                     # keep our changes to the parser minimal.
 # Argument processing.
-getopts('c:f:ndvN', \%opts);
+getopts('t:c:f:ndvN', \%opts);
 $splitter_config = $opts{'c'} || "./splitter.conf";
 $debug = $opts{'d'};
@@ -374 +415 @@
 
 $startem = $opts{'n'} ? 0 : 1;          # If true, start the sub-experiments
+$timeout = $opts{'t'} || $opts{'timeout'};
 $eid = $opts{'experiment'};             # Experiment ID
 $tcl = $opts{'f'} || shift;             # The experiment description
@@ -541 +583 @@
             $cc->close();
         }
-        else { warn "No control gateway for $gateways?"; }
+        else { warn "No control gateway for $gateways?\n"; }
             
         $gateways = 0;
@@ -695 +737 @@
 for my $tb  (keys %allocated) {
     if ($tb ne $master) {
-        if (&start_segment($tb, $eid, $tbparams)) { $started{$tb}++; }
+        if (&start_segment($tb, $eid, $tbparams, $timeout)) { $started{$tb}++; }
         else { last TESTBED; }
     }
@@ -701 +743 @@
 
 # Now the master
-if (&start_segment($master, $eid, $tbparams)) { 
+if (&start_segment($master, $eid, $tbparams, $timeout)) { 
     $started{$master}++;
 }