← 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/usr/share/perl/5.36/diagnostics.pm
StatementsExecuted 64227 statements in 161ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
2056315125.8ms25.8msdiagnostics::::CORE:substdiagnostics::CORE:subst (opcode)
9551118.2ms19.9msdiagnostics::::bolddiagnostics::bold
14119616.59ms6.59msdiagnostics::::CORE:substcontdiagnostics::CORE:substcont (opcode)
2499213.64ms3.64msdiagnostics::::CORE:readlinediagnostics::CORE:readline (opcode)
423213.22ms4.18msdiagnostics::::italicdiagnostics::italic
1113.22ms3.80msdiagnostics::::BEGIN@186diagnostics::BEGIN@186
2498111.96ms2.31msdiagnostics::::unescapediagnostics::unescape
1111.29ms1.29msdiagnostics::::CORE:sortdiagnostics::CORE:sort (opcode)
4557711.04ms1.04msdiagnostics::::CORE:matchdiagnostics::CORE:match (opcode)
28011426µs742µsdiagnostics::::_split_pod_linkdiagnostics::_split_pod_link
111420µs464µsdiagnostics::::BEGIN@196diagnostics::BEGIN@196
111372µs422µsdiagnostics::::BEGIN@197diagnostics::BEGIN@197
33324µs28µsdiagnostics::::importdiagnostics::import
31120µs20µsdiagnostics::::death_trapdiagnostics::death_trap
11112µs12µsdiagnostics::::CORE:opendiagnostics::CORE:open (opcode)
32110µs10µsdiagnostics::::CORE:ftisdiagnostics::CORE:ftis (opcode)
1118µs8µsdiagnostics::::CORE:eofdiagnostics::CORE:eof (opcode)
1118µs9µsdiagnostics::::BEGIN@184diagnostics::BEGIN@184
1116µs6µsdiagnostics::::CORE:closediagnostics::CORE:close (opcode)
1115µs5µsdiagnostics::::BEGIN@185diagnostics::BEGIN@185
0000s0sdiagnostics::::autodescribediagnostics::autodescribe
0000s0sdiagnostics::::disablediagnostics::disable
0000s0sdiagnostics::::enablediagnostics::enable
0000s0sdiagnostics::::noopdiagnostics::noop
0000s0sdiagnostics::::shortendiagnostics::shorten
0000s0sdiagnostics::::splainthisdiagnostics::splainthis
0000s0sdiagnostics::::warn_trapdiagnostics::warn_trap
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1package diagnostics;
2
3=head1 NAME
4
5diagnostics, splain - produce verbose warning diagnostics
6
7=head1 SYNOPSIS
8
9Using the C<diagnostics> pragma:
10
11 use diagnostics;
12 use diagnostics -verbose;
13
14 enable diagnostics;
15 disable diagnostics;
16
17Using the C<splain> standalone filter program:
18
19 perl program 2>diag.out
20 splain [-v] [-p] diag.out
21
22Using diagnostics to get stack traces from a misbehaving script:
23
24 perl -Mdiagnostics=-traceonly my_script.pl
25
26=head1 DESCRIPTION
27
28=head2 The C<diagnostics> Pragma
29
30This module extends the terse diagnostics normally emitted by both the
31perl compiler and the perl interpreter (from running perl with a -w
32switch or C<use warnings>), augmenting them with the more
33explicative and endearing descriptions found in L<perldiag>. Like the
34other pragmata, it affects the compilation phase of your program rather
35than merely the execution phase.
36
37To use in your program as a pragma, merely invoke
38
39 use diagnostics;
40
41at the start (or near the start) of your program. (Note
42that this I<does> enable perl's B<-w> flag.) Your whole
43compilation will then be subject(ed :-) to the enhanced diagnostics.
44These still go out B<STDERR>.
45
46Due to the interaction between runtime and compiletime issues,
47and because it's probably not a very good idea anyway,
48you may not use C<no diagnostics> to turn them off at compiletime.
49However, you may control their behaviour at runtime using the
50disable() and enable() methods to turn them off and on respectively.
51
52The B<-verbose> flag first prints out the L<perldiag> introduction before
53any other diagnostics. The $diagnostics::PRETTY variable can generate nicer
54escape sequences for pagers.
55
56Warnings dispatched from perl itself (or more accurately, those that match
57descriptions found in L<perldiag>) are only displayed once (no duplicate
58descriptions). User code generated warnings a la warn() are unaffected,
59allowing duplicate user messages to be displayed.
60
61This module also adds a stack trace to the error message when perl dies.
62This is useful for pinpointing what
63caused the death. The B<-traceonly> (or
64just B<-t>) flag turns off the explanations of warning messages leaving just
65the stack traces. So if your script is dieing, run it again with
66
67 perl -Mdiagnostics=-traceonly my_bad_script
68
69to see the call stack at the time of death. By supplying the B<-warntrace>
70(or just B<-w>) flag, any warnings emitted will also come with a stack
71trace.
72
73=head2 The I<splain> Program
74
75Another program, I<splain> is actually nothing
76more than a link to the (executable) F<diagnostics.pm> module, as well as
77a link to the F<diagnostics.pod> documentation. The B<-v> flag is like
78the C<use diagnostics -verbose> directive.
79The B<-p> flag is like the
80$diagnostics::PRETTY variable. Since you're post-processing with
81I<splain>, there's no sense in being able to enable() or disable() processing.
82
83Output from I<splain> is directed to B<STDOUT>, unlike the pragma.
84
85=head1 EXAMPLES
86
87The following file is certain to trigger a few errors at both
88runtime and compiletime:
89
90 use diagnostics;
91 print NOWHERE "nothing\n";
92 print STDERR "\n\tThis message should be unadorned.\n";
93 warn "\tThis is a user warning";
94 print "\nDIAGNOSTIC TESTER: Please enter a <CR> here: ";
95 my $a, $b = scalar <STDIN>;
96 print "\n";
97 print $x/$y;
98
99If you prefer to run your program first and look at its problem
100afterwards, do this:
101
102 perl -w test.pl 2>test.out
103 ./splain < test.out
104
105Note that this is not in general possible in shells of more dubious heritage,
106as the theoretical
107
108 (perl -w test.pl >/dev/tty) >& test.out
109 ./splain < test.out
110
111Because you just moved the existing B<stdout> to somewhere else.
112
113If you don't want to modify your source code, but still have on-the-fly
114warnings, do this:
115
116 exec 3>&1; perl -w test.pl 2>&1 1>&3 3>&- | splain 1>&2 3>&-
117
118Nifty, eh?
119
120If you want to control warnings on the fly, do something like this.
121Make sure you do the C<use> first, or you won't be able to get
122at the enable() or disable() methods.
123
124 use diagnostics; # checks entire compilation phase
125 print "\ntime for 1st bogus diags: SQUAWKINGS\n";
126 print BOGUS1 'nada';
127 print "done with 1st bogus\n";
128
129 disable diagnostics; # only turns off runtime warnings
130 print "\ntime for 2nd bogus: (squelched)\n";
131 print BOGUS2 'nada';
132 print "done with 2nd bogus\n";
133
134 enable diagnostics; # turns back on runtime warnings
135 print "\ntime for 3rd bogus: SQUAWKINGS\n";
136 print BOGUS3 'nada';
137 print "done with 3rd bogus\n";
138
139 disable diagnostics;
140 print "\ntime for 4th bogus: (squelched)\n";
141 print BOGUS4 'nada';
142 print "done with 4th bogus\n";
143
144=head1 INTERNALS
145
146Diagnostic messages derive from the F<perldiag.pod> file when available at
147runtime. Otherwise, they may be embedded in the file itself when the
148splain package is built. See the F<Makefile> for details.
149
150If an extant $SIG{__WARN__} handler is discovered, it will continue
151to be honored, but only after the diagnostics::splainthis() function
152(the module's $SIG{__WARN__} interceptor) has had its way with your
153warnings.
154
155There is a $diagnostics::DEBUG variable you may set if you're desperately
156curious what sorts of things are being intercepted.
157
158 BEGIN { $diagnostics::DEBUG = 1 }
159
160
161=head1 BUGS
162
163Not being able to say "no diagnostics" is annoying, but may not be
164insurmountable.
165
166The C<-pretty> directive is called too late to affect matters.
167You have to do this instead, and I<before> you load the module.
168
169 BEGIN { $diagnostics::PRETTY = 1 }
170
171I could start up faster by delaying compilation until it should be
172needed, but this gets a "panic: top_level" when using the pragma form
173in Perl 5.001e.
174
175While it's true that this documentation is somewhat subserious, if you use
176a program named I<splain>, you should expect a bit of whimsy.
177
178=head1 AUTHOR
179
180Tom Christiansen <F<tchrist@mox.perl.com>>, 25 June 1995.
181
182=cut
183
184217µs211µs
# spent 9µs (8+1) within diagnostics::BEGIN@184 which was called: # once (8µs+1µs) by main::BEGIN@8 at line 184
use strict;
# spent 9µs making 1 call to diagnostics::BEGIN@184 # spent 2µs making 1 call to strict::import
185224µs15µs
# spent 5µs within diagnostics::BEGIN@185 which was called: # once (5µs+0s) by main::BEGIN@8 at line 185
use 5.009001;
# spent 5µs making 1 call to diagnostics::BEGIN@185
1862127µs23.83ms
# spent 3.80ms (3.22+583µs) within diagnostics::BEGIN@186 which was called: # once (3.22ms+583µs) by main::BEGIN@8 at line 186
use Carp;
# spent 3.80ms making 1 call to diagnostics::BEGIN@186 # spent 26µs making 1 call to Exporter::import
1871800ns$Carp::Internal{__PACKAGE__.""}++;
188
1891200nsour $VERSION = '1.39';
190our $DEBUG;
191our $VERBOSE;
192our $PRETTY;
1931100nsour $TRACEONLY = 0;
1941100nsour $WARNTRACE = 0;
195
196285µs2471µs
# spent 464µs (420+44) within diagnostics::BEGIN@196 which was called: # once (420µs+44µs) by main::BEGIN@8 at line 196
use Config;
# spent 464µs making 1 call to diagnostics::BEGIN@196 # spent 6µs making 1 call to Config::import
19722.16ms2447µs
# spent 422µs (372+50) within diagnostics::BEGIN@197 which was called: # once (372µs+50µs) by main::BEGIN@8 at line 197
use Text::Tabs 'expand';
# spent 422µs making 1 call to diagnostics::BEGIN@197 # spent 25µs making 1 call to Exporter::import
19816µs13µsmy $privlib = $Config{privlibexp};
# spent 3µs making 1 call to Config::FETCH
1991800nsif ($^O eq 'VMS') {
200 require VMS::Filespec;
201 $privlib = VMS::Filespec::unixify($privlib);
202}
2031900nsmy @trypod = (
204 "$privlib/pod/perldiag.pod",
205 "$privlib/pods/perldiag.pod",
206 );
207# handy for development testing of new warnings etc
20816µs14µsunshift @trypod, "./pod/perldiag.pod" if -e "pod/perldiag.pod";
# spent 4µs making 1 call to diagnostics::CORE:ftis
20919µs26µs(my $PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0];
# spent 6µs making 2 calls to diagnostics::CORE:ftis, avg 3µs/call
210
2111300ns$DEBUG ||= 0;
212
21312µslocal $| = 1;
2141100nslocal $_;
21511µslocal $.;
216
2171100nsmy $standalone;
2181100nsmy(%HTML_2_Troff, %HTML_2_Latin_1, %HTML_2_ASCII_7);
219
220CONFIG: {
2212400ns our $opt_p = our $opt_d = our $opt_v = our $opt_f = '';
222
2231400ns unless (caller) {
224 $standalone++;
225 require Getopt::Std;
226 Getopt::Std::getopts('pdvf:')
227 or die "Usage: $0 [-v] [-p] [-f splainpod]";
228 $PODFILE = $opt_f if $opt_f;
229 $DEBUG = 2 if $opt_d;
230 $VERBOSE = $opt_v;
231 $PRETTY = $opt_p;
232 }
233
234114µs112µs if (open(POD_DIAG, '<', $PODFILE)) {
# spent 12µs making 1 call to diagnostics::CORE:open
2351100ns warn "Happy happy podfile from real $PODFILE\n" if $DEBUG;
2361700ns last CONFIG;
237 }
238
239 if (caller) {
240 INCPATH: {
241 for my $file ( (map { "$_/".__PACKAGE__.".pm" } @INC), $0) {
242 warn "Checking $file\n" if $DEBUG;
243 if (open(POD_DIAG, '<', $file)) {
244 while (<POD_DIAG>) {
245 next unless
246 /^__END__\s*# wish diag dbase were more accessible/;
247 print STDERR "podfile is $file\n" if $DEBUG;
248 last INCPATH;
249 }
250 }
251 }
252 }
253 } else {
254 print STDERR "podfile is <DATA>\n" if $DEBUG;
255 *POD_DIAG = *main::DATA;
256 }
257}
258110µs18µsif (eof(POD_DIAG)) {
# spent 8µs making 1 call to diagnostics::CORE:eof
259 die "couldn't find diagnostic data in $PODFILE @INC $0";
260}
261
262
263%HTML_2_Troff = (
26412µs 'amp' => '&', # ampersand
265 'lt' => '<', # left chevron, less-than
266 'gt' => '>', # right chevron, greater-than
267 'quot' => '"', # double quote
268 'sol' => '/', # forward slash / solidus
269 'verbar' => '|', # vertical bar
270
271 "Aacute" => "A\\*'", # capital A, acute accent
272 # etc
273
274);
275
27611µs%HTML_2_Latin_1 = (
277 'amp' => '&', # ampersand
278 'lt' => '<', # left chevron, less-than
279 'gt' => '>', # right chevron, greater-than
280 'quot' => '"', # double quote
281 'sol' => '/', # Forward slash / solidus
282 'verbar' => '|', # vertical bar
283
284 # # capital A, acute accent
285 "Aacute" => chr utf8::unicode_to_native(0xC1)
286
287 # etc
288);
289
29011µs%HTML_2_ASCII_7 = (
291 'amp' => '&', # ampersand
292 'lt' => '<', # left chevron, less-than
293 'gt' => '>', # right chevron, greater-than
294 'quot' => '"', # double quote
295 'sol' => '/', # Forward slash / solidus
296 'verbar' => '|', # vertical bar
297
298 "Aacute" => "A" # capital A, acute accent
299 # etc
300);
301
302our %HTML_Escapes;
3031800ns*HTML_Escapes = do {
304 if ($standalone) {
305 $PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7;
306 } else {
3071300ns \%HTML_2_Latin_1;
308 }
309};
310
3111800ns*THITHER = $standalone ? *STDOUT : *STDERR;
312
3131200nsmy %transfmt = ();
3141200nsmy $transmo = <<EOFUNC;
315sub transmo {
316 #local \$^W = 0; # recursive warnings we do NOT need!
317EOFUNC
318
3191100nsmy %msg;
3201100nsmy $over_level = 0; # We look only at =item lines at the first =over level
321{
3222200ns print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
32311µs local $/ = '';
3241100ns local $_;
3251100ns my $header;
326 my @headers;
327 my $for_item;
328 my $seen_body;
32911.92ms1461975µs while (<POD_DIAG>) {
# spent 975µs making 1461 calls to diagnostics::CORE:readline, avg 667ns/call
330
331
# spent 742µs (426+316) within diagnostics::_split_pod_link which was called 280 times, avg 3µs/call: # 280 times (426µs+316µs) by main::BEGIN@8 at line 344, avg 3µs/call
sub _split_pod_link {
332280494µs280316µs $_[0] =~ m'(?:([^|]*)\|)?([^/]*)(?:/("?)(.*)\3)?'s;
# spent 316µs making 280 calls to diagnostics::CORE:match, avg 1µs/call
3332802.69ms ($1,$2,$4);
334 }
335
3362498894µs24982.31ms unescape();
# spent 2.31ms making 2498 calls to diagnostics::unescape, avg 924ns/call
3372498370µs if ($PRETTY) {
338 sub noop { return $_[0] } # spensive for a noop
339286520.2ms87341.73ms
# spent 19.9ms (18.2+1.73) within diagnostics::bold which was called 955 times, avg 21µs/call: # 955 times (18.2ms+1.73ms) by main::BEGIN@8 at line 341, avg 21µs/call
sub bold { my $str =$_[0]; $str =~ s/(.)/$1\b$1/g; return $str; }
# spent 1.49ms making 7779 calls to diagnostics::CORE:substcont, avg 191ns/call # spent 248µs making 955 calls to diagnostics::CORE:subst, avg 259ns/call
34012694.31ms4705957µs
# spent 4.18ms (3.22+957µs) within diagnostics::italic which was called 423 times, avg 10µs/call: # 386 times (2.94ms+881µs) by main::BEGIN@8 at line 345, avg 10µs/call # 37 times (278µs+77µs) by main::BEGIN@8 at line 342, avg 10µs/call
sub italic { my $str = $_[0]; $str =~ s/(.)/_\b$1/g; return $str; }
# spent 827µs making 4282 calls to diagnostics::CORE:substcont, avg 193ns/call # spent 130µs making 423 calls to diagnostics::CORE:subst, avg 308ns/call
341345319.0ms488036.3ms s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/bold($+)/ges;
# spent 19.9ms making 955 calls to diagnostics::bold, avg 21µs/call # spent 12.4ms making 2498 calls to diagnostics::CORE:subst, avg 5µs/call # spent 4.07ms making 1427 calls to diagnostics::CORE:substcont, avg 3µs/call
34225351.77ms2604825µs s/[IF]<(.*?)>/italic($1)/ges;
# spent 444µs making 2498 calls to diagnostics::CORE:subst, avg 178ns/call # spent 354µs making 37 calls to diagnostics::italic, avg 10µs/call # spent 26µs making 69 calls to diagnostics::CORE:substcont, avg 383ns/call
34324984.44ms3038576µs s/L<(.*?)>/
# spent 408µs making 2498 calls to diagnostics::CORE:subst, avg 163ns/call # spent 169µs making 540 calls to diagnostics::CORE:substcont, avg 313ns/call
344280215µs280742µs my($text,$page,$sect) = _split_pod_link($1);
# spent 742µs making 280 calls to diagnostics::_split_pod_link, avg 3µs/call
345280264µs3863.82ms defined $text
# spent 3.82ms making 386 calls to diagnostics::italic, avg 10µs/call
346 ? $text
347 : defined $sect
348 ? italic($sect) . ' in ' . italic($page)
349 : italic($page)
350 /ges;
35124984.26ms2498442µs s/S<(.*?)>/
# spent 442µs making 2498 calls to diagnostics::CORE:subst, avg 177ns/call
352 $1
353 /ges;
354 } else {
355 s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/$+/gs;
356 s/[IF]<(.*?)>/$1/gs;
357 s/L<(.*?)>/
358 my($text,$page,$sect) = _split_pod_link($1);
359 defined $text
360 ? $text
361 : defined $sect
362 ? qq '"$sect" in $page'
363 : $page
364 /ges;
365 s/S<(.*?)>/
366 $1
367 /ges;
368 }
36924987.51ms2498283µs unless (/^=/) {
# spent 283µs making 2498 calls to diagnostics::CORE:match, avg 113ns/call
3701435204µs if (defined $header) {
3711433180µs154µs if ( $header eq 'DESCRIPTION' &&
# spent 4µs making 15 calls to diagnostics::CORE:match, avg 287ns/call
372 ( /Optional warnings are enabled/
373 || /Some of these messages are generic./
374 ) )
375 {
3762700ns next;
377 }
3781431769µs143151.9ms $_ = expand $_;
# spent 51.9ms making 1431 calls to Text::Tabs::expand, avg 36µs/call
37914315.79ms14312.50ms s/^/ /gm;
# spent 2.50ms making 1431 calls to diagnostics::CORE:subst, avg 2µs/call
3801431735µs $msg{$header} .= $_;
3811474293µs for my $h(@headers) { $msg{$h} .= $_ }
3821431119µs ++$seen_body;
3831431177µs undef $for_item;
384 }
3851433271µs next;
386 }
387
388 # If we have not come across the body of the description yet, then
389 # the previous header needs to share the same description.
3901063199µs if ($seen_body) {
391 @headers = ();
392 }
393 else {
394309µs push @headers, $header if defined $header;
395 }
396
39710635.45ms10632.35ms if ( ! s/=item (.*?)\s*\z//s || $over_level != 1) {
# spent 2.35ms making 1063 calls to diagnostics::CORE:subst, avg 2µs/call
398
3992558µs9311µs if ( s/=head1\sDESCRIPTION//) {
# spent 6µs making 44 calls to diagnostics::CORE:match, avg 143ns/call # spent 5µs making 49 calls to diagnostics::CORE:subst, avg 98ns/call
4001700ns $msg{$header = 'DESCRIPTION'} = '';
4011200ns undef $for_item;
402 }
403 elsif( s/^=for\s+diagnostics\s*\n(.*?)\s*\z// ) {
404 $for_item = $1;
405 }
406 elsif( /^=over\b/ ) {
407 $over_level++;
408 }
409 elsif( /^=back\b/ ) { # Stop processing body here
4104300ns $over_level--;
4114800ns if ($over_level == 0) {
4121100ns undef $header;
41310s undef $for_item;
4141100ns $seen_body = 0;
4151500ns next;
416 }
417 }
418247µs next;
419 }
420
4211038148µs if( $for_item ) { $header = $for_item; undef $for_item }
422 else {
4231038328µs $header = $1;
424
42510386.03ms1038143µs $header =~ s/\n/ /gs; # Allow multi-line headers
# spent 143µs making 1038 calls to diagnostics::CORE:subst, avg 137ns/call
426 }
427
428 # strip formatting directives from =item line
4291038591µs1038108µs $header =~ s/[A-Z]<(.*?)>/$1/g;
# spent 108µs making 1038 calls to diagnostics::CORE:subst, avg 104ns/call
430
431 # Since we strip "(\.\s*)\n" when we search a warning, strip it here as well
43210384.34ms10383.79ms $header =~ s/(\.\s*)?$//;
# spent 3.79ms making 1038 calls to diagnostics::CORE:subst, avg 4µs/call
433
43410381.14ms my @toks = split( /(%l?[dxX]|%[ucp]|%(?:\.\d+)?[fs])/, $header );
4351038223µs if (@toks > 1) {
43664873µs my $conlen = 0;
437648310µs for my $i (0..$#toks){
4382274739µs if( $i % 2 ){
4399163.99ms1718428µs if( $toks[$i] eq '%c' ){
# spent 428µs making 1718 calls to diagnostics::CORE:match, avg 249ns/call
440 $toks[$i] = '.';
441 } elsif( $toks[$i] =~ /^%(?:d|u)$/ ){
442 $toks[$i] = '\d+';
443 } elsif( $toks[$i] =~ '^%(?:s|.*f)$' ){
444 $toks[$i] = $i == $#toks ? '.*' : '.*?';
445 } elsif( $toks[$i] =~ '%.(\d+)s' ){
446 $toks[$i] = ".{$1}";
447 } elsif( $toks[$i] =~ '^%l*([pxX])$' ){
448 $toks[$i] = $1 eq 'X' ? '[\dA-F]+' : '[\da-f]+';
449 }
450 } elsif( length( $toks[$i] ) ){
4511324422µs $toks[$i] = quotemeta $toks[$i];
4521324155µs $conlen += length( $toks[$i] );
453 }
454 }
455648274µs my $lhs = join( '', @toks );
4566482.11ms6481.74ms $lhs =~ s/(\\\s)+/\\s+/g; # Replace lit space with multi-space match
# spent 1.74ms making 648 calls to diagnostics::CORE:subst, avg 3µs/call
457 $transfmt{$header}{pat} =
458648747µs " s^\\s*$lhs\\s*\Q$header\Es\n\t&& return 1;\n";
459648201µs $transfmt{$header}{len} = $conlen;
460 } else {
461390157µs my $lhs = "\Q$header\E";
462390979µs390755µs $lhs =~ s/(\\\s)+/\\s+/g; # Replace lit space with multi-space match
# spent 755µs making 390 calls to diagnostics::CORE:subst, avg 2µs/call
463 $transfmt{$header}{pat} =
464390389µs " s^\\s*$lhs\\s*\Q$header\E\n\t && return 1;\n";
465390122µs $transfmt{$header}{len} = length( $header );
466 }
467
468 print STDERR __PACKAGE__.": Duplicate entry: \"$header\"\n"
4691038232µs if $msg{$header};
470
4711038339µs $msg{$header} = '';
47210383.66ms10382.67ms $seen_body = 0;
# spent 2.67ms making 1038 calls to diagnostics::CORE:readline, avg 3µs/call
473 }
474
475
476111µs16µs close POD_DIAG unless *main::DATA eq *POD_DIAG;
# spent 6µs making 1 call to diagnostics::CORE:close
477
4781300ns die "No diagnostics?" unless %msg;
479
480 # Apply patterns in order of decreasing sum of lengths of fixed parts
481 # Seems the best way of hitting the right one.
48211.45ms11.29ms for my $hdr ( sort { $transfmt{$b}{len} <=> $transfmt{$a}{len} }
# spent 1.29ms making 1 call to diagnostics::CORE:sort
483 keys %transfmt ){
4841038351µs $transmo .= $transfmt{$hdr}{pat};
485 }
4861300ns $transmo .= " return 0;\n}\n";
4871500ns print STDERR $transmo if $DEBUG;
488143.2ms eval $transmo;
48914µs die $@ if $@;
490}
491
4921500nsif ($standalone) {
493 if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" }
494 while (defined (my $error = <>)) {
495 splainthis($error) || print THITHER $error;
496 }
497 exit;
498}
499
5001500nsmy $olddie;
501my $oldwarn;
502
503
# spent 28µs (24+4) within diagnostics::import which was called 3 times, avg 9µs/call: # once (16µs+4µs) by main::BEGIN@8 at line 8 of /home/hejohns/documentsNoSync/22f/490/gradescope-utils/bin/split.pl # once (4µs+0s) by Gradescope::Translate::BEGIN@7 at line 7 of /home/hejohns/documentsNoSync/22f/490/gradescope-utils/lib/Gradescope/Translate.pm # once (3µs+0s) by Gradescope::Color::BEGIN@7 at line 7 of /home/hejohns/documentsNoSync/22f/490/gradescope-utils/lib/Gradescope/Color.pm
sub import {
5043800ns shift;
50532µs $^W = 1; # yup, clobbered the global variable;
506 # tough, if you want diags, you want diags.
50738µs return if defined $SIG{__WARN__} && ($SIG{__WARN__} eq \&warn_trap);
508
50911µs for (@_) {
510
51116µs11µs /^-d(ebug)?$/ && do {
# spent 1µs making 1 call to diagnostics::CORE:match
512 $DEBUG++;
513 next;
514 };
515
51614µs13µs /^-v(erbose)?$/ && do {
# spent 3µs making 1 call to diagnostics::CORE:match
5171500ns $VERBOSE++;
5181800ns next;
519 };
520
521 /^-p(retty)?$/ && do {
522 print STDERR "$0: I'm afraid it's too late for prettiness.\n";
523 $PRETTY++;
524 next;
525 };
526 # matches trace and traceonly for legacy doc mixup reasons
527 /^-t(race(only)?)?$/ && do {
528 $TRACEONLY++;
529 next;
530 };
531 /^-w(arntrace)?$/ && do {
532 $WARNTRACE++;
533 next;
534 };
535
536 warn "Unknown flag: $_";
537 }
538
5391300ns $oldwarn = $SIG{__WARN__};
5401500ns $olddie = $SIG{__DIE__};
54112µs $SIG{__WARN__} = \&warn_trap;
54213µs $SIG{__DIE__} = \&death_trap;
543}
544
545sub enable { &import }
546
547sub disable {
548 shift;
549 return unless $SIG{__WARN__} eq \&warn_trap;
550 $SIG{__WARN__} = $oldwarn || '';
551 $SIG{__DIE__} = $olddie || '';
552}
553
554sub warn_trap {
555 my $warning = $_[0];
556 if (caller eq __PACKAGE__ or !splainthis($warning)) {
557 if ($WARNTRACE) {
558 print STDERR Carp::longmess($warning);
559 } else {
560 print STDERR $warning;
561 }
562 }
563 goto &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap;
564};
565
566
# spent 20µs within diagnostics::death_trap which was called 3 times, avg 7µs/call: # 3 times (20µs+0s) by Locale::Maketext::Simple::load_loc at line 140 of Locale/Maketext/Simple.pm, avg 7µs/call
sub death_trap {
56732µs my $exception = $_[0];
568
569 # See if we are coming from anywhere within an eval. If so we don't
570 # want to explain the exception because it's going to get caught.
5713800ns my $in_eval = 0;
5723400ns my $i = 0;
57337µs while (my $caller = (caller($i++))[3]) {
57461µs if ($caller eq '(eval)') {
5753400ns $in_eval = 1;
57632µs last;
577 }
578 }
579
5803500ns splainthis($exception) unless $in_eval;
58131µs if (caller eq __PACKAGE__) {
582 print STDERR "INTERNAL EXCEPTION: $exception";
583 }
5843800ns &$olddie if defined $olddie and $olddie and $olddie ne \&death_trap;
585
58636µs return if $in_eval;
587
588 # We don't want to unset these if we're coming from an eval because
589 # then we've turned off diagnostics.
590
591 # Switch off our die/warn handlers so we don't wind up in our own
592 # traps.
593 $SIG{__DIE__} = $SIG{__WARN__} = '';
594
595 $exception =~ s/\n(?=.)/\n\t/gas;
596
597 die Carp::longmess("__diagnostics__")
598 =~ s/^__diagnostics__.*?line \d+\.?\n/
599 "Uncaught exception from user code:\n\t$exception"
600 /re;
601 # up we go; where we stop, nobody knows, but i think we die now
602 # but i'm deeply afraid of the &$olddie guy reraising and us getting
603 # into an indirect recursion loop
604};
605
606my %exact_duplicate;
607my %old_diag;
608my $count;
609my $wantspace;
610sub splainthis {
611 return 0 if $TRACEONLY;
612 for (my $tmp = shift) {
613 local $\;
614 local $!;
615 ### &finish_compilation unless %msg;
616 s/(\.\s*)?\n+$//;
617 my $orig = $_;
618 # return unless defined;
619
620 # get rid of the where-are-we-in-input part
621 s/, <.*?> (?:line|chunk).*$//;
622
623 # Discard 1st " at <file> line <no>" and all text beyond
624 # but be aware of messages containing " at this-or-that"
625 my $real = 0;
626 my @secs = split( / at / );
627 return unless @secs;
628 $_ = $secs[0];
629 for my $i ( 1..$#secs ){
630 if( $secs[$i] =~ /.+? (?:line|chunk) \d+/ ){
631 $real = 1;
632 last;
633 } else {
634 $_ .= ' at ' . $secs[$i];
635 }
636 }
637
638 # remove parenthesis occurring at the end of some messages
639 s/^\((.*)\)$/$1/;
640
641 if ($exact_duplicate{$orig}++) {
642 return &transmo;
643 } else {
644 return 0 unless &transmo;
645 }
646
647 my $short = shorten($orig);
648 if ($old_diag{$_}) {
649 autodescribe();
650 print THITHER "$short (#$old_diag{$_})\n";
651 $wantspace = 1;
652 } elsif (!$msg{$_} && $orig =~ /\n./s) {
653 # A multiline message, like "Attempt to reload /
654 # Compilation failed"
655 my $found;
656 for (split /^/, $orig) {
657 splainthis($_) and $found = 1;
658 }
659 return $found;
660 } else {
661 autodescribe();
662 $old_diag{$_} = ++$count;
663 print THITHER "\n" if $wantspace;
664 $wantspace = 0;
665 print THITHER "$short (#$old_diag{$_})\n";
666 if ($msg{$_}) {
667 print THITHER $msg{$_};
668 } else {
669 if (0 and $standalone) {
670 print THITHER " **** Error #$old_diag{$_} ",
671 ($real ? "is" : "appears to be"),
672 " an unknown diagnostic message.\n\n";
673 }
674 return 0;
675 }
676 }
677 return 1;
678 }
679}
680
681sub autodescribe {
682 if ($VERBOSE and not $count) {
683 print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"),
684 "\n$msg{DESCRIPTION}\n";
685 }
686}
687
688
# spent 2.31ms (1.96+350µs) within diagnostics::unescape which was called 2498 times, avg 924ns/call: # 2498 times (1.96ms+350µs) by main::BEGIN@8 at line 336, avg 924ns/call
sub unescape {
68924983.01ms2520350µs s {
# spent 342µs making 2498 calls to diagnostics::CORE:subst, avg 137ns/call # spent 8µs making 22 calls to diagnostics::CORE:substcont, avg 377ns/call
690 do {
691 exists $HTML_Escapes{$1}
692 ? do { $HTML_Escapes{$1} }
693 : do {
694152µs warn "Unknown escape: E<$1> in $_";
695 "E<$1>";
696 }
697158µs }
698 }egx;
699
- -
703}
704
705sub shorten {
706 my $line = $_[0];
707 if (length($line) > 79 and index($line, "\n") == -1) {
708 my $space_place = rindex($line, ' ', 79);
709 if ($space_place != -1) {
710 substr($line, $space_place, 1) = "\n\t";
711 }
712 }
713 return $line;
714}
715
716
7171463µs1 unless $standalone; # or it'll complain about itself
718__END__ # wish diag dbase were more accessible
 
# spent 6µs within diagnostics::CORE:close which was called: # once (6µs+0s) by main::BEGIN@8 at line 476
sub diagnostics::CORE:close; # opcode
# spent 8µs within diagnostics::CORE:eof which was called: # once (8µs+0s) by main::BEGIN@8 at line 258
sub diagnostics::CORE:eof; # opcode
# spent 10µs within diagnostics::CORE:ftis which was called 3 times, avg 3µs/call: # 2 times (6µs+0s) by main::BEGIN@8 at line 209, avg 3µs/call # once (4µs+0s) by main::BEGIN@8 at line 208
sub diagnostics::CORE:ftis; # opcode
# spent 1.04ms within diagnostics::CORE:match which was called 4557 times, avg 229ns/call: # 2498 times (283µs+0s) by main::BEGIN@8 at line 369, avg 113ns/call # 1718 times (428µs+0s) by main::BEGIN@8 at line 439, avg 249ns/call # 280 times (316µs+0s) by diagnostics::_split_pod_link at line 332, avg 1µs/call # 44 times (6µs+0s) by main::BEGIN@8 at line 399, avg 143ns/call # 15 times (4µs+0s) by main::BEGIN@8 at line 371, avg 287ns/call # once (3µs+0s) by diagnostics::import at line 516 # once (1µs+0s) by diagnostics::import at line 511
sub diagnostics::CORE:match; # opcode
# spent 12µs within diagnostics::CORE:open which was called: # once (12µs+0s) by main::BEGIN@8 at line 234
sub diagnostics::CORE:open; # opcode
# spent 3.64ms within diagnostics::CORE:readline which was called 2499 times, avg 1µs/call: # 1461 times (975µs+0s) by main::BEGIN@8 at line 329, avg 667ns/call # 1038 times (2.67ms+0s) by main::BEGIN@8 at line 472, avg 3µs/call
sub diagnostics::CORE:readline; # opcode
# spent 1.29ms within diagnostics::CORE:sort which was called: # once (1.29ms+0s) by main::BEGIN@8 at line 482
sub diagnostics::CORE:sort; # opcode
# spent 25.8ms within diagnostics::CORE:subst which was called 20563 times, avg 1µs/call: # 2498 times (12.4ms+0s) by main::BEGIN@8 at line 341, avg 5µs/call # 2498 times (444µs+0s) by main::BEGIN@8 at line 342, avg 178ns/call # 2498 times (442µs+0s) by main::BEGIN@8 at line 351, avg 177ns/call # 2498 times (408µs+0s) by main::BEGIN@8 at line 343, avg 163ns/call # 2498 times (342µs+0s) by diagnostics::unescape at line 689, avg 137ns/call # 1431 times (2.50ms+0s) by main::BEGIN@8 at line 379, avg 2µs/call # 1063 times (2.35ms+0s) by main::BEGIN@8 at line 397, avg 2µs/call # 1038 times (3.79ms+0s) by main::BEGIN@8 at line 432, avg 4µs/call # 1038 times (143µs+0s) by main::BEGIN@8 at line 425, avg 137ns/call # 1038 times (108µs+0s) by main::BEGIN@8 at line 429, avg 104ns/call # 955 times (248µs+0s) by diagnostics::bold at line 339, avg 259ns/call # 648 times (1.74ms+0s) by main::BEGIN@8 at line 456, avg 3µs/call # 423 times (130µs+0s) by diagnostics::italic at line 340, avg 308ns/call # 390 times (755µs+0s) by main::BEGIN@8 at line 462, avg 2µs/call # 49 times (5µs+0s) by main::BEGIN@8 at line 399, avg 98ns/call
sub diagnostics::CORE:subst; # opcode
# spent 6.59ms within diagnostics::CORE:substcont which was called 14119 times, avg 467ns/call: # 7779 times (1.49ms+0s) by diagnostics::bold at line 339, avg 191ns/call # 4282 times (827µs+0s) by diagnostics::italic at line 340, avg 193ns/call # 1427 times (4.07ms+0s) by main::BEGIN@8 at line 341, avg 3µs/call # 540 times (169µs+0s) by main::BEGIN@8 at line 343, avg 313ns/call # 69 times (26µs+0s) by main::BEGIN@8 at line 342, avg 383ns/call # 22 times (8µs+0s) by diagnostics::unescape at line 689, avg 377ns/call
sub diagnostics::CORE:substcont; # opcode
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.