1 package IPC::Run::Debug;
7 IPC::Run::Debug - debugging routines for IPC::Run
12 ## Environment variable usage
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
19 ## To force debugging on (levels are from 0..10)
20 export IPCRUNDEBUG=basic
22 ## Leave unset or set to "" to compile in debugging support and
23 ## allow runtime control of it using the debug option.
27 Controls IPC::Run debugging. Debugging levels are now set by using words,
28 but the numbers shown are still supported for backwards compatibility:
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
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,
43 To do this in a script, here's a way that allows it to be overridden:
46 unless ( defined $ENV{IPCRUNDEBUG} ) {
47 eval 'local $ENV{IPCRUNDEBUG} = "none"; require IPC::Run::Debug"'
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:
56 unless ( grep /^--debug/, @ARGV ) {
57 eval 'local $ENV{IPCRUNDEBUG} = "none"; require IPC::Run::Debug"'
61 Both of those are untested.
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 ();".
71 use vars qw{$VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS};
74 @ISA = qw( Exporter );
81 _debugging_gory_details
82 _debugging_not_optimized
93 all => [ @EXPORT, @EXPORT_OK ],
97 my $disable_debugging =
98 defined $ENV{IPCRUNDEBUG}
101 || lc $ENV{IPCRUNDEBUG} eq "none"
104 eval( $disable_debugging ? <<'STUBS' : <<'SUBS' ) or die $@;
105 sub _map_fds() { "" }
107 sub _debug_desc_fd {}
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 }
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;
138 warn "No fds open???" unless $map =~ /\d/;
139 $map =~ s/(.{1,12})-*$/$1/;
143 use vars qw( $parent_pid );
147 ## TODO: move debugging to it's own module and make it compile-time
150 ## Give kid process debugging nice names
153 sub _set_child_debug_name {
157 ## There's a bit of hackery going on here.
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
164 ## Thus, $cur_self was born.
182 sub _debugging_level() {
185 $level = $IPC::Run::cur_self->{debug} || 0
186 if $IPC::Run::cur_self
187 && ( $IPC::Run::cur_self->{debug} || 0 ) >= $level;
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";
196 $level = $v if $v > $level;
201 sub _debugging_atleast($) {
202 my $min_level = shift || 1;
204 my $level = _debugging_level;
206 return $level >= $min_level ? $level : 0;
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" }
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 = {};
221 $IPC::Run::cur_self->{debug},
222 $IPC::Run::cur_self->{DEBUG_FD},
229 # return unless _debugging || _debugging_not_optimized;
231 my $fd = defined &IPC::Run::_debug_fd
232 ? IPC::Run::_debug_fd()
241 defined $IPC::Run::cur_self ? "#$IPC::Run::cur_self->{ID}" : (),
244 defined $debug_name && length $debug_name ? $debug_name : (),
249 sprintf( " %04d", time - $^T ),
250 ( _debugging_details ? ( " ", _map_fds ) : () ),
251 length $debug_id ? ( " [", $debug_id, "]" ) : (),
255 my $msg = join( '', map defined $_ ? $_ : "<undef>", @_ );
257 $msg =~ s{^}{$prefix}gm;
259 POSIX::write( $fd, $msg, length $msg );
263 my @fd_descs = ( 'stdin', 'stdout', 'stderr' );
266 return unless _debugging;
271 Carp::carp join " ", caller(0), $text, $op if defined $op && UNIVERSAL::isa( $op, "IO::Pty" );
278 ? ( $fd_descs[$op->{FD}] )
279 : ( 'fd ', $op->{FD} )
285 ( defined $kid ? ( ' ', $kid->{NUM}, ) : () ),
288 ? $fd_descs[$op->{KFD}]
290 && defined $kid->{DEBUG_FD}
291 && $op->{KFD} == $kid->{DEBUG_FD}
292 ? ( 'debug (', $op->{KFD}, ')' )
293 : ( 'fd ', $op->{KFD} )
310 Barrie Slaymaker <barries@slaysys.com>, with numerous suggestions by p5p.