Argh, still hanging on hearing back from MythTV. Switch to forking a child for the...

By forking a child we can wait around for a short period, and then kill them off.

diff --git a/bin/mythtv-status b/bin/mythtv-status
index a495fd432eb5d239a779ccb6c63e534eeaf3c824..10491d67e61c4032adf7e3b9d231d423131247ec 100755 (executable)
--- a/bin/mythtv-status
+++ b/bin/mythtv-status
@@ -645,19 +645,11 @@ sub load_xml {
     close IN;
   } else {
     my $url = "http://$c->{'host'}:$c->{'port'}/xml";
-    my $ua = LWP::UserAgent->new;
-    $ua->timeout(30);
-    $ua->env_proxy;
-    my $response = ua_request_with_timeout($ua, $url);
-
-    die "Sorry, failed to fetch $url: Connection to MythTV timed out.\n"
-      unless defined $response;
-
-    die "Sorry, failed to fetch $url:\n" . $response->status_line . "\n"
-      unless $response->is_success;
+    my $content_type;
+    ($content_type, $status) = xml_fetch($url);
 
-    $status = $response->decoded_content;
-    my $content_type = $response->header('Content-Type');
+    die "Nothing was received from the MythTV Backend"
+      unless defined $status;
     ($charset)  = ($content_type =~ /charset="(\S+?)"/);
   }
 
@@ -1018,6 +1010,70 @@ sub normalise_disk_space {
   return $_[0];
 }
 
+# Perform the fetch from the MythTV Backend in a child process.
+sub xml_fetch {
+  my ($url) = @_;
+
+  $| = 1;
+  my $pid = pipe_from_fork('CHILD');
+  if ($pid) {
+    # parent
+    my $content_type;
+    my $status;
+
+    eval {
+      local $SIG{ALRM} = sub { die "alarm\n" };
+      alarm(30);
+      $content_type = <CHILD>;
+      while (my $line = <CHILD>) {
+        $status .= $line;
+      }
+      alarm(0);
+    };
+
+    # The child didn't get back to us in time, kill them off.
+    if ($@) {
+      kill 15, $pid
+    }
+
+    return ($content_type, $status);
+  } else {
+    # child
+    my $ua = LWP::UserAgent->new;
+    $ua->timeout(30);
+    $ua->env_proxy;
+
+    my $response = ua_request_with_timeout($ua, $url);
+    die "Sorry, failed to fetch $url: Connection to MythTV timed out.\n"
+      unless defined $response;
+
+    die "Sorry, failed to fetch $url:\n" . $response->status_line . "\n"
+      unless $response->is_success;
+
+    print $response->header('Content-Type') . "\n";
+    print $response->decoded_content . "\n";
+
+    exit 0;
+  }
+}
+
+# simulate open(FOO, "-|")
+sub pipe_from_fork ($) {
+  my $parent = shift;
+
+  pipe $parent, my $child or die;
+  my $pid = fork();
+  die "fork() failed: $!" unless defined $pid;
+
+  if ($pid) {
+    close $child;
+  } else {
+    close $parent;
+    open(STDOUT, ">&=" . fileno($child)) or die;
+  }
+  $pid;
+}
+
 # Takes a LWP::UserAgent, and a HTTP::Request, returns a HTTP::Request
 # Based on:
 # http://stackoverflow.com/questions/73308/true-timeout-on-lwpuseragent-request-method