polettix

I'm working on a program that is thin wrapper around the execution of many other programs (mainly shells scripts) in Linux. The initial - and working! - choice was to use system():

my $code = system {$program} $program;

but it showed some limits soon...

In particular, I'm printing extensive log messages, both from the controlling program and the called ones, and it all goes to the terminal. Obvious question from cow-orkers was that they wanted it in a file so that it could be perused at will later.

No problem... just leave my program alone and use tee! There is a weird catch though: if the called scripts happen to start some daemons but not in the real orthodox way, it will leave the output handles open and tee will wait for their output even when the main program exited. This is a feature that really gets in the way!

Now, I'm using Log::Log4perl::Tiny, so I figured that with a little change I could add multichannel output easily, i.e. to log both on STDERR and a file. As a result, this is what will be available when I manage to do proper releasing on CPAN (developer packages are already there):

Log::Log4perl->easy_init(
   {
      level => $INFO,
      layout => "[%d] [$me:%-5P:%-5p] %m%n",
      channels => [
         fh => \*STDERR,
         file_create => do {
            my ($sec, $min, $hour, $mday, $mon, $year) = localtime();
            sprintf 'ecmc-run-%04d%02d%02d-%02d%02d%02d.log',
               $year + 1900, $mon + 1, $mday, $hour, $min, $sec;
         },
      ],
   }
);

