tools/cmake/scripts/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 compatibility:
  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.90';
  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
 122 sub _map_fds {
 123    my $map = '';
 124    my $digit = 0;
 125    my $in_use;
 126    my $dummy;
 127    for my $fd (0..63) {
 128       ## I'd like a quicker way (less user, cpu & expecially sys and kernal
 129       ## calls) to detect open file descriptors.  Let me know...
 130       ## Hmmm, could do a 0 length read and check for bad file descriptor...
 131       ## but that segfaults on Win32
 132       my $test_fd = POSIX::dup( $fd );
 133       $in_use = defined $test_fd;
 134       POSIX::close $test_fd if $in_use;
 135       $map .= $in_use ? $digit : '-';
 136       $digit = 0 if ++$digit > 9;
 137    }
 138    warn "No fds open???" unless $map =~ /\d/;
 139    $map =~ s/(.{1,12})-*$/$1/;
 140    return $map;
 141 }
 142
 143 use vars qw( $parent_pid );
 144
 145 $parent_pid = $$;
 146
 147 ## TODO: move debugging to it's own module and make it compile-time
 148 ## optimizable.
 149
 150 ## Give kid process debugging nice names
 151 my $debug_name;
 152
 153 sub _set_child_debug_name {
 154    $debug_name = shift;
 155 }
 156
 157 ## There's a bit of hackery going on here.
 158 ##
 159 ## We want to have any code anywhere be able to emit
 160 ## debugging statements without knowing what harness the code is
 161 ## being called in/from, since we'd need to pass a harness around to
 162 ## everything.
 163 ##
 164 ## Thus, $cur_self was born.
 165 #
 166 my %debug_levels = (
 167    none    => 0,
 168    basic   => 1,
 169    data    => 2,
 170    details => 3,
 171    gore           => 4,
 172    gory_details   => 4,
 173    "gory details" => 4,
 174    gory           => 4,
 175    gorydetails    => 4,
 176    all     => 10,
 177    notopt  => 0,
 178 );
 179
 180 my $warned;
 181
 182 sub _debugging_level() {
 183    my $level = 0;
 184
 185    $level = $IPC::Run::cur_self->{debug} || 0
 186       if $IPC::Run::cur_self
 187          && ( $IPC::Run::cur_self->{debug} || 0 ) >= $level;
 188
 189    if ( defined $ENV{IPCRUNDEBUG} ) {
 190       my $v = $ENV{IPCRUNDEBUG};
 191       $v = $debug_levels{lc $v} if $v =~ /[a-zA-Z]/;
 192       unless ( defined $v ) {
 193          $warned ||= warn "Unknown debug level $ENV{IPCRUNDEBUG}, assuming 'basic' (1)\n";
 194          $v = 1;
 195       }
 196       $level = $v if $v > $level;
 197    }
 198    return $level;
 199 }
 200
 201 sub _debugging_atleast($) {
 202    my $min_level = shift || 1;
 203
 204    my $level = _debugging_level;
 205
 206    return $level >= $min_level ? $level : 0;
 207 }
 208
 209 sub _debugging()               { _debugging_atleast 1 }
 210 sub _debugging_data()          { _debugging_atleast 2 }
 211 sub _debugging_details()       { _debugging_atleast 3 }
 212 sub _debugging_gory_details()  { _debugging_atleast 4 }
 213 sub _debugging_not_optimized() { ( $ENV{IPCRUNDEBUG} || "" ) eq "notopt" }
 214
 215 sub _debug_init {
 216    ## This routine is called only in spawned children to fake out the
 217    ## debug routines so they'll emit debugging info.
 218    $IPC::Run::cur_self = {};
 219    (  $parent_pid,
 220       $^T,
 221       $IPC::Run::cur_self->{debug},
 222       $IPC::Run::cur_self->{DEBUG_FD},
 223       $debug_name
 224    ) = @_;
 225 }
 226
 227
 228 sub _debug {
 229 #   return unless _debugging || _debugging_not_optimized;
 230
 231    my $fd = defined &IPC::Run::_debug_fd
 232       ? IPC::Run::_debug_fd()
 233       : fileno STDERR;
 234
 235    my $s;
 236    my $debug_id;
 237    $debug_id = join(
 238       " ",
 239       join(
 240          "",
 241          defined $IPC::Run::cur_self ? "#$IPC::Run::cur_self->{ID}" : (),
 242          "($$)",
 243       ),
 244       defined $debug_name && length $debug_name ? $debug_name        : (),
 245    );
 246    my $prefix = join(
 247       "",
 248       "IPC::Run",
 249       sprintf( " %04d", time - $^T ),
 250       ( _debugging_details ? ( " ", _map_fds ) : () ),
 251       length $debug_id ? ( " [", $debug_id, "]" ) : (),
 252       ": ",
 253    );
 254
 255    my $msg = join( '', map defined $_ ? $_ : "<undef>", @_ );
 256    chomp $msg;
 257    $msg =~ s{^}{$prefix}gm;
 258    $msg .= "\n";
 259    POSIX::write( $fd, $msg, length $msg );
 260 }
 261
 262
 263 my @fd_descs = ( 'stdin', 'stdout', 'stderr' );
 264
 265 sub _debug_desc_fd {
 266    return unless _debugging;
 267    my $text = shift;
 268    my $op = pop;
 269    my $kid = $_[0];
 270
 271 Carp::carp join " ", caller(0), $text, $op  if defined $op  && UNIVERSAL::isa( $op, "IO::Pty" );
 272
 273    _debug(
 274       $text,
 275       ' ',
 276       ( defined $op->{FD}
 277          ? $op->{FD} < 3
 278             ? ( $fd_descs[$op->{FD}] )
 279             : ( 'fd ', $op->{FD} )
 280          : $op->{FD}
 281       ),
 282       ( defined $op->{KFD}
 283          ? (
 284             ' (kid',
 285             ( defined $kid ? ( ' ', $kid->{NUM}, ) : () ),
 286             "'s ",
 287             ( $op->{KFD} < 3
 288                ? $fd_descs[$op->{KFD}]
 289                : defined $kid
 290                   && defined $kid->{DEBUG_FD}
 291                   && $op->{KFD} == $kid->{DEBUG_FD}
 292                   ? ( 'debug (', $op->{KFD}, ')' )
 293                   : ( 'fd ', $op->{KFD} )
 294             ),
 295             ')',
 296          )
 297          : ()
 298       ),
 299    );
 300 }
 301
 302 1;
 303
 304 SUBS
 305
 306 =pod
 307
 308 =head1 AUTHOR
 309
 310 Barrie Slaymaker <barries@slaysys.com>, with numerous suggestions by p5p.
 311
 312 =cut