comment on

Hello Wise Monks, I'm seeking your help again. I need to write a Perl script that would do several simple things:

Wait on STDIN for commands from the controller script, parse and execute these commands. There are only two of them at the moment: run, kill and quit. Run command accepts an arbitrary ID string and a script to pass on, ended with a dot - well, SMTP-like. Just like this:
```
run foo-bar-id
foo-foo-foo
bar-bar-bar
qux-qux-qux
.
[download]
```
The idea is that lines between #^run.*?$# and #\.# are passed on to the executed script. The kill <id> and quit commands are self-explanatory.
Upon receiving "run" command, my script should execute certain program in background, passing collected lines into its STDIN. The program then will stream out some text data in unbuffered fashion until killed (or something bad happens).
For all executed programs, my script should gather their output, prepend it with corresponding IDs and print to STDOUT. If you think that it looks suspiciously like multiplexing, you're right.
If an executed program dies in background, my script should silently restart it if it's not explicitly told not to by using "run nowatch <id>" command or somesuch.

Now that sounds easy, isn't it? I thought so, too, before I spent three days trying to understand the deep magic between pipes and signals. This is what I got so far:


#!/usr/bin/perl

use warnings;
use IO::Handle;
use IO::Select;
use File::Temp;
use Data::Dumper;

#use constant SCRIPT_PATH => '/path/to/obscure/program'; # It's always
+ there.

if (-x SCRIPT_PATH) {
  print "OK\n";
} else {
  print "FAIL No script found at " . SCRIPT_PATH . "\n";
  exit(1);
};

STDIN->blocking(0);
STDOUT->blocking(0);

my $io = IO::Handle->new_from_fd(fileno(STDIN), "r");
my $select = IO::Select->new($io);


my $buf = "";

$DEADER = 0;

sub Zombie_Alert {
  $DEADER = wait;
#  $SIG{CHLD} = \&Zombie_Alert;
};

$SIG{CHLD} = \&Zombie_Alert;

%CHILDREN = ();

