WWWWWW

Current Directory: /usr/share/perl5/vendor_perl/IPC
Viewing File: /usr/share/perl5/vendor_perl/IPC/Run3.pm
package IPC::Run3;
BEGIN { require 5.006_000; } # i.e. 5.6.0
use strict;

=head1 NAME

IPC::Run3 - run a subprocess with input/ouput redirection

=head1 VERSION

version 0.048

=cut

our $VERSION = '0.048';

=head1 SYNOPSIS

    use IPC::Run3;    # Exports run3() by default

    run3 \@cmd, \$in, \$out, \$err;

=head1 DESCRIPTION

This module allows you to run a subprocess and redirect stdin, stdout,
and/or stderr to files and perl data structures.  It aims to satisfy 99% of the
need for using C<system>, C<qx>, and C<open3>
with a simple, extremely Perlish API.

Speed, simplicity, and portability are paramount.  (That's speed of Perl code;
which is often much slower than the kind of buffered I/O that this module uses
to spool input to and output from the child command.)

=cut

use Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw( run3 );
our %EXPORT_TAGS = ( all => \@EXPORT );

use constant debugging => $ENV{IPCRUN3DEBUG} || $ENV{IPCRUNDEBUG} || 0;
use constant profiling => $ENV{IPCRUN3PROFILE} || $ENV{IPCRUNPROFILE} || 0;
use constant is_win32  => 0 <= index $^O, "Win32";

BEGIN {
   if ( is_win32 ) {
      eval "use Win32 qw( GetOSName ); use Win32::ShellQuote qw(quote_native); 1" or die $@;
   }
}

#use constant is_win2k => is_win32 && GetOSName() =~ /Win2000/i;
#use constant is_winXP => is_win32 && GetOSName() =~ /WinXP/i;

use Carp qw( croak );
use File::Temp qw( tempfile );
use POSIX qw( dup dup2 );

# We cache the handles of our temp files in order to
# keep from having to incur the (largish) overhead of File::Temp
my %fh_cache;
my $fh_cache_pid = $$;

my $profiler;

sub _profiler { $profiler } # test suite access

BEGIN {
    if ( profiling ) {
        eval "use Time::HiRes qw( gettimeofday ); 1" or die $@;
        if ( $ENV{IPCRUN3PROFILE} =~ /\A\d+\z/ ) {
            require IPC::Run3::ProfPP;
            IPC::Run3::ProfPP->import;
            $profiler = IPC::Run3::ProfPP->new(Level => $ENV{IPCRUN3PROFILE});
        } else {
            my ( $dest, undef, $class ) =
               reverse split /(=)/, $ENV{IPCRUN3PROFILE}, 2;
            $class = "IPC::Run3::ProfLogger"
                unless defined $class && length $class;
            if ( not eval "require $class" ) {
                my $e = $@;
                $class = "IPC::Run3::$class";
                eval "require IPC::Run3::$class" or die $e;
            }
            $profiler = $class->new( Destination => $dest );
        }
        $profiler->app_call( [ $0, @ARGV ], scalar gettimeofday() );
    }
}


END {
    $profiler->app_exit( scalar gettimeofday() ) if profiling;
}

sub _binmode {
    my ( $fh, $mode, $what ) = @_;
    # if $mode is not given, then default to ":raw", except on Windows,
    # where we default to ":crlf";
    # otherwise if a proper layer string was given, use that,
    # else use ":raw"
    my $layer = !$mode
       ? (is_win32 ? ":crlf" : ":raw")
       : ($mode =~ /^:/ ? $mode : ":raw");
    warn "binmode $what, $layer\n" if debugging >= 2;

    binmode $fh, ":raw" unless $layer eq ":raw";      # remove all layers first
    binmode $fh, $layer or croak "binmode $layer failed: $!";
}

