Initial Commit
This commit is contained in:
Riley Schneider
4416
database/perl/vendor/lib/IPC/Run.pm
vendored
Normal file
4416
database/perl/vendor/lib/IPC/Run.pm
vendored
Normal file
File diff suppressed because it is too large
Load Diff
310
database/perl/vendor/lib/IPC/Run/Debug.pm
vendored
Normal file
310
database/perl/vendor/lib/IPC/Run/Debug.pm
vendored
Normal file
@@ -0,0 +1,310 @@
|
||||
package IPC::Run::Debug;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
IPC::Run::Debug - debugging routines for IPC::Run
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
##
|
||||
## Environment variable usage
|
||||
##
|
||||
## To force debugging off and shave a bit of CPU and memory
|
||||
## by compile-time optimizing away all debugging code in IPC::Run
|
||||
## (debug => ...) options to IPC::Run will be ignored.
|
||||
export IPCRUNDEBUG=none
|
||||
|
||||
## To force debugging on (levels are from 0..10)
|
||||
export IPCRUNDEBUG=basic
|
||||
|
||||
## Leave unset or set to "" to compile in debugging support and
|
||||
## allow runtime control of it using the debug option.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Controls IPC::Run debugging. Debugging levels are now set by using words,
|
||||
but the numbers shown are still supported for backwards compatibility:
|
||||
|
||||
0 none disabled (special, see below)
|
||||
1 basic what's running
|
||||
2 data what's being sent/received
|
||||
3 details what's going on in more detail
|
||||
4 gory way too much detail for most uses
|
||||
10 all use this when submitting bug reports
|
||||
noopts optimizations forbidden due to inherited STDIN
|
||||
|
||||
The C<none> level is special when the environment variable IPCRUNDEBUG
|
||||
is set to this the first time IPC::Run::Debug is loaded: it prevents
|
||||
the debugging code from being compiled in to the remaining IPC::Run modules,
|
||||
saving a bit of cpu.
|
||||
|
||||
To do this in a script, here's a way that allows it to be overridden:
|
||||
|
||||
BEGIN {
|
||||
unless ( defined $ENV{IPCRUNDEBUG} ) {
|
||||
eval 'local $ENV{IPCRUNDEBUG} = "none"; require IPC::Run::Debug"'
|
||||
or die $@;
|
||||
}
|
||||
}
|
||||
|
||||
This should force IPC::Run to not be debuggable unless somebody sets
|
||||
the IPCRUNDEBUG flag; modify this formula to grep @ARGV if need be:
|
||||
|
||||
BEGIN {
|
||||
unless ( grep /^--debug/, @ARGV ) {
|
||||
eval 'local $ENV{IPCRUNDEBUG} = "none"; require IPC::Run::Debug"'
|
||||
or die $@;
|
||||
}
|
||||
|
||||
Both of those are untested.
|
||||
|
||||
=cut
|
||||
|
||||
## We use @EXPORT for the end user's convenience: there's only one function
|
||||
## exported, it's homonymous with the module, it's an unusual name, and
|
||||
## it can be suppressed by "use IPC::Run ();".
|
||||
|
||||
use strict;
|
||||
use Exporter;
|
||||
use vars qw{$VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS};
|
||||
|
||||
BEGIN {
|
||||
$VERSION = '20200505.0';
|
||||
@ISA = qw( Exporter );
|
||||
@EXPORT = qw(
|
||||
_debug
|
||||
_debug_desc_fd
|
||||
_debugging
|
||||
_debugging_data
|
||||
_debugging_details
|
||||
_debugging_gory_details
|
||||
_debugging_not_optimized
|
||||
_set_child_debug_name
|
||||
);
|
||||
|
||||
@EXPORT_OK = qw(
|
||||
_debug_init
|
||||
_debugging_level
|
||||
_map_fds
|
||||
);
|
||||
%EXPORT_TAGS = (
|
||||
default => \@EXPORT,
|
||||
all => [ @EXPORT, @EXPORT_OK ],
|
||||
);
|
||||
}
|
||||
|
||||
my $disable_debugging = defined $ENV{IPCRUNDEBUG}
|
||||
&& ( !$ENV{IPCRUNDEBUG}
|
||||
|| lc $ENV{IPCRUNDEBUG} eq "none" );
|
||||
|
||||
eval( $disable_debugging ? <<'STUBS' : <<'SUBS' ) or die $@;
|
||||
sub _map_fds() { "" }
|
||||
sub _debug {}
|
||||
sub _debug_desc_fd {}
|
||||
sub _debug_init {}
|
||||
sub _set_child_debug_name {}
|
||||
sub _debugging() { 0 }
|
||||
sub _debugging_level() { 0 }
|
||||
sub _debugging_data() { 0 }
|
||||
sub _debugging_details() { 0 }
|
||||
sub _debugging_gory_details() { 0 }
|
||||
sub _debugging_not_optimized() { 0 }
|
||||
|
||||
1;
|
||||
STUBS
|
||||
|
||||
use POSIX ();
|
||||
|
||||
sub _map_fds {
|
||||
my $map = '';
|
||||
my $digit = 0;
|
||||
my $in_use;
|
||||
my $dummy;
|
||||
for my $fd (0..63) {
|
||||
## I'd like a quicker way (less user, cpu & especially sys and kernel
|
||||
## calls) to detect open file descriptors. Let me know...
|
||||
## Hmmm, could do a 0 length read and check for bad file descriptor...
|
||||
## but that segfaults on Win32
|
||||
my $test_fd = POSIX::dup( $fd );
|
||||
$in_use = defined $test_fd;
|
||||
POSIX::close $test_fd if $in_use;
|
||||
$map .= $in_use ? $digit : '-';
|
||||
$digit = 0 if ++$digit > 9;
|
||||
}
|
||||
warn "No fds open???" unless $map =~ /\d/;
|
||||
$map =~ s/(.{1,12})-*$/$1/;
|
||||
return $map;
|
||||
}
|
||||
|
||||
use vars qw( $parent_pid );
|
||||
|
||||
$parent_pid = $$;
|
||||
|
||||
## TODO: move debugging to its own module and make it compile-time
|
||||
## optimizable.
|
||||
|
||||
## Give kid process debugging nice names
|
||||
my $debug_name;
|
||||
|
||||
sub _set_child_debug_name {
|
||||
$debug_name = shift;
|
||||
}
|
||||
|
||||
## There's a bit of hackery going on here.
|
||||
##
|
||||
## We want to have any code anywhere be able to emit
|
||||
## debugging statements without knowing what harness the code is
|
||||
## being called in/from, since we'd need to pass a harness around to
|
||||
## everything.
|
||||
##
|
||||
## Thus, $cur_self was born.
|
||||
#
|
||||
my %debug_levels = (
|
||||
none => 0,
|
||||
basic => 1,
|
||||
data => 2,
|
||||
details => 3,
|
||||
gore => 4,
|
||||
gory_details => 4,
|
||||
"gory details" => 4,
|
||||
gory => 4,
|
||||
gorydetails => 4,
|
||||
all => 10,
|
||||
notopt => 0,
|
||||
);
|
||||
|
||||
my $warned;
|
||||
|
||||
sub _debugging_level() {
|
||||
my $level = 0;
|
||||
|
||||
$level = $IPC::Run::cur_self->{debug} || 0
|
||||
if $IPC::Run::cur_self
|
||||
&& ( $IPC::Run::cur_self->{debug} || 0 ) >= $level;
|
||||
|
||||
if ( defined $ENV{IPCRUNDEBUG} ) {
|
||||
my $v = $ENV{IPCRUNDEBUG};
|
||||
$v = $debug_levels{lc $v} if $v =~ /[a-zA-Z]/;
|
||||
unless ( defined $v ) {
|
||||
$warned ||= warn "Unknown debug level $ENV{IPCRUNDEBUG}, assuming 'basic' (1)\n";
|
||||
$v = 1;
|
||||
}
|
||||
$level = $v if $v > $level;
|
||||
}
|
||||
return $level;
|
||||
}
|
||||
|
||||
sub _debugging_atleast($) {
|
||||
my $min_level = shift || 1;
|
||||
|
||||
my $level = _debugging_level;
|
||||
|
||||
return $level >= $min_level ? $level : 0;
|
||||
}
|
||||
|
||||
sub _debugging() { _debugging_atleast 1 }
|
||||
sub _debugging_data() { _debugging_atleast 2 }
|
||||
sub _debugging_details() { _debugging_atleast 3 }
|
||||
sub _debugging_gory_details() { _debugging_atleast 4 }
|
||||
sub _debugging_not_optimized() { ( $ENV{IPCRUNDEBUG} || "" ) eq "notopt" }
|
||||
|
||||
sub _debug_init {
|
||||
## This routine is called only in spawned children to fake out the
|
||||
## debug routines so they'll emit debugging info.
|
||||
$IPC::Run::cur_self = {};
|
||||
( $parent_pid,
|
||||
$^T,
|
||||
$IPC::Run::cur_self->{debug},
|
||||
$IPC::Run::cur_self->{DEBUG_FD},
|
||||
$debug_name
|
||||
) = @_;
|
||||
}
|
||||
|
||||
|
||||
sub _debug {
|
||||
# return unless _debugging || _debugging_not_optimized;
|
||||
|
||||
my $fd = defined &IPC::Run::_debug_fd
|
||||
? IPC::Run::_debug_fd()
|
||||
: fileno STDERR;
|
||||
|
||||
my $s;
|
||||
my $debug_id;
|
||||
$debug_id = join(
|
||||
" ",
|
||||
join(
|
||||
"",
|
||||
defined $IPC::Run::cur_self ? "#$IPC::Run::cur_self->{ID}" : (),
|
||||
"($$)",
|
||||
),
|
||||
defined $debug_name && length $debug_name ? $debug_name : (),
|
||||
);
|
||||
my $prefix = join(
|
||||
"",
|
||||
"IPC::Run",
|
||||
sprintf( " %04d", time - $^T ),
|
||||
( _debugging_details ? ( " ", _map_fds ) : () ),
|
||||
length $debug_id ? ( " [", $debug_id, "]" ) : (),
|
||||
": ",
|
||||
);
|
||||
|
||||
my $msg = join( '', map defined $_ ? $_ : "<undef>", @_ );
|
||||
chomp $msg;
|
||||
$msg =~ s{^}{$prefix}gm;
|
||||
$msg .= "\n";
|
||||
POSIX::write( $fd, $msg, length $msg );
|
||||
}
|
||||
|
||||
|
||||
my @fd_descs = ( 'stdin', 'stdout', 'stderr' );
|
||||
|
||||
sub _debug_desc_fd {
|
||||
return unless _debugging;
|
||||
my $text = shift;
|
||||
my $op = pop;
|
||||
my $kid = $_[0];
|
||||
|
||||
Carp::carp join " ", caller(0), $text, $op if defined $op && UNIVERSAL::isa( $op, "IO::Pty" );
|
||||
|
||||
_debug(
|
||||
$text,
|
||||
' ',
|
||||
( defined $op->{FD}
|
||||
? $op->{FD} < 3
|
||||
? ( $fd_descs[$op->{FD}] )
|
||||
: ( 'fd ', $op->{FD} )
|
||||
: $op->{FD}
|
||||
),
|
||||
( defined $op->{KFD}
|
||||
? (
|
||||
' (kid',
|
||||
( defined $kid ? ( ' ', $kid->{NUM}, ) : () ),
|
||||
"'s ",
|
||||
( $op->{KFD} < 3
|
||||
? $fd_descs[$op->{KFD}]
|
||||
: defined $kid
|
||||
&& defined $kid->{DEBUG_FD}
|
||||
&& $op->{KFD} == $kid->{DEBUG_FD}
|
||||
? ( 'debug (', $op->{KFD}, ')' )
|
||||
: ( 'fd ', $op->{KFD} )
|
||||
),
|
||||
')',
|
||||
)
|
||||
: ()
|
||||
),
|
||||
);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
SUBS
|
||||
|
||||
=pod
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Barrie Slaymaker <barries@slaysys.com>, with numerous suggestions by p5p.
|
||||
|
||||
=cut
|
||||
575
database/perl/vendor/lib/IPC/Run/IO.pm
vendored
Normal file
575
database/perl/vendor/lib/IPC/Run/IO.pm
vendored
Normal file
@@ -0,0 +1,575 @@
|
||||
package IPC::Run::IO;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
IPC::Run::IO -- I/O channels for IPC::Run.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
B<NOT IMPLEMENTED YET ON Win32! Win32 does not allow select() on
|
||||
normal file descriptors; IPC::RUN::IO needs to use IPC::Run::Win32Helper
|
||||
to do this.>
|
||||
|
||||
use IPC::Run qw( io );
|
||||
|
||||
## The sense of '>' and '<' is opposite of perl's open(),
|
||||
## but agrees with IPC::Run.
|
||||
$io = io( "filename", '>', \$recv );
|
||||
$io = io( "filename", 'r', \$recv );
|
||||
|
||||
## Append to $recv:
|
||||
$io = io( "filename", '>>', \$recv );
|
||||
$io = io( "filename", 'ra', \$recv );
|
||||
|
||||
$io = io( "filename", '<', \$send );
|
||||
$io = io( "filename", 'w', \$send );
|
||||
|
||||
$io = io( "filename", '<<', \$send );
|
||||
$io = io( "filename", 'wa', \$send );
|
||||
|
||||
## Handles / IO objects that the caller opens:
|
||||
$io = io( \*HANDLE, '<', \$send );
|
||||
|
||||
$f = IO::Handle->new( ... ); # Any subclass of IO::Handle
|
||||
$io = io( $f, '<', \$send );
|
||||
|
||||
require IPC::Run::IO;
|
||||
$io = IPC::Run::IO->new( ... );
|
||||
|
||||
## Then run(), harness(), or start():
|
||||
run $io, ...;
|
||||
|
||||
## You can, of course, use io() or IPC::Run::IO->new() as an
|
||||
## argument to run(), harness, or start():
|
||||
run io( ... );
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This class and module allows filehandles and filenames to be harnessed for
|
||||
I/O when used IPC::Run, independent of anything else IPC::Run is doing
|
||||
(except that errors & exceptions can affect all things that IPC::Run is
|
||||
doing).
|
||||
|
||||
=head1 SUBCLASSING
|
||||
|
||||
INCOMPATIBLE CHANGE: due to the awkwardness introduced in ripping pseudohashes
|
||||
out of Perl, this class I<no longer> uses the fields pragma.
|
||||
|
||||
=cut
|
||||
|
||||
## This class is also used internally by IPC::Run in a very intimate way,
|
||||
## since this is a partial factoring of code from IPC::Run plus some code
|
||||
## needed to do standalone channels. This factoring process will continue
|
||||
## at some point. Don't know how far how fast.
|
||||
|
||||
use strict;
|
||||
use Carp;
|
||||
use Fcntl;
|
||||
use Symbol;
|
||||
|
||||
use IPC::Run::Debug;
|
||||
use IPC::Run qw( Win32_MODE );
|
||||
|
||||
use vars qw{$VERSION};
|
||||
|
||||
BEGIN {
|
||||
$VERSION = '20200505.0';
|
||||
if (Win32_MODE) {
|
||||
eval "use IPC::Run::Win32Helper; require IPC::Run::Win32IO; 1"
|
||||
or ( $@ && die )
|
||||
or die "$!";
|
||||
}
|
||||
}
|
||||
|
||||
sub _empty($);
|
||||
*_empty = \&IPC::Run::_empty;
|
||||
|
||||
=head1 SUBROUTINES
|
||||
|
||||
=over 4
|
||||
|
||||
=item new
|
||||
|
||||
I think it takes >> or << along with some other data.
|
||||
|
||||
TODO: Needs more thorough documentation. Patches welcome.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
$class = ref $class || $class;
|
||||
|
||||
my ( $external, $type, $internal ) = ( shift, shift, pop );
|
||||
|
||||
croak "$class: '$_' is not a valid I/O operator"
|
||||
unless $type =~ /^(?:<<?|>>?)$/;
|
||||
|
||||
my IPC::Run::IO $self = $class->_new_internal( $type, undef, undef, $internal, undef, @_ );
|
||||
|
||||
if ( !ref $external ) {
|
||||
$self->{FILENAME} = $external;
|
||||
}
|
||||
elsif ( ref $external eq 'GLOB' || UNIVERSAL::isa( $external, 'IO::Handle' ) ) {
|
||||
$self->{HANDLE} = $external;
|
||||
$self->{DONT_CLOSE} = 1;
|
||||
}
|
||||
else {
|
||||
croak "$class: cannot accept " . ref($external) . " to do I/O with";
|
||||
}
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
## IPC::Run uses this ctor, since it preparses things and needs more
|
||||
## smarts.
|
||||
sub _new_internal {
|
||||
my $class = shift;
|
||||
$class = ref $class || $class;
|
||||
|
||||
$class = "IPC::Run::Win32IO"
|
||||
if Win32_MODE && $class eq "IPC::Run::IO";
|
||||
|
||||
my IPC::Run::IO $self;
|
||||
$self = bless {}, $class;
|
||||
|
||||
my ( $type, $kfd, $pty_id, $internal, $binmode, @filters ) = @_;
|
||||
|
||||
# Older perls (<=5.00503, at least) don't do list assign to
|
||||
# psuedo-hashes well.
|
||||
$self->{TYPE} = $type;
|
||||
$self->{KFD} = $kfd;
|
||||
$self->{PTY_ID} = $pty_id;
|
||||
$self->binmode($binmode);
|
||||
$self->{FILTERS} = [@filters];
|
||||
|
||||
## Add an adapter to the end of the filter chain (which is usually just the
|
||||
## read/writer sub pushed by IPC::Run) to the DEST or SOURCE, if need be.
|
||||
if ( $self->op =~ />/ ) {
|
||||
croak "'$_' missing a destination" if _empty $internal;
|
||||
$self->{DEST} = $internal;
|
||||
if ( UNIVERSAL::isa( $self->{DEST}, 'CODE' ) ) {
|
||||
## Put a filter on the end of the filter chain to pass the
|
||||
## output on to the CODE ref. For SCALAR refs, the last
|
||||
## filter in the chain writes directly to the scalar itself. See
|
||||
## _init_filters(). For CODE refs, however, we need to adapt from
|
||||
## the SCALAR to calling the CODE.
|
||||
unshift(
|
||||
@{ $self->{FILTERS} },
|
||||
sub {
|
||||
my ($in_ref) = @_;
|
||||
|
||||
return IPC::Run::input_avail() && do {
|
||||
$self->{DEST}->($$in_ref);
|
||||
$$in_ref = '';
|
||||
1;
|
||||
}
|
||||
}
|
||||
);
|
||||
}
|
||||
}
|
||||
else {
|
||||
croak "'$_' missing a source" if _empty $internal;
|
||||
$self->{SOURCE} = $internal;
|
||||
if ( UNIVERSAL::isa( $internal, 'CODE' ) ) {
|
||||
push(
|
||||
@{ $self->{FILTERS} },
|
||||
sub {
|
||||
my ( $in_ref, $out_ref ) = @_;
|
||||
return 0 if length $$out_ref;
|
||||
|
||||
return undef
|
||||
if $self->{SOURCE_EMPTY};
|
||||
|
||||
my $in = $internal->();
|
||||
unless ( defined $in ) {
|
||||
$self->{SOURCE_EMPTY} = 1;
|
||||
return undef;
|
||||
}
|
||||
return 0 unless length $in;
|
||||
$$out_ref = $in;
|
||||
|
||||
return 1;
|
||||
}
|
||||
);
|
||||
}
|
||||
elsif ( UNIVERSAL::isa( $internal, 'SCALAR' ) ) {
|
||||
push(
|
||||
@{ $self->{FILTERS} },
|
||||
sub {
|
||||
my ( $in_ref, $out_ref ) = @_;
|
||||
return 0 if length $$out_ref;
|
||||
|
||||
## pump() clears auto_close_ins, finish() sets it.
|
||||
return $self->{HARNESS}->{auto_close_ins} ? undef : 0
|
||||
if IPC::Run::_empty ${ $self->{SOURCE} }
|
||||
|| $self->{SOURCE_EMPTY};
|
||||
|
||||
$$out_ref = $$internal;
|
||||
eval { $$internal = '' }
|
||||
if $self->{HARNESS}->{clear_ins};
|
||||
|
||||
$self->{SOURCE_EMPTY} = $self->{HARNESS}->{auto_close_ins};
|
||||
|
||||
return 1;
|
||||
}
|
||||
);
|
||||
}
|
||||
}
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
=item filename
|
||||
|
||||
Gets/sets the filename. Returns the value after the name change, if
|
||||
any.
|
||||
|
||||
=cut
|
||||
|
||||
sub filename {
|
||||
my IPC::Run::IO $self = shift;
|
||||
$self->{FILENAME} = shift if @_;
|
||||
return $self->{FILENAME};
|
||||
}
|
||||
|
||||
=item init
|
||||
|
||||
Does initialization required before this can be run. This includes open()ing
|
||||
the file, if necessary, and clearing the destination scalar if necessary.
|
||||
|
||||
=cut
|
||||
|
||||
sub init {
|
||||
my IPC::Run::IO $self = shift;
|
||||
|
||||
$self->{SOURCE_EMPTY} = 0;
|
||||
${ $self->{DEST} } = ''
|
||||
if $self->mode =~ /r/ && ref $self->{DEST} eq 'SCALAR';
|
||||
|
||||
$self->open if defined $self->filename;
|
||||
$self->{FD} = $self->fileno;
|
||||
|
||||
if ( !$self->{FILTERS} ) {
|
||||
$self->{FBUFS} = undef;
|
||||
}
|
||||
else {
|
||||
@{ $self->{FBUFS} } = map {
|
||||
my $s = "";
|
||||
\$s;
|
||||
} ( @{ $self->{FILTERS} }, '' );
|
||||
|
||||
$self->{FBUFS}->[0] = $self->{DEST}
|
||||
if $self->{DEST} && ref $self->{DEST} eq 'SCALAR';
|
||||
push @{ $self->{FBUFS} }, $self->{SOURCE};
|
||||
}
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
=item open
|
||||
|
||||
If a filename was passed in, opens it. Determines if the handle is open
|
||||
via fileno(). Throws an exception on error.
|
||||
|
||||
=cut
|
||||
|
||||
my %open_flags = (
|
||||
'>' => O_RDONLY,
|
||||
'>>' => O_RDONLY,
|
||||
'<' => O_WRONLY | O_CREAT | O_TRUNC,
|
||||
'<<' => O_WRONLY | O_CREAT | O_APPEND,
|
||||
);
|
||||
|
||||
sub open {
|
||||
my IPC::Run::IO $self = shift;
|
||||
|
||||
croak "IPC::Run::IO: Can't open() a file with no name"
|
||||
unless defined $self->{FILENAME};
|
||||
$self->{HANDLE} = gensym unless $self->{HANDLE};
|
||||
|
||||
_debug "opening '", $self->filename, "' mode '", $self->mode, "'"
|
||||
if _debugging_data;
|
||||
sysopen(
|
||||
$self->{HANDLE},
|
||||
$self->filename,
|
||||
$open_flags{ $self->op },
|
||||
) or croak "IPC::Run::IO: $! opening '$self->{FILENAME}', mode '" . $self->mode . "'";
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
=item open_pipe
|
||||
|
||||
If this is a redirection IO object, this opens the pipe in a platform
|
||||
independent manner.
|
||||
|
||||
=cut
|
||||
|
||||
sub _do_open {
|
||||
my $self = shift;
|
||||
my ( $child_debug_fd, $parent_handle ) = @_;
|
||||
|
||||
if ( $self->dir eq "<" ) {
|
||||
( $self->{TFD}, $self->{FD} ) = IPC::Run::_pipe_nb;
|
||||
if ($parent_handle) {
|
||||
CORE::open $parent_handle, ">&=$self->{FD}"
|
||||
or croak "$! duping write end of pipe for caller";
|
||||
}
|
||||
}
|
||||
else {
|
||||
( $self->{FD}, $self->{TFD} ) = IPC::Run::_pipe;
|
||||
if ($parent_handle) {
|
||||
CORE::open $parent_handle, "<&=$self->{FD}"
|
||||
or croak "$! duping read end of pipe for caller";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub open_pipe {
|
||||
my IPC::Run::IO $self = shift;
|
||||
|
||||
## Hmmm, Maybe allow named pipes one day. But until then...
|
||||
croak "IPC::Run::IO: Can't pipe() when a file name has been set"
|
||||
if defined $self->{FILENAME};
|
||||
|
||||
$self->_do_open(@_);
|
||||
|
||||
## return ( child_fd, parent_fd )
|
||||
return $self->dir eq "<"
|
||||
? ( $self->{TFD}, $self->{FD} )
|
||||
: ( $self->{FD}, $self->{TFD} );
|
||||
}
|
||||
|
||||
sub _cleanup { ## Called from Run.pm's _cleanup
|
||||
my $self = shift;
|
||||
undef $self->{FAKE_PIPE};
|
||||
}
|
||||
|
||||
=item close
|
||||
|
||||
Closes the handle. Throws an exception on failure.
|
||||
|
||||
|
||||
=cut
|
||||
|
||||
sub close {
|
||||
my IPC::Run::IO $self = shift;
|
||||
|
||||
if ( defined $self->{HANDLE} ) {
|
||||
close $self->{HANDLE}
|
||||
or croak(
|
||||
"IPC::Run::IO: $! closing "
|
||||
. (
|
||||
defined $self->{FILENAME}
|
||||
? "'$self->{FILENAME}'"
|
||||
: "handle"
|
||||
)
|
||||
);
|
||||
}
|
||||
else {
|
||||
IPC::Run::_close( $self->{FD} );
|
||||
}
|
||||
|
||||
$self->{FD} = undef;
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
=item fileno
|
||||
|
||||
Returns the fileno of the handle. Throws an exception on failure.
|
||||
|
||||
|
||||
=cut
|
||||
|
||||
sub fileno {
|
||||
my IPC::Run::IO $self = shift;
|
||||
|
||||
my $fd = fileno $self->{HANDLE};
|
||||
croak(
|
||||
"IPC::Run::IO: $! "
|
||||
. (
|
||||
defined $self->{FILENAME}
|
||||
? "'$self->{FILENAME}'"
|
||||
: "handle"
|
||||
)
|
||||
) unless defined $fd;
|
||||
|
||||
return $fd;
|
||||
}
|
||||
|
||||
=item mode
|
||||
|
||||
Returns the operator in terms of 'r', 'w', and 'a'. There is a state
|
||||
'ra', unlike Perl's open(), which indicates that data read from the
|
||||
handle or file will be appended to the output if the output is a scalar.
|
||||
This is only meaningful if the output is a scalar, it has no effect if
|
||||
the output is a subroutine.
|
||||
|
||||
The redirection operators can be a little confusing, so here's a reference
|
||||
table:
|
||||
|
||||
> r Read from handle in to process
|
||||
< w Write from process out to handle
|
||||
>> ra Read from handle in to process, appending it to existing
|
||||
data if the destination is a scalar.
|
||||
<< wa Write from process out to handle, appending to existing
|
||||
data if IPC::Run::IO opened a named file.
|
||||
|
||||
=cut
|
||||
|
||||
sub mode {
|
||||
my IPC::Run::IO $self = shift;
|
||||
|
||||
croak "IPC::Run::IO: unexpected arguments for mode(): @_" if @_;
|
||||
|
||||
## TODO: Optimize this
|
||||
return ( $self->{TYPE} =~ /</ ? 'w' : 'r' ) . ( $self->{TYPE} =~ /<<|>>/ ? 'a' : '' );
|
||||
}
|
||||
|
||||
=item op
|
||||
|
||||
Returns the operation: '<', '>', '<<', '>>'. See L</mode> if you want
|
||||
to spell these 'r', 'w', etc.
|
||||
|
||||
=cut
|
||||
|
||||
sub op {
|
||||
my IPC::Run::IO $self = shift;
|
||||
|
||||
croak "IPC::Run::IO: unexpected arguments for op(): @_" if @_;
|
||||
|
||||
return $self->{TYPE};
|
||||
}
|
||||
|
||||
=item binmode
|
||||
|
||||
Sets/gets whether this pipe is in binmode or not. No effect off of Win32
|
||||
OSs, of course, and on Win32, no effect after the harness is start()ed.
|
||||
|
||||
=cut
|
||||
|
||||
sub binmode {
|
||||
my IPC::Run::IO $self = shift;
|
||||
|
||||
$self->{BINMODE} = shift if @_;
|
||||
|
||||
return $self->{BINMODE};
|
||||
}
|
||||
|
||||
=item dir
|
||||
|
||||
Returns the first character of $self->op. This is either "<" or ">".
|
||||
|
||||
=cut
|
||||
|
||||
sub dir {
|
||||
my IPC::Run::IO $self = shift;
|
||||
|
||||
croak "IPC::Run::IO: unexpected arguments for dir(): @_" if @_;
|
||||
|
||||
return substr $self->{TYPE}, 0, 1;
|
||||
}
|
||||
|
||||
##
|
||||
## Filter Scaffolding
|
||||
##
|
||||
#my $filter_op ; ## The op running a filter chain right now
|
||||
#my $filter_num; ## Which filter is being run right now.
|
||||
|
||||
use vars (
|
||||
'$filter_op', ## The op running a filter chain right now
|
||||
'$filter_num' ## Which filter is being run right now.
|
||||
);
|
||||
|
||||
sub _init_filters {
|
||||
my IPC::Run::IO $self = shift;
|
||||
|
||||
confess "\$self not an IPC::Run::IO" unless UNIVERSAL::isa( $self, "IPC::Run::IO" );
|
||||
$self->{FBUFS} = [];
|
||||
|
||||
$self->{FBUFS}->[0] = $self->{DEST}
|
||||
if $self->{DEST} && ref $self->{DEST} eq 'SCALAR';
|
||||
|
||||
return unless $self->{FILTERS} && @{ $self->{FILTERS} };
|
||||
|
||||
push @{ $self->{FBUFS} }, map {
|
||||
my $s = "";
|
||||
\$s;
|
||||
} ( @{ $self->{FILTERS} }, '' );
|
||||
|
||||
push @{ $self->{FBUFS} }, $self->{SOURCE};
|
||||
}
|
||||
|
||||
=item poll
|
||||
|
||||
TODO: Needs confirmation that this is correct. Was previously undocumented.
|
||||
|
||||
I believe this is polling the IO for new input and then returns undef if there will never be any more input, 0 if there is none now, but there might be in the future, and TRUE if more input was gotten.
|
||||
|
||||
=cut
|
||||
|
||||
sub poll {
|
||||
my IPC::Run::IO $self = shift;
|
||||
my ($harness) = @_;
|
||||
|
||||
if ( defined $self->{FD} ) {
|
||||
my $d = $self->dir;
|
||||
if ( $d eq "<" ) {
|
||||
if ( vec $harness->{WOUT}, $self->{FD}, 1 ) {
|
||||
_debug_desc_fd( "filtering data to", $self )
|
||||
if _debugging_details;
|
||||
return $self->_do_filters($harness);
|
||||
}
|
||||
}
|
||||
elsif ( $d eq ">" ) {
|
||||
if ( vec $harness->{ROUT}, $self->{FD}, 1 ) {
|
||||
_debug_desc_fd( "filtering data from", $self )
|
||||
if _debugging_details;
|
||||
return $self->_do_filters($harness);
|
||||
}
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub _do_filters {
|
||||
my IPC::Run::IO $self = shift;
|
||||
|
||||
( $self->{HARNESS} ) = @_;
|
||||
|
||||
my ( $saved_op, $saved_num ) = ( $IPC::Run::filter_op, $IPC::Run::filter_num );
|
||||
$IPC::Run::filter_op = $self;
|
||||
$IPC::Run::filter_num = -1;
|
||||
my $redos = 0;
|
||||
my $r;
|
||||
{
|
||||
$@ = '';
|
||||
$r = eval { IPC::Run::get_more_input(); };
|
||||
|
||||
# Detect Resource temporarily unavailable and re-try 200 times (2 seconds), assuming select behaves (which it doesn't always? need ref)
|
||||
if ( ( $@ || '' ) =~ $IPC::Run::_EAGAIN && $redos++ < 200 ) {
|
||||
select( undef, undef, undef, 0.01 );
|
||||
redo;
|
||||
}
|
||||
}
|
||||
( $IPC::Run::filter_op, $IPC::Run::filter_num ) = ( $saved_op, $saved_num );
|
||||
$self->{HARNESS} = undef;
|
||||
die "ack ", $@ if $@;
|
||||
return $r;
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Barrie Slaymaker <barries@slaysys.com>
|
||||
|
||||
=head1 TODO
|
||||
|
||||
Implement bidirectionality.
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
670
database/perl/vendor/lib/IPC/Run/Timer.pm
vendored
Normal file
670
database/perl/vendor/lib/IPC/Run/Timer.pm
vendored
Normal file
@@ -0,0 +1,670 @@
|
||||
package IPC::Run::Timer;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
IPC::Run::Timer -- Timer channels for IPC::Run.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use IPC::Run qw( run timer timeout );
|
||||
## or IPC::Run::Timer ( timer timeout );
|
||||
## or IPC::Run::Timer ( :all );
|
||||
|
||||
## A non-fatal timer:
|
||||
$t = timer( 5 ); # or...
|
||||
$t = IO::Run::Timer->new( 5 );
|
||||
run $t, ...;
|
||||
|
||||
## A timeout (which is a timer that dies on expiry):
|
||||
$t = timeout( 5 ); # or...
|
||||
$t = IO::Run::Timer->new( 5, exception => "harness timed out" );
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This class and module allows timers and timeouts to be created for use
|
||||
by IPC::Run. A timer simply expires when it's time is up. A timeout
|
||||
is a timer that throws an exception when it expires.
|
||||
|
||||
Timeouts are usually a bit simpler to use than timers: they throw an
|
||||
exception on expiration so you don't need to check them:
|
||||
|
||||
## Give @cmd 10 seconds to get started, then 5 seconds to respond
|
||||
my $t = timeout( 10 );
|
||||
$h = start(
|
||||
\@cmd, \$in, \$out,
|
||||
$t,
|
||||
);
|
||||
pump $h until $out =~ /prompt/;
|
||||
|
||||
$in = "some stimulus";
|
||||
$out = '';
|
||||
$t->time( 5 )
|
||||
pump $h until $out =~ /expected response/;
|
||||
|
||||
You do need to check timers:
|
||||
|
||||
## Give @cmd 10 seconds to get started, then 5 seconds to respond
|
||||
my $t = timer( 10 );
|
||||
$h = start(
|
||||
\@cmd, \$in, \$out,
|
||||
$t,
|
||||
);
|
||||
pump $h until $t->is_expired || $out =~ /prompt/;
|
||||
|
||||
$in = "some stimulus";
|
||||
$out = '';
|
||||
$t->time( 5 )
|
||||
pump $h until $out =~ /expected response/ || $t->is_expired;
|
||||
|
||||
Timers and timeouts that are reset get started by start() and
|
||||
pump(). Timers change state only in pump(). Since run() and
|
||||
finish() both call pump(), they act like pump() with respect to
|
||||
timers.
|
||||
|
||||
Timers and timeouts have three states: reset, running, and expired.
|
||||
Setting the timeout value resets the timer, as does calling
|
||||
the reset() method. The start() method starts (or restarts) a
|
||||
timer with the most recently set time value, no matter what state
|
||||
it's in.
|
||||
|
||||
=head2 Time values
|
||||
|
||||
All time values are in seconds. Times may be any kind of perl number,
|
||||
e.g. as integer or floating point seconds, optionally preceded by
|
||||
punctuation-separated days, hours, and minutes.
|
||||
|
||||
Examples:
|
||||
|
||||
1 1 second
|
||||
1.1 1.1 seconds
|
||||
60 60 seconds
|
||||
1:0 1 minute
|
||||
1:1 1 minute, 1 second
|
||||
1:90 2 minutes, 30 seconds
|
||||
1:2:3:4.5 1 day, 2 hours, 3 minutes, 4.5 seconds
|
||||
'inf' the infinity perl special number (the timer never finishes)
|
||||
|
||||
Absolute date/time strings are *not* accepted: year, month and
|
||||
day-of-month parsing is not available (patches welcome :-).
|
||||
|
||||
=head2 Interval fudging
|
||||
|
||||
When calculating an end time from a start time and an interval, IPC::Run::Timer
|
||||
instances add a little fudge factor. This is to ensure that no time will
|
||||
expire before the interval is up.
|
||||
|
||||
First a little background. Time is sampled in discrete increments. We'll
|
||||
call the
|
||||
exact moment that the reported time increments from one interval to the
|
||||
next a tick, and the interval between ticks as the time period. Here's
|
||||
a diagram of three ticks and the periods between them:
|
||||
|
||||
|
||||
-0-0-0-0-0-0-0-0-0-0-1-1-1-1-1-1-1-1-1-1-2-...
|
||||
^ ^ ^
|
||||
|<--- period 0 ---->|<--- period 1 ---->|
|
||||
| | |
|
||||
tick 0 tick 1 tick 2
|
||||
|
||||
To see why the fudge factor is necessary, consider what would happen
|
||||
when a timer with an interval of 1 second is started right at the end of
|
||||
period 0:
|
||||
|
||||
|
||||
-0-0-0-0-0-0-0-0-0-0-1-1-1-1-1-1-1-1-1-1-2-...
|
||||
^ ^ ^ ^
|
||||
| | | |
|
||||
| | | |
|
||||
tick 0 |tick 1 tick 2
|
||||
|
|
||||
start $t
|
||||
|
||||
Assuming that check() is called many times per period, then the timer
|
||||
is likely to expire just after tick 1, since the time reported will have
|
||||
lept from the value '0' to the value '1':
|
||||
|
||||
-0-0-0-0-0-0-0-0-0-0-1-1-1-1-1-1-1-1-1-1-2-...
|
||||
^ ^ ^ ^ ^
|
||||
| | | | |
|
||||
| | | | |
|
||||
tick 0 |tick 1| tick 2
|
||||
| |
|
||||
start $t |
|
||||
|
|
||||
check $t
|
||||
|
||||
Adding a fudge of '1' in this example means that the timer is guaranteed
|
||||
not to expire before tick 2.
|
||||
|
||||
The fudge is not added to an interval of '0'.
|
||||
|
||||
This means that intervals guarantee a minimum interval. Given that
|
||||
the process running perl may be suspended for some period of time, or that
|
||||
it gets busy doing something time-consuming, there are no other guarantees on
|
||||
how long it will take a timer to expire.
|
||||
|
||||
=head1 SUBCLASSING
|
||||
|
||||
INCOMPATIBLE CHANGE: Due to the awkwardness introduced by ripping
|
||||
pseudohashes out of Perl, this class I<no longer> uses the fields
|
||||
pragma.
|
||||
|
||||
=head1 FUNCTIONS & METHODS
|
||||
|
||||
=over
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use Carp;
|
||||
use Fcntl;
|
||||
use Symbol;
|
||||
use Exporter;
|
||||
use Scalar::Util ();
|
||||
use vars qw( $VERSION @ISA @EXPORT_OK %EXPORT_TAGS );
|
||||
|
||||
BEGIN {
|
||||
$VERSION = '20200505.0';
|
||||
@ISA = qw( Exporter );
|
||||
@EXPORT_OK = qw(
|
||||
check
|
||||
end_time
|
||||
exception
|
||||
expire
|
||||
interval
|
||||
is_expired
|
||||
is_reset
|
||||
is_running
|
||||
name
|
||||
reset
|
||||
start
|
||||
timeout
|
||||
timer
|
||||
);
|
||||
|
||||
%EXPORT_TAGS = ( 'all' => \@EXPORT_OK );
|
||||
}
|
||||
|
||||
require IPC::Run;
|
||||
use IPC::Run::Debug;
|
||||
|
||||
##
|
||||
## Some helpers
|
||||
##
|
||||
my $resolution = 1;
|
||||
|
||||
sub _parse_time {
|
||||
for ( $_[0] ) {
|
||||
my $val;
|
||||
if ( not defined $_ ) {
|
||||
$val = $_;
|
||||
}
|
||||
else {
|
||||
my @f = split( /:/, $_, -1 );
|
||||
if ( scalar @f > 4 ) {
|
||||
croak "IPC::Run: expected <= 4 elements in time string '$_'";
|
||||
}
|
||||
for (@f) {
|
||||
if ( not Scalar::Util::looks_like_number($_) ) {
|
||||
croak "IPC::Run: non-numeric element '$_' in time string '$_'";
|
||||
}
|
||||
}
|
||||
my ( $s, $m, $h, $d ) = reverse @f;
|
||||
$val = ( ( ( $d || 0 ) * 24 + ( $h || 0 ) ) * 60 + ( $m || 0 ) ) * 60 + ( $s || 0 );
|
||||
}
|
||||
return $val;
|
||||
}
|
||||
}
|
||||
|
||||
sub _calc_end_time {
|
||||
my IPC::Run::Timer $self = shift;
|
||||
my $interval = $self->interval;
|
||||
$interval += $resolution if $interval;
|
||||
$self->end_time( $self->start_time + $interval );
|
||||
}
|
||||
|
||||
=item timer
|
||||
|
||||
A constructor function (not method) of IPC::Run::Timer instances:
|
||||
|
||||
$t = timer( 5 );
|
||||
$t = timer( 5, name => 'stall timer', debug => 1 );
|
||||
|
||||
$t = timer;
|
||||
$t->interval( 5 );
|
||||
|
||||
run ..., $t;
|
||||
run ..., $t = timer( 5 );
|
||||
|
||||
This convenience function is a shortened spelling of
|
||||
|
||||
IPC::Run::Timer->new( ... );
|
||||
|
||||
. It returns a timer in the reset state with a given interval.
|
||||
|
||||
If an exception is provided, it will be thrown when the timer notices that
|
||||
it has expired (in check()). The name is for debugging usage, if you plan on
|
||||
having multiple timers around. If no name is provided, a name like "timer #1"
|
||||
will be provided.
|
||||
|
||||
=cut
|
||||
|
||||
sub timer {
|
||||
return IPC::Run::Timer->new(@_);
|
||||
}
|
||||
|
||||
=item timeout
|
||||
|
||||
A constructor function (not method) of IPC::Run::Timer instances:
|
||||
|
||||
$t = timeout( 5 );
|
||||
$t = timeout( 5, exception => "kablooey" );
|
||||
$t = timeout( 5, name => "stall", exception => "kablooey" );
|
||||
|
||||
$t = timeout;
|
||||
$t->interval( 5 );
|
||||
|
||||
run ..., $t;
|
||||
run ..., $t = timeout( 5 );
|
||||
|
||||
A This convenience function is a shortened spelling of
|
||||
|
||||
IPC::Run::Timer->new( exception => "IPC::Run: timeout ...", ... );
|
||||
|
||||
. It returns a timer in the reset state that will throw an
|
||||
exception when it expires.
|
||||
|
||||
Takes the same parameters as L</timer>, any exception passed in overrides
|
||||
the default exception.
|
||||
|
||||
=cut
|
||||
|
||||
sub timeout {
|
||||
my $t = IPC::Run::Timer->new(@_);
|
||||
$t->exception( "IPC::Run: timeout on " . $t->name )
|
||||
unless defined $t->exception;
|
||||
return $t;
|
||||
}
|
||||
|
||||
=item new
|
||||
|
||||
IPC::Run::Timer->new() ;
|
||||
IPC::Run::Timer->new( 5 ) ;
|
||||
IPC::Run::Timer->new( 5, exception => 'kablooey' ) ;
|
||||
|
||||
Constructor. See L</timer> for details.
|
||||
|
||||
=cut
|
||||
|
||||
my $timer_counter;
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
$class = ref $class || $class;
|
||||
|
||||
my IPC::Run::Timer $self = bless {}, $class;
|
||||
|
||||
$self->{STATE} = 0;
|
||||
$self->{DEBUG} = 0;
|
||||
$self->{NAME} = "timer #" . ++$timer_counter;
|
||||
|
||||
while (@_) {
|
||||
my $arg = shift;
|
||||
if ( $arg eq 'exception' ) {
|
||||
$self->exception(shift);
|
||||
}
|
||||
elsif ( $arg eq 'name' ) {
|
||||
$self->name(shift);
|
||||
}
|
||||
elsif ( $arg eq 'debug' ) {
|
||||
$self->debug(shift);
|
||||
}
|
||||
else {
|
||||
$self->interval($arg);
|
||||
}
|
||||
}
|
||||
|
||||
_debug $self->name . ' constructed'
|
||||
if $self->{DEBUG} || _debugging_details;
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
=item check
|
||||
|
||||
check $t;
|
||||
check $t, $now;
|
||||
$t->check;
|
||||
|
||||
Checks to see if a timer has expired since the last check. Has no effect
|
||||
on non-running timers. This will throw an exception if one is defined.
|
||||
|
||||
IPC::Run::pump() calls this routine for any timers in the harness.
|
||||
|
||||
You may pass in a version of now, which is useful in case you have
|
||||
it lying around or you want to check several timers with a consistent
|
||||
concept of the current time.
|
||||
|
||||
Returns the time left before end_time or 0 if end_time is no longer
|
||||
in the future or the timer is not running
|
||||
(unless, of course, check() expire()s the timer and this
|
||||
results in an exception being thrown).
|
||||
|
||||
Returns undef if the timer is not running on entry, 0 if check() expires it,
|
||||
and the time left if it's left running.
|
||||
|
||||
=cut
|
||||
|
||||
sub check {
|
||||
my IPC::Run::Timer $self = shift;
|
||||
return undef if !$self->is_running;
|
||||
return 0 if $self->is_expired;
|
||||
|
||||
my ($now) = @_;
|
||||
$now = _parse_time($now);
|
||||
$now = time unless defined $now;
|
||||
|
||||
_debug( "checking ", $self->name, " (end time ", $self->end_time, ") at ", $now ) if $self->{DEBUG} || _debugging_details;
|
||||
|
||||
my $left = $self->end_time - $now;
|
||||
return $left if $left > 0;
|
||||
|
||||
$self->expire;
|
||||
return 0;
|
||||
}
|
||||
|
||||
=item debug
|
||||
|
||||
Sets/gets the current setting of the debugging flag for this timer. This
|
||||
has no effect if debugging is not enabled for the current harness.
|
||||
|
||||
=cut
|
||||
|
||||
sub debug {
|
||||
my IPC::Run::Timer $self = shift;
|
||||
$self->{DEBUG} = shift if @_;
|
||||
return $self->{DEBUG};
|
||||
}
|
||||
|
||||
=item end_time
|
||||
|
||||
$et = $t->end_time;
|
||||
$et = end_time $t;
|
||||
|
||||
$t->end_time( time + 10 );
|
||||
|
||||
Returns the time when this timer will or did expire. Even if this time is
|
||||
in the past, the timer may not be expired, since check() may not have been
|
||||
called yet.
|
||||
|
||||
Note that this end_time is not start_time($t) + interval($t), since some
|
||||
small extra amount of time is added to make sure that the timer does not
|
||||
expire before interval() elapses. If this were not so, then
|
||||
|
||||
Changing end_time() while a timer is running will set the expiration time.
|
||||
Changing it while it is expired has no affect, since reset()ing a timer always
|
||||
clears the end_time().
|
||||
|
||||
=cut
|
||||
|
||||
sub end_time {
|
||||
my IPC::Run::Timer $self = shift;
|
||||
if (@_) {
|
||||
$self->{END_TIME} = shift;
|
||||
_debug $self->name, ' end_time set to ', $self->{END_TIME}
|
||||
if $self->{DEBUG} > 2 || _debugging_details;
|
||||
}
|
||||
return $self->{END_TIME};
|
||||
}
|
||||
|
||||
=item exception
|
||||
|
||||
$x = $t->exception;
|
||||
$t->exception( $x );
|
||||
$t->exception( undef );
|
||||
|
||||
Sets/gets the exception to throw, if any. 'undef' means that no
|
||||
exception will be thrown. Exception does not need to be a scalar: you
|
||||
may ask that references be thrown.
|
||||
|
||||
=cut
|
||||
|
||||
sub exception {
|
||||
my IPC::Run::Timer $self = shift;
|
||||
if (@_) {
|
||||
$self->{EXCEPTION} = shift;
|
||||
_debug $self->name, ' exception set to ', $self->{EXCEPTION}
|
||||
if $self->{DEBUG} || _debugging_details;
|
||||
}
|
||||
return $self->{EXCEPTION};
|
||||
}
|
||||
|
||||
=item interval
|
||||
|
||||
$i = interval $t;
|
||||
$i = $t->interval;
|
||||
$t->interval( $i );
|
||||
|
||||
Sets the interval. Sets the end time based on the start_time() and the
|
||||
interval (and a little fudge) if the timer is running.
|
||||
|
||||
=cut
|
||||
|
||||
sub interval {
|
||||
my IPC::Run::Timer $self = shift;
|
||||
if (@_) {
|
||||
$self->{INTERVAL} = _parse_time(shift);
|
||||
_debug $self->name, ' interval set to ', $self->{INTERVAL}
|
||||
if $self->{DEBUG} > 2 || _debugging_details;
|
||||
|
||||
$self->_calc_end_time if $self->state;
|
||||
}
|
||||
return $self->{INTERVAL};
|
||||
}
|
||||
|
||||
=item expire
|
||||
|
||||
expire $t;
|
||||
$t->expire;
|
||||
|
||||
Sets the state to expired (undef).
|
||||
Will throw an exception if one
|
||||
is defined and the timer was not already expired. You can expire a
|
||||
reset timer without starting it.
|
||||
|
||||
=cut
|
||||
|
||||
sub expire {
|
||||
my IPC::Run::Timer $self = shift;
|
||||
if ( defined $self->state ) {
|
||||
_debug $self->name . ' expired'
|
||||
if $self->{DEBUG} || _debugging;
|
||||
|
||||
$self->state(undef);
|
||||
croak $self->exception if $self->exception;
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
|
||||
=item is_running
|
||||
|
||||
=cut
|
||||
|
||||
sub is_running {
|
||||
my IPC::Run::Timer $self = shift;
|
||||
return $self->state ? 1 : 0;
|
||||
}
|
||||
|
||||
=item is_reset
|
||||
|
||||
=cut
|
||||
|
||||
sub is_reset {
|
||||
my IPC::Run::Timer $self = shift;
|
||||
return defined $self->state && $self->state == 0;
|
||||
}
|
||||
|
||||
=item is_expired
|
||||
|
||||
=cut
|
||||
|
||||
sub is_expired {
|
||||
my IPC::Run::Timer $self = shift;
|
||||
return !defined $self->state;
|
||||
}
|
||||
|
||||
=item name
|
||||
|
||||
Sets/gets this timer's name. The name is only used for debugging
|
||||
purposes so you can tell which freakin' timer is doing what.
|
||||
|
||||
=cut
|
||||
|
||||
sub name {
|
||||
my IPC::Run::Timer $self = shift;
|
||||
|
||||
$self->{NAME} = shift if @_;
|
||||
return
|
||||
defined $self->{NAME} ? $self->{NAME}
|
||||
: defined $self->{EXCEPTION} ? 'timeout'
|
||||
: 'timer';
|
||||
}
|
||||
|
||||
=item reset
|
||||
|
||||
reset $t;
|
||||
$t->reset;
|
||||
|
||||
Resets the timer to the non-running, non-expired state and clears
|
||||
the end_time().
|
||||
|
||||
=cut
|
||||
|
||||
sub reset {
|
||||
my IPC::Run::Timer $self = shift;
|
||||
$self->state(0);
|
||||
$self->end_time(undef);
|
||||
_debug $self->name . ' reset'
|
||||
if $self->{DEBUG} || _debugging;
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
=item start
|
||||
|
||||
start $t;
|
||||
$t->start;
|
||||
start $t, $interval;
|
||||
start $t, $interval, $now;
|
||||
|
||||
Starts or restarts a timer. This always sets the start_time. It sets the
|
||||
end_time based on the interval if the timer is running or if no end time
|
||||
has been set.
|
||||
|
||||
You may pass an optional interval or current time value.
|
||||
|
||||
Not passing a defined interval causes the previous interval setting to be
|
||||
re-used unless the timer is reset and an end_time has been set
|
||||
(an exception is thrown if no interval has been set).
|
||||
|
||||
Not passing a defined current time value causes the current time to be used.
|
||||
|
||||
Passing a current time value is useful if you happen to have a time value
|
||||
lying around or if you want to make sure that several timers are started
|
||||
with the same concept of start time. You might even need to lie to an
|
||||
IPC::Run::Timer, occasionally.
|
||||
|
||||
=cut
|
||||
|
||||
sub start {
|
||||
my IPC::Run::Timer $self = shift;
|
||||
|
||||
my ( $interval, $now ) = map { _parse_time($_) } @_;
|
||||
$now = _parse_time($now);
|
||||
$now = time unless defined $now;
|
||||
|
||||
$self->interval($interval) if defined $interval;
|
||||
|
||||
## start()ing a running or expired timer clears the end_time, so that the
|
||||
## interval is used. So does specifying an interval.
|
||||
$self->end_time(undef) if !$self->is_reset || $interval;
|
||||
|
||||
croak "IPC::Run: no timer interval or end_time defined for " . $self->name
|
||||
unless defined $self->interval || defined $self->end_time;
|
||||
|
||||
$self->state(1);
|
||||
$self->start_time($now);
|
||||
## The "+ 1" is in case the START_TIME was sampled at the end of a
|
||||
## tick (which are one second long in this module).
|
||||
$self->_calc_end_time
|
||||
unless defined $self->end_time;
|
||||
|
||||
_debug(
|
||||
$self->name, " started at ", $self->start_time,
|
||||
", with interval ", $self->interval, ", end_time ", $self->end_time
|
||||
) if $self->{DEBUG} || _debugging;
|
||||
return undef;
|
||||
}
|
||||
|
||||
=item start_time
|
||||
|
||||
Sets/gets the start time, in seconds since the epoch. Setting this manually
|
||||
is a bad idea, it's better to call L</start>() at the correct time.
|
||||
|
||||
=cut
|
||||
|
||||
sub start_time {
|
||||
my IPC::Run::Timer $self = shift;
|
||||
if (@_) {
|
||||
$self->{START_TIME} = _parse_time(shift);
|
||||
_debug $self->name, ' start_time set to ', $self->{START_TIME}
|
||||
if $self->{DEBUG} > 2 || _debugging;
|
||||
}
|
||||
|
||||
return $self->{START_TIME};
|
||||
}
|
||||
|
||||
=item state
|
||||
|
||||
$s = state $t;
|
||||
$t->state( $s );
|
||||
|
||||
Get/Set the current state. Only use this if you really need to transfer the
|
||||
state to/from some variable.
|
||||
Use L</expire>, L</start>, L</reset>, L</is_expired>, L</is_running>,
|
||||
L</is_reset>.
|
||||
|
||||
Note: Setting the state to 'undef' to expire a timer will not throw an
|
||||
exception.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub state {
|
||||
my IPC::Run::Timer $self = shift;
|
||||
if (@_) {
|
||||
$self->{STATE} = shift;
|
||||
_debug $self->name, ' state set to ', $self->{STATE}
|
||||
if $self->{DEBUG} > 2 || _debugging;
|
||||
}
|
||||
return $self->{STATE};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 TODO
|
||||
|
||||
use Time::HiRes; if it's present.
|
||||
|
||||
Add detection and parsing of [[[HH:]MM:]SS formatted times and intervals.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Barrie Slaymaker <barries@slaysys.com>
|
||||
|
||||
=cut
|
||||
486
database/perl/vendor/lib/IPC/Run/Win32Helper.pm
vendored
Normal file
486
database/perl/vendor/lib/IPC/Run/Win32Helper.pm
vendored
Normal file
@@ -0,0 +1,486 @@
|
||||
package IPC::Run::Win32Helper;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
IPC::Run::Win32Helper - helper routines for IPC::Run on Win32 platforms.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use IPC::Run::Win32Helper; # Exports all by default
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
IPC::Run needs to use sockets to redirect subprocess I/O so that the select() loop
|
||||
will work on Win32. This seems to only work on WinNT and Win2K at this time, not
|
||||
sure if it will ever work on Win95 or Win98. If you have experience in this area, please
|
||||
contact me at barries@slaysys.com, thanks!.
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use Carp;
|
||||
use IO::Handle;
|
||||
use vars qw{ $VERSION @ISA @EXPORT };
|
||||
|
||||
BEGIN {
|
||||
$VERSION = '20200505.0';
|
||||
@ISA = qw( Exporter );
|
||||
@EXPORT = qw(
|
||||
win32_spawn
|
||||
win32_parse_cmd_line
|
||||
_dont_inherit
|
||||
_inherit
|
||||
);
|
||||
}
|
||||
|
||||
require POSIX;
|
||||
|
||||
use Text::ParseWords;
|
||||
use Win32::Process;
|
||||
use IPC::Run::Debug;
|
||||
use Win32API::File qw(
|
||||
FdGetOsFHandle
|
||||
SetHandleInformation
|
||||
HANDLE_FLAG_INHERIT
|
||||
INVALID_HANDLE_VALUE
|
||||
);
|
||||
|
||||
## Takes an fd or a GLOB ref, never never never a Win32 handle.
|
||||
sub _dont_inherit {
|
||||
for (@_) {
|
||||
next unless defined $_;
|
||||
my $fd = $_;
|
||||
$fd = fileno $fd if ref $fd;
|
||||
_debug "disabling inheritance of ", $fd if _debugging_details;
|
||||
my $osfh = FdGetOsFHandle $fd;
|
||||
croak $^E if !defined $osfh || $osfh == INVALID_HANDLE_VALUE;
|
||||
|
||||
SetHandleInformation( $osfh, HANDLE_FLAG_INHERIT, 0 );
|
||||
}
|
||||
}
|
||||
|
||||
sub _inherit { #### REMOVE
|
||||
for (@_) { #### REMOVE
|
||||
next unless defined $_; #### REMOVE
|
||||
my $fd = $_; #### REMOVE
|
||||
$fd = fileno $fd if ref $fd; #### REMOVE
|
||||
_debug "enabling inheritance of ", $fd if _debugging_details; #### REMOVE
|
||||
my $osfh = FdGetOsFHandle $fd; #### REMOVE
|
||||
croak $^E if !defined $osfh || $osfh == INVALID_HANDLE_VALUE; #### REMOVE
|
||||
#### REMOVE
|
||||
SetHandleInformation( $osfh, HANDLE_FLAG_INHERIT, 1 ); #### REMOVE
|
||||
} #### REMOVE
|
||||
} #### REMOVE
|
||||
#### REMOVE
|
||||
#sub _inherit {
|
||||
# for ( @_ ) {
|
||||
# next unless defined $_;
|
||||
# my $osfh = GetOsFHandle $_;
|
||||
# croak $^E if ! defined $osfh || $osfh == INVALID_HANDLE_VALUE;
|
||||
# SetHandleInformation( $osfh, HANDLE_FLAG_INHERIT, HANDLE_FLAG_INHERIT );
|
||||
# }
|
||||
#}
|
||||
|
||||
=pod
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
=over
|
||||
|
||||
=item optimize()
|
||||
|
||||
Most common incantations of C<run()> (I<not> C<harness()>, C<start()>,
|
||||
or C<finish()>) now use temporary files to redirect input and output
|
||||
instead of pumper processes.
|
||||
|
||||
Temporary files are used when sending to child processes if input is
|
||||
taken from a scalar with no filter subroutines. This is the only time
|
||||
we can assume that the parent is not interacting with the child's
|
||||
redirected input as it runs.
|
||||
|
||||
Temporary files are used when receiving from children when output is
|
||||
to a scalar or subroutine with or without filters, but only if
|
||||
the child in question closes its inputs or takes input from
|
||||
unfiltered SCALARs or named files. Normally, a child inherits its STDIN
|
||||
from its parent; to close it, use "0<&-" or the C<< noinherit => 1 >> option.
|
||||
If data is sent to the child from CODE refs, filehandles or from
|
||||
scalars through filters than the child's outputs will not be optimized
|
||||
because C<optimize()> assumes the parent is interacting with the child.
|
||||
It is ok if the output is filtered or handled by a subroutine, however.
|
||||
|
||||
This assumes that all named files are real files (as opposed to named
|
||||
pipes) and won't change; and that a process is not communicating with
|
||||
the child indirectly (through means not visible to IPC::Run).
|
||||
These can be an invalid assumptions, but are the 99% case.
|
||||
Write me if you need an option to enable or disable optimizations; I
|
||||
suspect it will work like the C<binary()> modifier.
|
||||
|
||||
To detect cases that you might want to optimize by closing inputs, try
|
||||
setting the C<IPCRUNDEBUG> environment variable to the special C<notopt>
|
||||
value:
|
||||
|
||||
C:> set IPCRUNDEBUG=notopt
|
||||
C:> my_app_that_uses_IPC_Run.pl
|
||||
|
||||
=item optimizer() rationalizations
|
||||
|
||||
Only for that limited case can we be sure that it's ok to batch all the
|
||||
input in to a temporary file. If STDIN is from a SCALAR or from a named
|
||||
file or filehandle (again, only in C<run()>), then outputs to CODE refs
|
||||
are also assumed to be safe enough to batch through a temp file,
|
||||
otherwise only outputs to SCALAR refs are batched. This can cause a bit
|
||||
of grief if the parent process benefits from or relies on a bit of
|
||||
"early returns" coming in before the child program exits. As long as
|
||||
the output is redirected to a SCALAR ref, this will not be visible.
|
||||
When output is redirected to a subroutine or (deprecated) filters, the
|
||||
subroutine will not get any data until after the child process exits,
|
||||
and it is likely to get bigger chunks of data at once.
|
||||
|
||||
The reason for the optimization is that, without it, "pumper" processes
|
||||
are used to overcome the inconsistencies of the Win32 API. We need to
|
||||
use anonymous pipes to connect to the child processes' stdin, stdout,
|
||||
and stderr, yet select() does not work on these. select() only works on
|
||||
sockets on Win32. So for each redirected child handle, there is
|
||||
normally a "pumper" process that connects to the parent using a
|
||||
socket--so the parent can select() on that fd--and to the child on an
|
||||
anonymous pipe--so the child can read/write a pipe.
|
||||
|
||||
Using a socket to connect directly to the child (as at least one MSDN
|
||||
article suggests) seems to cause the trailing output from most children
|
||||
to be lost. I think this is because child processes rarely close their
|
||||
stdout and stderr explicitly, and the winsock dll does not seem to flush
|
||||
output when a process that uses it exits without explicitly closing
|
||||
them.
|
||||
|
||||
Because of these pumpers and the inherent slowness of Win32
|
||||
CreateProcess(), child processes with redirects are quite slow to
|
||||
launch; so this routine looks for the very common case of
|
||||
reading/writing to/from scalar references in a run() routine and
|
||||
converts such reads and writes in to temporary file reads and writes.
|
||||
|
||||
Such files are marked as FILE_ATTRIBUTE_TEMPORARY to increase speed and
|
||||
as FILE_FLAG_DELETE_ON_CLOSE so it will be cleaned up when the child
|
||||
process exits (for input files). The user's default permissions are
|
||||
used for both the temporary files and the directory that contains them,
|
||||
hope your Win32 permissions are secure enough for you. Files are
|
||||
created with the Win32API::File defaults of
|
||||
FILE_SHARE_READ|FILE_SHARE_WRITE.
|
||||
|
||||
Setting the debug level to "details" or "gory" will give detailed
|
||||
information about the optimization process; setting it to "basic" or
|
||||
higher will tell whether or not a given call is optimized. Setting
|
||||
it to "notopt" will highlight those calls that aren't optimized.
|
||||
|
||||
=cut
|
||||
|
||||
sub optimize {
|
||||
my ($h) = @_;
|
||||
|
||||
my @kids = @{ $h->{KIDS} };
|
||||
|
||||
my $saw_pipe;
|
||||
|
||||
my ( $ok_to_optimize_outputs, $veto_output_optimization );
|
||||
|
||||
for my $kid (@kids) {
|
||||
( $ok_to_optimize_outputs, $veto_output_optimization ) = ()
|
||||
unless $saw_pipe;
|
||||
|
||||
_debug "Win32 optimizer: (kid $kid->{NUM}) STDIN piped, carrying over ok of non-SCALAR output optimization"
|
||||
if _debugging_details && $ok_to_optimize_outputs;
|
||||
_debug "Win32 optimizer: (kid $kid->{NUM}) STDIN piped, carrying over veto of non-SCALAR output optimization"
|
||||
if _debugging_details && $veto_output_optimization;
|
||||
|
||||
if ( $h->{noinherit} && !$ok_to_optimize_outputs ) {
|
||||
_debug "Win32 optimizer: (kid $kid->{NUM}) STDIN not inherited from parent oking non-SCALAR output optimization"
|
||||
if _debugging_details && $ok_to_optimize_outputs;
|
||||
$ok_to_optimize_outputs = 1;
|
||||
}
|
||||
|
||||
for ( @{ $kid->{OPS} } ) {
|
||||
if ( substr( $_->{TYPE}, 0, 1 ) eq "<" ) {
|
||||
if ( $_->{TYPE} eq "<" ) {
|
||||
if ( @{ $_->{FILTERS} } > 1 ) {
|
||||
## Can't assume that the filters are idempotent.
|
||||
}
|
||||
elsif (ref $_->{SOURCE} eq "SCALAR"
|
||||
|| ref $_->{SOURCE} eq "GLOB"
|
||||
|| UNIVERSAL::isa( $_, "IO::Handle" ) ) {
|
||||
if ( $_->{KFD} == 0 ) {
|
||||
_debug
|
||||
"Win32 optimizer: (kid $kid->{NUM}) 0$_->{TYPE}",
|
||||
ref $_->{SOURCE},
|
||||
", ok to optimize outputs"
|
||||
if _debugging_details;
|
||||
$ok_to_optimize_outputs = 1;
|
||||
}
|
||||
$_->{SEND_THROUGH_TEMP_FILE} = 1;
|
||||
next;
|
||||
}
|
||||
elsif ( !ref $_->{SOURCE} && defined $_->{SOURCE} ) {
|
||||
if ( $_->{KFD} == 0 ) {
|
||||
_debug
|
||||
"Win32 optimizer: (kid $kid->{NUM}) 0<$_->{SOURCE}, ok to optimize outputs",
|
||||
if _debugging_details;
|
||||
$ok_to_optimize_outputs = 1;
|
||||
}
|
||||
next;
|
||||
}
|
||||
}
|
||||
_debug
|
||||
"Win32 optimizer: (kid $kid->{NUM}) ",
|
||||
$_->{KFD},
|
||||
$_->{TYPE},
|
||||
defined $_->{SOURCE}
|
||||
? ref $_->{SOURCE}
|
||||
? ref $_->{SOURCE}
|
||||
: $_->{SOURCE}
|
||||
: defined $_->{FILENAME} ? $_->{FILENAME}
|
||||
: "",
|
||||
@{ $_->{FILTERS} } > 1 ? " with filters" : (),
|
||||
", VETOING output opt."
|
||||
if _debugging_details || _debugging_not_optimized;
|
||||
$veto_output_optimization = 1;
|
||||
}
|
||||
elsif ( $_->{TYPE} eq "close" && $_->{KFD} == 0 ) {
|
||||
$ok_to_optimize_outputs = 1;
|
||||
_debug "Win32 optimizer: (kid $kid->{NUM}) saw 0<&-, ok to optimize outputs"
|
||||
if _debugging_details;
|
||||
}
|
||||
elsif ( $_->{TYPE} eq "dup" && $_->{KFD2} == 0 ) {
|
||||
$veto_output_optimization = 1;
|
||||
_debug "Win32 optimizer: (kid $kid->{NUM}) saw 0<&$_->{KFD2}, VETOING output opt."
|
||||
if _debugging_details || _debugging_not_optimized;
|
||||
}
|
||||
elsif ( $_->{TYPE} eq "|" ) {
|
||||
$saw_pipe = 1;
|
||||
}
|
||||
}
|
||||
|
||||
if ( !$ok_to_optimize_outputs && !$veto_output_optimization ) {
|
||||
_debug "Win32 optimizer: (kid $kid->{NUM}) child STDIN not redirected, VETOING non-SCALAR output opt."
|
||||
if _debugging_details || _debugging_not_optimized;
|
||||
$veto_output_optimization = 1;
|
||||
}
|
||||
|
||||
if ( $ok_to_optimize_outputs && $veto_output_optimization ) {
|
||||
$ok_to_optimize_outputs = 0;
|
||||
_debug "Win32 optimizer: (kid $kid->{NUM}) non-SCALAR output optimizations VETOed"
|
||||
if _debugging_details || _debugging_not_optimized;
|
||||
}
|
||||
|
||||
## SOURCE/DEST ARRAY means it's a filter.
|
||||
## TODO: think about checking to see if the final input/output of
|
||||
## a filter chain (an ARRAY SOURCE or DEST) is a scalar...but
|
||||
## we may be deprecating filters.
|
||||
|
||||
for ( @{ $kid->{OPS} } ) {
|
||||
if ( $_->{TYPE} eq ">" ) {
|
||||
if (
|
||||
ref $_->{DEST} eq "SCALAR"
|
||||
|| (
|
||||
(
|
||||
@{ $_->{FILTERS} } > 1
|
||||
|| ref $_->{DEST} eq "CODE"
|
||||
|| ref $_->{DEST} eq "ARRAY" ## Filters?
|
||||
)
|
||||
&& ( $ok_to_optimize_outputs && !$veto_output_optimization )
|
||||
)
|
||||
) {
|
||||
$_->{RECV_THROUGH_TEMP_FILE} = 1;
|
||||
next;
|
||||
}
|
||||
_debug
|
||||
"Win32 optimizer: NOT optimizing (kid $kid->{NUM}) ",
|
||||
$_->{KFD},
|
||||
$_->{TYPE},
|
||||
defined $_->{DEST}
|
||||
? ref $_->{DEST}
|
||||
? ref $_->{DEST}
|
||||
: $_->{SOURCE}
|
||||
: defined $_->{FILENAME} ? $_->{FILENAME}
|
||||
: "",
|
||||
@{ $_->{FILTERS} } ? " with filters" : (),
|
||||
if _debugging_details;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=item win32_parse_cmd_line
|
||||
|
||||
@words = win32_parse_cmd_line( q{foo bar 'baz baz' "bat bat"} );
|
||||
|
||||
returns 4 words. This parses like the bourne shell (see
|
||||
the bit about shellwords() in L<Text::ParseWords>), assuming we're
|
||||
trying to be a little cross-platform here. The only difference is
|
||||
that "\" is *not* treated as an escape except when it precedes
|
||||
punctuation, since it's used all over the place in DOS path specs.
|
||||
|
||||
TODO: globbing? probably not (it's unDOSish).
|
||||
|
||||
TODO: shebang emulation? Probably, but perhaps that should be part
|
||||
of Run.pm so all spawned processes get the benefit.
|
||||
|
||||
LIMITATIONS: shellwords dies silently on malformed input like
|
||||
|
||||
a\"
|
||||
|
||||
=cut
|
||||
|
||||
sub win32_parse_cmd_line {
|
||||
my $line = shift;
|
||||
$line =~ s{(\\[\w\s])}{\\$1}g;
|
||||
return shellwords $line;
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=item win32_spawn
|
||||
|
||||
Spawns a child process, possibly with STDIN, STDOUT, and STDERR (file descriptors 0, 1, and 2, respectively) redirected.
|
||||
|
||||
B<LIMITATIONS>.
|
||||
|
||||
Cannot redirect higher file descriptors due to lack of support for this in the
|
||||
Win32 environment.
|
||||
|
||||
This can be worked around by marking a handle as inheritable in the
|
||||
parent (or leaving it marked; this is the default in perl), obtaining it's
|
||||
Win32 handle with C<Win32API::GetOSFHandle(FH)> or
|
||||
C<Win32API::FdGetOsFHandle($fd)> and passing it to the child using the command
|
||||
line, the environment, or any other IPC mechanism (it's a plain old integer).
|
||||
The child can then use C<OsFHandleOpen()> or C<OsFHandleOpenFd()> and possibly
|
||||
C<<open FOO ">&BAR">> or C<<open FOO ">&$fd>> as need be. Ach, the pain!
|
||||
|
||||
Remember to check the Win32 handle against INVALID_HANDLE_VALUE.
|
||||
|
||||
=cut
|
||||
|
||||
sub _save {
|
||||
my ( $saved, $saved_as, $fd ) = @_;
|
||||
|
||||
## We can only save aside the original fds once.
|
||||
return if exists $saved->{$fd};
|
||||
|
||||
my $saved_fd = IPC::Run::_dup($fd);
|
||||
_dont_inherit $saved_fd;
|
||||
|
||||
$saved->{$fd} = $saved_fd;
|
||||
$saved_as->{$saved_fd} = $fd;
|
||||
|
||||
_dont_inherit $saved->{$fd};
|
||||
}
|
||||
|
||||
sub _dup2_gently {
|
||||
my ( $saved, $saved_as, $fd1, $fd2 ) = @_;
|
||||
_save $saved, $saved_as, $fd2;
|
||||
|
||||
if ( exists $saved_as->{$fd2} ) {
|
||||
## The target fd is colliding with a saved-as fd, gotta bump
|
||||
## the saved-as fd to another fd.
|
||||
my $orig_fd = delete $saved_as->{$fd2};
|
||||
my $saved_fd = IPC::Run::_dup($fd2);
|
||||
_dont_inherit $saved_fd;
|
||||
|
||||
$saved->{$orig_fd} = $saved_fd;
|
||||
$saved_as->{$saved_fd} = $orig_fd;
|
||||
}
|
||||
_debug "moving $fd1 to kid's $fd2" if _debugging_details;
|
||||
IPC::Run::_dup2_rudely( $fd1, $fd2 );
|
||||
}
|
||||
|
||||
sub win32_spawn {
|
||||
my ( $cmd, $ops ) = @_;
|
||||
|
||||
## NOTE: The debug pipe write handle is passed to pump processes as STDOUT.
|
||||
## and is not to the "real" child process, since they would not know
|
||||
## what to do with it...unlike Unix, we have no code executing in the
|
||||
## child before the "real" child is exec()ed.
|
||||
|
||||
my %saved; ## Map of parent's orig fd -> saved fd
|
||||
my %saved_as; ## Map of parent's saved fd -> orig fd, used to
|
||||
## detect collisions between a KFD and the fd a
|
||||
## parent's fd happened to be saved to.
|
||||
|
||||
for my $op (@$ops) {
|
||||
_dont_inherit $op->{FD} if defined $op->{FD};
|
||||
|
||||
if ( defined $op->{KFD} && $op->{KFD} > 2 ) {
|
||||
## TODO: Detect this in harness()
|
||||
## TODO: enable temporary redirections if ever necessary, not
|
||||
## sure why they would be...
|
||||
## 4>&1 1>/dev/null 1>&4 4>&-
|
||||
croak "Can't redirect fd #", $op->{KFD}, " on Win32";
|
||||
}
|
||||
|
||||
## This is very similar logic to IPC::Run::_do_kid_and_exit().
|
||||
if ( defined $op->{TFD} ) {
|
||||
unless ( $op->{TFD} == $op->{KFD} ) {
|
||||
_dup2_gently \%saved, \%saved_as, $op->{TFD}, $op->{KFD};
|
||||
_dont_inherit $op->{TFD};
|
||||
}
|
||||
}
|
||||
elsif ( $op->{TYPE} eq "dup" ) {
|
||||
_dup2_gently \%saved, \%saved_as, $op->{KFD1}, $op->{KFD2}
|
||||
unless $op->{KFD1} == $op->{KFD2};
|
||||
}
|
||||
elsif ( $op->{TYPE} eq "close" ) {
|
||||
_save \%saved, \%saved_as, $op->{KFD};
|
||||
IPC::Run::_close( $op->{KFD} );
|
||||
}
|
||||
elsif ( $op->{TYPE} eq "init" ) {
|
||||
## TODO: detect this in harness()
|
||||
croak "init subs not allowed on Win32";
|
||||
}
|
||||
}
|
||||
|
||||
my $process;
|
||||
my $cmd_line = join " ", map {
|
||||
( my $s = $_ ) =~ s/"/"""/g;
|
||||
$s = qq{"$s"} if /[\"\s]|^$/;
|
||||
$s;
|
||||
} @$cmd;
|
||||
|
||||
_debug "cmd line: ", $cmd_line
|
||||
if _debugging;
|
||||
|
||||
Win32::Process::Create(
|
||||
$process,
|
||||
$cmd->[0],
|
||||
$cmd_line,
|
||||
1, ## Inherit handles
|
||||
0, ## Inherit parent priortiy class. Was NORMAL_PRIORITY_CLASS
|
||||
".",
|
||||
) or croak "$!: Win32::Process::Create()";
|
||||
|
||||
for my $orig_fd ( keys %saved ) {
|
||||
IPC::Run::_dup2_rudely( $saved{$orig_fd}, $orig_fd );
|
||||
IPC::Run::_close( $saved{$orig_fd} );
|
||||
}
|
||||
|
||||
return ( $process->GetProcessID(), $process );
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Barries Slaymaker <barries@slaysys.com>. Funded by Perforce Software, Inc.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 2001, Barrie Slaymaker, All Rights Reserved.
|
||||
|
||||
You may use this under the terms of either the GPL 2.0 or the Artistic License.
|
||||
|
||||
=cut
|
||||
551
database/perl/vendor/lib/IPC/Run/Win32IO.pm
vendored
Normal file
551
database/perl/vendor/lib/IPC/Run/Win32IO.pm
vendored
Normal file
@@ -0,0 +1,551 @@
|
||||
package IPC::Run::Win32IO;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
IPC::Run::Win32IO - helper routines for IPC::Run on Win32 platforms.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use IPC::Run::Win32IO; # Exports all by default
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
IPC::Run needs to use sockets to redirect subprocess I/O so that the select()
|
||||
loop will work on Win32. This seems to only work on WinNT and Win2K at this
|
||||
time, not sure if it will ever work on Win95 or Win98. If you have experience
|
||||
in this area, please contact me at barries@slaysys.com, thanks!.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
A specialized IO class used on Win32.
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use Carp;
|
||||
use IO::Handle;
|
||||
use Socket;
|
||||
require POSIX;
|
||||
|
||||
use vars qw{$VERSION};
|
||||
|
||||
BEGIN {
|
||||
$VERSION = '20200505.0';
|
||||
}
|
||||
|
||||
use Socket qw( IPPROTO_TCP TCP_NODELAY );
|
||||
use Symbol;
|
||||
use Text::ParseWords;
|
||||
use Win32::Process;
|
||||
use IPC::Run::Debug qw( :default _debugging_level );
|
||||
use IPC::Run::Win32Helper qw( _inherit _dont_inherit );
|
||||
use Fcntl qw( O_TEXT O_RDONLY );
|
||||
|
||||
use base qw( IPC::Run::IO );
|
||||
my @cleanup_fields;
|
||||
|
||||
BEGIN {
|
||||
## These fields will be set to undef in _cleanup to close
|
||||
## the handles.
|
||||
@cleanup_fields = (
|
||||
'SEND_THROUGH_TEMP_FILE', ## Set by WinHelper::optimize()
|
||||
'RECV_THROUGH_TEMP_FILE', ## Set by WinHelper::optimize()
|
||||
'TEMP_FILE_NAME', ## The name of the temp file, needed for
|
||||
## error reporting / debugging only.
|
||||
|
||||
'PARENT_HANDLE', ## The handle of the socket for the parent
|
||||
'PUMP_SOCKET_HANDLE', ## The socket handle for the pump
|
||||
'PUMP_PIPE_HANDLE', ## The anon pipe handle for the pump
|
||||
'CHILD_HANDLE', ## The anon pipe handle for the child
|
||||
|
||||
'TEMP_FILE_HANDLE', ## The Win32 filehandle for the temp file
|
||||
);
|
||||
}
|
||||
|
||||
## REMOVE OSFHandleOpen
|
||||
use Win32API::File qw(
|
||||
GetOsFHandle
|
||||
OsFHandleOpenFd
|
||||
OsFHandleOpen
|
||||
FdGetOsFHandle
|
||||
SetHandleInformation
|
||||
SetFilePointer
|
||||
HANDLE_FLAG_INHERIT
|
||||
INVALID_HANDLE_VALUE
|
||||
|
||||
createFile
|
||||
WriteFile
|
||||
ReadFile
|
||||
CloseHandle
|
||||
|
||||
FILE_ATTRIBUTE_TEMPORARY
|
||||
FILE_FLAG_DELETE_ON_CLOSE
|
||||
FILE_FLAG_WRITE_THROUGH
|
||||
|
||||
FILE_BEGIN
|
||||
);
|
||||
|
||||
# FILE_ATTRIBUTE_HIDDEN
|
||||
# FILE_ATTRIBUTE_SYSTEM
|
||||
|
||||
BEGIN {
|
||||
## Force AUTOLOADED constants to be, well, constant by getting them
|
||||
## to AUTOLOAD before compilation continues. Sigh.
|
||||
() = (
|
||||
SOL_SOCKET,
|
||||
SO_REUSEADDR,
|
||||
IPPROTO_TCP,
|
||||
TCP_NODELAY,
|
||||
HANDLE_FLAG_INHERIT,
|
||||
INVALID_HANDLE_VALUE,
|
||||
);
|
||||
}
|
||||
|
||||
use constant temp_file_flags => ( FILE_ATTRIBUTE_TEMPORARY() | FILE_FLAG_DELETE_ON_CLOSE() | FILE_FLAG_WRITE_THROUGH() );
|
||||
|
||||
# FILE_ATTRIBUTE_HIDDEN() |
|
||||
# FILE_ATTRIBUTE_SYSTEM() |
|
||||
my $tmp_file_counter;
|
||||
my $tmp_dir;
|
||||
|
||||
sub _cleanup {
|
||||
my IPC::Run::Win32IO $self = shift;
|
||||
my ($harness) = @_;
|
||||
|
||||
$self->_recv_through_temp_file($harness)
|
||||
if $self->{RECV_THROUGH_TEMP_FILE};
|
||||
|
||||
CloseHandle( $self->{TEMP_FILE_HANDLE} )
|
||||
if defined $self->{TEMP_FILE_HANDLE};
|
||||
|
||||
close( $self->{CHILD_HANDLE} )
|
||||
if defined $self->{CHILD_HANDLE};
|
||||
|
||||
$self->{$_} = undef for @cleanup_fields;
|
||||
}
|
||||
|
||||
sub _create_temp_file {
|
||||
my IPC::Run::Win32IO $self = shift;
|
||||
|
||||
## Create a hidden temp file that Win32 will delete when we close
|
||||
## it.
|
||||
unless ( defined $tmp_dir ) {
|
||||
$tmp_dir = File::Spec->catdir( File::Spec->tmpdir, "IPC-Run.tmp" );
|
||||
|
||||
## Trust in the user's umask.
|
||||
## This could possibly be a security hole, perhaps
|
||||
## we should offer an option. Hmmmm, really, people coding
|
||||
## security conscious apps should audit this code and
|
||||
## tell me how to make it better. Nice cop-out :).
|
||||
unless ( -d $tmp_dir ) {
|
||||
mkdir $tmp_dir or croak "$!: $tmp_dir";
|
||||
}
|
||||
}
|
||||
|
||||
$self->{TEMP_FILE_NAME} = File::Spec->catfile(
|
||||
## File name is designed for easy sorting and not conflicting
|
||||
## with other processes. This should allow us to use "t"runcate
|
||||
## access in CreateFile in case something left some droppings
|
||||
## around (which should never happen because we specify
|
||||
## FLAG_DELETE_ON_CLOSE.
|
||||
## heh, belt and suspenders are better than bug reports; God forbid
|
||||
## that NT should ever crash before a temp file gets deleted!
|
||||
$tmp_dir, sprintf "Win32io-%06d-%08d", $$, $tmp_file_counter++
|
||||
);
|
||||
|
||||
$self->{TEMP_FILE_HANDLE} = createFile(
|
||||
$self->{TEMP_FILE_NAME},
|
||||
"trw", ## new, truncate, read, write
|
||||
{
|
||||
Flags => temp_file_flags,
|
||||
},
|
||||
) or croak "Can't create temporary file, $self->{TEMP_FILE_NAME}: $^E";
|
||||
|
||||
$self->{TFD} = OsFHandleOpenFd $self->{TEMP_FILE_HANDLE}, 0;
|
||||
$self->{FD} = undef;
|
||||
|
||||
_debug
|
||||
"Win32 Optimizer: temp file (",
|
||||
$self->{KFD},
|
||||
$self->{TYPE},
|
||||
$self->{TFD},
|
||||
", fh ",
|
||||
$self->{TEMP_FILE_HANDLE},
|
||||
"): ",
|
||||
$self->{TEMP_FILE_NAME}
|
||||
if _debugging_details;
|
||||
}
|
||||
|
||||
sub _reset_temp_file_pointer {
|
||||
my $self = shift;
|
||||
SetFilePointer( $self->{TEMP_FILE_HANDLE}, 0, 0, FILE_BEGIN )
|
||||
or confess "$^E seeking on (fd $self->{TFD}) $self->{TEMP_FILE_NAME} for kid's fd $self->{KFD}";
|
||||
}
|
||||
|
||||
sub _send_through_temp_file {
|
||||
my IPC::Run::Win32IO $self = shift;
|
||||
|
||||
_debug "Win32 optimizer: optimizing " . " $self->{KFD} $self->{TYPE} temp file instead of ",
|
||||
ref $self->{SOURCE} || $self->{SOURCE}
|
||||
if _debugging_details;
|
||||
|
||||
$self->_create_temp_file;
|
||||
|
||||
if ( defined ${ $self->{SOURCE} } ) {
|
||||
my $bytes_written = 0;
|
||||
my $data_ref;
|
||||
if ( $self->binmode ) {
|
||||
$data_ref = $self->{SOURCE};
|
||||
}
|
||||
else {
|
||||
my $data = ${ $self->{SOURCE} }; # Ugh, a copy.
|
||||
$data =~ s/(?<!\r)\n/\r\n/g;
|
||||
$data_ref = \$data;
|
||||
}
|
||||
|
||||
WriteFile(
|
||||
$self->{TEMP_FILE_HANDLE},
|
||||
$$data_ref,
|
||||
0, ## Write entire buffer
|
||||
$bytes_written,
|
||||
[], ## Not overlapped.
|
||||
) or croak "$^E writing $self->{TEMP_FILE_NAME} for kid to read on fd $self->{KFD}";
|
||||
_debug "Win32 optimizer: wrote $bytes_written to temp file $self->{TEMP_FILE_NAME}"
|
||||
if _debugging_data;
|
||||
|
||||
$self->_reset_temp_file_pointer;
|
||||
|
||||
}
|
||||
|
||||
_debug "Win32 optimizer: kid to read $self->{KFD} from temp file on $self->{TFD}"
|
||||
if _debugging_details;
|
||||
}
|
||||
|
||||
sub _init_recv_through_temp_file {
|
||||
my IPC::Run::Win32IO $self = shift;
|
||||
|
||||
$self->_create_temp_file;
|
||||
}
|
||||
|
||||
## TODO: Use the Win32 API in the select loop to see if the file has grown
|
||||
## and read it incrementally if it has.
|
||||
sub _recv_through_temp_file {
|
||||
my IPC::Run::Win32IO $self = shift;
|
||||
|
||||
## This next line kicks in if the run() never got to initting things
|
||||
## and needs to clean up.
|
||||
return undef unless defined $self->{TEMP_FILE_HANDLE};
|
||||
|
||||
push @{ $self->{FILTERS} }, sub {
|
||||
my ( undef, $out_ref ) = @_;
|
||||
|
||||
return undef unless defined $self->{TEMP_FILE_HANDLE};
|
||||
|
||||
my $r;
|
||||
my $s;
|
||||
ReadFile(
|
||||
$self->{TEMP_FILE_HANDLE},
|
||||
$s,
|
||||
999_999, ## Hmmm, should read the size.
|
||||
$r,
|
||||
[]
|
||||
) or croak "$^E reading from $self->{TEMP_FILE_NAME}";
|
||||
|
||||
_debug "ReadFile( $self->{TFD} ) = $r chars '$s'" if _debugging_data;
|
||||
|
||||
return undef unless $r;
|
||||
|
||||
$s =~ s/\r\n/\n/g unless $self->binmode;
|
||||
|
||||
my $pos = pos $$out_ref;
|
||||
$$out_ref .= $s;
|
||||
pos($out_ref) = $pos;
|
||||
return 1;
|
||||
};
|
||||
|
||||
my ($harness) = @_;
|
||||
|
||||
$self->_reset_temp_file_pointer;
|
||||
|
||||
1 while $self->_do_filters($harness);
|
||||
|
||||
pop @{ $self->{FILTERS} };
|
||||
|
||||
IPC::Run::_close( $self->{TFD} );
|
||||
}
|
||||
|
||||
=head1 SUBROUTINES
|
||||
|
||||
=over
|
||||
|
||||
=item poll
|
||||
|
||||
Windows version of IPC::Run::IP::poll.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub poll {
|
||||
my IPC::Run::Win32IO $self = shift;
|
||||
|
||||
return if $self->{SEND_THROUGH_TEMP_FILE} || $self->{RECV_THROUGH_TEMP_FILE};
|
||||
|
||||
return $self->SUPER::poll(@_);
|
||||
}
|
||||
|
||||
## When threaded Perls get good enough, we should use threads here.
|
||||
## The problem with threaded perls is that they dup() all sorts of
|
||||
## filehandles and fds and don't allow sufficient control over
|
||||
## closing off the ones we don't want.
|
||||
|
||||
sub _spawn_pumper {
|
||||
my ( $stdin, $stdout, $debug_fd, $binmode, $child_label, @opts ) = @_;
|
||||
my ( $stdin_fd, $stdout_fd ) = ( fileno $stdin, fileno $stdout );
|
||||
|
||||
_debug "pumper stdin = ", $stdin_fd if _debugging_details;
|
||||
_debug "pumper stdout = ", $stdout_fd if _debugging_details;
|
||||
_inherit $stdin_fd, $stdout_fd, $debug_fd;
|
||||
my @I_options = map qq{"-I$_"}, @INC;
|
||||
|
||||
my $cmd_line = join(
|
||||
" ",
|
||||
qq{"$^X"},
|
||||
@I_options,
|
||||
qw(-MIPC::Run::Win32Pump -e 1 ),
|
||||
## I'm using this clunky way of passing filehandles to the child process
|
||||
## in order to avoid some kind of premature closure of filehandles
|
||||
## problem I was having with VCP's test suite when passing them
|
||||
## via CreateProcess. All of the ## REMOVE code is stuff I'd like
|
||||
## to be rid of and the ## ADD code is what I'd like to use.
|
||||
FdGetOsFHandle($stdin_fd), ## REMOVE
|
||||
FdGetOsFHandle($stdout_fd), ## REMOVE
|
||||
FdGetOsFHandle($debug_fd), ## REMOVE
|
||||
$binmode ? 1 : 0,
|
||||
$$, $^T, _debugging_level, qq{"$child_label"},
|
||||
@opts
|
||||
);
|
||||
|
||||
# open SAVEIN, "<&STDIN" or croak "$! saving STDIN"; #### ADD
|
||||
# open SAVEOUT, ">&STDOUT" or croak "$! saving STDOUT"; #### ADD
|
||||
# open SAVEERR, ">&STDERR" or croak "$! saving STDERR"; #### ADD
|
||||
# _dont_inherit \*SAVEIN; #### ADD
|
||||
# _dont_inherit \*SAVEOUT; #### ADD
|
||||
# _dont_inherit \*SAVEERR; #### ADD
|
||||
# open STDIN, "<&$stdin_fd" or croak "$! dup2()ing $stdin_fd (pumper's STDIN)"; #### ADD
|
||||
# open STDOUT, ">&$stdout_fd" or croak "$! dup2()ing $stdout_fd (pumper's STDOUT)"; #### ADD
|
||||
# open STDERR, ">&$debug_fd" or croak "$! dup2()ing $debug_fd (pumper's STDERR/debug_fd)"; #### ADD
|
||||
|
||||
_debug "pump cmd line: ", $cmd_line if _debugging_details;
|
||||
|
||||
my $process;
|
||||
Win32::Process::Create(
|
||||
$process,
|
||||
$^X,
|
||||
$cmd_line,
|
||||
1, ## Inherit handles
|
||||
NORMAL_PRIORITY_CLASS,
|
||||
".",
|
||||
) or croak "$!: Win32::Process::Create()";
|
||||
|
||||
# open STDIN, "<&SAVEIN" or croak "$! restoring STDIN"; #### ADD
|
||||
# open STDOUT, ">&SAVEOUT" or croak "$! restoring STDOUT"; #### ADD
|
||||
# open STDERR, ">&SAVEERR" or croak "$! restoring STDERR"; #### ADD
|
||||
# close SAVEIN or croak "$! closing SAVEIN"; #### ADD
|
||||
# close SAVEOUT or croak "$! closing SAVEOUT"; #### ADD
|
||||
# close SAVEERR or croak "$! closing SAVEERR"; #### ADD
|
||||
|
||||
close $stdin or croak "$! closing pumper's stdin in parent";
|
||||
close $stdout or croak "$! closing pumper's stdout in parent";
|
||||
|
||||
# Don't close $debug_fd, we need it, as do other pumpers.
|
||||
|
||||
# Pause a moment to allow the child to get up and running and emit
|
||||
# debug messages. This does not always work.
|
||||
# select undef, undef, undef, 1 if _debugging_details;
|
||||
|
||||
_debug "_spawn_pumper pid = ", $process->GetProcessID
|
||||
if _debugging_data;
|
||||
}
|
||||
|
||||
my $loopback = inet_aton "127.0.0.1";
|
||||
my $tcp_proto = getprotobyname('tcp');
|
||||
croak "$!: getprotobyname('tcp')" unless defined $tcp_proto;
|
||||
|
||||
sub _socket {
|
||||
my ($server) = @_;
|
||||
$server ||= gensym;
|
||||
my $client = gensym;
|
||||
|
||||
my $listener = gensym;
|
||||
socket $listener, PF_INET, SOCK_STREAM, $tcp_proto
|
||||
or croak "$!: socket()";
|
||||
setsockopt $listener, SOL_SOCKET, SO_REUSEADDR, pack( "l", 0 )
|
||||
or croak "$!: setsockopt()";
|
||||
|
||||
unless ( bind $listener, sockaddr_in( 0, $loopback ) ) {
|
||||
croak "Error binding: $!";
|
||||
}
|
||||
|
||||
my ($port) = sockaddr_in( getsockname($listener) );
|
||||
|
||||
_debug "win32 port = $port" if _debugging_details;
|
||||
|
||||
listen $listener, my $queue_size = 1
|
||||
or croak "$!: listen()";
|
||||
|
||||
{
|
||||
socket $client, PF_INET, SOCK_STREAM, $tcp_proto
|
||||
or croak "$!: socket()";
|
||||
|
||||
my $paddr = sockaddr_in( $port, $loopback );
|
||||
|
||||
connect $client, $paddr
|
||||
or croak "$!: connect()";
|
||||
|
||||
croak "$!: accept" unless defined $paddr;
|
||||
|
||||
## The windows "default" is SO_DONTLINGER, which should make
|
||||
## sure all socket data goes through. I have my doubts based
|
||||
## on experimentation, but nothing prompts me to set SO_LINGER
|
||||
## at this time...
|
||||
setsockopt $client, IPPROTO_TCP, TCP_NODELAY, pack( "l", 0 )
|
||||
or croak "$!: setsockopt()";
|
||||
}
|
||||
|
||||
{
|
||||
_debug "accept()ing on port $port" if _debugging_details;
|
||||
my $paddr = accept( $server, $listener );
|
||||
croak "$!: accept()" unless defined $paddr;
|
||||
}
|
||||
|
||||
_debug "win32 _socket = ( ", fileno $server, ", ", fileno $client, " ) on port $port"
|
||||
if _debugging_details;
|
||||
return ( $server, $client );
|
||||
}
|
||||
|
||||
sub _open_socket_pipe {
|
||||
my IPC::Run::Win32IO $self = shift;
|
||||
my ( $debug_fd, $parent_handle ) = @_;
|
||||
|
||||
my $is_send_to_child = $self->dir eq "<";
|
||||
|
||||
$self->{CHILD_HANDLE} = gensym;
|
||||
$self->{PUMP_PIPE_HANDLE} = gensym;
|
||||
|
||||
(
|
||||
$self->{PARENT_HANDLE},
|
||||
$self->{PUMP_SOCKET_HANDLE}
|
||||
) = _socket $parent_handle;
|
||||
|
||||
## These binmodes seem to have no effect on Win2K, but just to be safe
|
||||
## I do them.
|
||||
binmode $self->{PARENT_HANDLE} or die $!;
|
||||
binmode $self->{PUMP_SOCKET_HANDLE} or die $!;
|
||||
|
||||
_debug "PUMP_SOCKET_HANDLE = ", fileno $self->{PUMP_SOCKET_HANDLE}
|
||||
if _debugging_details;
|
||||
##my $buf;
|
||||
##$buf = "write on child end of " . fileno( $self->{WRITE_HANDLE} ) . "\n\n\n\n\n";
|
||||
##POSIX::write(fileno $self->{WRITE_HANDLE}, $buf, length $buf) or warn "$! in syswrite";
|
||||
##$buf = "write on parent end of " . fileno( $self->{CHILD_HANDLE} ) . "\r\n";
|
||||
##POSIX::write(fileno $self->{CHILD_HANDLE},$buf, length $buf) or warn "$! in syswrite";
|
||||
## $self->{CHILD_HANDLE}->autoflush( 1 );
|
||||
## $self->{WRITE_HANDLE}->autoflush( 1 );
|
||||
|
||||
## Now fork off a data pump and arrange to return the correct fds.
|
||||
if ($is_send_to_child) {
|
||||
pipe $self->{CHILD_HANDLE}, $self->{PUMP_PIPE_HANDLE}
|
||||
or croak "$! opening child pipe";
|
||||
_debug "CHILD_HANDLE = ", fileno $self->{CHILD_HANDLE}
|
||||
if _debugging_details;
|
||||
_debug "PUMP_PIPE_HANDLE = ", fileno $self->{PUMP_PIPE_HANDLE}
|
||||
if _debugging_details;
|
||||
}
|
||||
else {
|
||||
pipe $self->{PUMP_PIPE_HANDLE}, $self->{CHILD_HANDLE}
|
||||
or croak "$! opening child pipe";
|
||||
_debug "CHILD_HANDLE = ", fileno $self->{CHILD_HANDLE}
|
||||
if _debugging_details;
|
||||
_debug "PUMP_PIPE_HANDLE = ", fileno $self->{PUMP_PIPE_HANDLE}
|
||||
if _debugging_details;
|
||||
}
|
||||
|
||||
## These binmodes seem to have no effect on Win2K, but just to be safe
|
||||
## I do them.
|
||||
binmode $self->{CHILD_HANDLE};
|
||||
binmode $self->{PUMP_PIPE_HANDLE};
|
||||
|
||||
## No child should ever see this.
|
||||
_dont_inherit $self->{PARENT_HANDLE};
|
||||
|
||||
## We clear the inherit flag so these file descriptors are not inherited.
|
||||
## It'll be dup()ed on to STDIN/STDOUT/STDERR before CreateProcess is
|
||||
## called and *that* fd will be inheritable.
|
||||
_dont_inherit $self->{PUMP_SOCKET_HANDLE};
|
||||
_dont_inherit $self->{PUMP_PIPE_HANDLE};
|
||||
_dont_inherit $self->{CHILD_HANDLE};
|
||||
|
||||
## Need to return $self so the HANDLEs don't get freed.
|
||||
## Return $self, $parent_fd, $child_fd
|
||||
my ( $parent_fd, $child_fd ) = (
|
||||
fileno $self->{PARENT_HANDLE},
|
||||
fileno $self->{CHILD_HANDLE}
|
||||
);
|
||||
|
||||
## Both PUMP_..._HANDLEs will be closed, no need to worry about
|
||||
## inheritance.
|
||||
_debug "binmode on" if _debugging_data && $self->binmode;
|
||||
_spawn_pumper(
|
||||
$is_send_to_child
|
||||
? ( $self->{PUMP_SOCKET_HANDLE}, $self->{PUMP_PIPE_HANDLE} )
|
||||
: ( $self->{PUMP_PIPE_HANDLE}, $self->{PUMP_SOCKET_HANDLE} ),
|
||||
$debug_fd,
|
||||
$self->binmode,
|
||||
$child_fd . $self->dir . "pump" . $self->dir . $parent_fd,
|
||||
);
|
||||
|
||||
{
|
||||
my $foo;
|
||||
confess "PARENT_HANDLE no longer open"
|
||||
unless POSIX::read( $parent_fd, $foo, 0 );
|
||||
}
|
||||
|
||||
_debug "win32_fake_pipe = ( $parent_fd, $child_fd )"
|
||||
if _debugging_details;
|
||||
|
||||
$self->{FD} = $parent_fd;
|
||||
$self->{TFD} = $child_fd;
|
||||
}
|
||||
|
||||
sub _do_open {
|
||||
my IPC::Run::Win32IO $self = shift;
|
||||
|
||||
if ( $self->{SEND_THROUGH_TEMP_FILE} ) {
|
||||
return $self->_send_through_temp_file(@_);
|
||||
}
|
||||
elsif ( $self->{RECV_THROUGH_TEMP_FILE} ) {
|
||||
return $self->_init_recv_through_temp_file(@_);
|
||||
}
|
||||
else {
|
||||
return $self->_open_socket_pipe(@_);
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Barries Slaymaker <barries@slaysys.com>. Funded by Perforce Software, Inc.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 2001, Barrie Slaymaker, All Rights Reserved.
|
||||
|
||||
You may use this under the terms of either the GPL 2.0 or the Artistic License.
|
||||
|
||||
=cut
|
||||
173
database/perl/vendor/lib/IPC/Run/Win32Pump.pm
vendored
Normal file
173
database/perl/vendor/lib/IPC/Run/Win32Pump.pm
vendored
Normal file
@@ -0,0 +1,173 @@
|
||||
package IPC::Run::Win32Pump;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
IPC::Run::Win32Pump - helper processes to shovel data to/from parent, child
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Internal use only; see IPC::Run::Win32IO and best of luck to you.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
See L<IPC::Run::Win32Helper|IPC::Run::Win32Helper> for details. This
|
||||
module is used in subprocesses that are spawned to shovel data to/from
|
||||
parent processes from/to their child processes. Where possible, pumps
|
||||
are optimized away.
|
||||
|
||||
NOTE: This is not a real module: it's a script in module form, designed
|
||||
to be run like
|
||||
|
||||
$^X -MIPC::Run::Win32Pumper -e 1 ...
|
||||
|
||||
It parses a bunch of command line parameters from IPC::Run::Win32IO.
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use vars qw{$VERSION};
|
||||
|
||||
BEGIN {
|
||||
$VERSION = '20200505.0';
|
||||
}
|
||||
|
||||
use Win32API::File qw(
|
||||
OsFHandleOpen
|
||||
);
|
||||
|
||||
my ( $stdin_fh, $stdout_fh, $debug_fh, $binmode, $parent_pid, $parent_start_time, $debug, $child_label );
|
||||
|
||||
BEGIN {
|
||||
( $stdin_fh, $stdout_fh, $debug_fh, $binmode, $parent_pid, $parent_start_time, $debug, $child_label ) = @ARGV;
|
||||
## Rather than letting IPC::Run::Debug export all-0 constants
|
||||
## when not debugging, we do it manually in order to not even
|
||||
## load IPC::Run::Debug.
|
||||
if ($debug) {
|
||||
eval "use IPC::Run::Debug qw( :default _debug_init ); 1;"
|
||||
or die $@;
|
||||
}
|
||||
else {
|
||||
eval <<STUBS_END or die $@;
|
||||
sub _debug {}
|
||||
sub _debug_init {}
|
||||
sub _debugging() { 0 }
|
||||
sub _debugging_data() { 0 }
|
||||
sub _debugging_details() { 0 }
|
||||
sub _debugging_gory_details() { 0 }
|
||||
1;
|
||||
STUBS_END
|
||||
}
|
||||
}
|
||||
|
||||
## For some reason these get created with binmode on. AAargh, gotta #### REMOVE
|
||||
## do it by hand below. #### REMOVE
|
||||
if ($debug) { #### REMOVE
|
||||
close STDERR; #### REMOVE
|
||||
OsFHandleOpen( \*STDERR, $debug_fh, "w" ) #### REMOVE
|
||||
or print "$! opening STDERR as Win32 handle $debug_fh in pumper $$"; #### REMOVE
|
||||
} #### REMOVE
|
||||
close STDIN; #### REMOVE
|
||||
OsFHandleOpen( \*STDIN, $stdin_fh, "r" ) #### REMOVE
|
||||
or die "$! opening STDIN as Win32 handle $stdin_fh in pumper $$"; #### REMOVE
|
||||
close STDOUT; #### REMOVE
|
||||
OsFHandleOpen( \*STDOUT, $stdout_fh, "w" ) #### REMOVE
|
||||
or die "$! opening STDOUT as Win32 handle $stdout_fh in pumper $$"; #### REMOVE
|
||||
|
||||
binmode STDIN;
|
||||
binmode STDOUT;
|
||||
$| = 1;
|
||||
select STDERR;
|
||||
$| = 1;
|
||||
select STDOUT;
|
||||
|
||||
$child_label ||= "pump";
|
||||
_debug_init(
|
||||
$parent_pid,
|
||||
$parent_start_time,
|
||||
$debug,
|
||||
fileno STDERR,
|
||||
$child_label,
|
||||
);
|
||||
|
||||
_debug "Entered" if _debugging_details;
|
||||
|
||||
# No need to close all fds; win32 doesn't seem to pass any on to us.
|
||||
$| = 1;
|
||||
my $buf;
|
||||
my $total_count = 0;
|
||||
while (1) {
|
||||
my $count = sysread STDIN, $buf, 10_000;
|
||||
last unless $count;
|
||||
if (_debugging_gory_details) {
|
||||
my $msg = "'$buf'";
|
||||
substr( $msg, 100, -1 ) = '...' if length $msg > 100;
|
||||
$msg =~ s/\n/\\n/g;
|
||||
$msg =~ s/\r/\\r/g;
|
||||
$msg =~ s/\t/\\t/g;
|
||||
$msg =~ s/([\000-\037\177-\277])/sprintf "\0x%02x", ord $1/eg;
|
||||
_debug sprintf( "%5d chars revc: ", $count ), $msg;
|
||||
}
|
||||
$total_count += $count;
|
||||
$buf =~ s/\r//g unless $binmode;
|
||||
if (_debugging_gory_details) {
|
||||
my $msg = "'$buf'";
|
||||
substr( $msg, 100, -1 ) = '...' if length $msg > 100;
|
||||
$msg =~ s/\n/\\n/g;
|
||||
$msg =~ s/\r/\\r/g;
|
||||
$msg =~ s/\t/\\t/g;
|
||||
$msg =~ s/([\000-\037\177-\277])/sprintf "\0x%02x", ord $1/eg;
|
||||
_debug sprintf( "%5d chars sent: ", $count ), $msg;
|
||||
}
|
||||
print $buf;
|
||||
}
|
||||
|
||||
_debug "Exiting, transferred $total_count chars" if _debugging_details;
|
||||
|
||||
## Perform a graceful socket shutdown. Windows defaults to SO_DONTLINGER,
|
||||
## which should cause a "graceful shutdown in the background" on sockets.
|
||||
## but that's only true if the process closes the socket manually, it
|
||||
## seems; if the process exits and lets the OS clean up, the OS is not
|
||||
## so kind. STDOUT is not always a socket, of course, but it won't hurt
|
||||
## to close a pipe and may even help. With a closed source OS, who
|
||||
## can tell?
|
||||
##
|
||||
## In any case, this close() is one of the main reasons we have helper
|
||||
## processes; if the OS closed socket fds gracefully when an app exits,
|
||||
## we'd just redirect the client directly to what is now the pump end
|
||||
## of the socket. As it is, however, we need to let the client play with
|
||||
## pipes, which don't have the abort-on-app-exit behavior, and then
|
||||
## adapt to the sockets in the helper processes to allow the parent to
|
||||
## select.
|
||||
##
|
||||
## Possible alternatives / improvements:
|
||||
##
|
||||
## 1) use helper threads instead of processes. I don't trust perl's threads
|
||||
## as of 5.005 or 5.6 enough (which may be myopic of me).
|
||||
##
|
||||
## 2) figure out if/how to get at WaitForMultipleObjects() with pipe
|
||||
## handles. May be able to take the Win32 handle and pass it to
|
||||
## Win32::Event::wait_any, dunno.
|
||||
##
|
||||
## 3) Use Inline::C or a hand-tooled XS module to do helper threads.
|
||||
## This would be faster than #1, but would require a ppm distro.
|
||||
##
|
||||
close STDOUT;
|
||||
close STDERR;
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Barries Slaymaker <barries@slaysys.com>. Funded by Perforce Software, Inc.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 2001, Barrie Slaymaker, All Rights Reserved.
|
||||
|
||||
You may use this under the terms of either the GPL 2.0 ir the Artistic License.
|
||||
|
||||
=cut
|
||||
846
database/perl/vendor/lib/IPC/Run3.pm
vendored
Normal file
846
database/perl/vendor/lib/IPC/Run3.pm
vendored
Normal file
@@ -0,0 +1,846 @@
|
||||
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;
|
||||
|
||||
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 {
|
||||
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;
|
||||
|
||||
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
|
||||
86
database/perl/vendor/lib/IPC/Run3/ProfArrayBuffer.pm
vendored
Normal file
86
database/perl/vendor/lib/IPC/Run3/ProfArrayBuffer.pm
vendored
Normal file
@@ -0,0 +1,86 @@
|
||||
package IPC::Run3::ProfArrayBuffer;
|
||||
|
||||
$VERSION = 0.048;
|
||||
|
||||
=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;
|
||||
157
database/perl/vendor/lib/IPC/Run3/ProfLogReader.pm
vendored
Normal file
157
database/perl/vendor/lib/IPC/Run3/ProfLogReader.pm
vendored
Normal file
@@ -0,0 +1,157 @@
|
||||
package IPC::Run3::ProfLogReader;
|
||||
|
||||
$VERSION = 0.048;
|
||||
|
||||
=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;
|
||||
139
database/perl/vendor/lib/IPC/Run3/ProfLogger.pm
vendored
Normal file
139
database/perl/vendor/lib/IPC/Run3/ProfLogger.pm
vendored
Normal file
@@ -0,0 +1,139 @@
|
||||
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;
|
||||
$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;
|
||||
156
database/perl/vendor/lib/IPC/Run3/ProfPP.pm
vendored
Normal file
156
database/perl/vendor/lib/IPC/Run3/ProfPP.pm
vendored
Normal file
@@ -0,0 +1,156 @@
|
||||
package IPC::Run3::ProfPP;
|
||||
|
||||
$VERSION = 0.048;
|
||||
|
||||
=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;
|
||||
256
database/perl/vendor/lib/IPC/Run3/ProfReporter.pm
vendored
Normal file
256
database/perl/vendor/lib/IPC/Run3/ProfReporter.pm
vendored
Normal file
@@ -0,0 +1,256 @@
|
||||
package IPC::Run3::ProfReporter;
|
||||
|
||||
$VERSION = 0.048;
|
||||
|
||||
=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;
|
||||
1115
database/perl/vendor/lib/IPC/System/Simple.pm
vendored
Normal file
1115
database/perl/vendor/lib/IPC/System/Simple.pm
vendored
Normal file
File diff suppressed because it is too large
Load Diff
Reference in New Issue
Block a user