File Coverage

blib/lib/IPC/Run/Debug.pm

Criterion	Covered	Total	%
statement	54	82	65.8
branch	13	52	25.0
condition	5	26	19.2
subroutine	16	22	72.7
pod			n/a
total	88	182	48.3

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 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 warnings;
use Exporter;
use vars qw{$VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS};

BEGIN {
    $VERSION = '20260402.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 ();
use constant Win32_MODE => $^O =~ /os2|Win32/i;

# Replace Win32API::File::INVALID_HANDLE_VALUE, which does not match the C ABI
# on 64-bit builds (https://github.com/chorny/Win32API-File/issues/13).
use constant C_ABI_INVALID_HANDLE_VALUE => length( pack 'P', undef ) == 4
  ? 0xffffffff
  : 0xffffffff << 32 | 0xffffffff;

sub _fd_is_open {
   my ($fd) = @_;
   if (Win32_MODE) {
      # Many OS functions can crash on closed FDs.  POSIX::close() can hang on
      # the read end of a pipe (https://github.com/Perl/perl5/issues/19963).
      # Borrow Gnulib's strategy.
      require Win32API::File;
      return Win32API::File::FdGetOsFHandle($fd) != C_ABI_INVALID_HANDLE_VALUE;
   }
   else {
      ## 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...
      my $test_fd = POSIX::dup( $fd );
      my $in_use = defined $test_fd;
      POSIX::close $test_fd if $in_use;
      return $in_use;
   }
}

sub _map_fds {
   my $map = '';
   my $digit = 0;
   my $dummy;
   for my $fd (0..63) {
      $map .= _fd_is_open($fd) ? $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 && defined $IPC::Run::cur_self->{ID}
         ? "#$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 $_ ? $_ : "", @_ );
   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 , with numerous suggestions by p5p.

=cut