sub _spool_data_to_child {
    my ( $type, $source, $binmode_it ) = @_;

    # If undef (not \undef) passed, they want the child to inherit
    # the parent's STDIN.
    return undef unless defined $source;

    my $fh;
    if ( ! $type ) {
        open $fh, "<", $source or croak "$!: $source";
       _binmode($fh, $binmode_it, "STDIN");
        warn "run3(): feeding file '$source' to child STDIN\n"
            if debugging >= 2;
    } elsif ( $type eq "FH" ) {
        $fh = $source;
        warn "run3(): feeding filehandle '$source' to child STDIN\n"
            if debugging >= 2;
    } else {
        $fh = $fh_cache{in} ||= tempfile;
        truncate $fh, 0;
        seek $fh, 0, 0;
       _binmode($fh, $binmode_it, "STDIN");
        my $seekit;
        if ( $type eq "SCALAR" ) {

            # When the run3()'s caller asks to feed an empty file
            # to the child's stdin, we want to pass a live file
            # descriptor to an empty file (like /dev/null) so that
            # they don't get surprised by invalid fd errors and get
            # normal EOF behaviors.
            return $fh unless defined $$source;  # \undef passed

            warn "run3(): feeding SCALAR to child STDIN",
                debugging >= 3
                   ? ( ": '", $$source, "' (", length $$source, " chars)" )
                   : (),
                "\n"
                if debugging >= 2;

            $seekit = length $$source;
            print $fh $$source or die "$! writing to temp file";

        } elsif ( $type eq "ARRAY" ) {
            warn "run3(): feeding ARRAY to child STDIN",
                debugging >= 3 ? ( ": '", @$source, "'" ) : (),
                "\n"
            if debugging >= 2;

            print $fh @$source or die "$! writing to temp file";
            $seekit = grep length, @$source;
        } elsif ( $type eq "CODE" ) {
            warn "run3(): feeding output of CODE ref '$source' to child STDIN\n"
                if debugging >= 2;
            my $parms = [];  # TODO: get these from $options
            while (1) {
                my $data = $source->( @$parms );
                last unless defined $data;
                print $fh $data or die "$! writing to temp file";
                $seekit = length $data;
            }
        }

        seek $fh, 0, 0 or croak "$! seeking on temp file for child's stdin"
            if $seekit;
    }

    croak "run3() can't redirect $type to child stdin"
        unless defined $fh;

    return $fh;
}

sub _fh_for_child_output {
    my ( $what, $type, $dest, $options ) = @_;

    my $fh;
    if ( $type eq "SCALAR" && $dest == \undef ) {
        warn "run3(): redirecting child $what to oblivion\n"
            if debugging >= 2;

        $fh = $fh_cache{nul} ||= do {
            open $fh, ">", File::Spec->devnull;
           $fh;
        };
    } elsif ( $type eq "FH" ) {
        $fh = $dest;
        warn "run3(): redirecting $what to filehandle '$dest'\n"
            if debugging >= 3;
    } elsif ( !$type ) {
        warn "run3(): feeding child $what to file '$dest'\n"
            if debugging >= 2;

        open $fh, $options->{"append_$what"} ? ">>" : ">", $dest
           or croak "$!: $dest";
    } else {
        warn "run3(): capturing child $what\n"
            if debugging >= 2;

        $fh = $fh_cache{$what} ||= tempfile;
        seek $fh, 0, 0;
        truncate $fh, 0;
    }

    my $binmode_it = $options->{"binmode_$what"};
    _binmode($fh, $binmode_it, uc $what);

    return $fh;
}

sub _read_child_output_fh {
    my ( $what, $type, $dest, $fh, $options ) = @_;

    return if $type eq "SCALAR" && $dest == \undef;

    seek $fh, 0, 0 or croak "$! seeking on temp file for child $what";

    if ( $type eq "SCALAR" ) {
        warn "run3(): reading child $what to SCALAR\n"
            if debugging >= 3;

        # two read()s are used instead of 1 so that the first will be
        # logged even it reads 0 bytes; the second won't.
        my $count = read $fh, $$dest, 10_000,
           $options->{"append_$what"} ? length $$dest : 0;
        while (1) {
            croak "$! reading child $what from temp file"
                unless defined $count;

            last unless $count;

            warn "run3(): read $count bytes from child $what",
                debugging >= 3 ? ( ": '", substr( $$dest, -$count ), "'" ) : (),
                "\n"
                if debugging >= 2;

            $count = read $fh, $$dest, 10_000, length $$dest;
        }
    } elsif ( $type eq "ARRAY" ) {
       if ($options->{"append_$what"}) {
           push @$dest, <$fh>;
       } else {
           @$dest = <$fh>;
       }
        if ( debugging >= 2 ) {
            my $count = 0;
            $count += length for @$dest;
            warn
                "run3(): read ",
                scalar @$dest,
                " records, $count bytes from child $what",
                debugging >= 3 ? ( ": '", @$dest, "'" ) : (),
                "\n";
        }
    } elsif ( $type eq "CODE" ) {
        warn "run3(): capturing child $what to CODE ref\n"
            if debugging >= 3;

        local $_;
        while ( <$fh> ) {
            warn
                "run3(): read ",
                length,
                " bytes from child $what",
                debugging >= 3 ? ( ": '", $_, "'" ) : (),
                "\n"
                if debugging >= 2;

            $dest->( $_ );
        }
    } else {
        croak "run3() can't redirect child $what to a $type";
    }

}

