← 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:04 2021

Filename/usr/local/lib/perl5/site_perl/Specio/OO.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sSpecio::OO::::BEGIN@10Specio::OO::BEGIN@10
0000s0sSpecio::OO::::BEGIN@108Specio::OO::BEGIN@108
0000s0sSpecio::OO::::BEGIN@11Specio::OO::BEGIN@11
0000s0sSpecio::OO::::BEGIN@12Specio::OO::BEGIN@12
0000s0sSpecio::OO::::BEGIN@123Specio::OO::BEGIN@123
0000s0sSpecio::OO::::BEGIN@13Specio::OO::BEGIN@13
0000s0sSpecio::OO::::BEGIN@14Specio::OO::BEGIN@14
0000s0sSpecio::OO::::BEGIN@18Specio::OO::BEGIN@18
0000s0sSpecio::OO::::BEGIN@248Specio::OO::BEGIN@248
0000s0sSpecio::OO::::BEGIN@3Specio::OO::BEGIN@3
0000s0sSpecio::OO::::BEGIN@4Specio::OO::BEGIN@4
0000s0sSpecio::OO::::BEGIN@6Specio::OO::BEGIN@6
0000s0sSpecio::OO::::BEGIN@7Specio::OO::BEGIN@7
0000s0sSpecio::OO::::BEGIN@76Specio::OO::BEGIN@76
0000s0sSpecio::OO::::BEGIN@8Specio::OO::BEGIN@8
0000s0sSpecio::OO::::BEGIN@9Specio::OO::BEGIN@9
0000s0sSpecio::OO::::BEGIN@94Specio::OO::BEGIN@94
0000s0sSpecio::OO::::CORE:matchSpecio::OO::CORE:match (opcode)
0000s0sSpecio::OO::::CORE:sortSpecio::OO::CORE:sort (opcode)
0000s0sSpecio::OO::::CORE:substSpecio::OO::CORE:subst (opcode)
0000s0sSpecio::OO::::__ANON__Specio::OO::__ANON__ (xsub)
0000s0sSpecio::OO::::__ANON__[:334]Specio::OO::__ANON__[:334]
0000s0sSpecio::OO::::_bad_args_messageSpecio::OO::_bad_args_message
0000s0sSpecio::OO::::_bad_value_messageSpecio::OO::_bad_value_message
0000s0sSpecio::OO::::_constructor_confessSpecio::OO::_constructor_confess
0000s0sSpecio::OO::::_eval_or_dieSpecio::OO::_eval_or_die
0000s0sSpecio::OO::::_inline_constructorSpecio::OO::_inline_constructor
0000s0sSpecio::OO::::_inline_predicateSpecio::OO::_inline_predicate
0000s0sSpecio::OO::::_inline_readerSpecio::OO::_inline_reader
0000s0sSpecio::OO::::_ooifySpecio::OO::_ooify
0000s0sSpecio::OO::::cloneSpecio::OO::clone
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package Specio::OO;
2
3use strict;
4use warnings;
5
6use Carp qw( confess );
7use List::Util qw( all );
8use MRO::Compat;
9use Role::Tiny;
10use Scalar::Util qw( weaken );
11use Specio::Helpers qw( perlstring );
12use Specio::PartialDump qw( partial_dump );
13use Specio::TypeChecks;
14use Storable qw( dclone );
15
16our $VERSION = '0.47';
17
18use Exporter qw( import );
19
20## no critic (Modules::ProhibitAutomaticExportation)
21our @EXPORT = qw(
22 clone
23 _ooify
24);
25## use critic
26
27## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
28sub _ooify {
29 my $class = shift;
30
31 my $attrs = $class->_attrs;
32 for my $name ( sort keys %{$attrs} ) {
33 my $attr = $attrs->{$name};
34
35 _inline_reader( $class, $name, $attr );
36 _inline_predicate( $class, $name, $attr );
37 }
38
39 _inline_constructor($class);
40}
41## use critic
42
43sub _inline_reader {
44 my $class = shift;
45 my $name = shift;
46 my $attr = shift;
47
48 my $reader;
49 if ( $attr->{lazy} && ( my $builder = $attr->{builder} ) ) {
50 my $source = <<'EOF';
51sub {
52 unless ( exists $_[0]->{%s} ) {
53 $_[0]->{%s} = $_[0]->%s;
54 Scalar::Util::weaken( $_[0]->{%s} ) if %s && ref $_[0]->{%s};
55 }
56 $_[0]->{%s};
57}
58EOF
59 $reader = sprintf(
60 $source,
61 $name,
62 $name,
63 $builder,
64 $name,
65 ( $attr->{weak_ref} ? 1 : 0 ),
66 $name,
67 $name,
68 );
69 }
70 else {
71 $reader = sprintf( 'sub { $_[0]->{%s} }', $name );
72 }
73
74 {
75 ## no critic (TestingAndDebugging::ProhibitNoStrict)
76 no strict 'refs';
77 *{ $class . '::' . $name } = _eval_or_die(
78 $reader, $class . '->' . $name,
79 );
80 }
81}
82
83sub _inline_predicate {
84 my $class = shift;
85 my $name = shift;
86 my $attr = shift;
87
88 return unless $attr->{predicate};
89
90 my $predicate = "sub { exists \$_[0]->{$name} }";
91
92 {
93 ## no critic (TestingAndDebugging::ProhibitNoStrict)
94 no strict 'refs';
95 *{ $class . '::' . $attr->{predicate} } = _eval_or_die(
96 $predicate, $class . '->' . $attr->{predicate},
97 );
98 }
99}
100
101my @RolesWithBUILD = qw( Specio::Constraint::Role::Interface );
102
103# This is an optimization to avoid calling this many times over:
104#
105# Specio::TypeChecks->can( 'is_' . $attr->{isa} )
106my %TypeChecks;
107
108BEGIN {
109 for my $sub (@Specio::TypeChecks::EXPORT_OK) {
110 my ($type) = $sub =~ /^is_(.+)$/
111 or next;
112 $TypeChecks{$type} = Specio::TypeChecks->can($sub);
113 }
114}
115
116sub _inline_constructor {
117 my $class = shift;
118
119 my @build_subs;
120 for my $parent ( @{ mro::get_linear_isa($class) } ) {
121 {
122 ## no critic (TestingAndDebugging::ProhibitNoStrict)
123 no strict 'refs';
124 push @build_subs, $parent . '::BUILD'
125 if defined &{ $parent . '::BUILD' };
126 }
127 }
128
129 # This is all a hack to avoid needing Class::Method::Modifiers to add a
130 # BUILD from a role. We can't just call the method in the role "BUILD" or
131 # it will be shadowed by a class's BUILD. So we give it a wacky unique
132 # name. We need to explicitly know which roles have a _X_BUILD method
133 # because Role::Tiny doesn't provide a way to list all the roles applied
134 # to a class.
135 for my $role (@RolesWithBUILD) {
136 if ( Role::Tiny::does_role( $class, $role ) ) {
137 ( my $build_name = $role ) =~ s/::/_/g;
138 $build_name = q{_} . $build_name . '_BUILD';
139 push @build_subs, $role . '::' . $build_name;
140 }
141 }
142
143 my $constructor = <<'EOF';
144sub {
145 my $class = shift;
146
147 my %p = do {
148 if ( @_ == 1 ) {
149 if ( ref $_[0] eq 'HASH' ) {
150 %{ shift() };
151 }
152 else {
153 Specio::OO::_constructor_confess(
154 Specio::OO::_bad_args_message( $class, @_ ) );
155 }
156 }
157 else {
158 Specio::OO::_constructor_confess(
159 Specio::OO::_bad_args_message( $class, @_ ) )
160 if @_ % 2;
161 @_;
162 }
163 };
164
165 my $self = bless {}, $class;
166
167EOF
168
169 my $attrs = $class->_attrs;
170 for my $name ( sort keys %{$attrs} ) {
171 my $attr = $attrs->{$name};
172 my $key_name = defined $attr->{init_arg} ? $attr->{init_arg} : $name;
173
174 if ( $attr->{required} ) {
175 $constructor .= <<"EOF";
176 Specio::OO::_constructor_confess(
177 "$class->new requires a $key_name argument.")
178 unless exists \$p{$key_name};
179EOF
180 }
181
182 if ( $attr->{builder} && !$attr->{lazy} ) {
183 my $builder = $attr->{builder};
184 $constructor .= <<"EOF";
185 \$p{$key_name} = $class->$builder unless exists \$p{$key_name};
186EOF
187 }
188
189 if ( $attr->{isa} ) {
190 my $validator;
191 if ( $TypeChecks{ $attr->{isa} } ) {
192 $validator
193 = 'Specio::TypeChecks::is_'
194 . $attr->{isa}
195 . "( \$p{$key_name} )";
196 }
197 else {
198 my $quoted_class = perlstring( $attr->{isa} );
199 $validator
200 = "Specio::TypeChecks::isa_class( \$p{$key_name}, $quoted_class )";
201 }
202
203 $constructor .= <<"EOF";
204 if ( exists \$p{$key_name} && !$validator ) {
205 Carp::confess(
206 Specio::OO::_bad_value_message(
207 "The value you provided to $class->new for $key_name is not a valid $attr->{isa}.",
208 \$p{$key_name},
209 )
210 );
211 }
212EOF
213 }
214
215 if ( $attr->{does} ) {
216 my $quoted_role = perlstring( $attr->{does} );
217 $constructor .= <<"EOF";
218 if ( exists \$p{$key_name} && !Specio::TypeChecks::does_role( \$p{$key_name}, $quoted_role ) ) {
219 Carp::confess(
220 Specio::OO::_bad_value_message(
221 "The value you provided to $class->new for $key_name does not do the $attr->{does} role.",
222 \$p{$key_name},
223 )
224 );
225 }
226EOF
227 }
228
229 if ( $attr->{weak_ref} ) {
230 $constructor .= " Scalar::Util::weaken( \$p{$key_name} );\n";
231 }
232
233 $constructor
234 .= " \$self->{$name} = \$p{$key_name} if exists \$p{$key_name};\n";
235
236 $constructor .= "\n";
237 }
238
239 $constructor .= ' $self->' . $_ . "(\\%p);\n" for @build_subs;
240 $constructor .= <<'EOF';
241
242 return $self;
243}
244EOF
245
246 {
247 ## no critic (TestingAndDebugging::ProhibitNoStrict)
248 no strict 'refs';
249 *{ $class . '::new' } = _eval_or_die(
250 $constructor, $class . '->new',
251 );
252 }
253}
254
255# This used to be done with Eval::Closure but that added a lot of unneeded
256# overhead. We're never actually eval'ing a closure, just plain source, so
257# doing it by hand is a worthwhile optimization.
258sub _eval_or_die {
259 local $@ = undef;
260 ## no critic (Variables::RequireInitializationForLocalVars)
261 # $SIG{__DIE__} = undef causes warnings with 5.8.x
262 local $SIG{__DIE__};
263 ## no critic (BuiltinFunctions::ProhibitStringyEval)
264 my $sub = eval <<"EOF";
265#line 1 "$_[1]"
266$_[0];
267EOF
268 my $e = $@;
269 die $e if $e;
270 return $sub;
271}
272
273## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
274sub _constructor_confess {
275 local $Carp::CarpLevel = $Carp::CarpLevel + 1;
276 confess shift;
277}
278
279sub _bad_args_message {
280 my $class = shift;
281
282 return
283 "$class->new requires either a hashref or hash as arguments. You passed "
284 . partial_dump(@_);
285}
286
287sub _bad_value_message {
288 my $message = shift;
289 my $value = shift;
290
291 return $message . ' You passed ' . partial_dump($value);
292}
293## use critic
294
295my %BuiltinTypes = map { $_ => 1 } qw(
296 SCALAR
297 ARRAY
298 HASH
299 CODE
300 REF
301 GLOB
302 LVALUE
303 FORMAT
304 IO
305 VSTRING
306 Regexp
307);
308
309sub clone {
310 my $self = shift;
311
312 # Attributes which provide a clone method are cloned by calling that
313 # method on the _clone_ (not the original). This is primarily to allow us
314 # to clone the coercions contained by a type in a way that doesn't lead to
315 # circular clone (type clones coercions which in turn need to clone their
316 # to/from types which in turn ...).
317 my $attrs = $self->_attrs;
318 my %special = map { $_ => $attrs->{$_}{clone} }
319 grep { $attrs->{$_}{clone} } keys %{$attrs};
320
321 my $new;
322 for my $key ( keys %{$self} ) {
323 my $value = $self->{$key};
324
325 if ( $special{$key} ) {
326 $new->{$key} = $value;
327 next;
328 }
329
330 # We need to special case arrays of Specio objects, as they may
331 # contain code refs which cannot be cloned with dclone. Not using
332 # blessed is a small optimization.
333 if ( ( ref $value eq 'ARRAY' )
334 && all { ( ref($_) || q{} ) =~ /Specio/ } @{$value} ) {
335
336 $new->{$key} = [ map { $_->clone } @{$value} ];
337 next;
338 }
339
340 # This is a weird hacky way of trying to avoid calling
341 # Scalar::Util::blessed, which showed up as a hotspot in profiling of
342 # loading DateTime. That's because we call ->clone a _lot_ (it's
343 # called every time a type is exported).
344 my $ref = ref $value;
345 $new->{$key}
346 = !$ref ? $value
347 : $ref eq 'CODE' ? $value
348 : $BuiltinTypes{$ref} ? dclone($value)
349 : $value->clone;
350 }
351
352 bless $new, ( ref $self );
353
354 for my $key ( keys %special ) {
355 my $method = $special{$key};
356 $new->{$key} = $new->$method;
357 }
358
359 return $new;
360}
361
3621;
363
364# ABSTRACT: A painfully poor reimplementation of Moo(se)
365
366__END__