App-Dex
view release on metacpan or search on metacpan
scripts/dex view on Meta::CPAN
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;
my $saved_fd0 = dup( 0 ) if defined $in_fh;
# 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 {
# The open() call here seems to not force fd 0 in some cases;
# I ran in to trouble when using this in VCP, not sure why.
# the dup2() seems to work.
dup2( fileno $in_fh, 0 )
# open STDIN, "<&=" . fileno $in_fh
or croak "run3(): $! redirecting STDIN"
if defined $in_fh;
# close $in_fh or croak "$! closing STDIN temp file"
# if ref $stdin;
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 {
scripts/dex view on Meta::CPAN
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.
scripts/dex view on Meta::CPAN
=head1 AUTHOR
Barrie Slaymaker E<lt>barries@slaysys.comE<gt>
=cut
1;
IPC_RUN3_PROFLOGREADER
$fatpacked{"IPC/Run3/ProfLogger.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'IPC_RUN3_PROFLOGGER';
package IPC::Run3::ProfLogger;
$VERSION = 0.048;
=head1 NAME
IPC::Run3::ProfLogger - write profiling data to a log file
=head1 SYNOPSIS
use IPC::Run3::ProfLogger;
my $logger = IPC::Run3::ProfLogger->new; ## write to "run3.out"
my $logger = IPC::Run3::ProfLogger->new( Destination => $fn );
$logger->app_call( \@cmd, $time );
$logger->run_exit( \@cmd1, @times1 );
$logger->run_exit( \@cmd1, @times1 );
$logger->app_exit( $time );
=head1 DESCRIPTION
Used by IPC::Run3 to write a profiling log file. Does not
generate reports or maintain statistics; its meant to have minimal
overhead.
Its API is compatible with a tiny subset of the other IPC::Run profiling
classes.
=cut
use strict;
=head1 METHODS
=head2 C<< IPC::Run3::ProfLogger->new( ... ) >>
=cut
sub new {
my $class = ref $_[0] ? ref shift : shift;
my $self = bless { @_ }, $class;
$self->{Destination} = "run3.out"
unless defined $self->{Destination} && length $self->{Destination};
open PROFILE, ">$self->{Destination}"
or die "$!: $self->{Destination}\n";
binmode PROFILE;
$self->{FH} = *PROFILE{IO};
$self->{times} = [];
return $self;
}
=head2 C<< $logger->run_exit( ... ) >>
=cut
sub run_exit {
my $self = shift;
my $fh = $self->{FH};
print( $fh
join(
" ",
(
map {
my $s = $_;
$s =~ s/\\/\\\\/g;
$s =~ s/ /_/g;
$s;
} @{shift()}
),
join(
",",
@{$self->{times}},
@_,
),
),
"\n"
);
}
=head2 C<< $logger->app_exit( $arg ) >>
=cut
sub app_exit {
my $self = shift;
my $fh = $self->{FH};
print $fh "\\app_exit ", shift, "\n";
}
=head2 C<< $logger->app_call( $t, @args) >>
=cut
sub app_call {
my $self = shift;
my $fh = $self->{FH};
my $t = shift;
print( $fh
join(
" ",
"\\app_call",
(
map {
my $s = $_;
$s =~ s/\\\\/\\/g;
( run in 1.026 second using v1.01-cache-2.11-cpan-cdf2f3d4e48 )