+++ /dev/null
-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/recieved
- 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 = '0.90';
- @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 & expecially sys and kernal
- ## 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 it's 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
