package IPC::Exe; #============================================================================== # # DESCRIPTION: # # Execute processes or Perl subroutines & string them via IPC. # Think shell pipes. # # # SYNTAX: # # Both exe() & bg() # - are exported by :DEFAULT # - return CODE references that need to be called # # exe &PREEXEC, LIST, &READER # exe &PREEXEC, &READER # exe &READER # # LIST is exec() in the child process after the parent is forked, # where the child's stdout is redirected to &READER's stdin. # # &PREEXEC is called right before exec() in the child process, so you may # reopen filehandles or do some child-only operations beforehand. # # Optionally, &PREEXEC could return a list of strings to perform common # filehandle redirections. For example, # # "2>null" silence stderr # ">#" silence stdout # "2>&1" redirect stderr to stdout # "1>&2" redirect stdout to stderr # "1><2" swap stdout and stderr # # &READER is called with LIST as its arguments. # &PREEXEC inherits the LIST passed to the previous &READER, which is # where it was called from. # # &READER is always called in the parent process. # &PREEXEC is always called in the child process. # # &PREEXEC and &READER are very similar and may be treated the same. # # It is important to note that the actions & return of &PREEXEC matters, # as it may be used to redirect filehandles before &PREEXEC becomes the # exec process. # # close( $IPC::Exe::PIPE ) in &READER to get exit status $? of process executing # last on the pipe # # If LIST is not provided, &PREEXEC will still be called. # If &PREEXEC is not provided, LIST will still exec(). # If &READER is not provided, it defaults to: # sub { print while ; close($IPC::Exe::PIPE); $? } # # exe( &READER ) returns &READER # # exe( ) returns an empty list. # # bg &BACKGROUND # # Call &BACKGROUND after sending it to the init process. # # Upon failure of background to init process, fall back by calling # &BACKGROUND in parent or child process. # # If &BACKGROUND is not a CODE reference, return an empty list. # # # EXAMPLE: # # &{ # bg exe sub { "2>#" }, qw( ls /tmp does_not_exist ), # exe "tac", # exe sub { print "2nd cmd: @_\n"; print "three> $_" while }, # bg exe "sort", # exe qw(cat -n), # exe sub { print "six> $_" while ; print "5th cmd: @_\n" }, # }; # # is like # # { ls /tmp does_not_exist 2> /dev/null | tac | [perlsub] | { sort | cat -n | [perlsub] } & } & # #============================================================================== BEGIN { use Exporter qw(import); our $VERSION = 2.00; our @EXPORT = qw(&exe &bg); } use warnings; use strict; # closure allows exe() to do its magical arguments arrangement sub exe { # return empty list if no arguments return () if @_ == 0; # return only single CODE argument # e.g. exe sub { .. }; # returns # sub { .. } my ($code) = @_; return $code if defined($code) && ref($code) eq "CODE" && @_ == 1; # otherwise return closure my @args = @_; return sub { my @_closure = @_; _exe(\@_closure, @args); } } sub _exe { # obtain reference to arguments passed to closure my $_closure = shift(); # obtain CODE references, if available, for READER & PREEXEC subroutines my ($Reader, $Preexec); $Reader = pop() if defined($_[$#_]) && ref($_[$#_]) eq "CODE"; $Preexec = shift() if defined($_[0]) && ref($_[0]) eq "CODE"; # safe pipe open to forked child connected to opened filehandle my ($FGPIPE, $gotchild); $gotchild = open($FGPIPE, "-|"); # check if fork was successful defined($gotchild) or warn("exe() cannot fork child :: $!") and return (); # parent reads stdout of child process if ($gotchild) { my ($ORIGSTDIN, @ret); # dup(2) stdin open($ORIGSTDIN, "<&STDIN") and open(STDIN, "<&", $FGPIPE); # call READER subroutine if ($Reader) { # create package-scope $IPC::Exe::PIPE our $PIPE = $FGPIPE; @ret = &$Reader(@_); } else { # if undefined, just print stdin print while <$FGPIPE>; close($FGPIPE); $ret[0] = $?; # return exit status of last pipe process } # restore stdin open(STDIN, "<&", $ORIGSTDIN); # collect child PIDs unshift(@ret, $gotchild); return @ret; } else # child performs exec() { # call PREEXEC subroutine if defined my @FHop = &$Preexec(@$_closure) if defined($Preexec); # exec() LIST if defined exit(0) unless @_; require File::Spec; my $DEVNULL = File::Spec->devnull(); for (@FHop) { if (defined() && !ref()) { # silence stderr /^\s*2>\s*(?:null|#)\s*$/ and open(STDERR, ">", $DEVNULL); # silence stdout /^\s*1?>\s*(?:null|#)\s*$/ and open(STDOUT, ">", $DEVNULL); # redirect stderr to stdout /^\s*2>&\s*1\s*$/ and open(STDERR, ">&", STDOUT); # redirect stdout to stderr /^\s*1?>&\s*2\s*$/ and open(STDOUT, ">&", STDERR); # swap stdout and stderr if (/^\s*1><2\s*$/) { my $SWAP; open($SWAP, ">&", STDOUT) and open(STDOUT, ">&", STDERR) and open(STDERR, ">&", $SWAP); } } } exec(@_) or die("exe() cannot exec '@_' :: $!"); } } # closure allows bg() to do its magical call placement sub bg ($) { # only take first CODE reference, ignore rest of arguments # return empty list if argument is not a CODE reference my ($code) = @_; return () unless defined($code) && ref($code) eq "CODE"; # otherwise return closure return sub { my @_closure = @_; _bg(\@_closure, $code); } } sub _bg { # obtain reference to arguments passed to closure my $_closure = shift(); # obtain CODE reference for BACKGROUND subroutine my $Background = shift(); # dup(2) stdout my $ORIGSTDOUT; open($ORIGSTDOUT, ">&", STDOUT); # double fork -- immediately wait() for child, # and init daemon will wait() for grandchild, once child exits # safe pipe open to forked child connected to opened filehandle my ($BGPIPE, $gotchild); $gotchild = open($BGPIPE, "-|"); # check if fork was successful warn("bg() cannot fork child, will try forking again :: $!") unless defined($gotchild); # parent reads stdout of child process if ($gotchild) { # background: parent reads output from child, # and waits for child to exit my $grandpid = <$BGPIPE>; close($BGPIPE); return $? ? $gotchild : -+-$grandpid; } else { # background: perform second fork my $gotgrand; $gotgrand = fork(); # check if second fork was successful if (defined($gotchild)) { warn("bg() cannot fork grandchild, using child instead (parent must wait) :: $!") unless defined($gotgrand); } else { if (defined($gotgrand)) { warn("bg() managed to fork child, using child now (parent must wait) :: $!") if $gotgrand; } else { warn("bg() cannot fork child again, using parent instead (parent does all the work) :: $!"); } } # send grand/child's PID to parent process somehow my $childpid; if (defined($gotgrand) && $gotgrand) { if (defined($gotchild)) { # child writes grandchild's PID to parent process print $gotgrand; } else { # parent returns child's PID later $childpid = $gotgrand; } } # child exits once grandchild is forked # grandchild calls BACKGROUND subroutine unless ($gotgrand) { # restore stdout open(STDOUT, ">&", $ORIGSTDOUT); # BACKGROUND subroutine does not need to return &$Background(@$_closure); } elsif (!defined($gotchild)) { # parent must wait to reap child waitpid($gotgrand, 0); } # $gotchild $gotgrand exit() # --------- --------- ------ # childpid grandpid both child & grandchild # childpid undef child # undef childpid child # undef undef none (parent executes BACKGROUND subroutine) exit(0) if defined($gotchild) && defined($gotgrand); exit(10) if defined($gotchild) && !defined($gotgrand); exit(10) if !defined($gotchild) && defined($gotgrand) && !$gotgrand; # falls back here if forks were unsuccessful return $childpid; } } 'IPC::Exe';