Run - Perl extension for to start programs in background

  use Run;
  $pid = spawn 'long_running_task', 'arg1', 'arg2' or die "spawn: $!";
  do_something_else();
  waitpid($pid,0);

package Run;

use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);

require Exporter;

# This is voodoo, but with these settings test works:

my $no_error_on_unwind_close = 1;
my $use_longer_control_F = 0;	# redir.t no. 13 is fragile with this

@ISA = qw(Exporter);
# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.
@EXPORT = qw(
	spawn
);
$VERSION = '0.03';

%EXPORT_TAGS = ( NEW => [qw(new_system new_spawn new_or new_and new_chain
			    new_env new_redir new_pipe new_readpipe
			    new_readpipe_split)] );
@EXPORT_OK = @{$EXPORT_TAGS{NEW}};

@Run::and::ISA = @Run::or::ISA = @Run::chain::ISA = @Run::spawn::ISA
  = @Run::system::ISA = qw(Run::base);

@Run::env::ISA = @Run::pipe::ISA = @Run::redir::ISA = qw(Run::base2);
@Run::readpipe::ISA = @Run::readpipe_split::ISA = qw(Run::base1);

my $Debug = $ENV{PERL_RUN_DEBUG} && fileno STDERR;
my $SaveErr;
if ($Debug) {
  if ($Debug > 1) {
    $SaveErr =  \*SAVERR;
    open $SaveErr, ">&STDERR" or die "Cannot dup STDERR: $!";
    require IO::Handle;
    bless $SaveErr, 'IO::Handle';
    $SaveErr->autoflush(1);
  } else {
    $SaveErr =  \*STDERR;
  }
}

