← Index
NYTProf Performance Profile   « line view »
For fastest.pl
  Run on Fri Jan 31 20:48:16 2014
Reported on Fri Jan 31 20:49:41 2014

Filename/opt/perl-5.18.1/lib/site_perl/5.18.1/Type/Utils.pm
StatementsExecuted 38 statements in 3.47ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
11120µs20µsType::Utils::::BEGIN@3 Type::Utils::BEGIN@3
11113µs29µsType::Utils::::BEGIN@172 Type::Utils::BEGIN@172
11112µs23µsType::Utils::::BEGIN@189 Type::Utils::BEGIN@189
11112µs27µsType::Utils::::BEGIN@219 Type::Utils::BEGIN@219
11111µs22µsType::Utils::::BEGIN@204 Type::Utils::BEGIN@204
11111µs22µsType::Utils::::BEGIN@249 Type::Utils::BEGIN@249
11111µs22µsType::Utils::::BEGIN@234 Type::Utils::BEGIN@234
11110µs43µsType::Utils::::BEGIN@14 Type::Utils::BEGIN@14
1119µs14µsType::Utils::::BEGIN@5 Type::Utils::BEGIN@5
1119µs348µsType::Utils::::BEGIN@17 Type::Utils::BEGIN@17
1118µs115µsType::Utils::::BEGIN@15 Type::Utils::BEGIN@15
1118µs24µsType::Utils::::BEGIN@4 Type::Utils::BEGIN@4
1115µs5µsType::Utils::::BEGIN@16 Type::Utils::BEGIN@16
1115µs5µsType::Utils::::BEGIN@7 Type::Utils::BEGIN@7
0000s0sType::Registry::DWIM::::simple_lookupType::Registry::DWIM::simple_lookup
0000s0sType::Utils::::_croak Type::Utils::_croak
0000s0sType::Utils::::as Type::Utils::as
0000s0sType::Utils::::class_type Type::Utils::class_type
0000s0sType::Utils::::coerce Type::Utils::coerce
0000s0sType::Utils::::compile_match_on_type Type::Utils::compile_match_on_type
0000s0sType::Utils::::declare Type::Utils::declare
0000s0sType::Utils::::declare_coercion Type::Utils::declare_coercion
0000s0sType::Utils::::duck_type Type::Utils::duck_type
0000s0sType::Utils::::dwim_type Type::Utils::dwim_type
0000s0sType::Utils::::english_list Type::Utils::english_list
0000s0sType::Utils::::enum Type::Utils::enum
0000s0sType::Utils::::extends Type::Utils::extends
0000s0sType::Utils::::from Type::Utils::from
0000s0sType::Utils::::inline_as Type::Utils::inline_as
0000s0sType::Utils::::intersection Type::Utils::intersection
0000s0sType::Utils::::match_on_type Type::Utils::match_on_type
0000s0sType::Utils::::message Type::Utils::message
0000s0sType::Utils::::role_type Type::Utils::role_type
0000s0sType::Utils::::to_type Type::Utils::to_type
0000s0sType::Utils::::union Type::Utils::union
0000s0sType::Utils::::via Type::Utils::via
0000s0sType::Utils::::where Type::Utils::where
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package Type::Utils;
2
3258µs120µs
# spent 20µs within Type::Utils::BEGIN@3 which was called: # once (20µs+0s) by Typed::BEGIN@11 at line 3
use 5.006001;
# spent 20µs making 1 call to Type::Utils::BEGIN@3
4230µs241µs
# spent 24µs (8+16) within Type::Utils::BEGIN@4 which was called: # once (8µs+16µs) by Typed::BEGIN@11 at line 4
use strict;
# spent 24µs making 1 call to Type::Utils::BEGIN@4 # spent 16µs making 1 call to strict::import
5246µs220µs
# spent 14µs (9+5) within Type::Utils::BEGIN@5 which was called: # once (9µs+5µs) by Typed::BEGIN@11 at line 5
use warnings;
# spent 14µs making 1 call to Type::Utils::BEGIN@5 # spent 5µs making 1 call to warnings::import
6
7
# spent 5µs within Type::Utils::BEGIN@7 which was called: # once (5µs+0s) by Typed::BEGIN@11 at line 10
BEGIN {
81500ns $Type::Utils::AUTHORITY = 'cpan:TOBYINK';
915µs $Type::Utils::VERSION = '0.038';
10160µs15µs}
# spent 5µs making 1 call to Type::Utils::BEGIN@7
11
12sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak }
13
14232µs275µs
# spent 43µs (10+33) within Type::Utils::BEGIN@14 which was called: # once (10µs+33µs) by Typed::BEGIN@11 at line 14
use Scalar::Util qw< blessed >;
# spent 43µs making 1 call to Type::Utils::BEGIN@14 # spent 33µs making 1 call to Exporter::import
15234µs2222µs
# spent 115µs (8+106) within Type::Utils::BEGIN@15 which was called: # once (8µs+106µs) by Typed::BEGIN@11 at line 15
use Type::Library;
# spent 115µs making 1 call to Type::Utils::BEGIN@15 # spent 106µs making 1 call to Exporter::Tiny::import
16234µs15µs
# spent 5µs within Type::Utils::BEGIN@16 which was called: # once (5µs+0s) by Typed::BEGIN@11 at line 16
use Type::Tiny;
# spent 5µs making 1 call to Type::Utils::BEGIN@16
172805µs2687µs
# spent 348µs (9+339) within Type::Utils::BEGIN@17 which was called: # once (9µs+339µs) by Typed::BEGIN@11 at line 17
use Types::TypeTiny qw< TypeTiny to_TypeTiny HashLike StringLike CodeLike >;
# spent 348µs making 1 call to Type::Utils::BEGIN@17 # spent 339µs making 1 call to Exporter::Tiny::import
18
1914µsour @EXPORT = qw<
20 declare as where message inline_as
21 class_type role_type duck_type union intersection enum
22 coerce from via
23 declare_coercion to_type
24>;
2514µsour @EXPORT_OK = (
26 @EXPORT,
27 qw<
28 extends type subtype
29 match_on_type compile_match_on_type
30 dwim_type english_list
31 >,
32);
33
341600nsrequire Exporter::Tiny;
35110µsour @ISA = 'Exporter::Tiny';
36
37sub extends
38{
39 _croak "Not a type library" unless caller->isa("Type::Library");
40 my $caller = caller->meta;
41
42 foreach my $lib (@_)
43 {
44 eval "use $lib; 1" or _croak "Could not load library '$lib': $@";
45
46 if ($lib->isa("Type::Library") or $lib eq 'Types::TypeTiny')
47 {
48 $caller->add_type( $lib->get_type($_) )
49 for sort $lib->meta->type_names;
50 $caller->add_coercion( $lib->get_coercion($_) )
51 for sort $lib->meta->coercion_names;
52 }
53 elsif ($lib->isa('MooseX::Types::Base'))
54 {
55 require Moose::Util::TypeConstraints;
56 my $types = $lib->type_storage;
57 for my $name (sort keys %$types)
58 {
59 my $moose = Moose::Util::TypeConstraints::find_type_constraint($types->{$name});
60 my $tt = Types::TypeTiny::to_TypeTiny($moose);
61 $caller->add_type(
62 $tt->create_child_type(library => $caller, name => $name, coercion => $moose->has_coercion ? 1 : 0)
63 );
64 }
65 }
66 elsif ($lib->isa('MouseX::Types::Base'))
67 {
68 require Mouse::Util::TypeConstraints;
69 my $types = $lib->type_storage;
70 for my $name (sort keys %$types)
71 {
72 my $mouse = Mouse::Util::TypeConstraints::find_type_constraint($types->{$name});
73 my $tt = Types::TypeTiny::to_TypeTiny($mouse);
74 $caller->add_type(
75 $tt->create_child_type(library => $caller, name => $name, coercion => $mouse->has_coercion ? 1 : 0)
76 );
77 }
78 }
79 else
80 {
81 _croak("'$lib' is not a type constraint library");
82 }
83 }
84}
85
86sub declare
87{
88 my %opts;
89 if (@_ % 2 == 0)
90 {
91 %opts = @_;
92 }
93 else
94 {
95 (my($name), %opts) = @_;
96 _croak "Cannot provide two names for type" if exists $opts{name};
97 $opts{name} = $name;
98 }
99
100 my $caller = caller($opts{_caller_level} || 0);
101 $opts{library} = $caller;
102
103 if (defined $opts{parent})
104 {
105 $opts{parent} = to_TypeTiny($opts{parent});
106
107 unless (TypeTiny->check($opts{parent}))
108 {
109 $caller->isa("Type::Library")
110 or _croak("Parent type cannot be a %s", ref($opts{parent})||'non-reference scalar');
111 $opts{parent} = $caller->meta->get_type($opts{parent})
112 or _croak("Could not find parent type");
113 }
114 }
115
116 my $type;
117 if (defined $opts{parent})
118 {
119 $type = delete($opts{parent})->create_child_type(%opts);
120 }
121 else
122 {
123 my $bless = delete($opts{bless}) || "Type::Tiny";
124 eval "require $bless";
125 $type = $bless->new(%opts);
126 }
127
128 if ($caller->isa("Type::Library"))
129 {
130 $caller->meta->add_type($type) unless $type->is_anon;
131 }
132
133 return $type;
134}
135
13611µs*subtype = \&declare;
1371400ns*type = \&declare;
138
139sub as (@)
140{
141 parent => @_;
142}
143
144sub where (&;@)
145{
146 constraint => @_;
147}
148
149sub message (&;@)
150{
151 message => @_;
152}
153
154sub inline_as (&;@)
155{
156 inlined => @_;
157}
158
159sub class_type
160{
161 my $name = ref($_[0]) ? undef : shift;
162 my %opts = %{ +shift };
163
164 if (defined $name)
165 {
166 $opts{name} = $name unless exists $opts{name};
167 $opts{class} = $name unless exists $opts{class};
168 }
169
170 $opts{bless} = "Type::Tiny::Class";
171
1722128µs245µs
# spent 29µs (13+16) within Type::Utils::BEGIN@172 which was called: # once (13µs+16µs) by Typed::BEGIN@11 at line 172
{ no warnings "numeric"; $opts{_caller_level}++ }
# spent 29µs making 1 call to Type::Utils::BEGIN@172 # spent 16µs making 1 call to warnings::unimport
173 declare(%opts);
174}
175
176sub role_type
177{
178 my $name = ref($_[0]) ? undef : shift;
179 my %opts = %{ +shift };
180
181 if (defined $name)
182 {
183 $opts{name} = $name unless exists $opts{name};
184 $opts{role} = $name unless exists $opts{role};
185 }
186
187 $opts{bless} = "Type::Tiny::Role";
188
1892132µs235µs
# spent 23µs (12+12) within Type::Utils::BEGIN@189 which was called: # once (12µs+12µs) by Typed::BEGIN@11 at line 189
{ no warnings "numeric"; $opts{_caller_level}++ }
# spent 23µs making 1 call to Type::Utils::BEGIN@189 # spent 12µs making 1 call to warnings::unimport
190 declare(%opts);
191}
192
193sub duck_type
194{
195 my $name = ref($_[0]) ? undef : shift;
196 my @methods = @{ +shift };
197
198 my %opts;
199 $opts{name} = $name if defined $name;
200 $opts{methods} = \@methods;
201
202 $opts{bless} = "Type::Tiny::Duck";
203
2042120µs234µs
# spent 22µs (11+11) within Type::Utils::BEGIN@204 which was called: # once (11µs+11µs) by Typed::BEGIN@11 at line 204
{ no warnings "numeric"; $opts{_caller_level}++ }
# spent 22µs making 1 call to Type::Utils::BEGIN@204 # spent 11µs making 1 call to warnings::unimport
205 declare(%opts);
206}
207
208sub enum
209{
210 my $name = ref($_[0]) ? undef : shift;
211 my @values = @{ +shift };
212
213 my %opts;
214 $opts{name} = $name if defined $name;
215 $opts{values} = \@values;
216
217 $opts{bless} = "Type::Tiny::Enum";
218
2192129µs242µs
# spent 27µs (12+15) within Type::Utils::BEGIN@219 which was called: # once (12µs+15µs) by Typed::BEGIN@11 at line 219
{ no warnings "numeric"; $opts{_caller_level}++ }
# spent 27µs making 1 call to Type::Utils::BEGIN@219 # spent 15µs making 1 call to warnings::unimport
220 declare(%opts);
221}
222
223sub union
224{
225 my $name = ref($_[0]) ? undef : shift;
226 my @tcs = @{ +shift };
227
228 my %opts;
229 $opts{name} = $name if defined $name;
230 $opts{type_constraints} = \@tcs;
231
232 $opts{bless} = "Type::Tiny::Union";
233
2342124µs232µs
# spent 22µs (11+11) within Type::Utils::BEGIN@234 which was called: # once (11µs+11µs) by Typed::BEGIN@11 at line 234
{ no warnings "numeric"; $opts{_caller_level}++ }
# spent 22µs making 1 call to Type::Utils::BEGIN@234 # spent 11µs making 1 call to warnings::unimport
235 declare(%opts);
236}
237
238sub intersection
239{
240 my $name = ref($_[0]) ? undef : shift;
241 my @tcs = @{ +shift };
242
243 my %opts;
244 $opts{name} = $name if defined $name;
245 $opts{type_constraints} = \@tcs;
246
247 $opts{bless} = "Type::Tiny::Intersection";
248
24921.69ms233µs
# spent 22µs (11+11) within Type::Utils::BEGIN@249 which was called: # once (11µs+11µs) by Typed::BEGIN@11 at line 249
{ no warnings "numeric"; $opts{_caller_level}++ }
# spent 22µs making 1 call to Type::Utils::BEGIN@249 # spent 11µs making 1 call to warnings::unimport
250 declare(%opts);
251}
252
253sub declare_coercion
254{
255 my %opts;
256 $opts{name} = shift if !ref($_[0]);
257
258 while (HashLike->check($_[0]) and not TypeTiny->check($_[0]))
259 {
260 %opts = (%opts, %{+shift});
261 }
262
263 my $caller = caller($opts{_caller_level} || 0);
264 $opts{library} = $caller;
265
266 my $bless = delete($opts{bless}) || "Type::Coercion";
267 eval "require $bless";
268 my $c = $bless->new(%opts);
269
270 my @C;
271
272 if ($caller->isa("Type::Library"))
273 {
274 my $meta = $caller->meta;
275 $meta->add_coercion($c) unless $c->is_anon;
276 while (@_)
277 {
278 push @C, map { ref($_) ? to_TypeTiny($_) : $meta->get_type($_)||$_ } shift;
279 push @C, shift;
280 }
281 }
282
283 $c->add_type_coercions(@C);
284
285 return $c->freeze;
286}
287
288sub coerce
289{
290 if ((scalar caller)->isa("Type::Library"))
291 {
292 my $meta = (scalar caller)->meta;
293 my ($type) = map { ref($_) ? to_TypeTiny($_) : $meta->get_type($_)||$_ } shift;
294 my @opts;
295 while (@_)
296 {
297 push @opts, map { ref($_) ? to_TypeTiny($_) : $meta->get_type($_)||$_ } shift;
298 push @opts, shift;
299 }
300 return $type->coercion->add_type_coercions(@opts);
301 }
302
303 my ($type, @opts) = @_;
304 $type = to_TypeTiny($type);
305 return $type->coercion->add_type_coercions(@opts);
306}
307
308sub from (@)
309{
310 return @_;
311}
312
313sub to_type (@)
314{
315 my $type = shift;
316 unless (TypeTiny->check($type))
317 {
318 caller->isa("Type::Library")
319 or _croak "Target type cannot be a string";
320 $type = caller->meta->get_type($type)
321 or _croak "Could not find target type";
322 }
323 return +{ type_constraint => $type }, @_;
324}
325
326sub via (&;@)
327{
328 return @_;
329}
330
331sub match_on_type
332{
333 my $value = shift;
334
335 while (@_)
336 {
337 my ($type, $code);
338 if (@_ == 1)
339 {
340 require Types::Standard;
341 ($type, $code) = (Types::Standard::Any(), shift);
342 }
343 else
344 {
345 ($type, $code) = splice(@_, 0, 2);
346 TypeTiny->($type);
347 }
348
349 $type->check($value) or next;
350
351 if (StringLike->check($code))
352 {
353 local $_ = $value;
354 if (wantarray) {
355 my @r = eval "$code";
356 die $@ if $@;
357 return @r;
358 }
359 if (defined wantarray) {
360 my $r = eval "$code";
361 die $@ if $@;
362 return $r;
363 }
364 eval "$code";
365 die $@ if $@;
366 return;
367 }
368 else
369 {
370 CodeLike->($code);
371 local $_ = $value;
372 return $code->($value);
373 }
374 }
375
376 _croak("No cases matched for %s", Type::Tiny::_dd($value));
377}
378
379sub compile_match_on_type
380{
381 my @code = 'sub { local $_ = $_[0]; ';
382 my @checks;
383 my @actions;
384
385 my $els = '';
386
387 while (@_)
388 {
389 my ($type, $code);
390 if (@_ == 1)
391 {
392 require Types::Standard;
393 ($type, $code) = (Types::Standard::Any(), shift);
394 }
395 else
396 {
397 ($type, $code) = splice(@_, 0, 2);
398 TypeTiny->($type);
399 }
400
401 if ($type->can_be_inlined)
402 {
403 push @code, sprintf('%sif (%s)', $els, $type->inline_check('$_'));
404 }
405 else
406 {
407 push @checks, $type;
408 push @code, sprintf('%sif ($checks[%d]->check($_))', $els, $#checks);
409 }
410
411 $els = 'els';
412
413 if (StringLike->check($code))
414 {
415 push @code, sprintf(' { %s }', $code);
416 }
417 else
418 {
419 CodeLike->($code);
420 push @actions, $code;
421 push @code, sprintf(' { $actions[%d]->(@_) }', $#actions);
422 }
423 }
424
425 push @code, 'else', ' { Type::Util::_croak("No cases matched for %s", Type::Tiny::_dd($_[0])) }';
426
427 push @code, '}'; # /sub
428
429 require Eval::TypeTiny;
430 return Eval::TypeTiny::eval_closure(
431 source => \@code,
432 environment => {
433 '@actions' => \@actions,
434 '@checks' => \@checks,
435 },
436 );
437}
438
439{
4401400ns package #hide
441 Type::Registry::DWIM;
442
44316µs our @ISA = qw(Type::Registry);
444
445 sub simple_lookup
446 {
447 my $self = shift;
448 my $r;
449
450 # If the lookup is chained to a class, then the class' own
451 # type registry gets first refusal.
452 #
453 if (defined $self->{"~~chained"})
454 {
455 my $chained = "Type::Registry"->for_class($self->{"~~chained"});
456 $r = eval { $chained->simple_lookup(@_) } unless $self == $chained;
457 return $r if defined $r;
458 }
459
460 # Fall back to types in Types::Standard.
461 require Types::Standard;
462 return 'Types::Standard'->get_type($_[0]) if 'Types::Standard'->has_type($_[0]);
463
464 # Only continue any further if we've been called from Type::Parser.
465 return unless $_[1];
466
467 # If Moose is loaded...
468 if ($INC{'Moose.pm'})
469 {
470 require Moose::Util::TypeConstraints;
471 require Types::TypeTiny;
472 $r = Moose::Util::TypeConstraints::find_type_constraint($_[0]);
473 return Types::TypeTiny::to_TypeTiny($r) if defined $r;
474 }
475
476 # If Mouse is loaded...
477 if ($INC{'Mouse.pm'})
478 {
479 require Mouse::Util::TypeConstraints;
480 require Types::TypeTiny;
481 $r = Mouse::Util::TypeConstraints::find_type_constraint($_[0]);
482 return Types::TypeTiny::to_TypeTiny($r) if defined $r;
483 }
484
485 return unless $_[0] =~ /^\s*(\w+(::\w+)*)\s*$/sm;
486 return unless defined $self->{"~~assume"};
487
488 # Lastly, if it looks like a class/role name, assume it's
489 # supposed to be a class/role type.
490 #
491
492 if ($self->{"~~assume"} eq "Type::Tiny::Class")
493 {
494 require Type::Tiny::Class;
495 return "Type::Tiny::Class"->new(class => $_[0]);
496 }
497
498 if ($self->{"~~assume"} eq "Type::Tiny::Role")
499 {
500 require Type::Tiny::Role;
501 return "Type::Tiny::Role"->new(role => $_[0]);
502 }
503
504 die;
505 }
506}
507
5081100nsour $dwimmer;
509sub dwim_type
510{
511 my ($string, %opts) = @_;
512 $opts{for} = caller unless defined $opts{for};
513
514 $dwimmer ||= do {
515 require Type::Registry;
516 'Type::Registry::DWIM'->new;
517 };
518
519 local $dwimmer->{'~~chained'} = $opts{for};
520 local $dwimmer->{'~~assume'} = $opts{does} ? 'Type::Tiny::Role' : 'Type::Tiny::Class';
521
522 $dwimmer->lookup($string);
523}
524
525sub english_list
526{
527 my $conjunction = ref($_[0]) eq 'SCALAR' ? ${+shift} : 'and';
528 my @items = sort @_;
529
530 return $items[0] if @items == 1;
531 return "$items[0] $conjunction $items[1]" if @items == 2;
532
533 my $tail = pop @items;
534 join(', ', @items, "$conjunction $tail");
535}
536
537111µs1;
538
539__END__