← 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:10 2023

Filename/home/hejohns/perl5/lib/perl5/Data/Printer/Common.pm
StatementsExecuted 48 statements in 1.77ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
111165µs65µsData::Printer::Common::::_filter_category_forData::Printer::Common::_filter_category_for
1117µs8µsData::Printer::Common::::BEGIN@3Data::Printer::Common::BEGIN@3
1117µs16µsData::Printer::Common::::BEGIN@5Data::Printer::Common::BEGIN@5
1117µs12µsData::Printer::Common::::BEGIN@401Data::Printer::Common::BEGIN@401
1116µs20µsData::Printer::Common::::BEGIN@206Data::Printer::Common::BEGIN@206
1115µs8µsData::Printer::Common::::BEGIN@428Data::Printer::Common::BEGIN@428
1113µs12µsData::Printer::Common::::BEGIN@4Data::Printer::Common::BEGIN@4
0000s0sData::Printer::Common::::__ANON__[:386]Data::Printer::Common::__ANON__[:386]
0000s0sData::Printer::Common::::_colorstripData::Printer::Common::_colorstrip
0000s0sData::Printer::Common::::_dieData::Printer::Common::_die
0000s0sData::Printer::Common::::_escape_charsData::Printer::Common::_escape_chars
0000s0sData::Printer::Common::::_fetch_anyofData::Printer::Common::_fetch_anyof
0000s0sData::Printer::Common::::_fetch_arrayref_of_scalarsData::Printer::Common::_fetch_arrayref_of_scalars
0000s0sData::Printer::Common::::_fetch_indexes_forData::Printer::Common::_fetch_indexes_for
0000s0sData::Printer::Common::::_fetch_scalar_or_defaultData::Printer::Common::_fetch_scalar_or_default
0000s0sData::Printer::Common::::_get_namespaceData::Printer::Common::_get_namespace
0000s0sData::Printer::Common::::_get_proper_callerData::Printer::Common::_get_proper_caller
0000s0sData::Printer::Common::::_get_superclasses_forData::Printer::Common::_get_superclasses_for
0000s0sData::Printer::Common::::_get_symbolData::Printer::Common::_get_symbol
0000s0sData::Printer::Common::::_initialize_mroData::Printer::Common::_initialize_mro
0000s0sData::Printer::Common::::_initialize_nsortData::Printer::Common::_initialize_nsort
0000s0sData::Printer::Common::::_linear_ISA_forData::Printer::Common::_linear_ISA_for
0000s0sData::Printer::Common::::_nsortData::Printer::Common::_nsort
0000s0sData::Printer::Common::::_nsort_ppData::Printer::Common::_nsort_pp
0000s0sData::Printer::Common::::_print_escapesData::Printer::Common::_print_escapes
0000s0sData::Printer::Common::::_process_stringData::Printer::Common::_process_string
0000s0sData::Printer::Common::::_reduce_stringData::Printer::Common::_reduce_string
0000s0sData::Printer::Common::::_trymeData::Printer::Common::_tryme
0000s0sData::Printer::Common::::_warnData::Printer::Common::_warn
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1package Data::Printer::Common;
2# Private library of shared Data::Printer code.
3214µs29µs
# spent 8µs (7+1000ns) within Data::Printer::Common::BEGIN@3 which was called: # once (7µs+1000ns) by Data::Printer::BEGIN@3.28 at line 3
use strict;
# spent 8µs making 1 call to Data::Printer::Common::BEGIN@3 # spent 1µs making 1 call to strict::import
4211µs220µs
# spent 12µs (3+9) within Data::Printer::Common::BEGIN@4 which was called: # once (3µs+9µs) by Data::Printer::BEGIN@3.28 at line 4
use warnings;
# spent 12µs making 1 call to Data::Printer::Common::BEGIN@4 # spent 9µs making 1 call to warnings::import
52761µs225µs
# spent 16µs (7+9) within Data::Printer::Common::BEGIN@5 which was called: # once (7µs+9µs) by Data::Printer::BEGIN@3.28 at line 5
use Scalar::Util;
# spent 16µs making 1 call to Data::Printer::Common::BEGIN@5 # spent 9µs making 1 call to Exporter::import
6
71200nsmy $mro_initialized = 0;
81100nsmy $nsort_initialized;
9
10
11
# spent 65µs within Data::Printer::Common::_filter_category_for which was called 11 times, avg 6µs/call: # 11 times (65µs+0s) by Data::Printer::Filter::__ANON__[/home/hejohns/perl5/lib/perl5/Data/Printer/Filter.pm:23] at line 18 of Data/Printer/Filter.pm, avg 6µs/call
sub _filter_category_for {
12113µs my ($name) = @_;
131145µs my %core_types = map { $_ => 1 }
14 qw(SCALAR LVALUE ARRAY HASH REF VSTRING GLOB FORMAT Regexp CODE);
151123µs return exists $core_types{$name} ? 'type_filters' : 'class_filters';
16}
17
18# strings are tough to process: there are control characters like "\t",
19# unicode characters to name or escape (or do nothing), max_string to
20# worry about, and every single piece of that could have its own color.
21# That, and hash keys and strings share this. So we put it all in one place.
22sub _process_string {
23 my ($ddp, $string, $src_color) = @_;
24
25 # colorizing messes with reduce_string because we are effectively
26 # adding new (invisible) characters to the string. So we need to
27 # handle reduction first. But! Because we colorize string_max
28 # *and* we should escape any colors already present, we need to
29 # do both at the same time.
30 $string = _reduce_string($ddp, $string, $src_color);
31
32 # now we escape all other control characters except for "\e", which was
33 # already escaped in _reduce_string(), and convert any chosen charset
34 # to the \x{} format. These could go in any particular order:
35 $string = _escape_chars($ddp, $string, $src_color);
36 $string = _print_escapes($ddp, $string, $src_color);
37
38 # finally, send our wrapped string:
39 return $ddp->maybe_colorize($string, $src_color);
40}
41
42sub _colorstrip {
43 my ($string) = @_;
44 $string =~ s{ \e\[ [\d;]* m }{}xmsg;
45 return $string;
46}
47
48sub _reduce_string {
49 my ($ddp, $string, $src_color) = @_;
50 my $max = $ddp->string_max;
51 my $str_len = length($string);
52 if ($max && $str_len && $str_len > $max) {
53 my $preserve = $ddp->string_preserve;
54 my $skipped_chars = $str_len - ($preserve eq 'none' ? 0 : $max);
55 my $skip_message = $ddp->maybe_colorize(
56 $ddp->string_overflow,
57 'caller_info',
58 undef,
59 $src_color
60 );
61 $skip_message =~ s/__SKIPPED__/$skipped_chars/g;
62 if ($preserve eq 'end') {
63 substr $string, 0, $skipped_chars, '';
64 $string =~ s{\e}{$ddp->maybe_colorize('\\e', 'escaped', undef, $src_color)}ge
65 if $ddp->print_escapes;
66 $string = $skip_message . $string;
67 }
68 elsif ($preserve eq 'begin') {
69 $string = substr($string, 0, $max);
70 $string =~ s{\e}{$ddp->maybe_colorize('\\e', 'escaped', undef, $src_color)}ge
71 if $ddp->print_escapes;
72 $string = $string . $skip_message;
73 }
74 elsif ($preserve eq 'extremes') {
75 my $leftside_chars = int($max / 2);
76 my $rightside_chars = $max - $leftside_chars;
77 my $leftside = substr($string, 0, $leftside_chars);
78 my $rightside = substr($string, -$rightside_chars);
79 if ($ddp->print_escapes) {
80 $leftside =~ s{\e}{$ddp->maybe_colorize('\\e', 'escaped', undef, $src_color)}ge;
81 $rightside =~ s{\e}{$ddp->maybe_colorize('\\e', 'escaped', undef, $src_color)}ge;
82 }
83 $string = $leftside . $skip_message . $rightside;
84 }
85 elsif ($preserve eq 'middle') {
86 my $string_middle = int($str_len / 2);
87 my $middle_substr = int($max / 2);
88 my $substr_begin = $string_middle - $middle_substr;
89 my $message_begin = $ddp->string_overflow;
90 $message_begin =~ s/__SKIPPED__/$substr_begin/gs;
91 my $chars_left = $str_len - ($substr_begin + $max);
92 my $message_end = $ddp->string_overflow;
93 $message_end =~ s/__SKIPPED__/$chars_left/gs;
94 $string = substr($string, $substr_begin, $max);
95 $string =~ s{\e}{$ddp->maybe_colorize('\\e', 'escaped', undef, $src_color)}ge
96 if $ddp->print_escapes;
97 $string = $ddp->maybe_colorize($message_begin, 'caller_info', undef, $src_color)
98 . $string
99 . $ddp->maybe_colorize($message_end, 'caller_info', undef, $src_color)
100 ;
101 }
102 else {
103 # preserving 'none' only shows the skipped message:
104 $string = $skip_message;
105 }
106 }
107 else {
108 # nothing to do? ok, then escape any colors already present:
109 $string =~ s{\e}{$ddp->maybe_colorize('\\e', 'escaped', undef, $src_color)}ge
110 if $ddp->print_escapes;
111 }
112 return $string;
113}
114
115
116# _escape_chars() replaces characters with their "escaped" versions.
117# Because it may be called on scalars or (scalar) hash keys and they
118# have different colors, we need to be aware of that.
119sub _escape_chars {
120 my ($ddp, $scalar, $src_color) = @_;
121
122 my $escape_kind = $ddp->escape_chars;
123 my %target_for = (
124 nonascii => '[^\x{00}-\x{7f}]+',
125 nonlatin1 => '[^\x{00}-\x{ff}]+',
126 );
127
128 if ($ddp->unicode_charnames) {
129 require charnames;
130 if ($escape_kind eq 'all') {
131 $scalar = join('', map { sprintf '\N{%s}', charnames::viacode(ord $_) } split //, $scalar);
132 $scalar = $ddp->maybe_colorize($scalar, 'escaped');
133 }
134 else {
135 $scalar =~ s{($target_for{$escape_kind})}{$ddp->maybe_colorize( (join '', map { sprintf '\N{%s}', charnames::viacode(ord $_) } split //, $1), 'escaped', undef, $src_color)}ge if exists $target_for{$escape_kind};
136 }
137 }
138 elsif ($escape_kind eq 'all') {
139 $scalar = join('', map { sprintf '\x{%02x}', ord $_ } split //, $scalar);
140 $scalar = $ddp->maybe_colorize($scalar, 'escaped');
141 }
142 else {
143 $scalar =~ s{($target_for{$escape_kind})}{$ddp->maybe_colorize((join '', map { sprintf '\x{%02x}', ord $_ } split //, $1), 'escaped', undef, $src_color)}ge if exists $target_for{$escape_kind};
144 }
145 return $scalar;
146}
147
148# _print_escapes() prints invisible chars if they exist on a string.
149# Because it may be called on scalars or (scalar) hash keys and they
150# have different colors, we need to be aware of that. Also, \e is
151# deliberately omitted because it was escaped from the original
152# string earlier, and the \e's we have now are our own colorized
153# output.
154sub _print_escapes {
155 my ($ddp, $string, $src_color) = @_;
156
157 # always escape the null character
158 $string =~ s/\0/$ddp->maybe_colorize('\\0', 'escaped', undef, $src_color)/ge;
159
160 return $string unless $ddp->print_escapes;
161
162 my %escaped = (
163 "\n" => '\n', # line feed
164 "\r" => '\r', # carriage return
165 "\t" => '\t', # horizontal tab
166 "\f" => '\f', # formfeed
167 "\b" => '\b', # backspace
168 "\a" => '\a', # alert (bell)
169 );
170 foreach my $k ( keys %escaped ) {
171 $string =~ s/$k/$ddp->maybe_colorize($escaped{$k}, 'escaped', undef, $src_color)/ge;
172 }
173 return $string;
174}
175
176sub _initialize_nsort {
177 return 'Sort::Key::Natural' if $INC{'Sort/Key/Natural.pm'};
178 return 'Sort::Naturally' if $INC{'Sort/Naturally.pm'};
179 return 'Sort::Key::Natural' if !_tryme('use Sort::Key::Natural; 1;');
180 return 'Sort::Naturally' if !_tryme('use Sort::Naturally; 1;');
181 return 'core';
182}
183
184sub _nsort {
185 if (!$nsort_initialized) {
186 my $nsort_class = _initialize_nsort();
187 if ($nsort_class eq 'Sort::Key::Natural') {
188 $nsort_initialized = \&{ $nsort_class . '::natsort' };
189 }
190 elsif ($nsort_class ne 'core') {
191 $nsort_initialized = \&{ $nsort_class . '::nsort' };
192 }
193 else {
194 $nsort_initialized = \&_nsort_pp
195 }
196 }
197 return $nsort_initialized->(@_);
198}
199
200# this is a very simple 'natural-ish' sorter, heavily inspired in
201# http://www.perlmonks.org/?node_id=657130 by thundergnat and tye
202sub _nsort_pp {
203 my $i;
204 my @unsorted = map lc, @_;
205 foreach my $data (@unsorted) {
2062757µs235µs
# spent 20µs (6+15) within Data::Printer::Common::BEGIN@206 which was called: # once (6µs+15µs) by Data::Printer::BEGIN@3.28 at line 206
no warnings 'uninitialized';
# spent 20µs making 1 call to Data::Printer::Common::BEGIN@206 # spent 15µs making 1 call to warnings::unimport
207 $data =~ s/((\.0*)?)(\d+)/("\x0" x length $2) . (pack 'aNa*', 0, length $3, $3)/eg;
208 $data .= ' ' . $i++;
209 }
210 return @_[ map { (split)[-1] } sort @unsorted ];
211}
212
213sub _fetch_arrayref_of_scalars {
214 my ($props, $name) = @_;
215 return [] unless exists $props->{$name} && ref $props->{$name} eq 'ARRAY';
216 my @valid;
217 foreach my $option (@{$props->{$name}}) {
218 if (ref $option) {
219 # FIXME: because there is no object at this point, we need to check
220 # the 'warnings' option ourselves.
221 _warn(undef, "'$name' option requires scalar values only. Ignoring $option.")
222 if !exists $props->{warnings} || !$props->{warnings};
223 next;
224 }
225 push @valid, $option;
226 }
227 return \@valid;
228}
229
230sub _fetch_anyof {
231 my ($props, $name, $default, $list) = @_;
232 return $default unless exists $props->{$name};
233 foreach my $option (@$list) {
234 return $option if $props->{$name} eq $option;
235 }
236 _die(
237 "invalid value '$props->{$name}' for option '$name'"
238 . "(must be one of: " . join(',', @$list) . ")"
239 );
240};
241
242
243sub _fetch_scalar_or_default {
244 my ($props, $name, $default) = @_;
245 return $default unless exists $props->{$name};
246
247 if (my $ref = ref $props->{$name}) {
248 _die("'$name' property must be a scalar, not a reference to $ref");
249 }
250 return $props->{$name};
251}
252
253sub _die {
254 my ($message) = @_;
255 my ($file, $line) = _get_proper_caller();
256 die '[Data::Printer] ' . $message . " at $file line $line.\n";
257}
258
259sub _warn {
260 my ($ddp, $message) = @_;
261 return if $ddp && !$ddp->warnings;
262 my ($file, $line) = _get_proper_caller();
263 warn '[Data::Printer] ' . $message . " at $file line $line.\n";
264}
265
266sub _get_proper_caller {
267 my $frame = 1;
268 while (my @caller = caller($frame++)) {
269 if ($caller[0] !~ /\AD(?:DP|ata::Printer)/) {
270 return ($caller[1], $caller[2]);
271 }
272 }
273 return ('n/d', 'n/d');
274}
275
276
277# simple eval++ adapted from Try::Tiny.
278# returns a (true) error message if failed.
279sub _tryme {
280 my ($subref_or_string) = @_;
281
282 my $previous_error = $@;
283 my ($failed, $error);
284
285 if (ref $subref_or_string eq 'CODE') {
286 $failed = not eval {
287 local $SIG{'__DIE__'}; # make sure we don't trigger any exception hooks.
288 $@ = $previous_error;
289 $subref_or_string->();
290 return 1;
291 };
292 $error = $@;
293 }
294 else {
295 my $code = q(local $SIG{'__DIE__'};) . $subref_or_string;
296 $failed = not eval $code;
297 $error = $@;
298 }
299 $@ = $previous_error;
300 # at this point $failed contains a true value if the eval died,
301 # even if some destructor overwrote $@ as the eval was unwinding.
302 return unless $failed;
303 return ($error || '(unknown error)');
304}
305
306
307# When printing array elements or hash keys, we may traverse all of it
308# or just a few chunks. This function returns those chunks' indexes, and
309# a scalar ref to a message whenever a chunk was skipped.
310sub _fetch_indexes_for {
311 my ($array_ref, $prefix, $ddp) = @_;
312
313 my $max_function = $prefix . '_max';
314 my $preserve_function = $prefix . '_preserve';
315 my $overflow_function = $prefix . '_overflow';
316 my $max = $ddp->$max_function;
317 my $preserve = $ddp->$preserve_function;
318
319 return (0 .. $#{$array_ref}) if !$max || @$array_ref <= $max;
320
321 my $skip_message = $ddp->maybe_colorize($ddp->$overflow_function, 'overflow');
322 if ($preserve eq 'begin' || $preserve eq 'end') {
323 my $n_elements = @$array_ref - $max;
324 $skip_message =~ s/__SKIPPED__/$n_elements/g;
325 return $preserve eq 'begin'
326 ? ((0 .. ($max - 1)), \$skip_message)
327 : (\$skip_message, ($n_elements .. $#{$array_ref}))
328 ;
329 }
330 elsif ($preserve eq 'extremes') {
331 my $half_max = int($max / 2);
332 my $last_index_of_chunk_one = $half_max - 1;
333 my $n_elements = @$array_ref - $max;
334
335 my $first_index_of_chunk_two = @$array_ref - ($max - $half_max);
336 $skip_message =~ s/__SKIPPED__/$n_elements/g;
337 return (
338 (0 .. $last_index_of_chunk_one),
339 \$skip_message,
340 ($first_index_of_chunk_two .. $#{$array_ref})
341 );
342 }
343 elsif ($preserve eq 'middle') {
344 my $array_middle = int($#{$array_ref} / 2);
345 my $first_index_to_show = $array_middle - int($max / 2);
346 my $last_index_to_show = $first_index_to_show + $max - 1;
347 my ($message_begin, $message_end) = ($skip_message, $skip_message);
348 $message_begin =~ s/__SKIPPED__/$first_index_to_show/gse;
349 my $items_left = $#{$array_ref} - $last_index_to_show;
350 $message_end =~ s/__SKIPPED__/$items_left/gs;
351 return (
352 \$message_begin,
353 $first_index_to_show .. $last_index_to_show,
354 \$message_end
355 );
356 }
357 else { # $preserve eq 'none'
358 my $n_elements = scalar(@$array_ref);
359 $skip_message =~ s/__SKIPPED__/$n_elements/g;
360 return (\$skip_message);
361 }
362}
363
364# helpers below strongly inspired by the excellent Package::Stash:
365sub _linear_ISA_for {
366 my ($class, $ddp) = @_;
367 _initialize_mro($ddp) unless $mro_initialized;
368 my $isa;
369 if ($mro_initialized > 0) {
370 $isa = mro::get_linear_isa($class);
371 }
372 else {
373 # minimal fallback in case Class::MRO isn't available
374 # (should only matter for perl < 5.009_005):
375 $isa = [ $class, _get_superclasses_for($class) ];
376 }
377 return [@$isa, ($ddp->class->universal ? 'UNIVERSAL' : ())];
378}
379
380sub _initialize_mro {
381 my ($ddp) = @_;
382 my $error = _tryme(sub {
383 if ($] < 5.009_005) { require MRO::Compat }
384 else { require mro }
385 1;
386 });
387 if ($error && index($error, 'in @INC') != -1 && $mro_initialized == 0) {
388 _warn(
389 $ddp,
390 ($] < 5.009_005 ? 'MRO::Compat' : 'mro') . ' not found in @INC.'
391 . ' Objects may display inaccurate/incomplete ISA and method list'
392 );
393 }
394 $mro_initialized = $error ? -1 : 1;
395}
396
397sub _get_namespace {
398 my ($class_name) = @_;
399 my $namespace;
400 {
4012110µs217µs
# spent 12µs (7+5) within Data::Printer::Common::BEGIN@401 which was called: # once (7µs+5µs) by Data::Printer::BEGIN@3.28 at line 401
no strict 'refs';
# spent 12µs making 1 call to Data::Printer::Common::BEGIN@401 # spent 5µs making 1 call to strict::unimport
402 $namespace = \%{ $class_name . '::' }
403 }
404 # before 5.10, stashes don't ever seem to drop to a refcount of zero,
405 # so weakening them isn't helpful
406 Scalar::Util::weaken($namespace) if $] >= 5.010;
407
408 return $namespace;
409}
410
411sub _get_superclasses_for {
412 my ($class_name) = @_;
413 my $namespace = _get_namespace($class_name);
414 my $res = _get_symbol($class_name, $namespace, 'ISA', 'ARRAY');
415 return @{ $res || [] };
416}
417
418sub _get_symbol {
419 my ($class_name, $namespace, $symbol_name, $symbol_kind) = @_;
420
421 if (exists $namespace->{$symbol_name}) {
422 my $entry_ref = \$namespace->{$symbol_name};
423 if (ref($entry_ref) eq 'GLOB') {
424 return *{$entry_ref}{$symbol_kind};
425 }
426 else {
427 if ($symbol_kind eq 'CODE') {
428248µs211µs
# spent 8µs (5+3) within Data::Printer::Common::BEGIN@428 which was called: # once (5µs+3µs) by Data::Printer::BEGIN@3.28 at line 428
no strict 'refs';
# spent 8µs making 1 call to Data::Printer::Common::BEGIN@428 # spent 3µs making 1 call to strict::unimport
429 return \&{ $class_name . '::' . $symbol_name };
430 }
431 }
432 }
433 return;
434}
435
43612µs1;
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.