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 c
+ommon
#       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 sam
+e.
#
#     It is important to note that the actions & return of &PREEXEC ma
+tters,
#       as it may be used to redirect filehandles before &PREEXEC beco
+mes the
#       exec process.
#
#     close( $IPC::Exe::PIPE ) in &READER to get exit status $? of pro
+cess 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 <STDIN>; 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 <S
+TDIN> },
#       bg exe "sort",
#          exe qw(cat -n),
#          exe sub { print "six> $_" while <STDIN>; 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 subro
+utines
    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 re
+turn ();

    # 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, ">", $DEVN
+ULL);

                # silence stdout
                /^\s*1?>\s*(?:null|#)\s*$/ and open(STDOUT, ">", $DEVN
+ULL);

                # redirect stderr to stdout
                /^\s*2>&\s*1\s*$/          and open(STDERR, ">&", STDO
+UT);

                # redirect stdout to stderr
                /^\s*1?>&\s*2\s*$/         and open(STDOUT, ">&", STDE
+RR);

                # 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 exi
+ts

    # 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 (pa
+rent must wait) :: $!")
              unless defined($gotgrand);
        }
        else
        {
            if (defined($gotgrand))
            {
                warn("bg() managed to fork child, using child now (par
+ent must wait) :: $!")
                  if $gotgrand;
            }
            else
            {
                warn("bg() cannot fork child again, using parent inste
+ad (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 su
+broutine)
        exit(0)  if  defined($gotchild) &&  defined($gotgrand);
        exit(10) if  defined($gotchild) && !defined($gotgrand);
        exit(10) if !defined($gotchild) &&  defined($gotgrand) && !$go
+tgrand;

        # falls back here if forks were unsuccessful
        return $childpid;
    }
}

'IPC::Exe';
[download]