← Index
NYTProf Performance Profile   « line view »
For split.pl
  Run on Thu Apr 20 02:05:47 2023
Reported on Thu Apr 20 18:31:09 2023

Filename/home/hejohns/perl5/lib/perl5/IPC/Run/Debug.pm
StatementsExecuted 15 statements in 278µs
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11112µs12µsIPC::Run::Debug::::BEGIN@74IPC::Run::Debug::BEGIN@74
1117µs8µsIPC::Run::Debug::::BEGIN@69IPC::Run::Debug::BEGIN@69
1114µs11µsIPC::Run::Debug::::BEGIN@71IPC::Run::Debug::BEGIN@71
1113µs13µsIPC::Run::Debug::::BEGIN@70IPC::Run::Debug::BEGIN@70
1113µs30µsIPC::Run::Debug::::BEGIN@72IPC::Run::Debug::BEGIN@72
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1package IPC::Run::Debug;
2
3=pod
4
5=head1 NAME
6
7IPC::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
27Controls IPC::Run debugging. Debugging levels are now set by using words,
28but 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/received
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
38The C<none> level is special when the environment variable IPCRUNDEBUG
39is set to this the first time IPC::Run::Debug is loaded: it prevents
40the debugging code from being compiled in to the remaining IPC::Run modules,
41saving a bit of cpu.
42
43To 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
52This should force IPC::Run to not be debuggable unless somebody sets
53the 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
61Both 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
69218µs29µs
# spent 8µs (7+1) within IPC::Run::Debug::BEGIN@69 which was called: # once (7µs+1µs) by IPC::Run::BEGIN@1052 at line 69
use strict;
# spent 8µs making 1 call to IPC::Run::Debug::BEGIN@69 # spent 1µs making 1 call to strict::import
70211µs223µs
# spent 13µs (3+10) within IPC::Run::Debug::BEGIN@70 which was called: # once (3µs+10µs) by IPC::Run::BEGIN@1052 at line 70
use warnings;
# spent 13µs making 1 call to IPC::Run::Debug::BEGIN@70 # spent 10µs making 1 call to warnings::import
71215µs219µs
# spent 11µs (4+8) within IPC::Run::Debug::BEGIN@71 which was called: # once (4µs+8µs) by IPC::Run::BEGIN@1052 at line 71
use Exporter;
# spent 11µs making 1 call to IPC::Run::Debug::BEGIN@71 # spent 8µs making 1 call to Exporter::import
72254µs258µs
# spent 30µs (3+28) within IPC::Run::Debug::BEGIN@72 which was called: # once (3µs+28µs) by IPC::Run::BEGIN@1052 at line 72
use vars qw{$VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS};
# spent 30µs making 1 call to IPC::Run::Debug::BEGIN@72 # spent 28µs making 1 call to vars::import
73
74
# spent 12µs within IPC::Run::Debug::BEGIN@74 which was called: # once (12µs+0s) by IPC::Run::BEGIN@1052 at line 97
BEGIN {
751300ns $VERSION = '20220807.0';
7615µs @ISA = qw( Exporter );
7713µs @EXPORT = qw(
78 _debug
79 _debug_desc_fd
80 _debugging
81 _debugging_data
82 _debugging_details
83 _debugging_gory_details
84 _debugging_not_optimized
85 _set_child_debug_name
86 );
87
881400ns @EXPORT_OK = qw(
89 _debug_init
90 _debugging_level
91 _map_fds
92 );
9313µs %EXPORT_TAGS = (
94 default => \@EXPORT,
95 all => [ @EXPORT, @EXPORT_OK ],
96 );
971120µs112µs}
# spent 12µs making 1 call to IPC::Run::Debug::BEGIN@74
98
99my $disable_debugging = defined $ENV{IPCRUNDEBUG}
100 && ( !$ENV{IPCRUNDEBUG}
1011600ns || lc $ENV{IPCRUNDEBUG} eq "none" );
102
103148µseval( $disable_debugging ? <<'STUBS' : <<'SUBS' ) or die $@;
# spent 108s executing statements in string eval
# includes 91.2s spent executing 25174040 calls to 14 subs defined therein.
104sub _map_fds() { "" }
105sub _debug {}
106sub _debug_desc_fd {}
107sub _debug_init {}
108sub _set_child_debug_name {}
109sub _debugging() { 0 }
110sub _debugging_level() { 0 }
111sub _debugging_data() { 0 }
112sub _debugging_details() { 0 }
113sub _debugging_gory_details() { 0 }
114sub _debugging_not_optimized() { 0 }
115
1161;
117STUBS
118
119use POSIX ();
120
121sub _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 & especially sys and kernel
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
142use vars qw( $parent_pid );
143
144$parent_pid = $$;
145
146## TODO: move debugging to its own module and make it compile-time
147## optimizable.
148
149## Give kid process debugging nice names
150my $debug_name;
151
152sub _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#
165my %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
179my $warned;
180
181sub _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
200sub _debugging_atleast($) {
201 my $min_level = shift || 1;
202
203 my $level = _debugging_level;
204
205 return $level >= $min_level ? $level : 0;
206}
207
208sub _debugging() { _debugging_atleast 1 }
209sub _debugging_data() { _debugging_atleast 2 }
210sub _debugging_details() { _debugging_atleast 3 }
211sub _debugging_gory_details() { _debugging_atleast 4 }
212sub _debugging_not_optimized() { ( $ENV{IPCRUNDEBUG} || "" ) eq "notopt" }
213
214sub _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
227sub _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 && defined $IPC::Run::cur_self->{ID}
241 ? "#$IPC::Run::cur_self->{ID}"
242 : (),
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
264my @fd_descs = ( 'stdin', 'stdout', 'stderr' );
265
266sub _debug_desc_fd {
267 return unless _debugging;
268 my $text = shift;
269 my $op = pop;
270 my $kid = $_[0];
271
272Carp::carp join " ", caller(0), $text, $op if defined $op && UNIVERSAL::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
3031;
304
305SUBS
306
307=pod
308
309=head1 AUTHOR
310
311Barrie Slaymaker <barries@slaysys.com>, with numerous suggestions by p5p.
312
313=cut
Report produced by the NYTProf 6.12 Perl profiler, developed by Tim Bunce based on work by Adam Kaplan and Salvador Fandiño García.