sub _type {
    my ( $redir ) = @_;

    return "FH" if eval {
        local $SIG{'__DIE__'};
        $redir->isa("IO::Handle")
    };

    my $type = ref $redir;
    return $type eq "GLOB" ? "FH" : $type;
}

sub _max_fd {
    my $fd = dup(0);
    POSIX::close $fd;
    return $fd;
}

my $run_call_time;
my $sys_call_time;
my $sys_exit_time;

sub run3 {
    $run_call_time = gettimeofday() if profiling;

    my $options = @_ && ref $_[-1] eq "HASH" ? pop : {};

    my ( $cmd, $stdin, $stdout, $stderr ) = @_;

    print STDERR "run3(): running ",
       join( " ", map "'$_'", ref $cmd ? @$cmd : $cmd ),
       "\n"
       if debugging;

    if ( ref $cmd ) {
        croak "run3(): empty command"     unless @$cmd;
        croak "run3(): undefined command" unless defined $cmd->[0];
        croak "run3(): command name ('')" unless length  $cmd->[0];
    } else {
        croak "run3(): missing command" unless @_;
        croak "run3(): undefined command" unless defined $cmd;
        croak "run3(): command ('')" unless length  $cmd;
    }

    foreach (qw/binmode_stdin binmode_stdout binmode_stderr/) {
       if (my $mode = $options->{$_}) {
           croak qq[option $_ must be a number or a proper layer string: "$mode"]
              unless $mode =~ /^(:|\d+$)/;
       }
    }

    my $in_type  = _type $stdin;
    my $out_type = _type $stdout;
    my $err_type = _type $stderr;

    if ($fh_cache_pid != $$) {
       # fork detected, close all cached filehandles and clear the cache
       close $_ foreach values %fh_cache;
       %fh_cache = ();
       $fh_cache_pid = $$;
    }

    # This routine proceeds in stages so that a failure in an early
    # stage prevents later stages from running, and thus from needing
    # cleanup.

    my $in_fh  = _spool_data_to_child $in_type, $stdin,
        $options->{binmode_stdin} if defined $stdin;

    my $out_fh = _fh_for_child_output "stdout", $out_type, $stdout,
        $options if defined $stdout;

    my $tie_err_to_out =
        defined $stderr && defined $stdout && $stderr eq $stdout;

    my $err_fh = $tie_err_to_out
        ? $out_fh
        : _fh_for_child_output "stderr", $err_type, $stderr,
            $options if defined $stderr;

    # this should make perl close these on exceptions
    local *STDIN_SAVE;
    local *STDOUT_SAVE;
    local *STDERR_SAVE;

    open STDIN_SAVE,  "<&STDIN"  or croak "run3(): $! saving STDIN"
        if defined $in_fh;
    open STDOUT_SAVE, ">&STDOUT" or croak "run3(): $! saving STDOUT"
        if defined $out_fh;
    open STDERR_SAVE, ">&STDERR" or croak "run3(): $! saving STDERR"
        if defined $err_fh;

    my $errno;
    my $ok = eval {
        open STDIN,  "<&=" . fileno $in_fh
            or croak "run3(): $! redirecting STDIN"
            if defined $in_fh;

        open STDOUT, ">&" . fileno $out_fh
            or croak "run3(): $! redirecting STDOUT"
            if defined $out_fh;

        open STDERR, ">&" . fileno $err_fh
            or croak "run3(): $! redirecting STDERR"
            if defined $err_fh;

        $sys_call_time = gettimeofday() if profiling;

        my $r = ref $cmd
              ? system { $cmd->[0] } is_win32 ? quote_native( @$cmd ) : @$cmd
              : system $cmd;

       $errno = $!;              # save $!, because later failures will overwrite it
        $sys_exit_time = gettimeofday() if profiling;
        if ( debugging ) {
            my $err_fh = defined $err_fh ? \*STDERR_SAVE : \*STDERR;
           if ( defined $r && $r != -1 ) {
              print $err_fh "run3(): \$? is $?\n";
           } else {
              print $err_fh "run3(): \$? is $?, \$! is $errno\n";
           }
        }

        if (
            defined $r
            && ( $r == -1 || ( is_win32 && $r == 0xFF00 ) )
            && !$options->{return_if_system_error}
        ) {
            croak( $errno );
        }

        1;
    };
    my $x = $@;

    my @errs;

    open STDIN,  "<&STDIN_SAVE"  or push @errs, "run3(): $! restoring STDIN"
        if defined $in_fh;
    open STDOUT, ">&STDOUT_SAVE" or push @errs, "run3(): $! restoring STDOUT"
        if defined $out_fh;
    open STDERR, ">&STDERR_SAVE" or push @errs, "run3(): $! restoring STDERR"
        if defined $err_fh;

    croak join ", ", @errs if @errs;

    die $x unless $ok;

    _read_child_output_fh "stdout", $out_type, $stdout, $out_fh, $options
        if defined $out_fh && $out_type && $out_type ne "FH";
    _read_child_output_fh "stderr", $err_type, $stderr, $err_fh, $options
        if defined $err_fh && $err_type && $err_type ne "FH" && !$tie_err_to_out;
    $profiler->run_exit(
       $cmd,
       $run_call_time,
       $sys_call_time,
       $sys_exit_time,
       scalar gettimeofday()
    ) if profiling;

    $! = $errno;              # restore $! from system()

    return 1;
}

