← 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/Filter/GenericClass.pm
StatementsExecuted 12 statements in 1.38ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
1118µs9µsData::Printer::Filter::GenericClass::::BEGIN@2Data::Printer::Filter::GenericClass::BEGIN@2
1116µs6µsData::Printer::Filter::GenericClass::::BEGIN@5Data::Printer::Filter::GenericClass::BEGIN@5
1114µs11µsData::Printer::Filter::GenericClass::::BEGIN@6Data::Printer::Filter::GenericClass::BEGIN@6
1113µs16µsData::Printer::Filter::GenericClass::::BEGIN@3Data::Printer::Filter::GenericClass::BEGIN@3
1113µs14µsData::Printer::Filter::GenericClass::::BEGIN@4Data::Printer::Filter::GenericClass::BEGIN@4
111300ns300nsData::Printer::Filter::GenericClass::::__ANON__Data::Printer::Filter::GenericClass::__ANON__ (xsub)
0000s0sData::Printer::Filter::GenericClass::::__ANON__[:102]Data::Printer::Filter::GenericClass::__ANON__[:102]
0000s0sData::Printer::Filter::GenericClass::::__ANON__[:184]Data::Printer::Filter::GenericClass::__ANON__[:184]
0000s0sData::Printer::Filter::GenericClass::::__ANON__[:199]Data::Printer::Filter::GenericClass::__ANON__[:199]
0000s0sData::Printer::Filter::GenericClass::::__ANON__[:213]Data::Printer::Filter::GenericClass::__ANON__[:213]
0000s0sData::Printer::Filter::GenericClass::::__ANON__[:72]Data::Printer::Filter::GenericClass::__ANON__[:72]
0000s0sData::Printer::Filter::GenericClass::::__ANON__[:91]Data::Printer::Filter::GenericClass::__ANON__[:91]
0000s0sData::Printer::Filter::GenericClass::::_get_all_subs_fromData::Printer::Filter::GenericClass::_get_all_subs_from
0000s0sData::Printer::Filter::GenericClass::::_get_overloadsData::Printer::Filter::GenericClass::_get_overloads
0000s0sData::Printer::Filter::GenericClass::::_get_stringificationData::Printer::Filter::GenericClass::_get_stringification
0000s0sData::Printer::Filter::GenericClass::::_methods_ofData::Printer::Filter::GenericClass::_methods_of
0000s0sData::Printer::Filter::GenericClass::::_show_methodsData::Printer::Filter::GenericClass::_show_methods
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::Filter::GenericClass;
2216µs210µs
# spent 9µs (8+1) within Data::Printer::Filter::GenericClass::BEGIN@2 which was called: # once (8µs+1µs) by Data::Printer::Object::BEGIN@61 at line 2
use strict;
# spent 9µs making 1 call to Data::Printer::Filter::GenericClass::BEGIN@2 # spent 1µs making 1 call to strict::import
3216µs228µs
# spent 16µs (3+13) within Data::Printer::Filter::GenericClass::BEGIN@3 which was called: # once (3µs+13µs) by Data::Printer::Object::BEGIN@61 at line 3
use warnings;
# spent 16µs making 1 call to Data::Printer::Filter::GenericClass::BEGIN@3 # spent 13µs making 1 call to warnings::import
4214µs226µs
# spent 14µs (3+12) within Data::Printer::Filter::GenericClass::BEGIN@4 which was called: # once (3µs+12µs) by Data::Printer::Object::BEGIN@61 at line 4
use Data::Printer::Filter;
# spent 14µs making 1 call to Data::Printer::Filter::GenericClass::BEGIN@4 # spent 12µs making 1 call to Data::Printer::Filter::import
5215µs26µs
# spent 6µs (6+300ns) within Data::Printer::Filter::GenericClass::BEGIN@5 which was called: # once (6µs+300ns) by Data::Printer::Object::BEGIN@61 at line 5
use Data::Printer::Common;
# spent 6µs making 1 call to Data::Printer::Filter::GenericClass::BEGIN@5 # spent 300ns making 1 call to Data::Printer::Filter::GenericClass::__ANON__
621.31ms218µs
# spent 11µs (4+7) within Data::Printer::Filter::GenericClass::BEGIN@6 which was called: # once (4µs+7µs) by Data::Printer::Object::BEGIN@61 at line 6
use Scalar::Util;
# spent 11µs making 1 call to Data::Printer::Filter::GenericClass::BEGIN@6 # spent 7µs making 1 call to Exporter::import
7
8filter '-class' => sub {
9 my ($object, $ddp) = @_;
10
11 # if the class implements its own Data::Printer method, we use it!
12 if ($ddp->class_method and my $method = $object->can( $ddp->class_method )) {
13 return $method->($object, $ddp) if ref $method eq 'CODE';
14 }
15
16 my $class_name = ref $object;
17
18 # there are many parts of the class filter that require the object's
19 # linear ISA, so we declare it earlier and load it only once:
20 my $linear_ISA = Data::Printer::Common::_linear_ISA_for($class_name, $ddp);
21
22 # if the object overloads stringification, use it!
23 # except for PDF::API2 which has a destructive stringify()
24 if ($ddp->class->stringify && $class_name ne 'PDF::API2') {
25 my $str = _get_stringification($ddp, $object, $class_name);
26 return $ddp->maybe_colorize("$str ($class_name)", 'class')
27 if defined $str;
28 }
29
30 # otherwise, do our generic object representation:
31 my $show_reftype = $ddp->class->show_reftype;
32 my $show_internals = $ddp->class->internals;
33 my $reftype;
34 if ($show_reftype || $show_internals) {
35 $reftype = Scalar::Util::reftype($object);
36 $reftype = 'Regexp' if $reftype eq 'REGEXP';
37 }
38
39 $ddp->{_class_depth}++;
40 my $string = $ddp->maybe_colorize( $class_name, 'class' );
41
42 if ($show_reftype) {
43 $string .= ' '
44 . $ddp->maybe_colorize('(', 'brackets')
45 . $ddp->maybe_colorize( $reftype, 'class' )
46 . $ddp->maybe_colorize(')', 'brackets');
47 }
48
49 if ($ddp->class->expand eq 'all' || $ddp->class->expand >= $ddp->{_class_depth}) {
50 $ddp->indent;
51 $string .= ' ' . $ddp->maybe_colorize('{', 'brackets');
52
53 my @superclasses = Data::Printer::Common::_get_superclasses_for($class_name);
54 if (@superclasses && $ddp->class->parents) {
55 $string .= $ddp->newline . 'parents: '
56 . join(', ', map $ddp->maybe_colorize($_, 'class'), @superclasses)
57 ;
58 }
59 my (%roles, %attributes);
60 if ($INC{'Role/Tiny.pm'} && exists $Role::Tiny::APPLIED_TO{$class_name}) {
61 %roles = %{ $Role::Tiny::APPLIED_TO{$class_name} };
62 }
63 my $is_moose = 0;
64
65 foreach my $parent (@$linear_ISA) {
66 if ($parent eq 'Moo::Object') {
67 Data::Printer::Common::_tryme(sub {
68 my $moo_maker = 'Moo'->_constructor_maker_for($class_name);
69 if (defined $moo_maker) {
70 %attributes = %{ $moo_maker->all_attribute_specs };
71 }
72 });
73 last;
74 }
75 elsif ($parent eq 'Moose::Object') {
76 Data::Printer::Common::_tryme(sub {
77 my $class_meta = $class_name->meta;
78 $is_moose = 1;
79 %attributes = map {
80 $_->name => {
81 index => $_->insertion_order,
82 init_arg => $_->init_arg,
83 is => (defined $_->writer ? 'rw' : 'ro'),
84 reader => $_->reader,
85 required => $_->is_required,
86 }
87 } $class_meta->get_all_attributes();
88 foreach my $role ($class_meta->calculate_all_roles()) {
89 $roles{ $role->name } = 1;
90 }
91 });
92 last;
93 }
94 elsif ($parent eq 'Object::Pad::UNIVERSAL') {
95 Data::Printer::Common::_tryme(sub {
96 my $meta = Object::Pad::MOP::Class->for_class( $class_name );
97 %attributes = map {
98 $_->name . $_->value($class_name) => {
99 }
100 } $meta->fields;
101 %roles = map { $_->name => 1 } $meta->direct_roles;
102 });
103 }
104 }
105 if ($ddp->class->show_methods ne 'none') {
106 if (my @role_list = keys %roles) {
107 @role_list = Data::Printer::Common::_nsort(@role_list)
108 if @role_list && $ddp->class->sort_methods;
109 $string .= $ddp->newline . 'roles (' . scalar(@role_list) . '): '
110 . join(', ' => map $ddp->maybe_colorize($_, 'class'), @role_list)
111 ;
112 }
113
114 if (my @attr_list = keys %attributes) {
115 @attr_list = Data::Printer::Common::_nsort(@attr_list)
116 if @attr_list && $ddp->class->sort_methods;
117 $string .= $ddp->newline . 'attributes (' . scalar(@attr_list) . '): '
118 . join(', ' => map $ddp->maybe_colorize($_, 'method'), @attr_list)
119 ;
120 }
121 }
122
123 my $show_linear_isa = $ddp->class->linear_isa && (
124 ($ddp->class->linear_isa eq 'auto' and @superclasses > 1)
125 or ($ddp->class->linear_isa ne 'auto')
126 );
127
128 if ($show_linear_isa && @$linear_ISA) {
129 $string .= $ddp->newline . 'linear @ISA: '
130 . join(', ' => map $ddp->maybe_colorize($_, 'class'), @$linear_ISA)
131 ;
132 }
133
134 if ($ddp->class->show_methods ne 'none') {
135 $string .= _show_methods($class_name, $linear_ISA, \%attributes, $ddp);
136 if ($is_moose && $ddp->class->show_wrapped) {
137 my $modified = '';
138 my $modified_count = 0;
139 $ddp->indent;
140 for my $method ($class_name->meta->get_all_methods) {
141 if (ref $method eq 'Class::MOP::Method::Wrapped') {
142 foreach my $kind (qw(before around after)) {
143 my $getter_method = $kind . '_modifiers';
144 if (my @modlist = $method->$getter_method) {
145 $modified .= $ddp->newline . $kind . ' ' . $method->name . ': '
146 . (@modlist > 1 ? $ddp->parse(\@modlist) : $ddp->parse($modlist[0]));
147 $modified_count++;
148 }
149 }
150 }
151 }
152 $ddp->outdent;
153 if ($modified_count) {
154 $string .= $ddp->newline . 'method modifiers (' . $modified_count . '):'
155 . $modified;
156 }
157 }
158 }
159
160 if ($ddp->class->show_overloads) {
161 my @overloads = _get_overloads($object);
162 if (@overloads) {
163 $string .= $ddp->newline . 'overloads: ' . join(', ' => @overloads);
164 }
165 }
166
167 if ($show_internals) {
168 $string .= $ddp->newline
169 . 'internals: '
170 . $ddp->parse_as($reftype, $object)
171 ;
172 }
173
174 $ddp->outdent;
175 $string .= $ddp->newline . $ddp->maybe_colorize('}', 'brackets');
176 }
177 $ddp->{_class_depth}--;
178
179 if ($ddp->show_tied and my $tie = ref tied $object) {
180 $string .= " (tied to $tie)";
181 }
182
183 return $string;
18415µs116µs};
# spent 16µs making 1 call to Data::Printer::Filter::__ANON__[Data/Printer/Filter.pm:23]
185
186#######################################
187### Private auxiliary helpers below ###
188#######################################
189
190sub _get_stringification {
191 my ($ddp, $object, $class_name) = @_;
192 require overload;
193 if (overload::Overloaded($object)
194 && (overload::Method($object, q(""))
195 || overload::Method($object, q(0+))
196 )
197 ) {
198 my $string;
199 my $error = Data::Printer::Common::_tryme(sub { $string = '' . $object });
200 if ($error) {
201 Data::Printer::Common::_warn(
202 $ddp,
203 "string/number overload error for object $class_name: $error"
204 );
205 }
206 else {
207 return $string;
208 }
209 }
210 foreach my $method (qw(as_string stringify to_string)) {
211 if ($object->can($method)) {
212 my $string;
213 my $error = Data::Printer::Common::_tryme(sub { $string = $object->$method });
214 if ($error) {
215 Data::Printer::Common::_warn(
216 $ddp,
217 "error stringifying object $class_name with $method\(\): $error"
218 );
219 }
220 else {
221 return $string;
222 }
223 }
224 }
225 return;
226}
227
228# returns array of all overloads in class;
229sub _get_overloads {
230 my ($object) = @_;
231 require overload;
232 return () unless overload::Overloaded($object);
233 return sort grep overload::Method($object, $_),
234 map split(/\s+/), values %overload::ops;
235}
236
237sub _show_methods {
238 my ($class_name, $linear_ISA, $attributes, $ddp) = @_;
239
240 my %methods = ( public => {}, private => {} );
241 my @all_methods = map _methods_of(
242 $_, Data::Printer::Common::_get_namespace($_)
243 ), @$linear_ISA;
244 my $show_methods = $ddp->class->show_methods;
245 my $show_inherited = $ddp->class->inherited;
246 my %seen_method_name;
247 foreach my $method (@all_methods) {
248 my ($package_string, $method_string) = @$method;
249 next if exists $attributes->{$method_string};
250 next if $seen_method_name{$method_string}++;
251 next if $method_string eq '__ANON__'; # anonymous subs don't matter here.
252 my $type = substr($method_string, 0, 1) eq '_' ? 'private' : 'public';
253 if ($package_string eq $class_name) {
254 next unless $show_methods eq 'all' || $show_methods eq $type;
255 $methods{$type}{$method_string} = undef;
256 }
257 else {
258 next unless $show_inherited eq 'all' || $show_inherited eq $type;
259 $methods{$type}{$method_string} = $package_string;
260 }
261 }
262 my $string = '';
263 foreach my $type (qw(public private)) {
264 next unless $show_methods eq 'all' or $show_methods eq $type
265 or $show_inherited eq 'all' or $show_inherited eq $type
266 ;
267 if ($ddp->class->format_inheritance eq 'string') {
268 my @method_list = keys %{$methods{$type}};
269 @method_list = Data::Printer::Common::_nsort(@method_list)
270 if @method_list && $ddp->class->sort_methods;
271
272 $string .= $ddp->newline . "$type methods (" . scalar(@method_list) . ')';
273 if (@method_list) {
274 $string .= ': '
275 . join(', ' => map {
276 $ddp->maybe_colorize(
277 $_ . (defined $methods{$type}{$_} ? " ($methods{$type}{$_})" : ''),
278 'method'
279 )
280 } @method_list)
281 ;
282 }
283 }
284 else { # 'lines'
285 # first we convert our hash to { pkg => [ @methods ] }
286 my %lined_methods;
287 my @base_methods;
288 my $total_methods = 0;
289 foreach my $method (keys %{$methods{$type}}) {
290 my $pkg_name = $methods{$type}{$method};
291 if (defined $pkg_name) {
292 push @{ $lined_methods{$pkg_name} }, $method;
293 }
294 else {
295 push @base_methods, $method;
296 }
297 $total_methods++;
298 }
299
300 # then we print them, starting with our own methods:
301 @base_methods = Data::Printer::Common::_nsort(@base_methods)
302 if @base_methods && $ddp->class->sort_methods;
303
304 $string .= $ddp->newline . "$type methods ($total_methods)"
305 . ($total_methods ? ':' : '')
306 ;
307 if (@base_methods) {
308 my $base_string = join(', ' => map {
309 $ddp->maybe_colorize($_, 'method')
310 } @base_methods);
311 $ddp->indent;
312 # newline only if we have parent methods to show:
313 $string .= (keys %lined_methods ? $ddp->newline : ' ') . $base_string;
314 $ddp->outdent;
315 }
316 foreach my $pkg (sort keys %lined_methods) {
317 $ddp->indent;
318 $string .= $ddp->newline . "$pkg:";
319 @{$lined_methods{$pkg}} = Data::Printer::Common::_nsort(@{$lined_methods{$pkg}})
320 if $ddp->class->sort_methods;
321 $ddp->indent;
322 $string .= $ddp->newline . join(', ' => map {
323 $ddp->maybe_colorize($_, 'method')
324 } @{$lined_methods{$pkg}}
325 );
326 $ddp->outdent;
327 $ddp->outdent;
328 }
329 }
330 }
331
332 return $string;
333}
334
335sub _methods_of {
336 require B;
337 my ($class_name, $namespace) = @_;
338 my @methods;
339 foreach my $subref (_get_all_subs_from($class_name, $namespace)) {
340 next unless $subref;
341 my $m = B::svref_2object($subref);
342 next unless $m && $m->isa('B::CV');
343 my $gv = $m->GV;
344 next unless $gv && !$gv->isa('B::Special') && $gv->NAME;
345 push @methods, [ $gv->STASH->NAME, $gv->NAME ];
346 }
347 return @methods;
348}
349
350sub _get_all_subs_from {
351 my ($class_name, $namespace) = @_;
352 my @subs;
353 foreach my $key (keys %$namespace) {
354 # perlsub says any sub starting with '(' is reserved for overload,
355 # so we skip those:
356 next if substr($key, 0, 1) eq '(';
357 if (
358 # any non-typeglob in the symbol table is a constant or stub
359 ref(\$namespace->{$key}) ne 'GLOB'
360 # regular subs are stored in the CODE slot of the typeglob
361 || defined(*{$namespace->{$key}}{CODE})
362 ) {
363 push @subs, $key;
364 }
365 }
366 my @symbols;
367 foreach my $sub (@subs) {
368 push @symbols, Data::Printer::Common::_get_symbol($class_name, $namespace, $sub, 'CODE');
369 }
370 return @symbols;
371}
372
37312µs1;
 
# spent 300ns within Data::Printer::Filter::GenericClass::__ANON__ which was called: # once (300ns+0s) by Data::Printer::Filter::GenericClass::BEGIN@5 at line 5
sub Data::Printer::Filter::GenericClass::__ANON__; # xsub
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.