KEEPEMCOMIN: while (my @ready = $select->can_read(undef)) {
  foreach my $handle (@ready) {
    my $line = ""; my $bufline = "";

    my $rv = $handle->sysread($bufline, 4096);
    $line .= $bufline;
    while ($rv == 4096) {

      $rv = $handle->sysread($bufline, 4096);
      $line .= $bufline unless !$rv;
    };

    if ($handle->fileno == fileno(STDIN)) { # process commands from ST
+DIN
      $buf .= $line;
      next KEEPEMCOMIN if $buf !~ /(^(run).*?^\.$)|(^(kill|quit).*?$)/
+sim;

      $buf =~ s#\r\n#\n#g;

YESSIR: while ($buf =~ /(^run.*?^\.$)|(^kill.*?$)|(^q(uit)?$)/gsim) {
        my $lbuf; $lbuf = $1 if $1; $lbuf = $2 if !$1 && $2;
        $lbuf = $3 if !$1 && !$2 && $3; my $savebuf = $lbuf;
        $lbuf =~ s#^\.\n##g;

        if ($lbuf =~ s/(^run.*?^)//sim) { $cmd = $1; chomp $cmd; };

        if ($cmd =~ /^run(\s+nowatch)?\s+(.*?)$/i) { # RUN command
          my $id = $2;
          my $watch = $1 && $1 =~ /nowatch/i ? 0 : 1;

          if (!$id) { print "FAIL No id specified\n"; next; };

         print spawn($id, $watch, $lbuf), "\n";
        } elsif ($cmd =~ /^kill\s+(.*?)$/i) {        # KILL command
          my $id = $1;

          if (my $pid = $CHILDREN{'id'.$id}) {
            my $fd = $CHILDREN{'id'.$id}{'io'}->fileno;

            kill SIGTERM, $pid;
            $select->remove($fd);
            undef $CHILDREN{'id'.$id}{'io'};
            delete($CHILDREN{'id'.$id});
            delete($CHILDREN{'pid'.$pid});
            delete($CHILDREN{'fd'.$fd});

            print "OK\n";
          } else {
            print "FAILED $2 No such id\n";
          };
        } elsif ($cmd =~ /^quit$/i) {   # QUIT command
          $SIG{CHLD} = 'IGNORE';
          foreach my $key (keys %CHILDREN) {
            next unless $key =~ /pid\d+/;
            kill SIGTERM, $CHILDREN{$key}{'pid'};

          };
          print "OK\n";
          exit(0);
        };
        $buf =~ s/$savebuf// unless !$savebuf;
        $buf =~ s/^\s*//g;
        next YESSIR if $buf;
      };
    } else {                          # process input from children
      local $id = $CHILDREN{'fd'.$handle->fileno}{'id'} . " ";
      foreach my $chunk (split /\n/, $line) { print "${id}${chunk}\n";
+ };
    };
  };
  if ($DEADER > 0) {   # ZOMBIE ALERT!
      if (exists($CHILDREN{'pid'.$DEADER})) {
        my $id = $CHILDREN{'pid'.$DEADER}{'id'};
        my $pid = $CHILDREN{'pid'.$DEADER}{'pid'};
        my $io = $CHILDREN{'pid'.$DEADER}{'io'};
        my $watch = $CHILDREN{'pid'.$DEADER}{'watch'};
        my $buf = $CHILDREN{'pid'.$DEADER}{'buf'};

        delete($CHILDREN{'id'.$id});
        delete($CHILDREN{'pid'.$pid});

        delete($CHILDREN{'fd'.$io->fileno});
        $select->remove($io->fileno);
        undef $io;

        if ($watch) {
          $ret = spawn($id, $watch, $buf);
          if ($ret =~ /FAIL/) { print "$ret\n"; }
        };
      } else { print "FAIL Unknown id died\n"; };
    $DEADER = 0;
    next KEEPEMCOMIN;
  };
};

exit(0);

$HANDLE = 1; # initial file handle number
$TMPNAME = undef; # temp file name

sub spawn {
  my ($id, $watch, $buf) = @_;

  unlink $TMPNAME unless !$TMPNAME;

  ($tmph, $TMPNAME) = File::Temp::tempfile();
  print $tmph $buf, "\n";
  close($tmph);

  $HANDLE++;

  if (my $pid = open('CHILD'.$HANDLE, "-|")) {    # parent process her
+e
    my $rd = IO::Handle->new_from_fd(fileno('CHILD'.$HANDLE), "r");
    $select->add($rd);

    my %kid;
    $kid{'id'} = $id;
    $kid{'pid'} = $pid;
    $kid{'io'} = $rd;
    $kid{'watch'} = $watch;
    $kid{'buf'} = $buf;

    $CHILDREN{'id'.$id} = \%kid;
    $CHILDREN{'pid'.$pid} = \%kid;
    $CHILDREN{'fd'.$rd->fileno} = \%kid;

    return "RUNNING $id";
  } elsif (defined($pid)) {  # child process here
    $SIG{INT} = $SIG{TERM} = $SIG{CHLD} = 'DEFAULT';
    open(STDIN, "<$TMPNAME");
    select STDOUT; $| = 1;
    exec(SCRIPT_PATH) or return "FAIL $id Cannot exec: $!";
  } else {
    return "FAIL $id Cannot fork: $!";
  };
};
[download]

And no, it ain't working as expected. There are several problems:

The $select->can_read() does not block, despite what documentation says. It keeps reporting that there's something in STDIN, even if there's nothing there for sure - thus entering a tight loop and hogging up CPU. Inserting a "sleep 1" right after it helps of course, but that's ugly kludge.
SIGCHLD is killing me. I cannot understand why it works differently depending on where my STDIN lies: if I run the script like "myscript < command_file" it appears to be working OK but if I run it in interactive mode and type (or paste) commands manually, it doesn't! It just silently goes to that exit(0) at the end of main script and exits! I think I tried all debugging methods Internet knows of and I still haven't got a clue WHY it does that. No error indication, no exceptions, no nothing - it just goes right out of the main loop right after signal handler! I'm at loss.
The script's behavior is erratic and bizarre, to say at least. One time I run it and it appears to work - another one it just sits there silently, and nothing happens. Black magic?

Frankly, I don't know what to think. A seemingly easy exercise in Perl Cookbook programming turned out to be a complete nightmare. And I don't even have a clue where it went so wrong... Hope somebody could shed a couple photons on this issue, I'd really appreciate it.

Oh, and there are limitations as well: this script will run under Solaris 9 using perl-5.6.1 provided with the system, and no non-standard modules are allowed. Ideally, this script shouldn't even be installed but run on-the-fly with perl -x after sshing on the box.

Thanks in advance for any input!

Regards,
Alex.

In reply to Non-blocking I/O woes by dwalin

Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!

Titles consisting of a single word are discouraged, and in most cases are disallowed outright.

Read Where should I post X? if you're not absolutely sure you're posting in the right place.

Please read these before you post! —

Posts may use any of the Perl Monks Approved HTML tags:

a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, details, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, summary, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr

You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)

	For:		Use:
	&		`&`
	<		`<`
	>		`>`
	[		`[`
	]		`]`

Link using PerlMonks shortcuts! What shortcuts can I use for linking?

See Writeup Formatting Tips and other pages linked from there for more info.