1;

__END__

=head2 C<< run3($cmd, $stdin, $stdout, $stderr, \%options) >>

All parameters after C<$cmd> are optional.

The parameters C<$stdin>, C<$stdout> and C<$stderr> indicate how the child's
corresponding filehandle (C<STDIN>, C<STDOUT> and C<STDERR>, resp.) will be
redirected.  Because the redirects come last, this allows C<STDOUT> and
C<STDERR> to default to the parent's by just not specifying them -- a common
use case.

C<run3> throws an exception if the wrapped C<system> call returned -1 or
anything went wrong with C<run3>'s processing of filehandles.  Otherwise it
returns true.  It leaves C<$?> intact for inspection of exit and wait status.

Note that a true return value from C<run3> doesn't mean that the command had a
successful exit code. Hence you should always check C<$?>.

See L</%options> for an option to handle the case of C<system> returning -1
yourself.

=head3 C<$cmd>

Usually C<$cmd> will be an ARRAY reference and the child is invoked via

  system @$cmd;

But C<$cmd> may also be a string in which case the child is invoked via

  system $cmd;

(cf. L<perlfunc/system> for the difference and the pitfalls of using
the latter form).

=head3 C<$stdin>, C<$stdout>, C<$stderr>

The parameters C<$stdin>, C<$stdout> and C<$stderr> can take one of the
following forms:

=over 4

=item C<undef> (or not specified at all)

The child inherits the corresponding filehandle from the parent.

  run3 \@cmd, $stdin;                   # child writes to same STDOUT and STDERR as parent
  run3 \@cmd, undef, $stdout, $stderr;  # child reads from same STDIN as parent

=item C<\undef>

The child's filehandle is redirected from or to the local equivalent of
C</dev/null> (as returned by C<< File::Spec->devnull() >>).

  run3 \@cmd, \undef, $stdout, $stderr; # child reads from /dev/null

=item a simple scalar

The parameter is taken to be the name of a file to read from
or write to. In the latter case, the file will be opened via

  open FH, ">", ...

i.e. it is created if it doesn't exist and truncated otherwise.
Note that the file is opened by the parent which will L<croak|Carp/croak>
in case of failure.

  run3 \@cmd, \undef, "out.txt";        # child writes to file "out.txt"

=item a filehandle (either a reference to a GLOB or an C<IO::Handle>)

