311 lines
7.6 KiB
Perl
311 lines
7.6 KiB
Perl
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
|