← 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/Declare.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sSpecio::Declare::::BEGIN@10Specio::Declare::BEGIN@10
0000s0sSpecio::Declare::::BEGIN@11Specio::Declare::BEGIN@11
0000s0sSpecio::Declare::::BEGIN@12Specio::Declare::BEGIN@12
0000s0sSpecio::Declare::::BEGIN@13Specio::Declare::BEGIN@13
0000s0sSpecio::Declare::::BEGIN@14Specio::Declare::BEGIN@14
0000s0sSpecio::Declare::::BEGIN@15Specio::Declare::BEGIN@15
0000s0sSpecio::Declare::::BEGIN@3Specio::Declare::BEGIN@3
0000s0sSpecio::Declare::::BEGIN@4Specio::Declare::BEGIN@4
0000s0sSpecio::Declare::::BEGIN@6Specio::Declare::BEGIN@6
0000s0sSpecio::Declare::::__ANON__Specio::Declare::__ANON__ (xsub)
0000s0sSpecio::Declare::::_make_tcSpecio::Declare::_make_tc
0000s0sSpecio::Declare::::anonSpecio::Declare::anon
0000s0sSpecio::Declare::::any_can_typeSpecio::Declare::any_can_type
0000s0sSpecio::Declare::::any_does_typeSpecio::Declare::any_does_type
0000s0sSpecio::Declare::::any_isa_typeSpecio::Declare::any_isa_type
0000s0sSpecio::Declare::::coerceSpecio::Declare::coerce
0000s0sSpecio::Declare::::declareSpecio::Declare::declare
0000s0sSpecio::Declare::::enumSpecio::Declare::enum
0000s0sSpecio::Declare::::importSpecio::Declare::import
0000s0sSpecio::Declare::::intersectionSpecio::Declare::intersection
0000s0sSpecio::Declare::::object_can_typeSpecio::Declare::object_can_type
0000s0sSpecio::Declare::::object_does_typeSpecio::Declare::object_does_type
0000s0sSpecio::Declare::::object_isa_typeSpecio::Declare::object_isa_type
0000s0sSpecio::Declare::::unionSpecio::Declare::union
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package Specio::Declare;
2
3use strict;
4use warnings;
5
6use parent 'Exporter';
7
8our $VERSION = '0.47';
9
10use Carp qw( croak );
11use Specio::Coercion;
12use Specio::Constraint::Simple;
13use Specio::DeclaredAt;
14use Specio::Helpers qw( install_t_sub _STRINGLIKE );
15use Specio::Registry qw( internal_types_for_package register );
16
17## no critic (Modules::ProhibitAutomaticExportation)
18our @EXPORT = qw(
19 anon
20 any_can_type
21 any_does_type
22 any_isa_type
23 coerce
24 declare
25 enum
26 intersection
27 object_can_type
28 object_does_type
29 object_isa_type
30 union
31);
32## use critic
33
34sub import {
35 my $package = shift;
36
37 # What the heck is this monstrosity?
38 #
39 # Moose version 2.0901 included a first pass at support for Specio. This
40 # was based on Specio c. 0.06 when Specio itself still used
41 # Moose. Unfortunately, recent changes to Specio broke this support and
42 # the Moose core needs updating.
43 #
44 # However, stable versions of Moose have since shipped with a test that
45 # attempts to test itself with Specio 0.07+. This was fine until I wanted
46 # to release a non-TRIAL Specio.
47 #
48 # Once that's out, anyone installing Specio will cause future attempts to
49 # install Moose to fail until Moose includes updated Specio support!
50 # Breaking Moose is not acceptable, thus this mess.
51 #
52 # Note that since Moose 2.1207 this test was renamed and the Specio tests
53 # actually run (and pass). We still need to leave this in here for quite
54 # some time. People should be able to install Specio and then install an
55 # older Moose indefinitely (or at least for a year or two).
56 if ( $ENV{HARNESS_ACTIVE}
57 && $0 =~ m{t[\\/]type_constraints[\\/]specio\.t$} ) {
58
59 require Test::More;
60 Test::More::plan( skip_all =>
61 'These tests will not pass with this version of Specio' );
62 exit 0;
63 }
64
65 my $caller = caller();
66
67 $package->export_to_level( 1, $package, @_ );
68
69 install_t_sub(
70 $caller,
71 internal_types_for_package($caller)
72 );
73
74 return;
75}
76
77sub declare {
78 my $name = _STRINGLIKE(shift)
79 or croak 'You must provide a name for declared types';
80 my %p = @_;
81
82 my $tc = _make_tc( name => $name, %p );
83
84 register( scalar caller(), $name, $tc, 'exportable' );
85
86 return $tc;
87}
88
89sub anon {
90 return _make_tc(@_);
91}
92
93sub enum {
94 my $name;
95 $name = shift if @_ % 2;
96 my %p = @_;
97
98 require Specio::Constraint::Enum;
99
100 my $tc = _make_tc(
101 ( defined $name ? ( name => $name ) : () ),
102 values => $p{values},
103 type_class => 'Specio::Constraint::Enum',
104 );
105
106 register( scalar caller(), $name, $tc, 'exportable' )
107 if defined $name;
108
109 return $tc;
110}
111
112sub object_can_type {
113 my $name;
114 $name = shift if @_ % 2;
115 my %p = @_;
116
117 # This cannot be loaded earlier, since it loads Specio::Library::Builtins,
118 # which in turn wants to load Specio::Declare (the current module).
119 require Specio::Constraint::ObjectCan;
120
121 my $tc = _make_tc(
122 ( defined $name ? ( name => $name ) : () ),
123 methods => $p{methods},
124 type_class => 'Specio::Constraint::ObjectCan',
125 );
126
127 register( scalar caller(), $name, $tc, 'exportable' )
128 if defined $name;
129
130 return $tc;
131}
132
133sub object_does_type {
134 my $name;
135 $name = shift if @_ % 2;
136 my %p = @_;
137
138 my $caller = scalar caller();
139
140 # If we are being called repeatedly with a single argument, then we don't
141 # want to blow up because the type has already been declared. This would
142 # force the user to use t() for all calls but the first, making their code
143 # pointlessly more complicated.
144 unless ( keys %p ) {
145 if ( my $exists = internal_types_for_package($caller)->{$name} ) {
146 return $exists;
147 }
148 }
149
150 require Specio::Constraint::ObjectDoes;
151
152 my $tc = _make_tc(
153 ( defined $name ? ( name => $name ) : () ),
154 role => ( defined $p{role} ? $p{role} : $name ),
155 type_class => 'Specio::Constraint::ObjectDoes',
156 );
157
158 register( scalar caller(), $name, $tc, 'exportable' )
159 if defined $name;
160
161 return $tc;
162}
163
164sub object_isa_type {
165 my $name;
166 $name = shift if @_ % 2;
167 my %p = @_;
168
169 my $caller = scalar caller();
170 unless ( keys %p ) {
171 if ( my $exists = internal_types_for_package($caller)->{$name} ) {
172 return $exists;
173 }
174 }
175
176 require Specio::Constraint::ObjectIsa;
177
178 my $tc = _make_tc(
179 ( defined $name ? ( name => $name ) : () ),
180 class => ( defined $p{class} ? $p{class} : $name ),
181 type_class => 'Specio::Constraint::ObjectIsa',
182 );
183
184 register( $caller, $name, $tc, 'exportable' )
185 if defined $name;
186
187 return $tc;
188}
189
190sub any_can_type {
191 my $name;
192 $name = shift if @_ % 2;
193 my %p = @_;
194
195 # This cannot be loaded earlier, since it loads Specio::Library::Builtins,
196 # which in turn wants to load Specio::Declare (the current module).
197 require Specio::Constraint::AnyCan;
198
199 my $tc = _make_tc(
200 ( defined $name ? ( name => $name ) : () ),
201 methods => $p{methods},
202 type_class => 'Specio::Constraint::AnyCan',
203 );
204
205 register( scalar caller(), $name, $tc, 'exportable' )
206 if defined $name;
207
208 return $tc;
209}
210
211sub any_does_type {
212 my $name;
213 $name = shift if @_ % 2;
214 my %p = @_;
215
216 my $caller = scalar caller();
217 unless ( keys %p ) {
218 if ( my $exists = internal_types_for_package($caller)->{$name} ) {
219 return $exists;
220 }
221 }
222
223 require Specio::Constraint::AnyDoes;
224
225 my $tc = _make_tc(
226 ( defined $name ? ( name => $name ) : () ),
227 role => ( defined $p{role} ? $p{role} : $name ),
228 type_class => 'Specio::Constraint::AnyDoes',
229 );
230
231 register( scalar caller(), $name, $tc, 'exportable' )
232 if defined $name;
233
234 return $tc;
235}
236
237sub any_isa_type {
238 my $name;
239 $name = shift if @_ % 2;
240 my %p = @_;
241
242 my $caller = scalar caller();
243 unless ( keys %p ) {
244 if ( my $exists = internal_types_for_package($caller)->{$name} ) {
245 return $exists;
246 }
247 }
248
249 require Specio::Constraint::AnyIsa;
250
251 my $tc = _make_tc(
252 ( defined $name ? ( name => $name ) : () ),
253 class => ( defined $p{class} ? $p{class} : $name ),
254 type_class => 'Specio::Constraint::AnyIsa',
255 );
256
257 register( scalar caller(), $name, $tc, 'exportable' )
258 if defined $name;
259
260 return $tc;
261}
262
263sub intersection {
264 my $name;
265 $name = shift if @_ % 2;
266 my %p = @_;
267
268 require Specio::Constraint::Intersection;
269
270 my $tc = _make_tc(
271 ( defined $name ? ( name => $name ) : () ),
272 %p,
273 type_class => 'Specio::Constraint::Intersection',
274 );
275
276 register( scalar caller(), $name, $tc, 'exportable' )
277 if defined $name;
278
279 return $tc;
280}
281
282sub union {
283 my $name;
284 $name = shift if @_ % 2;
285 my %p = @_;
286
287 require Specio::Constraint::Union;
288
289 my $tc = _make_tc(
290 ( defined $name ? ( name => $name ) : () ),
291 %p,
292 type_class => 'Specio::Constraint::Union',
293 );
294
295 register( scalar caller(), $name, $tc, 'exportable' )
296 if defined $name;
297
298 return $tc;
299}
300
301sub _make_tc {
302 my %p = @_;
303
304 my $class = delete $p{type_class} || 'Specio::Constraint::Simple';
305
306 $p{constraint} = delete $p{where} if exists $p{where};
307 $p{message_generator} = delete $p{message} if exists $p{message};
308 $p{inline_generator} = delete $p{inline} if exists $p{inline};
309
310 return $class->new(
311 %p,
312 declared_at => Specio::DeclaredAt->new_from_caller(2),
313 );
314}
315
316sub coerce {
317 my $to = shift;
318 my %p = @_;
319
320 $p{coercion} = delete $p{using} if exists $p{using};
321 $p{inline_generator} = delete $p{inline} if exists $p{inline};
322
323 return $to->add_coercion(
324 Specio::Coercion->new(
325 to => $to,
326 %p,
327 declared_at => Specio::DeclaredAt->new_from_caller(1),
328 )
329 );
330}
331
3321;
333
334# ABSTRACT: Specio declaration subroutines
335
336__END__