The filehandle is inherited by the child.

  open my $fh, ">", "out.txt";
  print $fh "prologue\n";
  ...
  run3 \@cmd, \undef, $fh;              # child writes to $fh
  ...
  print $fh "epilogue\n";
  close $fh;

=item a SCALAR reference

The referenced scalar is treated as a string to be read from or
written to. In the latter case, the previous content of the string
is overwritten.

  my $out;
  run3 \@cmd, \undef, \$out;           # child writes into string
  run3 \@cmd, \<<EOF;                  # child reads from string (can use "here" notation)
  Input
  to
  child
  EOF

=item an ARRAY reference

For C<$stdin>, the elements of C<@$stdin> are simply spooled to the child.

For C<$stdout> or C<$stderr>, the child's corresponding file descriptor
is read line by line (as determined by the current setting of C<$/>)
into C<@$stdout> or C<@$stderr>, resp. The previous content of the array
is overwritten.

  my @lines;
  run3 \@cmd, \undef, \@lines;         # child writes into array

=item a CODE reference

For C<$stdin>, C<&$stdin> will be called repeatedly (with no arguments) and
the return values are spooled to the child. C<&$stdin> must signal the end of
input by returning C<undef>.

For C<$stdout> or C<$stderr>, the child's corresponding file descriptor
is read line by line (as determined by the current setting of C<$/>)
and C<&$stdout> or C<&$stderr>, resp., is called with the contents of the line.
Note that there's no end-of-file indication.

  my $i = 0;
  sub producer {
    return $i < 10 ? "line".$i++."\n" : undef;
  }

  run3 \@cmd, \&producer;              # child reads 10 lines

Note that this form of redirecting the child's I/O doesn't imply
any form of concurrency between parent and child - run3()'s method of
operation is the same no matter which form of redirection you specify.

=back

If the same value is passed for C<$stdout> and C<$stderr>, then the child
will write both C<STDOUT> and C<STDERR> to the same filehandle.
In general, this means that

    run3 \@cmd, \undef, "foo.txt", "foo.txt";
    run3 \@cmd, \undef, \$both, \$both;

will DWIM and pass a single file handle to the child for both C<STDOUT> and
C<STDERR>, collecting all into file "foo.txt" or C<$both>.

=head3 C<\%options>

The last parameter, C<\%options>, must be a hash reference if present.

Currently the following keys are supported:

=over 4

=item C<binmode_stdin>, C<binmode_stdout>, C<binmode_stderr>

The value must a "layer" as described in L<perlfunc/binmode>.  If specified the
corresponding parameter C<$stdin>, C<$stdout> or C<$stderr>, resp., operates
with the given layer.

For backward compatibility, a true value that doesn't start with ":"
(e.g. a number) is interpreted as ":raw". If the value is false
or not specified, the default is ":crlf" on Windows and ":raw" otherwise.

Don't expect that values other than the built-in layers ":raw", ":crlf",
and (on newer Perls) ":bytes", ":utf8", ":encoding(...)" will work.

=item C<append_stdout>, C<append_stderr>

If their value is true then the corresponding parameter C<$stdout> or
C<$stderr>, resp., will append the child's output to the existing "contents" of
the redirector. This only makes sense if the redirector is a simple scalar (the
corresponding file is opened in append mode), a SCALAR reference (the output is
appended to the previous contents of the string) or an ARRAY reference (the
output is C<push>ed onto the previous contents of the array).

=item C<return_if_system_error>

If this is true C<run3> does B<not> throw an exception if C<system> returns -1
(cf. L<perlfunc/system> for possible failure scenarios.), but returns true
instead.  In this case C<$?> has the value -1 and C<$!> contains the errno of
the failing C<system> call.

=back

=head1 HOW IT WORKS

=over 4

=item (1)

For each redirector C<$stdin>, C<$stdout>, and C<$stderr>, C<run3()> furnishes
a filehandle:

=over 4

=item *

if the redirector already specifies a filehandle it just uses that

=item *

if the redirector specifies a filename, C<run3()> opens the file
in the appropriate mode

=item *

in all other cases, C<run3()> opens a temporary file (using
L<tempfile|Temp/tempfile>)

=back

=item (2)

