← 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/Role/Tiny.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sRole::Tiny::::BEGIN@16 Role::Tiny::BEGIN@16
0000s0sRole::Tiny::::BEGIN@2 Role::Tiny::BEGIN@2
0000s0sRole::Tiny::::BEGIN@24 Role::Tiny::BEGIN@24
0000s0sRole::Tiny::::BEGIN@242 Role::Tiny::BEGIN@242
0000s0sRole::Tiny::::BEGIN@25 Role::Tiny::BEGIN@25
0000s0sRole::Tiny::::BEGIN@29 Role::Tiny::BEGIN@29
0000s0sRole::Tiny::::BEGIN@3 Role::Tiny::BEGIN@3
0000s0sRole::Tiny::::BEGIN@484 Role::Tiny::BEGIN@484
0000s0sRole::Tiny::::BEGIN@65 Role::Tiny::BEGIN@65
0000s0sRole::Tiny::::CORE:match Role::Tiny::CORE:match (opcode)
0000s0sRole::Tiny::::CORE:sort Role::Tiny::CORE:sort (opcode)
0000s0sRole::Tiny::::CORE:subst Role::Tiny::CORE:subst (opcode)
0000s0sRole::Tiny::::__ANON__[:145] Role::Tiny::__ANON__[:145]
0000s0sRole::Tiny::::__ANON__[:150] Role::Tiny::__ANON__[:150]
0000s0sRole::Tiny::::__ANON__[:154] Role::Tiny::__ANON__[:154]
0000s0sRole::Tiny::::__ANON__[:465] Role::Tiny::__ANON__[:465]
0000s0sRole::Tiny::::__ANON__[:483] Role::Tiny::__ANON__[:483]
0000s0sRole::Tiny::__GUARD__::::DESTROYRole::Tiny::__GUARD__::DESTROY
0000s0sRole::Tiny::::_all_subs Role::Tiny::_all_subs
0000s0sRole::Tiny::::_build_class_with_roles Role::Tiny::_build_class_with_roles
0000s0sRole::Tiny::::_check_requires Role::Tiny::_check_requires
0000s0sRole::Tiny::::_check_roles Role::Tiny::_check_roles
0000s0sRole::Tiny::::_composite_info_for Role::Tiny::_composite_info_for
0000s0sRole::Tiny::::_composite_name Role::Tiny::_composite_name
0000s0sRole::Tiny::::_concrete_methods_of Role::Tiny::_concrete_methods_of
0000s0sRole::Tiny::::_copy_applied_list Role::Tiny::_copy_applied_list
0000s0sRole::Tiny::::_gen_subs Role::Tiny::_gen_subs
0000s0sRole::Tiny::::_getglob Role::Tiny::_getglob
0000s0sRole::Tiny::::_getstash Role::Tiny::_getstash
0000s0sRole::Tiny::::_install_does Role::Tiny::_install_does
0000s0sRole::Tiny::::_install_methods Role::Tiny::_install_methods
0000s0sRole::Tiny::::_install_modifiers Role::Tiny::_install_modifiers
0000s0sRole::Tiny::::_install_single_modifier Role::Tiny::_install_single_modifier
0000s0sRole::Tiny::::_install_subs Role::Tiny::_install_subs
0000s0sRole::Tiny::::_load_module Role::Tiny::_load_module
0000s0sRole::Tiny::::_mark_new_non_methods Role::Tiny::_mark_new_non_methods
0000s0sRole::Tiny::::_non_methods Role::Tiny::_non_methods
0000s0sRole::Tiny::::_require_module Role::Tiny::_require_module
0000s0sRole::Tiny::::_want_backcompat_hack Role::Tiny::_want_backcompat_hack
0000s0sRole::Tiny::::apply_role_to_package Role::Tiny::apply_role_to_package
0000s0sRole::Tiny::::apply_roles_to_object Role::Tiny::apply_roles_to_object
0000s0sRole::Tiny::::apply_roles_to_package Role::Tiny::apply_roles_to_package
0000s0sRole::Tiny::::apply_single_role_to_package Role::Tiny::apply_single_role_to_package
0000s0sRole::Tiny::::create_class_with_roles Role::Tiny::create_class_with_roles
0000s0sRole::Tiny::::croak Role::Tiny::croak
0000s0sRole::Tiny::::does_role Role::Tiny::does_role
0000s0sRole::Tiny::::import Role::Tiny::import
0000s0sRole::Tiny::::is_role Role::Tiny::is_role
0000s0sRole::Tiny::::make_role Role::Tiny::make_role
0000s0sRole::Tiny::::methods_provided_by Role::Tiny::methods_provided_by
0000s0sRole::Tiny::::role_application_steps Role::Tiny::role_application_steps
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package Role::Tiny;
2use strict;
3use warnings;
4
5our $VERSION = '2.002004';
6$VERSION =~ tr/_//d;
7
8our %INFO;
9our %APPLIED_TO;
10our %COMPOSED;
11our %COMPOSITE_INFO;
12our @ON_ROLE_CREATE;
13
14# Module state workaround totally stolen from Zefram's Module::Runtime.
15
16BEGIN {
17 *_WORK_AROUND_BROKEN_MODULE_STATE = "$]" < 5.009 ? sub(){1} : sub(){0};
18 *_WORK_AROUND_HINT_LEAKAGE
19 = "$]" < 5.011 && !("$]" >= 5.009004 && "$]" < 5.010001)
20 ? sub(){1} : sub(){0};
21 *_CONSTANTS_DEFLATE = "$]" >= 5.012 && "$]" < 5.020 ? sub(){1} : sub(){0};
22}
23
24sub _getglob { no strict 'refs'; \*{$_[0]} }
25sub _getstash { no strict 'refs'; \%{"$_[0]::"} }
26
27sub croak {
28 require Carp;
29 no warnings 'redefine';
30 *croak = \&Carp::croak;
31 goto &Carp::croak;
32}
33
34sub Role::Tiny::__GUARD__::DESTROY {
35 delete $INC{$_[0]->[0]} if @{$_[0]};
36}
37
38sub _load_module {
39 my ($module) = @_;
40 (my $file = "$module.pm") =~ s{::}{/}g;
41 return 1
42 if $INC{$file};
43
44 # can't just ->can('can') because a sub-package Foo::Bar::Baz
45 # creates a 'Baz::' key in Foo::Bar's symbol table
46 return 1
47 if grep !/::\z/, keys %{_getstash($module)};
48 my $guard = _WORK_AROUND_BROKEN_MODULE_STATE
49 && bless([ $file ], 'Role::Tiny::__GUARD__');
50 local %^H if _WORK_AROUND_HINT_LEAKAGE;
51 require $file;
52 pop @$guard if _WORK_AROUND_BROKEN_MODULE_STATE;
53 return 1;
54}
55
56sub _require_module {
57 _load_module($_[1]);
58}
59
60sub _all_subs {
61 my ($me, $package) = @_;
62 my $stash = _getstash($package);
63 return {
64 map {;
65 no strict 'refs';
66 # this is an ugly hack to populate the scalar slot of any globs, to
67 # prevent perl from converting constants back into scalar refs in the
68 # stash when they are used (perl 5.12 - 5.18). scalar slots on their own
69 # aren't detectable through pure perl, so this seems like an acceptable
70 # compromise.
71 ${"${package}::${_}"} = ${"${package}::${_}"}
72 if _CONSTANTS_DEFLATE;
73 $_ => \&{"${package}::${_}"}
74 }
75 grep exists &{"${package}::${_}"},
76 grep !/::\z/,
77 keys %$stash
78 };
79}
80
81sub import {
82 my $target = caller;
83 my $me = shift;
84 strict->import;
85 warnings->import;
86 my $non_methods = $me->_non_methods($target);
87 $me->_install_subs($target, @_);
88 $me->make_role($target);
89 $me->_mark_new_non_methods($target, $non_methods)
90 if $non_methods && %$non_methods;
91 return;
92}
93
94sub _mark_new_non_methods {
95 my ($me, $target, $old_non_methods) = @_;
96
97 my $non_methods = $INFO{$target}{non_methods};
98
99 my $subs = $me->_all_subs($target);
100 for my $sub (keys %$subs) {
101 if ( exists $old_non_methods->{$sub} && $non_methods->{$sub} != $subs->{$sub} ) {
102 $non_methods->{$sub} = $subs->{$sub};
103 }
104 }
105
106 return;
107}
108
109sub make_role {
110 my ($me, $target) = @_;
111
112 return if $me->is_role($target);
113 $INFO{$target}{is_role} = 1;
114
115 my $non_methods = $me->_all_subs($target);
116 delete @{$non_methods}{grep /\A\(/, keys %$non_methods};
117 $INFO{$target}{non_methods} = $non_methods;
118
119 # a role does itself
120 $APPLIED_TO{$target} = { $target => undef };
121 foreach my $hook (@ON_ROLE_CREATE) {
122 $hook->($target);
123 }
124}
125
126sub _install_subs {
127 my ($me, $target) = @_;
128 return if $me->is_role($target);
129 my %install = $me->_gen_subs($target);
130 *{_getglob("${target}::${_}")} = $install{$_}
131 for sort keys %install;
132 return;
133}
134
135sub _gen_subs {
136 my ($me, $target) = @_;
137 (
138 (map {;
139 my $type = $_;
140 $type => sub {
141 my $code = pop;
142 my @names = ref $_[0] eq 'ARRAY' ? @{ $_[0] } : @_;
143 push @{$INFO{$target}{modifiers}||=[]}, [ $type, @names, $code ];
144 return;
145 };
146 } qw(before after around)),
147 requires => sub {
148 push @{$INFO{$target}{requires}||=[]}, @_;
149 return;
150 },
151 with => sub {
152 $me->apply_roles_to_package($target, @_);
153 return;
154 },
155 );
156}
157
158sub role_application_steps {
159 qw(
160 _install_methods
161 _check_requires
162 _install_modifiers
163 _copy_applied_list
164 );
165}
166
167sub _copy_applied_list {
168 my ($me, $to, $role) = @_;
169 # copy our role list into the target's
170 @{$APPLIED_TO{$to}||={}}{keys %{$APPLIED_TO{$role}}} = ();
171}
172
173sub apply_roles_to_object {
174 my ($me, $object, @roles) = @_;
175 my $class = ref($object);
176 # on perl < 5.8.9, magic isn't copied to all ref copies. bless the parameter
177 # directly, so at least the variable passed to us will get any magic applied
178 bless($_[1], $me->create_class_with_roles($class, @roles));
179}
180
181my $role_suffix = 'A000';
182sub _composite_name {
183 my ($me, $superclass, @roles) = @_;
184
185 my $new_name = $superclass . '__WITH__' . join '__AND__', @roles;
186
187 if (length($new_name) > 252) {
188 $new_name = $COMPOSED{abbrev}{$new_name} ||= do {
189 my $abbrev = substr $new_name, 0, 250 - length $role_suffix;
190 $abbrev =~ s/(?<!:):$//;
191 $abbrev.'__'.$role_suffix++;
192 };
193 }
194 return $new_name;
195}
196
197sub create_class_with_roles {
198 my ($me, $superclass, @roles) = @_;
199
200 $me->_require_module($superclass);
201 $me->_check_roles(@roles);
202
203 my $new_name = $me->_composite_name($superclass, @roles);
204
205 return $new_name
206 if $COMPOSED{class}{$new_name};
207
208 return $me->_build_class_with_roles($new_name, $superclass, @roles);
209}
210
211sub _build_class_with_roles {
212 my ($me, $new_name, $superclass, @roles) = @_;
213
214 $COMPOSED{base}{$new_name} = $superclass;
215 @{*{_getglob("${new_name}::ISA")}} = ( $superclass );
216 $me->apply_roles_to_package($new_name, @roles);
217 $COMPOSED{class}{$new_name} = 1;
218 return $new_name;
219}
220
221sub _check_roles {
222 my ($me, @roles) = @_;
223 croak "No roles supplied!" unless @roles;
224
225 my %seen;
226 if (my @dupes = grep 1 == $seen{$_}++, @roles) {
227 croak "Duplicated roles: ".join(', ', @dupes);
228 }
229
230 foreach my $role (@roles) {
231 $me->_require_module($role);
232 croak "${role} is not a ${me}" unless $me->is_role($role);
233 }
234}
235
236our %BACKCOMPAT_HACK;
237$BACKCOMPAT_HACK{+__PACKAGE__} = 0;
238sub _want_backcompat_hack {
239 my $me = shift;
240 return $BACKCOMPAT_HACK{$me}
241 if exists $BACKCOMPAT_HACK{$me};
242 no warnings 'uninitialized';
243 $BACKCOMPAT_HACK{$me} =
244 $me->can('apply_single_role_to_package') != \&apply_single_role_to_package
245 && $me->can('role_application_steps') == \&role_application_steps
246}
247
248our $IN_APPLY_ROLES;
249sub apply_single_role_to_package {
250 return
251 if $IN_APPLY_ROLES;
252 local $IN_APPLY_ROLES = 1;
253
254 my ($me, $to, $role) = @_;
255 $me->apply_roles_to_package($to, $role);
256}
257
258sub apply_role_to_package {
259 my ($me, $to, $role) = @_;
260 $me->apply_roles_to_package($to, $role);
261}
262
263sub apply_roles_to_package {
264 my ($me, $to, @roles) = @_;
265 croak "Can't apply roles to object with apply_roles_to_package"
266 if ref $to;
267
268 $me->_check_roles(@roles);
269
270 my @have_conflicts;
271 my %role_methods;
272
273 if (@roles > 1) {
274 my %conflicts = %{$me->_composite_info_for(@roles)->{conflicts}};
275 @have_conflicts = grep $to->can($_), keys %conflicts;
276 delete @conflicts{@have_conflicts};
277
278 if (keys %conflicts) {
279 my $class = $COMPOSED{base}{$to} || $to;
280 my $fail =
281 join "\n",
282 map {
283 "Due to a method name conflict between roles "
284 .join(' and ', map "'$_'", sort values %{$conflicts{$_}})
285 .", the method '$_' must be implemented by '$class'"
286 } sort keys %conflicts;
287 croak $fail;
288 }
289
290 %role_methods = map +($_ => $me->_concrete_methods_of($_)), @roles;
291 }
292
293 if (!$IN_APPLY_ROLES and _want_backcompat_hack($me)) {
294 local $IN_APPLY_ROLES = 1;
295 foreach my $role (@roles) {
296 $me->apply_single_role_to_package($to, $role);
297 }
298 }
299
300 my $role_methods;
301 foreach my $step ($me->role_application_steps) {
302 foreach my $role (@roles) {
303 # conflicting methods are supposed to be treated as required by the
304 # composed role. we don't have an actual composed role, but because
305 # we know the target class already provides them, we can instead
306 # pretend that the roles don't do for the duration of application.
307 $role_methods = $role_methods{$role} and (
308 (local @{$role_methods}{@have_conflicts}),
309 (delete @{$role_methods}{@have_conflicts}),
310 );
311
312 $me->$step($to, $role);
313 }
314 }
315 $APPLIED_TO{$to}{join('|',@roles)} = 1;
316}
317
318sub _composite_info_for {
319 my ($me, @roles) = @_;
320 $COMPOSITE_INFO{join('|', sort @roles)} ||= do {
321 my %methods;
322 foreach my $role (@roles) {
323 my $this_methods = $me->_concrete_methods_of($role);
324 $methods{$_}{$this_methods->{$_}} = $role for keys %$this_methods;
325 }
326 delete $methods{$_} for grep keys(%{$methods{$_}}) == 1, keys %methods;
327 +{ conflicts => \%methods }
328 };
329}
330
331sub _check_requires {
332 my ($me, $to, $name, $requires) = @_;
333 $requires ||= $INFO{$name}{requires} || [];
334 if (my @requires_fail = grep !$to->can($_), @$requires) {
335 # role -> role, add to requires, role -> class, error out
336 if (my $to_info = $INFO{$to}) {
337 push @{$to_info->{requires}||=[]}, @requires_fail;
338 } else {
339 croak "Can't apply ${name} to ${to} - missing ".join(', ', @requires_fail);
340 }
341 }
342}
343
344sub _non_methods {
345 my ($me, $role) = @_;
346 my $info = $INFO{$role} or return {};
347
348 my %non_methods = %{ $info->{non_methods} || {} };
349
350 # this is only for backwards compatibility with older Moo, which
351 # reimplements method tracking rather than calling our method
352 my %not_methods = reverse %{ $info->{not_methods} || {} };
353 return \%non_methods unless keys %not_methods;
354
355 my $subs = $me->_all_subs($role);
356 for my $sub (grep !/\A\(/, keys %$subs) {
357 my $code = $subs->{$sub};
358 if (exists $not_methods{$code}) {
359 $non_methods{$sub} = $code;
360 }
361 }
362
363 return \%non_methods;
364}
365
366sub _concrete_methods_of {
367 my ($me, $role) = @_;
368 my $info = $INFO{$role};
369
370 return $info->{methods}
371 if $info && $info->{methods};
372
373 my $non_methods = $me->_non_methods($role);
374
375 my $subs = $me->_all_subs($role);
376 for my $sub (keys %$subs) {
377 if ( exists $non_methods->{$sub} && $non_methods->{$sub} == $subs->{$sub} ) {
378 delete $subs->{$sub};
379 }
380 }
381
382 if ($info) {
383 $info->{methods} = $subs;
384 }
385 return $subs;
386}
387
388sub methods_provided_by {
389 my ($me, $role) = @_;
390 $me->_require_module($role);
391 croak "${role} is not a ${me}" unless $me->is_role($role);
392 sort (keys %{$me->_concrete_methods_of($role)}, @{$INFO{$role}->{requires}||[]});
393}
394
395sub _install_methods {
396 my ($me, $to, $role) = @_;
397
398 my $methods = $me->_concrete_methods_of($role);
399
400 my %existing_methods;
401 @existing_methods{keys %{ $me->_all_subs($to) }} = ();
402
403 # _concrete_methods_of caches its result on roles. that cache needs to be
404 # invalidated after applying roles
405 delete $INFO{$to}{methods} if $INFO{$to};
406
407 foreach my $i (keys %$methods) {
408 next
409 if exists $existing_methods{$i};
410
411 my $glob = _getglob "${to}::${i}";
412 *$glob = $methods->{$i};
413
414 # overloads using method names have the method stored in the scalar slot
415 # and &overload::nil in the code slot.
416 next
417 unless $i =~ /^\(/
418 && ((defined &overload::nil && $methods->{$i} == \&overload::nil)
419 || (defined &overload::_nil && $methods->{$i} == \&overload::_nil));
420
421 my $overload = ${ _getglob "${role}::${i}" };
422 next
423 unless defined $overload;
424
425 *$glob = \$overload;
426 }
427
428 $me->_install_does($to);
429}
430
431sub _install_modifiers {
432 my ($me, $to, $name) = @_;
433 return unless my $modifiers = $INFO{$name}{modifiers};
434 my $info = $INFO{$to};
435 my $existing = ($info ? $info->{modifiers} : $COMPOSED{modifiers}{$to}) ||= [];
436 my @modifiers = grep {
437 my $modifier = $_;
438 !grep $_ == $modifier, @$existing;
439 } @{$modifiers||[]};
440 push @$existing, @modifiers;
441
442 if (!$info) {
443 foreach my $modifier (@modifiers) {
444 $me->_install_single_modifier($to, @$modifier);
445 }
446 }
447}
448
449my $vcheck_error;
450
451sub _install_single_modifier {
452 my ($me, @args) = @_;
453 defined($vcheck_error) or $vcheck_error = do {
454 local $@;
455 eval {
456 require Class::Method::Modifiers;
457 Class::Method::Modifiers->VERSION(1.05);
458 1;
459 } ? 0 : $@;
460 };
461 $vcheck_error and die $vcheck_error;
462 Class::Method::Modifiers::install_modifier(@args);
463}
464
465my $FALLBACK = sub { 0 };
466sub _install_does {
467 my ($me, $to) = @_;
468
469 # only add does() method to classes
470 return if $me->is_role($to);
471
472 my $does = $me->can('does_role');
473 # add does() only if they don't have one
474 *{_getglob "${to}::does"} = $does unless $to->can('does');
475
476 return
477 if $to->can('DOES') and $to->can('DOES') != (UNIVERSAL->can('DOES') || 0);
478
479 my $existing = $to->can('DOES') || $to->can('isa') || $FALLBACK;
480 my $new_sub = sub {
481 my ($proto, $role) = @_;
482 $proto->$does($role) or $proto->$existing($role);
483 };
484 no warnings 'redefine';
485 return *{_getglob "${to}::DOES"} = $new_sub;
486}
487
488# optimize for newer perls
489require mro
490 if "$]" >= 5.009_005;
491
492if (defined &mro::get_linear_isa) {
493 *_linear_isa = \&mro::get_linear_isa;
494}
495else {
496 my $e;
497 {
498 local $@;
499# this routine is simplified and not fully compatible with mro::get_linear_isa
500# but for our use the order doesn't matter, so we don't need to care
501 eval <<'END_CODE' or $e = $@;
502sub _linear_isa($;$) {
503 if (defined &mro::get_linear_isa) {
504 no warnings 'redefine', 'prototype';
505 *_linear_isa = \&mro::get_linear_isa;
506 goto &mro::get_linear_isa;
507 }
508
509 my @check = shift;
510 my @lin;
511
512 my %found;
513 while (defined(my $check = shift @check)) {
514 push @lin, $check;
515 no strict 'refs';
516 unshift @check, grep !$found{$_}++, @{"$check\::ISA"};
517 }
518
519 return \@lin;
520}
521
5221;
523END_CODE
524 }
525 die $e if defined $e;
526}
527
528sub does_role {
529 my ($proto, $role) = @_;
530 foreach my $class (@{_linear_isa(ref($proto)||$proto)}) {
531 return 1 if exists $APPLIED_TO{$class}{$role};
532 }
533 return 0;
534}
535
536sub is_role {
537 my ($me, $role) = @_;
538 return !!($INFO{$role} && (
539 $INFO{$role}{is_role}
540 # these are for backward compatibility with older Moo that overrode some
541 # methods without calling the originals, thus not getting is_role set
542 || $INFO{$role}{requires}
543 || $INFO{$role}{not_methods}
544 || $INFO{$role}{non_methods}
545 ));
546}
547
5481;
549__END__