(Yes, I'm invading the Log::Log4perl space, read the docs to see why).

The bummer is that whatever is printed by the programs called through system() is not going where I want, but only to STDERR/STDOUT! It was time to call someone else to the rescue, and I remembered about IPC::Run. After doing a bit of refactoring in Log::Log4perl::Tiny -- mainly to allow sending stuff directly to the managed channels, as a passthrough avoiding the whole log mechanism -- I could substitute the system call like this:

my $logger = get_logger();
my $outcome = run [ $command ], '<', \undef, '>&', sub {$logger->emit_log(@_)};
my $code = $CHILD_ERROR;

The >& is a handy shortcut to ask for merging STDOUT and STDERR; IPC::Run is powerful enough to accept a subroutine reference as a possible sink for data retrieved from the called program, so through a very basic adapter sub I was able to call the emit_log() function (i.e. the passthrough I was introducing above).

Does this work? Sort of... not to say that it doesn't. While it does the job of sending to the file the same stuff that is sent to the screen, it suffers from the very problem that tee has: the ill-behaved programs that daemonize stuff incorrectly hang the process. The situation is actually even worse here, because the hanging of the tee program was basically only annoying, while here it's my program to hang!

Time for some reading through the documentation, but alas to no avail. Additionally, my metacpan-fu might be low, but I didn't manage to find any valid alternative, so times were ripe for the infamous roll_your_own() solution that involved:

• fork()ing
• pipe()ing (you'll notice I just listed them in the wrong order...)
• open()ing the standard handles properly in the child
• exec()ing, read()ing, wait()ing... and more to come!

In short terms, a big bunch of boring low-level stuff. Let's bite the bullet then...

My main goal is to do something very simple: call a command, merge its STDOUT and STDERR in one and send those data to my logger. In the parent, it started like this:

sub run {
   my ($command) = @_;

   # the channel used by the child to talk to the parent
   pipe my $rfh, my $wfh or die "pipe(): $OS_ERROR";

   # fork() and initial error checking
   my $pid = fork();
   if (! defined $pid) {
      close $rfh;
      close $wfh;
      die "fork(): $OS_ERROR";
   }

   # if $pid is 0 hand over to the child
   child($command, $rfh, $wfh) unless $pid;

   # rest of this function is from the parent's perspective
   # ... will see it in a minute
}

The important thing to remember is that pipe() MUST be called before the fork(), otherwise the parent and the child will never share the channel. Explicitly closing the two pipe ends in case fork() fails is probably superfluous because the they are held by two lexicals anyway, and they would go out of scope after the die().

When the returned $pid is zero, it means that we are in the child end of the fork(), so we hand over the control to child() (which will never return). Otherwise, we have to implement the reading and logging of data:

sub run {
   my ($command) = @_;

   # ... first part of the sub, see above...
   # rest of this function is from the parent's perspective

   # dont' have anything to write from parent
   close $wfh;

   while ('necessary') {
      defined(my $nread = read $rfh, my $buffer, 4096)
         or LOGDIE "read(): $OS_ERROR";
      last unless $nread;
      $logger->emit_log($buffer);
   }

   # cleanup: filehandle and child reaping
   close $rfh or warn "close(): $OS_ERROR";
   wait();

   # return the child error code
   return $CHILD_ERROR;
}

And this is where it got really embarassing: I was having exactly the same problem as above! The trick is that the read is going to block whenever the write half of the pipe is still open, which again happens in the ill-behaving daemonizing scripts.

I have more levers at my disposal now, because I can check whether the child I spawned is still alive or not. This time I will have to complicate the loop because I have to check for two different conditions (alive child and readable filehandle), so I added IO::Select into the equation, to test whether I can read data from the filehandle but with a timeout that I pass to the sub. I somehow feel I can do better than this mostly-inactive waiting, but whatever.

sub run {
   my ($command, $read_timeout) = @_;

   # ... first part of the sub, see above...
   # rest of this function is from the parent's perspective

   # dont' have anything to write from parent
   close $wfh;

   # keep a flag for child exit
   my $active = 1;
   local $SIG{CHLD} = sub { $active = 0 }; # unset the flag

   # this will avoid hanging the read
   my $s = IO::Select->new($rfh);

   while ($active) {
      while ($s->can_read($read_timeout ||= 2)) {
         defined(my $nread = read $rfh, my $buffer, 4096)
            or LOGDIE "read(): $OS_ERROR";
         last unless $nread;
         $logger->emit_log($buffer);
      }
   }

   # cleanup: filehandle and child reaping
   close $rfh or warn "close(): $OS_ERROR";
   wait();

   # return the child error code
   return $CHILD_ERROR;
}

And as you already guessed, this sort-of works but still has a bunch of issues, the most apparent being:

• read() really? This is asking for trouble, because we would be suffering from input buffering! sysread() is the right function to call here
• there is an evident race that might prevent collecting any input from the child: in the time betweein the $active variable declaration and initialization, and when it is tested for the first time, there is a chance that it printed something and exited, so we would never enter the outer while loop to get what it said

The former is straightforward, we only need to add a sys. The second calls for a more convoluted solution:

sub run {
   my ($command, $read_timeout) = @_;

   # ... first part of the sub, see above...
   my $pid = fork();
   # ... other stuff here, already seen...
   # rest of this function is from the parent's perspective

   # dont' have anything to write from parent
   close $wfh;

   # keep a flag for child exit
   my $active = 1;
   local $SIG{CHLD} = sub { $active = 0 }; # unset the flag

   # this will avoid hanging the sysread
   my $s = IO::Select->new($rfh);

   # $active is a flag to indicate that the child is still alive
   while ($pid || $active) {
      $pid = 0; # we give at least one chance to the children
      while ($s->can_read($read_timeout ||= 2)) {
         defined(my $nread = sysread $rfh, my $buffer, 4096)
            or LOGDIE "read(): $OS_ERROR";
         last unless $nread;
         $logger->emit_log($buffer);
      }
   }

   # cleanup: filehandle and child reaping
   close $rfh or warn "close(): $OS_ERROR";
   wait();

   # return the child error code
   return $CHILD_ERROR;
}

I use the $pid variable as an additional flag to see whether I gave the child at least one chance to say something, making it inactive from the very first loop (sort of implementing a do ... while, but I don't like it very much).

Am I all set at this point? Not at all! If the child is very very fast, and exit before I install the signal handler for SIGCHLD, I might be losing it completely. My solution here is to install the signal handler before I fork(), so I'm sure it will be there whoever wins the after-fork() race between the child and the parent. Here's the final version of the sub then:

sub run {
   my ($command, $read_timeout) = @_;

   # the channel used by the child to talk to the parent
   pipe my $rfh, my $wfh or die "pipe(): $OS_ERROR";

   # keep a flag for child exit. It gets defined/initialized
   # here so that its initialization comes before spawning
   # otherwise there is a race and the signal might be missed
   my $active = 1;
   local $SIG{CHLD} = sub { $active = 0 }; # unset the flag

   # fork() and initial error checking
   my $pid = fork();
   if (! defined $pid) {
      close $rfh;
      close $wfh;
      LOGDIE "fork(): $OS_ERROR";
   }

   # if $pid is 0 hand over to the child
   child($command, $rfh, $wfh) unless $pid;

   # rest of this function is from the parent's perspective
   # dont' have anything to write from parent
   close $wfh;

   # this will avoid hanging the sysread
   my $s = IO::Select->new($rfh);

   # $active is a flag to indicate that the child is still alive
   while ($pid || $active) {
      $pid = 0; # we give at least one chance to the children
      while ($s->can_read($read_timeout ||= 2)) {
         defined(my $nread = sysread $rfh, my $buffer, 4096)
            or LOGDIE "read(): $OS_ERROR";
         last unless $nread;
         $logger->emit_log($buffer);
      }
   }

   # cleanup: filehandle and child reaping
   close $rfh or warn "close(): $OS_ERROR";
   wait();

   # return the child error code
   return $CHILD_ERROR;
}

How is the child function shaped anyway? There's a lot of stuff happening there too, but the comments should explain what's going on with sufficient clarity:

sub child {
   my ($command, $rfh, $wfh) = @_;

   # child shouldn't expect anything from the outside
   close STDIN;
   open STDIN, '<', '/dev/null' or LOGDIE "open(): $OS_ERROR";

   # child's STDOUT and STDERR are redirected towards the
   # pipe write end. Autoflush is set although it might
   # be ignored in the child of course.
   close STDOUT;
   open STDOUT, '>&', $wfh or LOGDIE "dup(): $OS_ERROR";
   select STDOUT;
   $OUTPUT_AUTOFLUSH++;

   close STDERR;
   open STDERR, '>&', $wfh or LOGDIE "dup(): $OS_ERROR";
   select STDERR;
   $OUTPUT_AUTOFLUSH++;

   # initial pipe ends are of no use now, close them
   close $rfh; # don't have to read anything
   close $wfh; # dup()-ed, release file handle

   (setsid() != -1) || WARN "setsid() failed: $OS_ERROR";

   exec {$command->[0]} @$command
      or LOGDIE "exec(): $OS_ERROR";
   return 0; # never reached
}

There is probably a bit of cargo-cult in the child() sub above, most notably in the use of close() (probably not needed) and in the strict order used to perform the actions (so that I'm mostly sure that the right file identifier numbers will be used). Although probably not necessary in this case, I also take care of closing the unneeded end of the pipe (i.e. $rfh in the child case), but it would be closed anyway upon exec().

At this point it is working... even though I wake up suddenly in the night with some anxiety that I might have missed other dark corner cases!