If C<run3()> opened a temporary file for C<$stdin> in step (1),
it writes the data using the specified method (either
from a string, an array or returned by a function) to the temporary file and rewinds it.

=item (3)

C<run3()> saves the parent's C<STDIN>, C<STDOUT> and C<STDERR> by duplicating
them to new filehandles. It duplicates the filehandles from step (1)
to C<STDIN>, C<STDOUT> and C<STDERR>, resp.

=item (4)

C<run3()> runs the child by invoking L<system|perlfunc/system> with C<$cmd> as
specified above.

=item (5)

C<run3()> restores the parent's C<STDIN>, C<STDOUT> and C<STDERR> saved in step (3).

=item (6)

If C<run3()> opened a temporary file for C<$stdout> or C<$stderr> in step (1),
it rewinds it and reads back its contents using the specified method (either to
a string, an array or by calling a function).

=item (7)

C<run3()> closes all filehandles that it opened explicitly in step (1).

=back

Note that when using temporary files, C<run3()> tries to amortize the overhead
by reusing them (i.e. it keeps them open and rewinds and truncates them
before the next operation).

=head1 LIMITATIONS

Often uses intermediate files (determined by File::Temp, and thus by the
File::Spec defaults and the TMPDIR env. variable) for speed, portability and
simplicity.

Use extreme caution when using C<run3> in a threaded environment if concurrent
calls of C<run3> are possible. Most likely, I/O from different invocations will
get mixed up. The reason is that in most thread implementations all threads in
a process share the same STDIN/STDOUT/STDERR.  Known failures are Perl ithreads
on Linux and Win32. Note that C<fork> on Win32 is emulated via Win32 threads
and hence I/O mix up is possible between forked children here (C<run3> is "fork
safe" on Unix, though).

=head1 DEBUGGING

To enable debugging use the IPCRUN3DEBUG environment variable to
a non-zero integer value:

  $ IPCRUN3DEBUG=1 myapp

=head1 PROFILING

To enable profiling, set IPCRUN3PROFILE to a number to enable emitting profile
information to STDERR (1 to get timestamps, 2 to get a summary report at the
END of the program, 3 to get mini reports after each run) or to a filename to
emit raw data to a file for later analysis.

=head1 COMPARISON

Here's how it stacks up to existing APIs:

=head2 compared to C<system()>, C<qx''>, C<open "...|">, C<open "|...">

=over

=item *

better: redirects more than one file descriptor

=item *

better: returns TRUE on success, FALSE on failure

=item *

better: throws an error if problems occur in the parent process (or the
pre-exec child)

=item *

better: allows a very perlish interface to Perl data structures and subroutines

=item *

better: allows 1 word invocations to avoid the shell easily:

 run3 ["foo"];  # does not invoke shell

=item *

worse: does not return the exit code, leaves it in $?

=back

=head2 compared to C<open2()>, C<open3()>

=over

=item *

better: no lengthy, error prone polling/select loop needed

=item *

better: hides OS dependencies

=item *

better: allows SCALAR, ARRAY, and CODE references to source and sink I/O

=item *

better: I/O parameter order is like C<open3()>  (not like C<open2()>).

=item *

worse: does not allow interaction with the subprocess

=back

=head2 compared to L<IPC::Run::run()|IPC::Run/run>

=over

=item *

better: smaller, lower overhead, simpler, more portable

=item *

better: no select() loop portability issues

=item *

better: does not fall prey to Perl closure leaks

=item *

worse: does not allow interaction with the subprocess (which IPC::Run::run()
allows by redirecting subroutines)

=item *

worse: lacks many features of C<IPC::Run::run()> (filters, pipes, redirects,
pty support)

=back

=head1 COPYRIGHT

Copyright 2003, R. Barrie Slaymaker, Jr., All Rights Reserved

=head1 LICENSE

You may use this module under the terms of the BSD, Artistic, or GPL licenses,
any version.

=head1 AUTHOR

Barrie Slaymaker E<lt>C<barries@slaysys.com>E<gt>

Ricardo SIGNES E<lt>C<rjbs@cpan.org>E<gt> performed routine maintenance since
2010, thanks to help from the following ticket and/or patch submitters: Jody
Belka, Roderich Schupp, David Morel, Jeff Lavallee, and anonymous others.

=cut
F1l3 Manager
