KevinSchoenmayer/GseTDDUebungKCLR
2
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial Commit

Browse Source
This commit is contained in:
Riley Schneider
2025-12-03 16:38:10 +01:00
parent c5e26bf594
commit b732d8d4b5
17680 changed files with 5977495 additions and 2 deletions
Download Patch File Download Diff File Expand all files Collapse all files

310
database/perl/vendor/lib/IPC/Run/Debug.pm vendored Normal file
View 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
View 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
View 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
View 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
View 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
View 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