Group :: Development/Perl
RPM: perl-IPC-Run3
Navigation
Main Changelog Spec Patches Sources Download Gear Bugs and FR Repocop
IPC-Run3-0.046/ 0000755 0000000 0000000 00000000000 12156162632 0012765 5 ustar 00root root 0000000 0000000 IPC-Run3-0.046/Changes 0000644 0000000 0000000 00000012365 12156162632 0014267 0 ustar 00root root 0000000 0000000 Changes file for IPC::Run3
0.046 2013-06-11
replace a die with a croak (thanks, Mike Doherty)
typo fixes in documentation (thanks, David Steinbrunner)
0.045 2011-12-23
skip a test that tickles an OpenBSD bug and hangs the process (thanks,
BinGOs)
0.044 2010-08-22
ignore user-defined __DIE__ handler in _type (Jeff Lavallee)
Added test for __DIE__ handler behavior
0.043 2009-05-30
No code changes
add repository location to META.yml
avoid hand-written META.yml by using META_MERGE
0.042 2008-08-09
No code changes
Rewrite a test in t/utf8.t that runs afoul of a misfeature
in Perl 5.8.0 (turn on ":utf8" by default on all filehandles
when running in a UTF8 locale; fixed since 5.8.1)
0.041 2008-08-03
Handle arbitrary binmode() layers in "binmode_*" options; for
backward compatibility, any true option that doesn't start
with ":" is treated as ":raw"
NOTE: This does work for the built-in layers, e.g. ":utf8",
but all bets are off for fancier stuff like ":via(...)" .
Add an option "return_if_system_error" that causes run3()
to refrain from throwing an exception when system() returns -1
(cf. RT 14272).
0.040 2007-12-26
major rewrite of pod:
- describe all possible forms of redirectors
- list available options
- explain how run3() works
fix #31343 by using the three argument form of open() for files;
unfortunately that isn't available before Perl 5.6.0,
hence "use 5.006_00"; also use lexical filehandles everywhere
implement options append_{stdout,stderr}; add test cases
edit META.yml so that the profiling modules IPC::Run3::Prof*
(which aren't of general use) won't show on CPAN
0.039 2007-11-01
avoid some warnings while testing profiler (thanks, SCOP)
0.038 2007-10-08
remove use warnings for 5.005 compat (thanks, David Golden)
0.037 2006-09-19
document license more clearly for META.yml
0.036 2006-09-19
document more clearly the return value of run3
0.035 2006-07-27
remove requirement for Test::Pod and ::Coverage just to build
0.034 2005-12-12
skip t/fork.t on MSWin32 (and Cygwin):
Win32 threads (and fork() is emulated via threads) in the
same process share the same STDIN/STDOUT/STDERR, hence
the method used by run3() (redirect STD* and then call system())
doesn't work here and IO crossover is to be expected -
a possible alternative on Win32 would be to use CreateProcess
which lets you explicitly specify three filehandles for the
new process' STDIN/STDOUT/STDERR; however Win32::Process::Create()
(from the libwin32 CPAN distribution) as omitted these
parameters from the Perl wrapper
add a note to the documentation about the problems with
concurrent calls to run3 in a threaded environment
(incl. fork() on Win32)
make sure all tests run with warnings on
0.033 2005-11-15
make documentation in IPC/Run3/ProfReporter.pm comply with
older versions of Pod::Coverage (fixes bug #15749)
new version of t/fork.t that will work on Windows
(there are still unresolved issues on Cygwin)
switch t/fd_leak.t to use Test::More and relax file descriptor check
to "same or fewer fd's after the call to run3 than before",
because Darwin 7.2 sometimes actually report fewer fd's
(fixes bug #15741)
extricated some dead code from IPC/Run3.pm that
resulted in 6 unused file descriptors
fix call to binmode missing a filehandle in IPC/Run3.pm
fix warnings in test scripts
0.032 2005-10-19
comaint granted to RSCHUPP (thanks, barry!)
fix bug #15003 "Data corruption with fork when both parent
and child use run3":
- purge %fh_cache when we detect that a fork has happened
- add t/fork.t to detect "crossover" between child processes
- fix (and test) only works on Unix, Windows has more
problems with run3 from a forked (pseudo) process
fix prereq - should specify 0 (not 1) if any version will do
added tests for redirection to/from filehandles to t/IPC-Run3.t
0.031 2005-09-27
documentation improvements
0.020 2005-07-12 08:39:00 EST
maintenance assumed (temporarily) by RJBS
removed inexplicable and mysterious MY::libscan from Makefile.PL
call import on ::PProf when profiling (argh!)
add Time::HiRes prereq
add Win32 prereq on Win32
add () to gettimeofday call to make debugger happy
properly handle redirection to filehandle
properly handle failure to start program
0.010 2004-03-09 01:46:11 EST
POD cleaned up
shell quoting improved for win32
0.009 2003-09-26 15:44:18 EDT
CRLF bugs fixed on WinNT, WinXP, Win2K
0.008 slipped out without an update to this file.
0.007 2003-04-01 09:02:21 EST
Fixed STDIN fd leak on NT 4.51 and perhaps other Win32s
Solved problem of world peace, see PEACE.txt
Improved t/fd_leak.t
0.006 2003-03-21 12:07:47 EST
Port to Win32
Test for and eliminate an fd leak
0.005 2003-02-25 15:11:47 EST
Fixed a few bugs in dealing with temp files and non-temp files
0.003 2003-02-11 15:47:59 EST
use dup2() to overwrite STDIN for the child
Added $ENV{IPCRUN3DEBUG} (and, silently, IPCRUNDEBUG)
debugging support. TODO: Add more debugging warnings.
0.000_1 2003-02-04 15:09:30
Created
IPC-Run3-0.046/LICENSE 0000644 0000000 0000000 00000000454 12156162632 0013775 0 ustar 00root root 0000000 0000000
You may use this module under the terms of the BSD, Artistic, or GPL licenses,
any version.
See more information at:
BSD: http://www.opensource.org/licenses/bsd-license.php
GPL: http://www.opensource.org/licenses/gpl-license.php
Artistic: http://opensource.org/licenses/artistic-license.php
IPC-Run3-0.046/MANIFEST 0000644 0000000 0000000 00000001167 12156162632 0014123 0 ustar 00root root 0000000 0000000 Changes
LICENSE
README
MANIFEST
MANIFEST.SKIP
Makefile.PL
bin/run3profpp
lib/IPC/Run3.pm
lib/IPC/Run3/ProfArrayBuffer.pm
lib/IPC/Run3/ProfLogReader.pm
lib/IPC/Run3/ProfLogger.pm
lib/IPC/Run3/ProfPP.pm
lib/IPC/Run3/ProfReporter.pm
t/IPC-Run3-ProfArrayBuffer.t
t/IPC-Run3-ProfLogReader.t
t/IPC-Run3-ProfLogger.t
t/IPC-Run3-ProfPP.t
t/IPC-Run3-ProfReporter.t
t/IPC-Run3-profiling.t
t/IPC-Run3.t
t/die_handler.t
t/fd_leak.t
t/fork.t
t/pod-coverage.t
t/pod.t
t/utf8.t
META.yml Module YAML meta-data (added by MakeMaker)
META.json Module JSON meta-data (added by MakeMaker)
IPC-Run3-0.046/MANIFEST.SKIP 0000644 0000000 0000000 00000000205 12156162632 0014660 0 ustar 00root root 0000000 0000000 CVS/.*
\.bak$
\.sw[a-z]$
\.tar$
\.tgz$
\.tar\.gz$
^mess/
^tmp/
^blib/
^t/test.txt$
^Makefile$
^Makefile\.[a-z]+$
^pm_to_blib$
~$
^\.
IPC-Run3-0.046/META.json 0000644 0000000 0000000 00000002104 12156162632 0014403 0 ustar 00root root 0000000 0000000 {
"abstract" : "run a subprocess with input/ouput redirection",
"author" : [
"Barrie Slaymaker <barries@slaysys.com>"
],
"dynamic_config" : 1,
"generated_by" : "ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.131560",
"license" : [
"open_source"
],
"meta-spec" : {
"url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
"version" : "2"
},
"name" : "IPC-Run3",
"no_index" : {
"directory" : [
"lib/IPC/Run3"
],
"file" : [
"bin/run3profpp"
]
},
"prereqs" : {
"build" : {
"requires" : {
"ExtUtils::MakeMaker" : "0"
}
},
"configure" : {
"requires" : {
"ExtUtils::MakeMaker" : "0"
}
},
"runtime" : {
"requires" : {
"Test::More" : "0.31",
"Time::HiRes" : "0"
}
}
},
"release_status" : "stable",
"resources" : {
"repository" : {
"url" : "http://github.com/rjbs/ipc-run3/"
}
},
"version" : "0.046"
}
IPC-Run3-0.046/META.yml 0000644 0000000 0000000 00000001157 12156162632 0014242 0 ustar 00root root 0000000 0000000 ---
abstract: 'run a subprocess with input/ouput redirection'
author:
- 'Barrie Slaymaker <barries@slaysys.com>'
build_requires:
ExtUtils::MakeMaker: 0
configure_requires:
ExtUtils::MakeMaker: 0
dynamic_config: 1
generated_by: 'ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.131560'
license: open_source
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: 1.4
name: IPC-Run3
no_index:
directory:
- lib/IPC/Run3
file:
- bin/run3profpp
requires:
Test::More: 0.31
Time::HiRes: 0
resources:
repository: http://github.com/rjbs/ipc-run3/
version: 0.046
IPC-Run3-0.046/Makefile.PL 0000644 0000000 0000000 00000001341 12156162632 0014736 0 ustar 00root root 0000000 0000000 use ExtUtils::MakeMaker;
WriteMakefile(
NAME => 'IPC::Run3',
VERSION_FROM => 'lib/IPC/Run3.pm',
ABSTRACT_FROM => 'lib/IPC/Run3.pm',
AUTHOR => 'Barrie Slaymaker <barries@slaysys.com>',
(eval { ExtUtils::MakeMaker->VERSION(6.21) } ? (LICENSE => 'open_source') : ()),
EXE_FILES => [],
PREREQ_PM => {
'Test::More' => '0.31',
'Time::HiRes' => 0,
($^O =~ /Win32/ ? (Win32 => 0) : ())
},
META_MERGE => {
resources => {
repository => 'http://github.com/rjbs/ipc-run3/',
},
no_index => {
dir => [ qw(lib/IPC/Run3) ],
file => [ qw(bin/run3profpp) ],
},
},
clean => { FILES => [ "t/test.txt", "t/utf8.txt" ] },
);
IPC-Run3-0.046/README 0000644 0000000 0000000 00000001015 12156162632 0013642 0 ustar 00root root 0000000 0000000 README for IPC-Run3 0.043
IPC::Run3 - run a subprocess in batch mode (a la system) on Unix, Win32, etc.
SYNOPSIS
use IPC::Run3; # Exports run3() by default
run3 \@cmd, \$in, \$out, \$err;
run3 \@cmd, \@in, \&out, \$err;
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 system, qx, and open3 with a simple, extremely Perlish API and none
of the bloat and rarely used features of IPC::Run.
IPC-Run3-0.046/bin/ 0000755 0000000 0000000 00000000000 12156162632 0013535 5 ustar 00root root 0000000 0000000 IPC-Run3-0.046/bin/run3profpp 0000644 0000000 0000000 00000003674 12156162632 0015610 0 ustar 00root root 0000000 0000000 #!/usr/local/bin/perl -w
$VERSION = 0.046;
=head1 NAME
run3profpp - Report on IPC::Run3 profiling data
=head1 SYNOPSIS
$ run3profpp [<profile_file_name>]
=head1 DESCRIPTION
IPC::Run3 may be run with profiling data enabled. It may report as it runs
or dump all of the data to a file. This program reads that file and generates
reports based on it.
The default filename is run3.out.
=cut
use strict;
use Getopt::Long;
sub _program_name {
require File::Basename;
File::Basename::basename( $0 );
}
sub _usage {
my ( $message ) = @_;
## Don't slow execution by always loading a rarely needed module.
## At least, we hope it's rarely needed.
require Pod::Usage;
$message = "Unkown error (message not provided)"
if defined $message && ! length $message;
my $help_mode = ! defined $message;
my $exitval = $help_mode ? 0 : do {
# The "message" may be a simple number, in which case it's an
# exit value.
$message =~ s/\A(\d+)\z// ? $1 : 1
};
Pod::Usage::pod2usage(
-verbose => $help_mode ? 2 : 1,
defined $message && length $message
? ( -message => $message )
: (),
-exitval => $exitval,
);
}
=head1 OPTIONS
=over
=item --help, -h, -?
Print out full help text.
=back
=cut
GetOptions(
"help|h|?" => sub { _usage },
) or _usage 1;
# _usage "Too few paramaters" unless @ARGV > 0;
# _usage "Too many paramaters" if @ARGV > 0;
###############################################################################
#
# Main program body
#
#
# End of the main program body
#
###############################################################################
=head1 LIMITATIONS
=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 <barries@slaysys.com>
=cut
1;
IPC-Run3-0.046/lib/ 0000755 0000000 0000000 00000000000 12156162632 0013533 5 ustar 00root root 0000000 0000000 IPC-Run3-0.046/lib/IPC/ 0000755 0000000 0000000 00000000000 12156162632 0014146 5 ustar 00root root 0000000 0000000 IPC-Run3-0.046/lib/IPC/Run3.pm 0000644 0000000 0000000 00000060426 12156162632 0015343 0 ustar 00root root 0000000 0000000 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.046
=cut
our $VERSION = '0.046';
=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 ); 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
? map {
# Probably need to offer a win32 escaping
# option, every command may be different.
( my $s = $_ ) =~ s/"/"""/g;
$s = qq{"$s"};
$s;
} @$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";
}
}
croak $! if defined $r && $r == -1 && !$options->{return_if_system_error};
1;
};
my $x = $@;
my @errs;
if ( defined $saved_fd0 ) {
dup2( $saved_fd0, 0 );
POSIX::close( $saved_fd0 );
}
# 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
IPC-Run3-0.046/lib/IPC/Run3/ 0000755 0000000 0000000 00000000000 12156162632 0014775 5 ustar 00root root 0000000 0000000 IPC-Run3-0.046/lib/IPC/Run3/ProfArrayBuffer.pm 0000644 0000000 0000000 00000002361 12156162632 0020374 0 ustar 00root root 0000000 0000000 package IPC::Run3::ProfArrayBuffer;
$VERSION = 0.046;
=head1 NAME
IPC::Run3::ProfArrayBuffer - Store profile events in RAM in an array
=head1 SYNOPSIS
=head1 DESCRIPTION
=cut
use strict;
=head1 METHODS
=over
=item C<< IPC::Run3::ProfArrayBuffer->new() >>
=cut
sub new {
my $class = ref $_[0] ? ref shift : shift;
my $self = bless { @_ }, $class;
$self->{Events} = [];
return $self;
}
=item C<< $buffer->app_call(@events) >>
=item C<< $buffer->app_exit(@events) >>
=item C<< $buffer->run_exit(@events) >>
The three above methods push the given events onto the stack of recorded
events.
=cut
for my $subname ( qw(app_call app_exit run_exit) ) {
no strict 'refs';
*{$subname} = sub {
push @{shift->{Events}}, [ $subname => @_ ];
};
}
=item get_events
Returns a list of all the events. Each event is an ARRAY reference
like:
[ "app_call", 1.1, ... ];
=cut
sub get_events {
my $self = shift;
@{$self->{Events}};
}
=back
=head1 LIMITATIONS
=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>barries@slaysys.comE<gt>
=cut
1;
IPC-Run3-0.046/lib/IPC/Run3/ProfLogReader.pm 0000644 0000000 0000000 00000005601 12156162632 0020030 0 ustar 00root root 0000000 0000000 package IPC::Run3::ProfLogReader;
$VERSION = 0.046;
=head1 NAME
IPC::Run3::ProfLogReader - read and process a ProfLogger file
=head1 SYNOPSIS
use IPC::Run3::ProfLogReader;
my $reader = IPC::Run3::ProfLogReader->new; ## use "run3.out"
my $reader = IPC::Run3::ProfLogReader->new( Source => $fn );
my $profiler = IPC::Run3::ProfPP; ## For example
my $reader = IPC::Run3::ProfLogReader->new( ..., Handler => $p );
$reader->read;
$eaderr->read_all;
=head1 DESCRIPTION
Reads a log file. Use the filename "-" to read from STDIN.
=cut
use strict;
=head1 METHODS
=head2 C<< IPC::Run3::ProfLogReader->new( ... ) >>
=cut
sub new {
my $class = ref $_[0] ? ref shift : shift;
my $self = bless { @_ }, $class;
$self->{Source} = "run3.out"
unless defined $self->{Source} && length $self->{Source};
my $source = $self->{Source};
if ( ref $source eq "GLOB" || UNIVERSAL::isa( $source, "IO::Handle" ) ) {
$self->{FH} = $source;
}
elsif ( $source eq "-" ) {
$self->{FH} = \*STDIN;
}
else {
open PROFILE, "<$self->{Source}" or die "$!: $self->{Source}\n";
$self->{FH} = *PROFILE{IO};
}
return $self;
}
=head2 C<< $reader->set_handler( $handler ) >>
=cut
sub set_handler { $_[0]->{Handler} = $_[1] }
=head2 C<< $reader->get_handler() >>
=cut
sub get_handler { $_[0]->{Handler} }
=head2 C<< $reader->read() >>
=cut
sub read {
my $self = shift;
my $fh = $self->{FH};
my @ln = split / /, <$fh>;
return 0 unless @ln;
return 1 unless $self->{Handler};
chomp $ln[-1];
## Ignore blank and comment lines.
return 1 if @ln == 1 && ! length $ln[0] || 0 == index $ln[0], "#";
if ( $ln[0] eq "\\app_call" ) {
shift @ln;
my @times = split /,/, pop @ln;
$self->{Handler}->app_call(
[
map {
s/\\\\/\\/g;
s/\\_/ /g;
$_;
} @ln
],
@times
);
}
elsif ( $ln[0] eq "\\app_exit" ) {
shift @ln;
$self->{Handler}->app_exit( pop @ln, @ln );
}
else {
my @times = split /,/, pop @ln;
$self->{Handler}->run_exit(
[
map {
s/\\\\/\\/g;
s/\\_/ /g;
$_;
} @ln
],
@times
);
}
return 1;
}
=head2 C<< $reader->read_all() >>
This method reads until there is nothing left to read, and then returns true.
=cut
sub read_all {
my $self = shift;
1 while $self->read;
return 1;
}
=head1 LIMITATIONS
=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>barries@slaysys.comE<gt>
=cut
1;
IPC-Run3-0.046/lib/IPC/Run3/ProfLogger.pm 0000644 0000000 0000000 00000005026 12156162632 0017404 0 ustar 00root root 0000000 0000000 package IPC::Run3::ProfLogger;
$VERSION = 0.046;
=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;
$s =~ s/ /\\_/g;
$s;
} @_
),
$t,
),
"\n"
);
}
=head1 LIMITATIONS
=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>barries@slaysys.comE<gt>
=cut
1;
IPC-Run3-0.046/lib/IPC/Run3/ProfPP.pm 0000644 0000000 0000000 00000007257 12156162632 0016514 0 ustar 00root root 0000000 0000000 package IPC::Run3::ProfPP;
$VERSION = 0.046;
=head1 NAME
IPC::Run3::ProfPP - Generate reports from IPC::Run3 profiling data
=head1 SYNOPSIS
=head1 DESCRIPTION
Used by IPC::Run3 and/or run3profpp to print out profiling reports for
human readers. Use other classes for extracting data in other ways.
The output methods are plain text, override these (see the source for
now) to provide other formats.
This class generates reports on each run3_exit() and app_exit() call.
=cut
require IPC::Run3::ProfReporter;
@ISA = qw( IPC::Run3::ProfReporter );
use strict;
use POSIX qw( floor );
=head1 METHODS
=head2 C<< IPC::Run3::ProfPP->new() >>
Returns a new profile reporting object.
=cut
sub _emit { shift; warn @_ }
sub _t {
sprintf "%10.6f secs", @_;
}
sub _r {
my ( $num, $denom ) = @_;
return () unless $denom;
sprintf "%10.6f", $num / $denom;
}
sub _pct {
my ( $num, $denom ) = @_;
return () unless $denom;
sprintf " (%3d%%)", floor( 100 * $num / $denom + 0.5 );
}
=head2 C<< $profpp->handle_app_call() >>
=cut
sub handle_app_call {
my $self = shift;
$self->_emit("IPC::Run3 parent: ",
join( " ", @{$self->get_app_cmd} ),
"\n",
);
$self->{NeedNL} = 1;
}
=head2 C<< $profpp->handle_app_exit() >>
=cut
sub handle_app_exit {
my $self = shift;
$self->_emit("\n") if $self->{NeedNL} && $self->{NeedNL} != 1;
$self->_emit( "IPC::Run3 total elapsed: ",
_t( $self->get_app_cumulative_time ),
"\n");
$self->_emit( "IPC::Run3 calls to run3(): ",
sprintf( "%10d", $self->get_run_count ),
"\n");
$self->_emit( "IPC::Run3 total spent in run3(): ",
_t( $self->get_run_cumulative_time ),
_pct( $self->get_run_cumulative_time, $self->get_app_cumulative_time ),
", ",
_r( $self->get_run_cumulative_time, $self->get_run_count ),
" per call",
"\n");
my $exclusive =
$self->get_app_cumulative_time - $self->get_run_cumulative_time;
$self->_emit( "IPC::Run3 total spent not in run3(): ",
_t( $exclusive ),
_pct( $exclusive, $self->get_app_cumulative_time ),
"\n");
$self->_emit( "IPC::Run3 total spent in children: ",
_t( $self->get_sys_cumulative_time ),
_pct( $self->get_sys_cumulative_time, $self->get_app_cumulative_time ),
", ",
_r( $self->get_sys_cumulative_time, $self->get_run_count ),
" per call",
"\n");
my $overhead =
$self->get_run_cumulative_time - $self->get_sys_cumulative_time;
$self->_emit( "IPC::Run3 total overhead: ",
_t( $overhead ),
_pct(
$overhead,
$self->get_sys_cumulative_time
),
", ",
_r( $overhead, $self->get_run_count ),
" per call",
"\n");
}
=head2 C<< $profpp->handle_run_exit() >>
=cut
sub handle_run_exit {
my $self = shift;
my $overhead = $self->get_run_time - $self->get_sys_time;
$self->_emit("\n") if $self->{NeedNL} && $self->{NeedNL} != 2;
$self->{NeedNL} = 3;
$self->_emit( "IPC::Run3 child: ",
join( " ", @{$self->get_run_cmd} ),
"\n");
$self->_emit( "IPC::Run3 run3() : ", _t( $self->get_run_time ), "\n",
"IPC::Run3 child : ", _t( $self->get_sys_time ), "\n",
"IPC::Run3 overhead: ", _t( $overhead ),
_pct( $overhead, $self->get_sys_time ),
"\n");
}
=head1 LIMITATIONS
=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>barries@slaysys.comE<gt>
=cut
1;
IPC-Run3-0.046/lib/IPC/Run3/ProfReporter.pm 0000644 0000000 0000000 00000012675 12156162632 0017777 0 ustar 00root root 0000000 0000000 package IPC::Run3::ProfReporter;
$VERSION = 0.046;
=head1 NAME
IPC::Run3::ProfReporter - base class for handling profiling data
=head1 SYNOPSIS
=head1 DESCRIPTION
See L<IPC::Run3::ProfPP|IPC::Run3::ProfPP> and for an example subclass.
This class just notes and accumulates times; subclasses use methods like
"handle_app_call", "handle_run_exit" and "handle_app_exit" to emit reports on
it. The default methods for these handlers are noops.
If run from the command line, a reporter will be created and run on
each logfile given as a command line parameter or on run3.out if none
are given.
This allows reports to be run like:
perl -MIPC::Run3::ProfPP -e1
perl -MIPC::Run3::ProfPP -e1 foo.out bar.out
Use "-" to read from STDIN (the log file format is meant to be moderately
greppable):
grep "^cvs " run3.out perl -MIPC::Run3::ProfPP -e1 -
Use --app to show only application level statistics (ie don't emit
a report section for each command run).
=cut
use strict;
my $loaded_by;
sub import {
$loaded_by = shift;
}
END {
my @caller;
for ( my $i = 0;; ++$i ) {
my @c = caller $i;
last unless @c;
@caller = @c;
}
if ( $caller[0] eq "main"
&& $caller[1] eq "-e"
) {
require IPC::Run3::ProfLogReader;
require Getopt::Long;
my ( $app, $run );
Getopt::Long::GetOptions(
"app" => \$app,
"run" => \$run,
);
$app = 1, $run = 1 unless $app || $run;
for ( @ARGV ? @ARGV : "" ) {
my $r = IPC::Run3::ProfLogReader->new(
Source => $_,
Handler => $loaded_by->new(
Source => $_,
app_report => $app,
run_report => $run,
),
);
$r->read_all;
}
}
}
=head1 METHODS
=over
=item C<< IPC::Run3::ProfReporter->new >>
Returns a new profile reporting object.
=cut
sub new {
my $class = ref $_[0] ? ref shift : shift;
my $self = bless { @_ }, $class;
$self->{app_report} = 1, $self->{run_report} = 1
unless $self->{app_report} || $self->{run_report};
return $self;
}
=item C<< $reporter->handle_app_call( ... ) >>
=item C<< $reporter->handle_app_exit( ... ) >>
=item C<< $reporter->handle_run_exit( ... ) >>
These methods are called by the handled events (see below).
=cut
sub handle_app_call {}
sub handle_app_exit {}
sub handle_run_exit {}
=item C<< $reporter->app_call(\@cmd, $time) >>
=item C<< $reporter->app_exit($time) >>
=item C<< $reporter->run_exit(@times) >>
$self->app_call( $time );
my $time = $self->get_app_call_time;
Sets the time (in floating point seconds) when the application, run3(),
or system() was called or exited. If no time parameter is passed, uses
IPC::Run3's time routine.
Use get_...() to retrieve these values (and _accum values, too). This
is a separate method to speed the execution time of the setters just a
bit.
=cut
sub app_call {
my $self = shift;
( $self->{app_cmd}, $self->{app_call_time} ) = @_;
$self->handle_app_call if $self->{app_report};
}
sub app_exit {
my $self = shift;
$self->{app_exit_time} = shift;
$self->handle_app_exit if $self->{app_report};
}
sub run_exit {
my $self = shift;
@{$self}{qw(
run_cmd run_call_time sys_call_time sys_exit_time run_exit_time
)} = @_;
++$self->{run_count};
$self->{run_cumulative_time} += $self->get_run_time;
$self->{sys_cumulative_time} += $self->get_sys_time;
$self->handle_run_exit if $self->{run_report};
}
=item C<< $reporter->get_run_count() >>
=item C<< $reporter->get_app_call_time() >>
=item C<< $reporter->get_app_exit_time() >>
=item C<< $reporter->get_app_cmd() >>
=item C<< $reporter->get_app_time() >>
=cut
sub get_run_count { shift->{run_count} }
sub get_app_call_time { shift->{app_call_time} }
sub get_app_exit_time { shift->{app_exit_time} }
sub get_app_cmd { shift->{app_cmd} }
sub get_app_time {
my $self = shift;
$self->get_app_exit_time - $self->get_app_call_time;
}
=item C<< $reporter->get_app_cumulative_time() >>
=cut
sub get_app_cumulative_time {
my $self = shift;
$self->get_app_exit_time - $self->get_app_call_time;
}
=item C<< $reporter->get_run_call_time() >>
=item C<< $reporter->get_run_exit_time() >>
=item C<< $reporter->get_run_time() >>
=cut
sub get_run_call_time { shift->{run_call_time} }
sub get_run_exit_time { shift->{run_exit_time} }
sub get_run_time {
my $self = shift;
$self->get_run_exit_time - $self->get_run_call_time;
}
=item C<< $reporter->get_run_cumulative_time() >>
=cut
sub get_run_cumulative_time { shift->{run_cumulative_time} }
=item C<< $reporter->get_sys_call_time() >>
=item C<< $reporter->get_sys_exit_time() >>
=item C<< $reporter->get_sys_time() >>
=cut
sub get_sys_call_time { shift->{sys_call_time} }
sub get_sys_exit_time { shift->{sys_exit_time} }
sub get_sys_time {
my $self = shift;
$self->get_sys_exit_time - $self->get_sys_call_time;
}
=item C<< $reporter->get_sys_cumulative_time() >>
=cut
sub get_sys_cumulative_time { shift->{sys_cumulative_time} }
=item C<< $reporter->get_run_cmd() >>
=cut
sub get_run_cmd { shift->{run_cmd} }
=back
=head1 LIMITATIONS
=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 <barries@slaysys.com>
=cut
1;
IPC-Run3-0.046/t/ 0000755 0000000 0000000 00000000000 12156162632 0013230 5 ustar 00root root 0000000 0000000 IPC-Run3-0.046/t/IPC-Run3-ProfArrayBuffer.t 0000644 0000000 0000000 00000000445 12156162632 0017715 0 ustar 00root root 0000000 0000000 #!perl -w
use Test;
use IPC::Run3::ProfArrayBuffer;
use strict;
my $b = IPC::Run3::ProfArrayBuffer->new;
my @tests = (
sub {
$b->app_call( 1 );
ok 0+$b->get_events, 1;
},
sub {
ok( ($b->get_events)[0]->[1], 1 );
},
);
plan tests => 0+@tests;
$_->() for @tests;
IPC-Run3-0.046/t/IPC-Run3-ProfLogReader.t 0000644 0000000 0000000 00000001025 12156162632 0017344 0 ustar 00root root 0000000 0000000 #!perl -w
use Test;
use IPC::Run3::ProfLogReader;
use IPC::Run3::ProfArrayBuffer;
use strict;
my $h = IPC::Run3::ProfArrayBuffer->new;
my $r = IPC::Run3::ProfLogReader->new(
Source => \*DATA,
Handler => $h,
);
my @tests = (
sub {
ok $r->read;
},
sub {
ok $r->read_all;
},
sub {
ok 0+$h->get_events, 3, "events read";
},
sub {
ok( ($h->get_events)[1]->[1]->[1], "there fella" );
},
);
plan tests => 0+@tests;
$_->() for @tests;
__DATA__
\app_call 1.0
hi there\_fella 1.1,1.2,1.3,1.4
\app_exit 1.5
IPC-Run3-0.046/t/IPC-Run3-ProfLogger.t 0000644 0000000 0000000 00000000216 12156162632 0016720 0 ustar 00root root 0000000 0000000 #!perl -w
use Test;
use IPC::Run3::ProfLogger;
use strict;
my @tests = (
sub {
ok 1;
},
);
plan tests => 0+@tests;
$_->() for @tests;
IPC-Run3-0.046/t/IPC-Run3-ProfPP.t 0000644 0000000 0000000 00000000517 12156162632 0016024 0 ustar 00root root 0000000 0000000 #!perl -w
use Test;
use IPC::Run3::ProfPP;
use strict;
my $p = IPC::Run3::ProfPP->new;
my @tests = (
sub {
local $SIG{__WARN__} = sub { };
$p->app_call( [ "parent_prog" ], 1.0 );
$p->run_exit( [ "child_prog" ], 1.1, 1.2, 1.3, 1.4 );
$p->app_exit( 1.5 );
ok 1;
},
);
plan tests => 0+@tests;
$_->() for @tests;
IPC-Run3-0.046/t/IPC-Run3-ProfReporter.t 0000644 0000000 0000000 00000001144 12156162632 0017304 0 ustar 00root root 0000000 0000000 #!perl -w
use Test;
use IPC::Run3::ProfReporter;
use strict;
my $p;
my @tests = (
sub {
$p = IPC::Run3::ProfReporter->new;;
ok UNIVERSAL::isa( $p, "IPC::Run3::ProfReporter" );
},
sub {
$p->app_call( [], 0.1 );
ok $p->get_app_call_time, 0.1;
},
sub {
$p->app_exit( 1.2 );
ok $p->get_app_exit_time, 1.2;
},
sub {
ok $p->get_app_time > 1.09;
},
sub {
ok $p->get_app_cumulative_time > 1.09;
},
sub {
$p->run_exit( [], 0.1, 0.2, 0.3, 0.4 );
ok $p->get_run_call_time, 0.1;
},
sub {
ok $p->get_sys_call_time, 0.2;
},
);
plan tests => 0+@tests;
$_->() for @tests;
IPC-Run3-0.046/t/IPC-Run3-profiling.t 0000644 0000000 0000000 00000000565 12156162632 0016652 0 ustar 00root root 0000000 0000000 #!perl -w
BEGIN {
$ENV{IPCRUN3PROFILE} = "IPC::Run3::ProfArrayBuffer=";
}
use strict;
use IPC::Run3;
use Test;
my @tests = (
sub {
run3 [$^X, '-e1' ];
## no app_exit call is expected because the app (ie this script)
## has not not exited quite yet.
ok scalar IPC::Run3::_profiler()->get_events, 2;
},
);
plan tests => 0+@tests;
$_->() for @tests;
IPC-Run3-0.046/t/IPC-Run3.t 0000644 0000000 0000000 00000011354 12156162632 0014661 0 ustar 00root root 0000000 0000000 #!perl -w
use Test qw( plan );
use IPC::Run3;
use strict;
my ( $in, $out, $err ) = @_;
my %e = (
map( { chr $_ => sprintf( "\\0x%02d", $_ ) } (0..255) ),
"\n" => "\\n",
"\r" => "\\r",
);
sub ok {
@_ = map { ( my $s = $_ ) =~ s/([\000-\037])/$e{$1}/ge; $s } @_;
goto &Test::ok;
}
my @tests = (
sub {
eval { run3 };
ok $@;
},
sub {
( $in, $out, $err ) = ();
run3 [$^X, '-e', 'print "OUT"' ], \undef, \$out, \$err;
ok $out, "OUT";
},
sub {
ok $err, "";
},
sub {
( $in, $out, $err ) = ();
$out = "STUFF";
run3 [$^X, '-e', 'print "OUT"' ], \undef, \$out, \$err, { append_stdout => 1 };
ok $out, "STUFFOUT";
},
sub {
( $in, $out, $err ) = ();
$err = "STUFF";
run3 [$^X, '-e', 'print STDERR "OUT"' ], \undef, \$out, \$err, { append_stderr => 1 };
ok $out, "";
},
sub {
ok $err, "STUFFOUT";
},
sub {
( $in, $out, $err ) = ();
run3 [$^X, '-e', 'print map uc, <>' ], \"in", \$out, \$err;
ok $out, "IN";
},
sub {
ok $err, "";
},
sub {
( $in, $out, $err ) = ();
run3 [$^X, '-e', 'print STDERR map uc, <>' ], \"in", \$out, \$err;
ok $out, "";
},
sub {
ok $err, "IN";
},
sub {
( $in, $out, $err ) = ();
run3 [$^X, '-e', 'print map uc, <>' ], [qw( in1 in2 )], \$out;
ok $out, "IN1IN2";
},
sub {
( $in, $out, $err ) = ();
my @ary;
run3 [$^X, '-e', 'print map uc, <>' ], [qw( in1 in2 )], \$out;
ok $out, "IN1IN2";
},
sub {
( $in, $out, $err ) = ();
my @out;
run3 [$^X, '-e', 'print "OUT1\nOUT2"' ], \undef, \@out, \$err;
ok scalar(@out), 2;
$out = join('', @out);
},
sub {
ok $out, "OUT1\nOUT2";
},
sub {
( $in, $out, $err ) = ();
my @out = ("STUFF\n");
run3 [$^X, '-e', 'print "OUT1\nOUT2"' ], \undef, \@out, \$err, { append_stdout => 1 };
ok scalar(@out), 3;
$out = join('', @out);
},
sub {
ok $out, "STUFF\nOUT1\nOUT2";
},
sub {
( $in, $out, $err ) = ();
run3 [$^X, '-e', 'print map { length($_)."[$_]" } <>' ], \"in1\nin2", \$out;
ok $out, "4[in1\n]3[in2]";
},
sub {
( $in, $out, $err ) = ();
run3 [$^X, '-e', 'binmode STDIN; binmode STDOUT; print map { length($_)."[$_]" } <>' ],
\"in1\nin2", \$out,
{ binmode_stdin => 1 };
ok $out, "4[in1\n]3[in2]";
},
sub {
( $in, $out, $err ) = ();
run3 [$^X, '-e', 'binmode STDIN; binmode STDOUT; print map { length($_)."[$_]" } <>' ],
\"in1\r\nin2", \$out,
{ binmode_stdin => 1, binmode_stdout => 1 };
ok $out, "5[in1\r\n]3[in2]";
},
sub {
( $in, $out, $err ) = ();
my @in = qw( in1 in2 );
run3 [$^X, '-e', 'print map uc, <>' ], sub { shift @in }, \$out;
ok $out, "IN1IN2";
},
sub {
( $in, $out, $err ) = ();
my @out;
run3 [$^X, '-e', 'print map uc, <>' ], \"in1\nin2", sub { push @out, shift };
ok scalar(@out), 2;
$out = join('', @out);
},
sub {
ok $out, "IN1\nIN2";
},
sub {
( $in, $out, $err ) = ();
run3 [$^X, '-e',
'$|=1; select STDERR; $| = 1; for (<>){print STDOUT uc;print STDERR lc}'
], \"in1\nin2\n", \$out,\$out;
ok $out, "IN1\nin1\nIN2\nin2\n";
},
sub {
my $fn = "t/test.txt";
unlink $fn or warn "$! unlinking $fn" if -e $fn;
( $in, $out, $err ) = ();
run3 [$^X, '-e', 'print "OUT"' ], \undef, $fn;
ok -s $fn, 3;
},
sub {
my $fn = "t/test.txt";
unlink $fn or warn "$! unlinking $fn" if -e $fn;
open FH, ">", $fn or warn "$! opening $fn";
print FH "STUFF";
close FH;
( $in, $out, $err ) = ();
run3 [$^X, '-e', 'print "OUT"' ], \undef, $fn, { append_stdout => 1 };
ok -s $fn, 8;
},
sub {
my $fn = "t/test.txt";
open FH, ">", $fn or warn "$! opening $fn";
( $in, $out, $err ) = ();
run3 [$^X, '-e', 'print "OUT"' ], \undef, \*FH;
close FH;
ok -s $fn, 3;
},
sub {
my $fn = "t/test.txt";
unlink $fn or warn "$! unlinking $fn" if -e $fn;
open FH, ">", $fn or warn "$! opening $fn";
print FH "IN1\nIN2\n";
close FH;
open FH, "<", $fn or warn "$! opening $fn";
( $in, $out, $err ) = ();
run3 [$^X, '-e', 'print <>' ], \*FH, \$out;
close FH;
ok $out, "IN1\nIN2\n";
},
# check that run3 doesn't die on platforms where system()
# returns -1 when SIGCHLD is ignored (RT #14272)
sub {
use Config;
if ( $^O eq 'openbsd' and $Config{'useithreads'} ) {
ok(1); # Bug in OpenBSD threaded perls causes a hang
}
else {
my $system_child_error = eval
{
local $SIG{CHLD} = "IGNORE";
system $^X, '-e', 0;
$?;
};
my $run3_child_error = eval
{
local $SIG{CHLD} = "IGNORE";
run3 [ $^X, '-e', 0 ], \undef, \undef, \undef, { return_if_system_error => 1 };
$?;
};
ok $run3_child_error, $system_child_error;
}
},
);
plan tests => 0+@tests;
$_->() for @tests;
IPC-Run3-0.046/t/die_handler.t 0000644 0000000 0000000 00000000325 12156162632 0015653 0 ustar 00root root 0000000 0000000 #!perl -w
use Test::More tests => 1;
use IPC::Run3;
use strict;
local $SIG{__DIE__} = sub { ok(0, '__DIE__ handler should not be called'); };
my ( $in, $out, $err );
ok(run3 [$^X, '-e1' ], $in, $out, $err);
IPC-Run3-0.046/t/fd_leak.t 0000644 0000000 0000000 00000001755 12156162632 0015012 0 ustar 00root root 0000000 0000000 #!perl -w
use Test::More;
use IPC::Run3;
use strict;
my ( $in, $out, $err ) = @_;
sub leaky
{
my ($what) = @_;
my $before_fd = IPC::Run3::_max_fd();
my $desc = join ",", map {
defined $_
? ref $_
? ( $_ == \undef )
? "\\undef"
: ref $_
: "'$_'"
: 'undef';
} @$what;
run3 [$^X, '-e1' ], @$what;
my $after_fd = IPC::Run3::_max_fd();
# on a sane system we'd expect == below,
# but apparently Darwin 7.2 is stranger than fiction
ok($after_fd <= $before_fd, "run3 [...],$desc");
}
my @tests = (
[],
[ \undef ],
[ \$in ],
[ $0 ],
[ undef, \$out ],
[ undef, undef, \$err ],
[ undef, \$out, \$err ],
[ \undef, \$out, \$err ],
[ \$in, \$out, \$err ],
[ $0, \$out, \$err ],
);
plan tests => 1+@tests;
## Force run3() to open some temp files.
run3 [$^X, '-e1' ], \$in, \$out, \$err;
ok(1, "open some temp files");
leaky($_) for @tests;
IPC-Run3-0.046/t/fork.t 0000644 0000000 0000000 00000003511 12156162632 0014356 0 ustar 00root root 0000000 0000000 #!perl -w
use Test::More;
plan skip_all => "Test::More 0.31 required for no_ending()" if $Test::More::VERSION <= 0.31;
plan skip_all => "tests fail on Win32 and Cygwin" if $^O =~ /^(MSWin32|cygwin)$/;
plan tests => 5;
use IPC::Run3;
use strict;
sub techo
{
my $exp = shift;
my $got;
run3 [ $^X, "-e", "print '$exp'" ], \undef, \$got, \undef;
return ($got, $exp);
}
my ($got, $exp);
# force IPC::Run3 into populating %fh_cache
# by running techo once in the parent
($got, $exp) = techo("parent$$ before fork");
is($got, $exp, "parent before fork");
if (my $pid = fork)
{
# parent
my $kid = waitpid($pid, 0);
ok($kid == $pid && $? == 0, "single child");
}
else
{
# child
# ask Test::More not to run its END block in the child
Test::More->builder->no_ending(1);
my ($got, $exp) = techo("child$$");
if ($exp eq $got)
{
exit(0);
}
else
{
diag qq[child $$: expected "$exp", got "$got"\n];
exit(1);
}
}
($got, $exp) = techo("parent$$ after fork");
is($got, $exp, "parent after fork");
# now run several child processes in parallel,
# all calling run3 repeatedly
my ($nkids, $nruns) = (5, 10); # usually enough, even on uniprocessor systems
my @kids;
for (1..$nkids)
{
if (my $kid = fork)
{
push @kids, $kid;
}
else
{
# child
Test::More->builder->no_ending(1);
for (1..$nruns)
{
my ($got, $exp) = techo("child$$:run$_");
next if $exp eq $got;
diag qq[child $$: expected "$exp", got "$got"\n];
exit(1);
}
exit(0);
}
}
my $nok = 0;
while (@kids)
{
my $kid = shift @kids;
my $pid = waitpid($kid, 0);
$nok++ if $pid == $kid && $? == 0;
}
ok($nok == $nkids, "$nkids parallel child processes, each run $nruns times");
($got, $exp) = techo("parent$$ after parallel forks");
is($got, $exp, "parent after parallel forks");
IPC-Run3-0.046/t/pod-coverage.t 0000644 0000000 0000000 00000000365 12156162632 0015774 0 ustar 00root root 0000000 0000000 #!perl -w
use Test::More;
eval "use Test::Pod::Coverage 1.04";
plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@;
all_pod_coverage_ok(
{ trustme => [ qr/_for_(?:created|modified)_(?:on|after|before)\Z/ ] }
);
IPC-Run3-0.046/t/pod.t 0000644 0000000 0000000 00000000216 12156162632 0014176 0 ustar 00root root 0000000 0000000 #!perl -w
use Test::More;
eval "use Test::Pod 1.00";
plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
all_pod_files_ok();
IPC-Run3-0.046/t/utf8.t 0000644 0000000 0000000 00000002471 12156162632 0014307 0 ustar 00root root 0000000 0000000 #!perl -w
use Test::More;
plan skip_all => qq["binmode FH, ':utf8'" needs Perl >= 5.8]
unless $^V >= 5.008;
plan tests => 3;
use IPC::Run3;
use strict;
my ( $in, $out, $err );
# Perl code to generate a Unicode string of
# LATIN1 SMALL LETTERS A, O, U WITH DIAERESIS
my $generate_unicode = qq[pack("U3", 0xe4, 0xf6, 0xfc)];
# bytes encoding the above in UTF8
my @expected_bytes = ( 0xc3, 0xa4, 0xc3, 0xb6, 0xc3, 0xbc );
# read as UTF8
( $in, $out, $err ) = ();
run3 [ $^X, "-e", "binmode STDOUT, ':utf8'; print $generate_unicode" ],
\undef, \$out, \undef, { binmode_stdout => ':utf8' };
is length($out), 3, "read Unicode string of 3 characters";
my @got_bytes;
{ use bytes; @got_bytes = unpack('C*', $out); }
is "@got_bytes", "@expected_bytes", "compare raw bytes read from command";
# write as UTF8
# NOTE: extra careful here, only write "Unicode safe" stuff in the child perl;
# e.g. Perl 5.8.0 might have ":utf8" implicitly turned on for STDOUT when
# invoked in a UTF8 locale (resulting in 12 bytes read into $out when simply
# copying STDIN to STDOUT)
( $in, $out, $err ) = ();
$in = eval $generate_unicode;
run3 [ $^X, "-e", "binmode STDIN, ':raw'; print join(' ', unpack('C*', <>))" ],
\$in, \$out, \undef, { binmode_stdin => ':utf8' };
is $out, "@expected_bytes", "compare raw bytes written to command";