← Index
NYTProf Performance Profile   « line view »
For /usr/local/libexec/sympa/task_manager-debug.pl
  Run on Tue Jun 1 22:32:51 2021
Reported on Tue Jun 1 22:35:05 2021

Filename/usr/local/lib/perl5/site_perl/Specio/PartialDump.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sSpecio::PartialDump::::BEGIN@10Specio::PartialDump::BEGIN@10
0000s0sSpecio::PartialDump::::BEGIN@3Specio::PartialDump::BEGIN@3
0000s0sSpecio::PartialDump::::BEGIN@4Specio::PartialDump::BEGIN@4
0000s0sSpecio::PartialDump::::BEGIN@8Specio::PartialDump::BEGIN@8
0000s0sSpecio::PartialDump::::_dump_as_listSpecio::PartialDump::_dump_as_list
0000s0sSpecio::PartialDump::::_dump_as_pairsSpecio::PartialDump::_dump_as_pairs
0000s0sSpecio::PartialDump::::_dump_as_pairs_recursiveSpecio::PartialDump::_dump_as_pairs_recursive
0000s0sSpecio::PartialDump::::_formatSpecio::PartialDump::_format
0000s0sSpecio::PartialDump::::_format_arraySpecio::PartialDump::_format_array
0000s0sSpecio::PartialDump::::_format_hashSpecio::PartialDump::_format_hash
0000s0sSpecio::PartialDump::::_format_keySpecio::PartialDump::_format_key
0000s0sSpecio::PartialDump::::_format_numberSpecio::PartialDump::_format_number
0000s0sSpecio::PartialDump::::_format_objectSpecio::PartialDump::_format_object
0000s0sSpecio::PartialDump::::_format_refSpecio::PartialDump::_format_ref
0000s0sSpecio::PartialDump::::_format_scalarSpecio::PartialDump::_format_scalar
0000s0sSpecio::PartialDump::::_format_stringSpecio::PartialDump::_format_string
0000s0sSpecio::PartialDump::::_format_undefSpecio::PartialDump::_format_undef
0000s0sSpecio::PartialDump::::_quoteSpecio::PartialDump::_quote
0000s0sSpecio::PartialDump::::_should_dump_as_pairsSpecio::PartialDump::_should_dump_as_pairs
0000s0sSpecio::PartialDump::::partial_dumpSpecio::PartialDump::partial_dump
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package Specio::PartialDump;
2
3use strict;
4use warnings;
5
6our $VERSION = '0.47';
7
8use Scalar::Util qw( looks_like_number reftype blessed );
9
10use Exporter qw( import );
11
12our @EXPORT_OK = qw( partial_dump );
13
14my $MaxLength = 100;
15my $MaxElements = 6;
16my $MaxDepth = 2;
17
18sub partial_dump {
19 my (@args) = @_;
20
21 my $dump
22 = _should_dump_as_pairs(@args)
23 ? _dump_as_pairs( 1, @args )
24 : _dump_as_list( 1, @args );
25
26 if ( length($dump) > $MaxLength ) {
27 my $max_length = $MaxLength - 3;
28 $max_length = 0 if $max_length < 0;
29 substr( $dump, $max_length, length($dump) - $max_length ) = '...';
30 }
31
32 return $dump;
33}
34
35sub _should_dump_as_pairs {
36 my (@what) = @_;
37
38 return if @what % 2 != 0; # must be an even list
39
40 for ( my $i = 0; $i < @what; $i += 2 ) {
41 return if ref $what[$i]; # plain strings are keys
42 }
43
44 return 1;
45}
46
47sub _dump_as_pairs {
48 my ( $depth, @what ) = @_;
49
50 my $truncated;
51 if ( defined $MaxElements and ( @what / 2 ) > $MaxElements ) {
52 $truncated = 1;
53 @what = splice( @what, 0, $MaxElements * 2 );
54 }
55
56 return join(
57 ', ', _dump_as_pairs_recursive( $depth, @what ),
58 ( $truncated ? "..." : () )
59 );
60}
61
62sub _dump_as_pairs_recursive {
63 my ( $depth, @what ) = @_;
64
65 return unless @what;
66
67 my ( $key, $value, @rest ) = @what;
68
69 return (
70 ( _format_key( $depth, $key ) . ': ' . _format( $depth, $value ) ),
71 _dump_as_pairs_recursive( $depth, @rest ),
72 );
73}
74
75sub _dump_as_list {
76 my ( $depth, @what ) = @_;
77
78 my $truncated;
79 if ( @what > $MaxElements ) {
80 $truncated = 1;
81 @what = splice( @what, 0, $MaxElements );
82 }
83
84 return join(
85 ', ', ( map { _format( $depth, $_ ) } @what ),
86 ( $truncated ? "..." : () )
87 );
88}
89
90sub _format {
91 my ( $depth, $value ) = @_;
92
93 defined($value)
94 ? (
95 ref($value)
96 ? (
97 blessed($value)
98 ? _format_object( $depth, $value )
99 : _format_ref( $depth, $value )
100 )
101 : (
102 looks_like_number($value)
103 ? _format_number( $depth, $value )
104 : _format_string( $depth, $value )
105 )
106 )
107 : _format_undef( $depth, $value ),;
108}
109
110sub _format_key {
111 my ( undef, $key ) = @_;
112 return $key;
113}
114
115sub _format_ref {
116 my ( $depth, $ref ) = @_;
117
118 if ( $depth > $MaxDepth ) {
119 return overload::StrVal($ref);
120 }
121 else {
122 my $reftype = reftype($ref);
123 $reftype = 'SCALAR'
124 if $reftype eq 'REF' || $reftype eq 'LVALUE';
125 my $method = "_format_" . lc $reftype;
126
127 if ( my $sub = __PACKAGE__->can($method) ) {
128 return $sub->( $depth, $ref );
129 }
130 else {
131 return overload::StrVal($ref);
132 }
133 }
134}
135
136sub _format_array {
137 my ( $depth, $array ) = @_;
138
139 my $class = blessed($array) || '';
140 $class .= "=" if $class;
141
142 return $class . "[ " . _dump_as_list( $depth + 1, @$array ) . " ]";
143}
144
145sub _format_hash {
146 my ( $depth, $hash ) = @_;
147
148 my $class = blessed($hash) || '';
149 $class .= "=" if $class;
150
151 return $class . "{ " . _dump_as_pairs(
152 $depth + 1,
153 map { $_ => $hash->{$_} } sort keys %$hash
154 ) . " }";
155}
156
157sub _format_scalar {
158 my ( $depth, $scalar ) = @_;
159
160 my $class = blessed($scalar) || '';
161 $class .= "=" if $class;
162
163 return $class . "\\" . _format( $depth + 1, $$scalar );
164}
165
166sub _format_object {
167 my ( $depth, $object ) = @_;
168
169 return _format_ref( $depth, $object );
170}
171
172sub _format_string {
173 my ( undef, $str ) = @_;
174
175 # FIXME use String::Escape ?
176
177 # remove vertical whitespace
178 $str =~ s/\n/\\n/g;
179 $str =~ s/\r/\\r/g;
180
181 # reformat nonprintables
182 $str =~ s/(\P{IsPrint})/"\\x{" . sprintf("%x", ord($1)) . "}"/ge;
183
184 _quote($str);
185}
186
187sub _quote {
188 my ($str) = @_;
189
190 qq{"$str"};
191}
192
193sub _format_undef {"undef"}
194
195sub _format_number {
196 my ( undef, $value ) = @_;
197 return "$value";
198}
199
200# ABSTRACT: A partially rear-ended copy of Devel::PartialDump without prereqs
201
2021;
203
204__END__