sub spawn {
  if ($^O eq 'os2') {
    if (@_ == 1 and ( $_[0] =~ /[\`|\"\'\$&;*?\{\}\[\]\(\)<>\s~]/ 
				# backslashes are allowed as far as
				# there is no whitespace.
		      or $_[0] =~ /^\s*\w+=/ )) {
      # system 1, blah would not use shell
      unshift @_, '/bin/sh', '-c'; # /bin/sh will be auto-translated
                                   # to the installed place by system().
    }
    return system 1, @_;
  } elsif ($^O eq 'MSWin32' or $^O eq 'VMS') {
    return system 1, @_;
  } else {
    print $SaveErr "forking...\t\t\t\t\t\t\t\$^F=$^F\n" if $Debug;
    my $pid = fork;
    return unless defined $pid;
    return $pid if $pid;	# parent
    # kid:
    print $SaveErr "execing `@_'...\n" if $Debug;
    exec @_ or die "exec '@_': $!";
  }
}

sub xfcntl ($$$$;$) {
  my ($fh, $mode, $flag, $errs, $how) = @_;
  my $fd = ref $fh ? fileno $fh : $fh;
  $how ||= "";
  my $str_mode = '';
  $str_mode = ($mode == Fcntl::F_GETFD() 
	       ? '=get'
	       : ($mode == Fcntl::F_SETFD()
		  ? '=set'
		  : '=???')) if $Debug;

  my $ret = fcntl($fh, $mode, $flag)
      or push @$errs, "$ {how}fcntl get $fd: $!", 
	 ($Debug and print $SaveErr $errs->[-1], "\n"),
         return;
  print $SaveErr "$ {how}fcntl($fd, $mode$str_mode, $flag) => $ret\n"
    if $Debug;
  $ret;
}

sub xclose ($$$) {
  my ($fh, $errs, $how) = @_;
  my $fd = fileno $fh;

  print $SaveErr "$ {how}closing fd=$fd...\n" if $Debug;
  my $res = close($fh);
  print "$ {how}close $fh fd=$fd => `$res': $!\n"
    if not $res and $Debug;
  if ($res or $no_error_on_unwind_close and  $how eq "unwind: ") {
    return $res;
  }
  push(@$errs, "$ {how}close $fh fd=$fd: $!");
  return;
}

sub xfdopen ($$$$$) {
  my ($fh1, $fh2, $mode, $errs, $how) = @_;
  my $fd1 = fileno $fh1;
  my $fd2 = ref $fh2 ? fileno $fh2 : $fh2;
  my $res;
  my $omode = ($mode eq 'r' ? '<' : '>');
  
  print $SaveErr "$ {how}open( fd=$fd1, '$omode&$fd2')\n" if $Debug;

  if ($res = open($fh1,"$omode&$fd2")) {
    print $SaveErr "   -> ", fileno $fh1, "\t\t\t\t$res\t\$^F=$^F\n" if $Debug;
    return $res;
  } else {
    push(@$errs, "$ {how}open( fd=$fd1, '$omode&$fd2'): $!"), 
    ($Debug and print $SaveErr $errs->[-1], "\n"),
    return;
  }
}

sub xnew_from_fd ($$$$) {	# Give up soon
  my ($fh, $mode, $errs, $how) = @_;
  my $fd = ref $fh ? fileno $fh : $fh;
  my $fd_printable = ref $fh ? "fh=>" . fileno $fh : $fh;

  print $SaveErr "$ {how}new_from_fd($fd_printable, $mode)\n" if $Debug;
  my $res = IO::Handle->new_from_fd($fh, $mode);
  if ($res) {
    print $SaveErr "   -> ", fileno $res, "\t\t\t\t$res\t\$^F=$^F\n" if $Debug;
    return $res;
  }
  push @$errs, "$ {how}new_from_fd($fd_printable, $mode): $!";
  print $SaveErr $errs->[-1], "\n" if $Debug;
  return;
}

# if we need to close_in_keed and need_in_parent, we need unwinding of fcntl
#
# returns undef on failure
#
# list to close may be too big, exclude fds which are going to be redirected
#
# Note that this is probably excessive, $^F handles this in simplest cases
#
# Need to maintain a list of all open fd, and give it to this guy
sub process_close_in_kid {
  # Stderr may be redirected, so we save the err text in @$errs:
  my ($close_in_child, $unwind, $redirected, $errs) = @_;
  return unless @$close_in_child;
  require Fcntl;
  my $fd;
  
  foreach $fd (@$close_in_child) {
    next if $redirected->{$fd}; # Do not close what we redirect!
    my $fl = xfcntl($fd, Fcntl::F_GETFD(), 1, $errs) or return;
    next if $fl & Fcntl::FD_CLOEXEC();
    xfcntl($fd, Fcntl::F_SETFD(), $fl | Fcntl::FD_CLOEXEC(), $errs) 
      or return;
    push @$unwind, ["fset", $fd, $fl];
  }
  return 1;
}

# returns undef on failure
sub do_unwind {
  my ($unwind, $errs) = @_;
  my $cmd;
  my $res = 1;

  while (@$unwind) {
    $cmd = pop @$unwind;
    if ($cmd->[0] eq 'fset') {
      xfcntl($cmd->[1], Fcntl::F_SETFD(), $cmd->[2], $errs, "unwind: ") 
	or undef $res;		# Continue on error
    } elsif ($cmd->[0] eq 'close') {
      xclose($cmd->[1], $errs, "unwind: ")
	or undef $res;		# Continue on error
    } elsif ($cmd->[0] eq 'fdopen') {
      xfdopen($cmd->[1], $cmd->[2], $cmd->[3], $errs, "unwind: ")
	or undef $res;		# Continue on error
    } else {
      push(@$errs, "unwind: unknown cmd `@$cmd'");
      print $SaveErr $errs->[-1], "\n" if $Debug;
    }
  }
  return $res;
}

sub cvt_2filehandle {
  my ($fds, $unwind, $errs) = @_;
  my ($fd, $fd_data);
  # Convert filename => filehandle.
  for $fd (keys %$fds) {
    $fd_data = $fds->{$fd};

    my $file = delete $fd_data->{filename};
    if ($file) {
      require IO::File;
      my $fh;

      # Will open a wrong guy, there should be a different way to do this...
      if (0 and $file =~ /^\s*([<>])\s*&\s*=\s*(.*)/s) {
	my $fd = $2;
	my $mode = $1 eq '<' ? "r" : "w";
	
	$fd = fileno $fd unless $fd =~ /^\d+\s*$/;
	$fh = fd_2filehandle($fd, $mode, $fds, $unwind, $errs) or return;
      } else {
	print $SaveErr "open `$file'\n" if $Debug;
	$fh = new IO::File $file 
	  or (push @$errs, "Cannot open `$file': $!"), 
	  ($Debug and print $SaveErr $errs->[-1], "\n"),
	  return;
	print $SaveErr "  --> ", fileno $fh, "\t\t\t\t$fh\t\$^F=$^F\n" if $Debug;
	push @$unwind, ["close", $fh]; # Will be done automagically when
	# goes out of scope, but would
	# not hurt to do earlier	
      }
      $fd_data->{filehandle} = $fh;
      $fd_data->{mode} = ($file =~ /^\s*(\+\s*)?[>|]/ ? 'w' : 'r');
      $fd_data->{kid_only} = 0;	# :-( Might redirect several kids to it
    }
  }
  return 1;
}

# Need to keep filehandles globally, since closing a clone close 
# the original
my %fd_hash = ( 0 => \*STDIN, 1 => \*STDOUT, 2 => \*STDERR);

# $old is any filehandle which is going to live long enough.
sub fd_2filehandle ($$$$$) {
  my ($fd,$mode,$fds,$unwind,$errs) = @_;
  require Fcntl;
  if (exists $fd_hash{$fd} and defined fileno($fd_hash{$fd})
      and fileno($fd_hash{$fd}) == $fd
      and fcntl($fd_hash{$fd}, Fcntl::F_GETFD(), 1)) { # Checking that it is not closed!
    require IO::Handle;
    bless $fd_hash{$fd}, 'IO::Handle' if ref $fd_hash{$fd} eq 'GLOB';
    print $SaveErr "filehandle $fd stashed...\n" if $Debug;
    return $fd_hash{$fd};	# In fact the corresponding FD may be
                                # closed, but there is nothing to do
                                # about it...
  }
  delete $fd_hash{$fd};
  # Grab the file descriptor
  my $fh = xnew_from_fd($fd, $mode, [], "grabfd: "); # ignore errors
  if (not defined $fh and $! =~ /bad\s+file\s+number/i) {
    print $SaveErr "Recovering from error in new_from_fd...\n" if $Debug;
    # Try to create missing filehandles
    my ($cnt, @tmp, $tmp_fh, $ok) = 0;
    my $old = $fds->{$fd}{filehandle};
    
    while ($cnt++ <= $fd) {	# Give up soon
      $tmp_fh = xnew_from_fd($old, $mode, $errs, "intermed fd: ") or return;
      $ok = 1, last if fileno $tmp_fh == $fd;
      push @tmp, $tmp_fh;
    }
    unless ($ok) {
      push @$errs, "Could not create fd=$fd";
      print $SaveErr $errs->[-1], "\n" if $Debug;
      return;
    }
    $fds->{$fd}{tmp_filehandles} = []
      unless defined $fds->{$fd}{tmp_filehandles};
    push @{$fds->{$fd}{tmp_filehandles}}, @tmp; # Do not close these guys soon
    $fh = $tmp_fh;
    process_close_in_kid(\@tmp, $unwind, $fds, $errs) or return;
  }
  return $fd_hash{$fd} = $fh;	# never close this
}

sub redirect_in_kid {
  my ($fds,$unwind,$errs,$max_fd_r) = @_;
  my ($fd_data, $fd);
  my $max_fd = -1;
  # Count
  for $fd (keys %$fds) {
    $max_fd = $fd if $fd > $max_fd;
  }
  return 1 unless $max_fd > -1;

  cvt_2filehandle($fds,$unwind,$errs) or return;
  
  # The guys below this level will be dup2()ed to on fdopen().
  # They also will not be closed on exec
  local $^F = $$max_fd_r = $max_fd if $max_fd > $^F; 

  my @close_in_child;
  require IO::Handle;
  for $fd (keys %$fds) {
    $fd_data = $fds->{$fd};

    # Grab the file descriptor
    $fd_data->{pre_filehandle} =
      fd_2filehandle($fd, $fd_data->{mode}, $fds, $unwind, $errs)
	or return;

    # Now save a copy to another filedescriptor
    $fd_data->{pre_filehandle_save} 
      = xnew_from_fd($fd_data->{pre_filehandle}, $fd_data->{mode}, $errs, "savecopy: ")
	or return;
    push @$unwind, ["close", $fd_data->{pre_filehandle_save}];
    push @close_in_child, $fd_data->{pre_filehandle_save};
    
    xfdopen($fd_data->{pre_filehandle}, fileno $fd_data->{filehandle},
	    $fd_data->{mode}, $errs, "final: ")
      or return;
    push @$unwind, 
      ["fdopen", $fd_data->{pre_filehandle}, $fd_data->{pre_filehandle_save},
       $fd_data->{mode}];
  }

  # Arrange for things to be closed in the kid:
  process_close_in_kid(\@close_in_child, $unwind, $fds, $errs) 
    or return;
  return 1;
}

sub run_system_spawn {
  my $do_spawn = shift;
  $_[1] = {} unless defined $_[1];
  my ($tree, $data) = @_;
  # Sets result in $data->{result} on failure
  (local %::ENV = %::ENV), 
  @::ENV{keys %{$data->{env}}} = values %{$data->{env}}
    if (exists $data->{env});

  # Expand args:
  my @args = map {ref $_ ? $_->run : ($_)} @$tree;
  my $has_undef = grep {not defined} @args;
  return if $has_undef;

  my $unwind = [];
  my $max_fd;
  my $print_errs = not exists $data->{errs};
  my $errs = $print_errs ? [] : $data->{errs};
  
  if (defined $data->{redir}) {	# local could create undefined value
    my $res = redirect_in_kid($data->{redir},$unwind,$errs,\$max_fd);
    if (not $res) {
      local $^F = $max_fd 
	if defined $max_fd and $max_fd > $^F and $use_longer_control_F;
      do_unwind($unwind,$errs);
      # Should hope that STDERR is now restored
      print STDERR join "\n", @$errs, "" if $print_errs and @$errs;
      return;
    }
  }
  local $^F = $max_fd 
    if defined $max_fd and $max_fd > $^F and $use_longer_control_F;

  my $res;
  if ($do_spawn or $data->{'spawn'}) {
    $res = spawn @args;
    push @{$data->{pids}}, $res if defined $res;
    push @$errs, "spawn `@args': $!" unless defined $res;
  } else {
    $res = system @args;    
    $data->{result} = $res if $res;
    push @$errs, "system `@args': rc=$res: $!" if $res;	# XXXX?
    $res = ($res == 0 ? 1 : undef);
  }

  do_unwind($unwind,$errs) if @$unwind;
  # Should hope that STDERR is now restored
  print STDERR join "\n", @$errs, "" if $print_errs and @$errs;
  return $res;
}

sub Run::system::run {
  run_system_spawn(0,@_);
}

sub Run::spawn::run {
  run_system_spawn(1,@_);
}


sub Run::chain::run {
  $_[1] = {} unless defined $_[1];
  my ($tree, $data) = @_;
  my $out = 1;
  
  print(STDERR "cannot 'chain' with spawn: $!\n"), return if $data->{'spawn'};
  for my $cmd (@$tree) {
    my $res = $cmd->run($data);
    undef $out unless defined $res;
  }
  return $out;
}

sub Run::and::run {
  $_[1] = {} unless defined $_[1];
  my ($tree, $data) = @_;
  
  print(STDERR "cannot 'and' with spawn: $!\n"), return if $data->{'spawn'};
  for my $cmd (@$tree) {
    my $res = $cmd->run($data);
    return unless defined $res;
  }
  return 1;
}

sub Run::or::run {
  $_[1] = {} unless defined $_[1];
  my ($tree, $data) = @_;
  
  print(STDERR "cannot 'or' with spawn: $!\n"), return if $data->{'spawn'};
  for my $cmd (@$tree) {
    my $res = $cmd->run($data);
    return 1 if defined $res;
  }
  return;
}

sub Run::env::run {
  $_[1] = {} unless defined $_[1];
  my ($tree, $data) = @_;
  my $cmd = $tree->[1];
  local $data->{env} = $data->{env};
  $data->{env} = {} unless defined $data->{env};
  my %env = %{$data->{env}};
  my $env = $tree->[0];
  @{$data->{env}}{keys %$env} = values %$env;
  
  my $res = $cmd->run($data);
  %{$data->{env}} = %env;
  return $res;
}

sub Run::redir::run {
  $_[1] = {} unless defined $_[1];
  my ($tree, $data) = @_;
  my $cmd = $tree->[1];
  local $data->{redir} = $data->{redir};
  $data->{redir} = {} unless defined $data->{redir};
  #local %{$data->{redir}} = %{$data->{redir}}; # Preserve data from being wiped
  my %oldredir = %{$data->{redir}}; # Preserve data from being wiped
  
  my $redir = $tree->[0];
  my $unwind = [];
  my $print_errs = not exists $data->{errs};
  my $errs = $print_errs ? [] : $data->{errs};
  my $ret;
  if (cvt_2filehandle($redir,$unwind,$errs)) { # OK
    my ($fd, $rfd);
    if (%{$data->{redir}}) {
      for $fd (keys %$redir) {
	$rfd = fileno $redir->{$fd}{filehandle};
	next unless exists $data->{redir}{$rfd}; # Target redirected already
	$redir->{$fd} = $data->{redir}{$rfd};
      }
    }
    @{$data->{redir}}{keys %$redir} = values %$redir;
  
    $ret = $cmd->run($data);
    return $ret unless @$unwind;
  }
  do_unwind($unwind,$errs) if @$unwind;
  # STDERR should not be redirected above, but signature of do_unwind is such...
  print STDERR join "\n", @$errs, "" if $print_errs and @$errs;
  %{$data->{redir}} = %oldredir; # Restore the data
  return $ret;
}

sub Run::pipe::run {
  $_[1] = {} unless defined $_[1];
  my ($tree, $data) = @_;
  my $cmd = $tree->[1];
  my $dir = $tree->[0];
  require IO::Handle;
  my $rpipe = IO::Handle->new;
  my $wpipe = IO::Handle->new;

  print $SaveErr "pipe creation (parent will $dir)\n" if $Debug;
  pipe($rpipe,$wpipe) 
    or print(STDERR "cannot create pipe: $!\n"), return;
  print $SaveErr "  --> ", fileno $rpipe, "\t\t\t\tread  $rpipe\t\$^F=$^F\n" if $Debug;
  print $SaveErr "  --> ", fileno $wpipe, "\t\t\t\twrite $wpipe\t\$^F=$^F\n" if $Debug;
  my ($toclose, $ret, $redir);
  
  if ($dir eq 'r') {
    $redir = new_redir({1 => {filehandle => $wpipe, mode => 'w'}}, $cmd);    
    $toclose = $wpipe;
    $ret = $rpipe;
  } else {
    $redir = new_redir({0 => {filehandle => $rpipe, mode => 'r'}}, $cmd);        
    $toclose = $rpipe;
    $ret = $wpipe;
  }
  # XXXX Do not use unwind argument???
  process_close_in_kid([$ret],[],{},[]); # XXXX No error handling here
  local $data->{'spawn'} = 1;
  $redir->run($data) or return;

  # XXXX This is not needed, since run() called unwind() which closed
  # fd=0/1, which invalidated $toclose anyway.

  xclose($toclose,[],"pipe::run: ")
    or print(STDERR "pipe::run: cannot close pipe end not belonging to me: $!\n"), return;
  return $ret;
}

sub Run::readpipe::run {
  $_[1] = {} unless defined $_[1];
  my ($tree, $data) = @_;
  my $cmd = $tree->[0];
  my $pipe = Run::pipe->new("r", $cmd)->run($data) or return;
  $pipe->input_record_separator(undef);
  return scalar <$pipe>;
}

sub Run::readpipe_split::run {
  $_[1] = {} unless defined $_[1];
  my ($tree, $data) = @_;
  my $cmd = $tree->[0];
  my $pipe = Run::pipe->new("r", $cmd)->run($data) or return;
  $pipe->input_record_separator(undef);
  return split ' ', scalar <$pipe>;
}

sub Run::base::new {
  my $class = shift;
  bless [@_], $class;
}

sub Run::base2::new {
  my $class = shift;
  die "need two arguments in $class\->new" unless @_ == 2;
  bless [@_], $class;
}

sub Run::base1::new {
  my $class = shift;
  die "need one argument in $class\->new" unless @_ == 1;
  bless [@_], $class;
}

sub new_system	{ Run::system->new(@_) }
sub new_spawn	{ 'Run::spawn'->new(@_) }
sub new_or	{ Run::or->new(@_) }
sub new_and	{ Run::and->new(@_) }
sub new_chain	{ Run::chain->new(@_) }
sub new_env	{ Run::env->new(@_) }
sub new_redir	{ Run::redir->new(@_) }
sub new_pipe	{ Run::pipe->new(@_) }
sub new_readpipe	{ Run::readpipe->new(@_) }
sub new_readpipe_split	{ Run::readpipe_split->new(@_) }

1;
__END__