Source/t/lib/IPC/Run/Debug.pm

   1 package IPC::Run::Debug;
   2
   3 =head1 NAME
   4
   5 IPC::Run::Debug - debugging routines for IPC::Run
   6
   7 =head1 SYNOPSIS
   8
   9    ##
  10    ## Environment variable usage
  11    ##
  12    ## To force debugging off and shave a bit of CPU and memory
  13    ## by compile-time optimizing away all debugging code in IPC::Run
  14    ## (debug => ...) options to IPC::Run will be ignored.
  15    export IPCRUNDEBUG=none
  16
  17    ## To force debugging on (levels are from 0..10)
  18    export IPCRUNDEBUG=basic
  19
  20    ## Leave unset or set to "" to compile in debugging support and
  21    ## allow runtime control of it using the debug option.
  22
  23 =head1 DESCRIPTION
  24
  25 Controls IPC::Run debugging.  Debugging levels are now set by using words,
  26 but the numbers shown are still supported for backwards compatability:
  27
  28    0  none         disabled (special, see below)
  29    1  basic        what's running
  30    2  data         what's being sent/recieved
  31    3  details      what's going on in more detail
  32    4  gory         way too much detail for most uses
  33    10 all          use this when submitting bug reports
  34       noopts       optimizations forbidden due to inherited STDIN
  35
  36 The C<none> level is special when the environment variable IPCRUNDEBUG
  37 is set to this the first time IPC::Run::Debug is loaded: it prevents
  38 the debugging code from being compiled in to the remaining IPC::Run modules,
  39 saving a bit of cpu.
  40
  41 To do this in a script, here's a way that allows it to be overridden:
  42
  43    BEGIN {
  44       unless ( defined $ENV{IPCRUNDEBUG} ) {
  45          eval 'local $ENV{IPCRUNDEBUG} = "none"; require IPC::Run::Debug"'
  46             or die $@;
  47       }
  48    }
  49
  50 This should force IPC::Run to not be debuggable unless somebody sets
  51 the IPCRUNDEBUG flag; modify this formula to grep @ARGV if need be:
  52
  53    BEGIN {
  54       unless ( grep /^--debug/, @ARGV ) {
  55          eval 'local $ENV{IPCRUNDEBUG} = "none"; require IPC::Run::Debug"'
  56          or die $@;
  57    }
  58
  59 Both of those are untested.
  60
  61 =cut
  62
  63 @ISA = qw( Exporter ) ;
  64
  65 ## We use @EXPORT for the end user's convenience: there's only one function
  66 ## exported, it's homonymous with the module, it's an unusual name, and
  67 ## it can be suppressed by "use IPC::Run () ;".
  68
  69 @EXPORT = qw(
  70    _debug
  71    _debug_desc_fd
  72    _debugging
  73    _debugging_data
  74    _debugging_details
  75    _debugging_gory_details
  76    _debugging_not_optimized
  77    _set_child_debug_name
  78 );
  79
  80
  81 @EXPORT_OK = qw(
  82    _debug_init
  83    _debugging_level
  84    _map_fds
  85 );
  86
  87 %EXPORT_TAGS = (
  88    default => \@EXPORT,
  89    all     => [ @EXPORT, @EXPORT_OK ],
  90 );
  91
  92 use strict ;
  93 use Exporter ;
  94
  95 my $disable_debugging =
  96    defined $ENV{IPCRUNDEBUG}
  97    && (
  98       ! $ENV{IPCRUNDEBUG}
  99       || lc $ENV{IPCRUNDEBUG} eq "none"
 100    );
 101
 102 eval( $disable_debugging ? <<'STUBS' : <<'SUBS' ) or die $@;
 103 sub _map_fds()                 { "" }
 104 sub _debug                     {}
 105 sub _debug_desc_fd             {}
 106 sub _debug_init                {}
 107 sub _set_child_debug_name      {}
 108 sub _debugging()               { 0 }
 109 sub _debugging_level()         { 0 }
 110 sub _debugging_data()          { 0 }
 111 sub _debugging_details()       { 0 }
 112 sub _debugging_gory_details()  { 0 }
 113 sub _debugging_not_optimized() { 0 }
 114
 115 1;
 116 STUBS
 117
 118 use POSIX;
 119 use UNIVERSAL qw( isa );
 120
 121 sub _map_fds {
 122    my $map = '' ;
 123    my $digit = 0 ;
 124    my $in_use ;
 125    my $dummy ;
 126    for my $fd (0..63) {
 127       ## I'd like a quicker way (less user, cpu & expecially sys and kernal
 128       ## calls) to detect open file descriptors.  Let me know...
 129       ## Hmmm, could do a 0 length read and check for bad file descriptor...
 130       ## but that segfaults on Win32
 131       my $test_fd = POSIX::dup( $fd ) ;
 132       $in_use = defined $test_fd ;
 133       POSIX::close $test_fd if $in_use ;
 134       $map .= $in_use ? $digit : '-';
 135       $digit = 0 if ++$digit > 9 ;
 136    }
 137    warn "No fds open???" unless $map =~ /\d/ ;
 138    $map =~ s/(.{1,12})-*$/$1/ ;
 139    return $map ;
 140 }
 141
 142 use vars qw( $parent_pid ) ;
 143
 144 $parent_pid = $$ ;
 145
 146 ## TODO: move debugging to it's own module and make it compile-time
 147 ## optimizable.
 148
 149 ## Give kid process debugging nice names
 150 my $debug_name ;
 151
 152 sub _set_child_debug_name {
 153    $debug_name = shift;
 154 }
 155
 156 ## There's a bit of hackery going on here.
 157 ##
 158 ## We want to have any code anywhere be able to emit
 159 ## debugging statements without knowing what harness the code is
 160 ## being called in/from, since we'd need to pass a harness around to
 161 ## everything.
 162 ##
 163 ## Thus, $cur_self was born.
 164 #
 165 my %debug_levels = (
 166    none    => 0,
 167    basic   => 1,
 168    data    => 2,
 169    details => 3,
 170    gore           => 4,
 171    gory_details   => 4,
 172    "gory details" => 4,
 173    gory           => 4,
 174    gorydetails    => 4,
 175    all     => 10,
 176    notopt  => 0,
 177 );
 178
 179 my $warned;
 180
 181 sub _debugging_level() {
 182    my $level = 0 ;
 183
 184    $level = $IPC::Run::cur_self->{debug} || 0
 185       if $IPC::Run::cur_self
 186          && ( $IPC::Run::cur_self->{debug} || 0 ) >= $level ;
 187
 188    if ( defined $ENV{IPCRUNDEBUG} ) {
 189       my $v = $ENV{IPCRUNDEBUG};
 190       $v = $debug_levels{lc $v} if $v =~ /[a-zA-Z]/;
 191       unless ( defined $v ) {
 192          $warned ||= warn "Unknown debug level $ENV{IPCRUNDEBUG}, assuming 'basic' (1)\n";
 193          $v = 1;
 194       }
 195       $level = $v if $v > $level ;
 196    }
 197    return $level ;
 198 }
 199
 200 sub _debugging_atleast($) {
 201    my $min_level = shift || 1 ;
 202
 203    my $level = _debugging_level ;
 204
 205    return $level >= $min_level ? $level : 0 ;
 206 }
 207
 208 sub _debugging()               { _debugging_atleast 1 }
 209 sub _debugging_data()          { _debugging_atleast 2 }
 210 sub _debugging_details()       { _debugging_atleast 3 }
 211 sub _debugging_gory_details()  { _debugging_atleast 4 }
 212 sub _debugging_not_optimized() { ( $ENV{IPCRUNDEBUG} || "" ) eq "notopt" }
 213
 214 sub _debug_init {
 215    ## This routine is called only in spawned children to fake out the
 216    ## debug routines so they'll emit debugging info.
 217    $IPC::Run::cur_self = {} ;
 218    (  $parent_pid,
 219       $^T,
 220       $IPC::Run::cur_self->{debug},
 221       $IPC::Run::cur_self->{DEBUG_FD},
 222       $debug_name
 223    ) = @_ ;
 224 }
 225
 226
 227 sub _debug {
 228 #   return unless _debugging || _debugging_not_optimized ;
 229
 230    my $fd = defined &IPC::Run::_debug_fd
 231       ? IPC::Run::_debug_fd()
 232       : fileno STDERR;
 233
 234    my $s ;
 235    my $debug_id ;
 236    $debug_id = join(
 237       " ",
 238       join(
 239          "",
 240          defined $IPC::Run::cur_self ? "#$IPC::Run::cur_self->{ID}" : (),
 241          "($$)",
 242       ),
 243       defined $debug_name && length $debug_name ? $debug_name        : (),
 244    ) ;
 245    my $prefix = join(
 246       "",
 247       "IPC::Run",
 248       sprintf( " %04d", time - $^T ),
 249       ( _debugging_details ? ( " ", _map_fds ) : () ),
 250       length $debug_id ? ( " [", $debug_id, "]" ) : (),
 251       ": ",
 252    ) ;
 253
 254    my $msg = join( '', map defined $_ ? $_ : "<undef>", @_ ) ;
 255    chomp $msg ;
 256    $msg =~ s{^}{$prefix}gm ;
 257    $msg .= "\n" ;
 258    POSIX::write( $fd, $msg, length $msg ) ;
 259 }
 260
 261
 262 my @fd_descs = ( 'stdin', 'stdout', 'stderr' ) ;
 263
 264 sub _debug_desc_fd {
 265    return unless _debugging ;
 266    my $text = shift ;
 267    my $op = pop ;
 268    my $kid = $_[0] ;
 269
 270 Carp::carp join " ", caller(0), $text, $op  if defined $op  && isa( $op, "IO::Pty" ) ;
 271
 272    _debug(
 273       $text,
 274       ' ',
 275       ( defined $op->{FD}
 276          ? $op->{FD} < 3
 277             ? ( $fd_descs[$op->{FD}] )
 278             : ( 'fd ', $op->{FD} )
 279          : $op->{FD}
 280       ),
 281       ( defined $op->{KFD}
 282          ? (
 283             ' (kid',
 284             ( defined $kid ? ( ' ', $kid->{NUM}, ) : () ),
 285             "'s ",
 286             ( $op->{KFD} < 3
 287                ? $fd_descs[$op->{KFD}]
 288                : defined $kid
 289                   && defined $kid->{DEBUG_FD}
 290                   && $op->{KFD} == $kid->{DEBUG_FD}
 291                   ? ( 'debug (', $op->{KFD}, ')' )
 292                   : ( 'fd ', $op->{KFD} )
 293             ),
 294             ')',
 295          )
 296          : ()
 297       ),
 298    ) ;
 299 }
 300
 301 1;
 302
 303 SUBS
 304
 305 =head1 AUTHOR
 306
 307 Barrie Slaymaker <barries@slaysys.com>, with numerous suggestions by p5p.
 308
 309 =cut
 310
 311 1 ;