local-lib5/lib/perl5/IPC/Run/Debug.pm

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