File Coverage

blib/lib/Type/Tiny.pm
Criterion Covered Total %
statement 700 763 92.0
branch 351 462 75.9
condition 201 300 67.0
subroutine 210 224 93.7
pod 85 85 100.0
total 1547 1834 84.4


line stmt bran cond sub pod time code
1             package Type::Tiny;
2              
3 279     279   287429 use 5.008001;
  279         1269  
4 279     279   1660 use strict;
  279         559  
  279         5918  
5 279     279   1346 use warnings;
  279         587  
  279         13476  
6              
7             BEGIN {
8 279 50   279   12943 if ( $] < 5.010 ) { require Devel::TypeTiny::Perl58Compat }
  0         0  
9             }
10              
11             BEGIN {
12 279     279   942 $Type::Tiny::AUTHORITY = 'cpan:TOBYINK';
13 279         584 $Type::Tiny::VERSION = '2.004000';
14 279         30710 $Type::Tiny::XS_VERSION = '0.016';
15             }
16              
17             $Type::Tiny::VERSION =~ tr/_//d;
18             $Type::Tiny::XS_VERSION =~ tr/_//d;
19              
20             our @InternalPackages = qw(
21             Devel::TypeTiny::Perl56Compat
22             Devel::TypeTiny::Perl58Compat
23             Error::TypeTiny
24             Error::TypeTiny::Assertion
25             Error::TypeTiny::Compilation
26             Error::TypeTiny::WrongNumberOfParameters
27             Eval::TypeTiny
28             Eval::TypeTiny::CodeAccumulator
29             Eval::TypeTiny::Sandbox
30             Exporter::Tiny
31             Reply::Plugin::TypeTiny
32             Test::TypeTiny
33             Type::Coercion
34             Type::Coercion::FromMoose
35             Type::Coercion::Union
36             Type::Library
37             Type::Params
38             Type::Params::Alternatives
39             Type::Params::Parameter
40             Type::Params::Signature
41             Type::Parser
42             Type::Parser::AstBuilder
43             Type::Parser::Token
44             Type::Parser::TokenStream
45             Type::Registry
46             Types::Common
47             Types::Common::Numeric
48             Types::Common::String
49             Types::Standard
50             Types::Standard::_Stringable
51             Types::Standard::ArrayRef
52             Types::Standard::CycleTuple
53             Types::Standard::Dict
54             Types::Standard::HashRef
55             Types::Standard::Map
56             Types::Standard::ScalarRef
57             Types::Standard::StrMatch
58             Types::Standard::Tied
59             Types::Standard::Tuple
60             Types::TypeTiny
61             Type::Tie
62             Type::Tie::ARRAY
63             Type::Tie::BASE
64             Type::Tie::HASH
65             Type::Tie::SCALAR
66             Type::Tiny
67             Type::Tiny::_DeclaredType
68             Type::Tiny::_HalfOp
69             Type::Tiny::Class
70             Type::Tiny::ConsrtainedObject
71             Type::Tiny::Duck
72             Type::Tiny::Enum
73             Type::Tiny::Intersection
74             Type::Tiny::Role
75             Type::Tiny::Union
76             Type::Utils
77             );
78              
79 279     279   2166 use Scalar::Util qw( blessed );
  279         593  
  279         15011  
80 279     279   73465 use Types::TypeTiny ();
  279         765  
  279         112712  
81              
82             our $SafePackage = sprintf 'package %s;', __PACKAGE__;
83              
84 15     15   230 sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak }
  15         89  
85              
86 40153 50   40153   138872 sub _swap { $_[2] ? @_[ 1, 0 ] : @_[ 0, 1 ] }
87              
88             BEGIN {
89 279     279   1601 my $support_smartmatch = 0+ !!( $] >= 5.010001 );
90 279         18152 eval qq{ sub SUPPORT_SMARTMATCH () { !! $support_smartmatch } };
91            
92 279         2781 my $fixed_precedence = 0+ !!( $] >= 5.014 );
93 279         11473 eval qq{ sub _FIXED_PRECEDENCE () { !! $fixed_precedence } };
94            
95             my $try_xs =
96             exists( $ENV{PERL_TYPE_TINY_XS} ) ? !!$ENV{PERL_TYPE_TINY_XS}
97             : exists( $ENV{PERL_ONLY} ) ? !$ENV{PERL_ONLY}
98 279 50       2407 : 1;
    50          
99            
100 279         602 my $use_xs = 0;
101 279 50       1086 $try_xs and eval {
102 279         1724 require Type::Tiny::XS;
103 279         3288 'Type::Tiny::XS'->VERSION( $Type::Tiny::XS_VERSION );
104 279         1047 $use_xs++;
105             };
106            
107             *_USE_XS =
108             $use_xs
109             ? sub () { !!1 }
110 279 50       1230 : sub () { !!0 };
111            
112             *_USE_MOUSE =
113             $try_xs
114 261 50   261   2467 ? sub () { $INC{'Mouse/Util.pm'} and Mouse::Util::MOUSE_XS() }
115 279 50       1482 : sub () { !!0 };
116            
117 279         605 my $strict_mode = 0;
118 279   100     2798 $ENV{$_} && ++$strict_mode for qw(
119             EXTENDED_TESTING
120             AUTHOR_TESTING
121             RELEASE_TESTING
122             PERL_STRICT
123             );
124 279 100       9638 *_STRICT_MODE = $strict_mode ? sub () { !!1 } : sub () { !!0 };
125             } #/ BEGIN
126              
127             {
128              
129             sub _install_overloads {
130 279     279   1828 no strict 'refs';
  279         735  
  279         9527  
131 279     279   1606 no warnings 'redefine', 'once';
  279         641  
  279         3140310  
132            
133             # Coverage is checked on Perl 5.26
134 1942 50   1942   6843 if ( $] < 5.010 ) { # uncoverable statement
135 0         0 require overload; # uncoverable statement
136 0         0 push @_, fallback => 1; # uncoverable statement
137 0         0 goto \&overload::OVERLOAD; # uncoverable statement
138             }
139            
140 1942         4005 my $class = shift;
141 1942     0   5246 *{ $class . '::((' } = sub { };
  1942         10975  
142 1942     0   5750 *{ $class . '::()' } = sub { };
  1942         7856  
143 1942         3401 *{ $class . '::()' } = do { my $x = 1; \$x };
  1942         4741  
  1942         2931  
  1942         3280  
144 1942         5504 while ( @_ ) {
145 6921         10396 my $f = shift;
146 6921 100       12770 *{ $class . '::(' . $f } = ref $_[0] ? shift : do {
  6921         31242  
147 542         1170 my $m = shift;
148 715     715   78233 sub { shift->$m( @_ ) }
149 542         2164 };
150             }
151             } #/ sub _install_overloads
152             }
153              
154             __PACKAGE__->_install_overloads(
155             q("") => sub {
156 44966 50   44966   241205 caller =~ m{^(Moo::HandleMoose|Sub::Quote)}
157             ? $_[0]->_stringify_no_magic
158             : $_[0]->display_name;
159             },
160 42006     42006   113939 q(bool) => sub { 1 },
161             q(&{}) => "_overload_coderef",
162             q(|) => sub {
163 64     64   3708 my @tc = _swap @_;
164 64         101 if ( !_FIXED_PRECEDENCE && $_[2] ) {
165             if ( blessed $tc[0] ) {
166             if ( blessed $tc[0] eq "Type::Tiny::_HalfOp" ) {
167             my $type = $tc[0]->{type};
168             my $param = $tc[0]->{param};
169             my $op = $tc[0]->{op};
170             require Type::Tiny::Union;
171             return "Type::Tiny::_HalfOp"->new(
172             $op,
173             $param,
174             "Type::Tiny::Union"->new_by_overload( type_constraints => [ $type, $tc[1] ] ),
175             );
176             } #/ if ( blessed $tc[0] eq...)
177             } #/ if ( blessed $tc[0] )
178             elsif ( ref $tc[0] eq 'ARRAY' ) {
179             require Type::Tiny::_HalfOp;
180             return "Type::Tiny::_HalfOp"->new( '|', @tc );
181             }
182             } #/ if ( !_FIXED_PRECEDENCE...)
183 64         9485 require Type::Tiny::Union;
184 64         338 return "Type::Tiny::Union"->new_by_overload( type_constraints => \@tc );
185             },
186             q(&) => sub {
187 40059     40059   1765461 my @tc = _swap @_;
188 40059         66165 if ( !_FIXED_PRECEDENCE && $_[2] ) {
189             if ( blessed $tc[0] ) {
190             if ( blessed $tc[0] eq "Type::Tiny::_HalfOp" ) {
191             my $type = $tc[0]->{type};
192             my $param = $tc[0]->{param};
193             my $op = $tc[0]->{op};
194             require Type::Tiny::Intersection;
195             return "Type::Tiny::_HalfOp"->new(
196             $op,
197             $param,
198             "Type::Tiny::Intersection"->new_by_overload( type_constraints => [ $type, $tc[1] ] ),
199             );
200             } #/ if ( blessed $tc[0] eq...)
201             } #/ if ( blessed $tc[0] )
202             elsif ( ref $tc[0] eq 'ARRAY' ) {
203             require Type::Tiny::_HalfOp;
204             return "Type::Tiny::_HalfOp"->new( '&', @tc );
205             }
206             } #/ if ( !_FIXED_PRECEDENCE...)
207 40059         199381 require Type::Tiny::Intersection;
208 40059         135872 "Type::Tiny::Intersection"->new_by_overload( type_constraints => \@tc );
209             },
210 69     69   1408 q(~) => sub { shift->complementary_type },
211 699     699   6746 q(==) => sub { $_[0]->equals( $_[1] ) },
212 1     1   6 q(!=) => sub { not $_[0]->equals( $_[1] ) },
213 8     8   71 q(<) => sub { my $m = $_[0]->can( 'is_subtype_of' ); $m->( _swap @_ ) },
  8         26  
214             q(>) => sub {
215 10     10   100 my $m = $_[0]->can( 'is_subtype_of' );
216 10         32 $m->( reverse _swap @_ );
217             },
218 6     6   58 q(<=) => sub { my $m = $_[0]->can( 'is_a_type_of' ); $m->( _swap @_ ) },
  6         15  
219             q(>=) => sub {
220 6     6   88 my $m = $_[0]->can( 'is_a_type_of' );
221 6         16 $m->( reverse _swap @_ );
222             },
223 27     27   7536 q(eq) => sub { "$_[0]" eq "$_[1]" },
224 0 0   0   0 q(cmp) => sub { $_[2] ? ( "$_[1]" cmp "$_[0]" ) : ( "$_[0]" cmp "$_[1]" ) },
225 1     1   64 q(0+) => sub { $_[0]{uniq} },
226 4 100 50 4   3320 q(/) => sub { ( _STRICT_MODE xor $_[2] ) ? $_[0] : $_[1] },
227             );
228              
229             __PACKAGE__->_install_overloads(
230 3     3   588 q(~~) => sub { $_[0]->check( $_[1] ) },
231             ) if Type::Tiny::SUPPORT_SMARTMATCH;
232              
233             # Would be easy to just return sub { $self->assert_return(@_) }
234             # but try to build a more efficient coderef whenever possible.
235             #
236             sub _overload_coderef {
237 12845     12845   28403 my $self = shift;
238            
239             # Bypass generating a coderef if we've already got the best possible one.
240             #
241 12845 100       39307 return $self->{_overload_coderef} if $self->{_overload_coderef_no_rebuild};
242            
243             # Subclasses of Type::Tiny might override assert_return to do some kind
244             # of interesting thing. In that case, we can't rely on it having identical
245             # behaviour to Type::Tiny::inline_assert.
246             #
247             $self->{_overrides_assert_return} =
248             ( $self->can( 'assert_return' ) != \&assert_return )
249 12826 100       38871 unless exists $self->{_overrides_assert_return};
250            
251 12826 100       39083 if ( $self->{_overrides_assert_return} ) {
    100          
252 1   33     7 $self->{_overload_coderef} ||= do {
253 1         4 Scalar::Util::weaken( my $weak = $self );
254 1     2   6 sub { $weak->assert_return( @_ ) };
  2         11  
255             };
256 1         3 ++$self->{_overload_coderef_no_rebuild};
257             }
258             elsif ( exists( &Sub::Quote::quote_sub ) ) {
259            
260             # Use `=` instead of `||=` because we want to overwrite non-Sub::Quote
261             # coderef if possible.
262 162 100       356 $self->{_overload_coderef} = $self->can_be_inlined
263             ? Sub::Quote::quote_sub(
264             $self->inline_assert( '$_[0]' ),
265             )
266             : Sub::Quote::quote_sub(
267             $self->inline_assert( '$_[0]', '$type' ),
268             { '$type' => \$self },
269             );
270 162         12957 ++$self->{_overload_coderef_no_rebuild};
271             } #/ elsif ( exists( &Sub::Quote::quote_sub...))
272             else {
273 12663         67637 require Eval::TypeTiny;
274 12663 100 66     44474 $self->{_overload_coderef} ||= $self->can_be_inlined
275             ? Eval::TypeTiny::eval_closure(
276             source => sprintf(
277             'sub { %s }', $self->inline_assert( '$_[0]', undef, no_wrapper => 1 )
278             ),
279             description => sprintf( "compiled assertion 'assert_%s'", $self ),
280             )
281             : Eval::TypeTiny::eval_closure(
282             source => sprintf(
283             'sub { %s }', $self->inline_assert( '$_[0]', '$type', no_wrapper => 1 )
284             ),
285             description => sprintf( "compiled assertion 'assert_%s'", $self ),
286             environment => { '$type' => \$self },
287             );
288             } #/ else [ if ( $self->{_overrides_assert_return...})]
289            
290 12826         80466 $self->{_overload_coderef};
291             } #/ sub _overload_coderef
292              
293             our %ALL_TYPES;
294              
295             my $QFS;
296             my $uniq = 1;
297              
298             sub new {
299 93746     93746 1 170364 my $class = shift;
300 93746 50       305072 my %params = ( @_ == 1 ) ? %{ $_[0] } : @_;
  0         0  
301            
302 93746         198351 for ( qw/ name display_name library / ) {
303 281238 100       589538 $params{$_} = $params{$_} . '' if defined $params{$_};
304             }
305            
306 93746         147573 my $level = 0;
307 93746   66     324216 while ( not exists $params{definition_context} and $level < 20 ) {
308 229201   66     411497 our $_TT_GUTS ||= do {
309 268         14658 my $g = join '|', map quotemeta, grep !m{^Types::}, @InternalPackages;
310 268         130217 qr/\A(?:$g)\z/o
311             };
312 229201         387796 my $package = caller $level;
313 229201 100       1122948 if ( $package !~ $_TT_GUTS ) {
314 93746         476658 @{ $params{definition_context} = {} }{ qw/ package file line / } = caller $level;
  93746         377645  
315             }
316 229201         692014 ++$level;
317             }
318            
319 93746 100       181058 if ( exists $params{parent} ) {
320             $params{parent} =
321             ref( $params{parent} ) =~ /^Type::Tiny\b/
322             ? $params{parent}
323 11257 50       43892 : Types::TypeTiny::to_TypeTiny( $params{parent} );
324            
325             _croak "Parent must be an instance of %s", __PACKAGE__
326             unless blessed( $params{parent} )
327 11257 50 33     52242 && $params{parent}->isa( __PACKAGE__ );
328            
329 11257 100 100     31731 if ( $params{parent}->deprecated and not exists $params{deprecated} ) {
330 3         8 $params{deprecated} = 1;
331             }
332             } #/ if ( exists $params{parent...})
333            
334 93746 100 66     338291 if ( exists $params{constraint}
      100        
335             and defined $params{constraint}
336             and not ref $params{constraint} )
337             {
338 79         436 require Eval::TypeTiny;
339 79         195 my $code = $params{constraint};
340 79         496 $params{constraint} = Eval::TypeTiny::eval_closure(
341             source => sprintf( 'sub ($) { %s }', $code ),
342             description => "anonymous check",
343             );
344             $params{inlined} ||= sub {
345 269     269   577 my ( $type ) = @_;
346 269 100       1078 my $inlined = $_ eq '$_' ? "do { $code }" : "do { local \$_ = $_; $code }";
347 269 100       495 $type->has_parent ? ( undef, $inlined ) : $inlined;
348             }
349 79 50 50     541 if ( !exists $params{parent} or $params{parent}->can_be_inlined );
      66        
350             } #/ if ( exists $params{constraint...})
351            
352             # canonicalize to a boolean
353 93746         183797 $params{deprecated} = !!$params{deprecated};
354            
355 93746 100       214411 $params{name} = "__ANON__" unless exists $params{name};
356 93746         164652 $params{uniq} = $uniq++;
357            
358 93746 100       206180 if ( $params{name} ne "__ANON__" ) {
359            
360             # First try a fast ASCII-only expression, but fall back to Unicode
361             $params{name} =~ /^_{0,2}[A-Z][A-Za-z0-9_]+$/sm
362             or eval q( use 5.008; $params{name} =~ /^_{0,2}\p{Lu}[\p{L}0-9_]+$/sm )
363 11667 100 66     58504 or _croak '"%s" is not a valid type name', $params{name};
  1         28  
  1         4  
  1         732  
  1         30  
  1         15  
364             }
365            
366 93745 100 100     213789 if ( exists $params{coercion} and !ref $params{coercion} and $params{coercion} )
      100        
367             {
368             $params{parent}->has_coercion
369 2 50       10 or _croak
370             "coercion => 1 requires type to have a direct parent with a coercion";
371            
372 2         9 $params{coercion} = $params{parent}->coercion->type_coercion_map;
373             }
374            
375 93745 100 100     526152 if ( !exists $params{inlined}
      100        
      100        
      100        
      100        
376             and exists $params{constraint}
377             and ( !exists $params{parent} or $params{parent}->can_be_inlined )
378             and $QFS ||= "Sub::Quote"->can( "quoted_from_sub" ) )
379             {
380 6 100       10 my ( undef, $perlstring, $captures ) = @{ $QFS->( $params{constraint} ) || [] };
  6         22  
381            
382             $params{inlined} = sub {
383 28     28   53 my ( $self, $var ) = @_;
384 28 50       136 my $code = Sub::Quote::inlinify(
385             $perlstring,
386             $var,
387             $var eq q($_) ? '' : "local \$_ = $var;",
388             1,
389             );
390 28 100       588 $code = sprintf( '%s and %s', $self->parent->inline_check( $var ), $code )
391             if $self->has_parent;
392 28         68 return $code;
393             }
394 6 100 100     359 if $perlstring && !$captures;
395             } #/ if ( !exists $params{inlined...})
396            
397 93745         190639 my $self = bless \%params, $class;
398            
399 93745 100       195570 unless ( $params{tmp} ) {
400 93687         212976 my $uniq = $self->{uniq};
401            
402 93687         295975 $ALL_TYPES{$uniq} = $self;
403 93687         303102 Scalar::Util::weaken( $ALL_TYPES{$uniq} );
404            
405 93687         136710 my $tmp = $self;
406 93687         209508 Scalar::Util::weaken( $tmp );
407 93687     0   356683 $Moo::HandleMoose::TYPE_MAP{ $self->_stringify_no_magic } = sub { $tmp };
  0         0  
408             } #/ unless ( $params{tmp} )
409            
410 93745 100       341735 if ( ref( $params{coercion} ) eq q(CODE) ) {
    100          
411 2         12 require Types::Standard;
412 2         6 my $code = delete( $params{coercion} );
413 2         8 $self->{coercion} = $self->_build_coercion;
414 2         9 $self->coercion->add_type_coercions( Types::Standard::Any(), $code );
415             }
416             elsif ( ref( $params{coercion} ) eq q(ARRAY) ) {
417 5         19 my $arr = delete( $params{coercion} );
418 5         23 $self->{coercion} = $self->_build_coercion;
419 5         26 $self->coercion->add_type_coercions( @$arr );
420             }
421            
422             # Documenting this here because it's too weird to be in the pod.
423             # There's a secret attribute called "_build_coercion" which takes a
424             # coderef. If present, then when $type->coercion is lazy built,
425             # the blank Type::Coercion object gets passed to the coderef,
426             # allowing the coderef to manipulate it a little. This is used by
427             # Types::TypeTiny to allow it to build a coercion for the TypeTiny
428             # type constraint without needing to load Type::Coercion yet.
429            
430 93745 100       215841 if ( $params{my_methods} ) {
431 1013         5752 require Eval::TypeTiny;
432             Scalar::Util::reftype( $params{my_methods}{$_} ) eq 'CODE'
433             and Eval::TypeTiny::set_subname(
434             sprintf( "%s::my_%s", $self->qualified_name, $_ ),
435             $params{my_methods}{$_},
436 1013   66     2071 ) for keys %{ $params{my_methods} };
  1013         9138  
437             } #/ if ( $params{my_methods...})
438            
439             # In general, mutating a type constraint after it's been created
440             # is a bad idea and will probably not work. However some places are
441             # especially harmful and can lead to confusing errors, so allow
442             # subclasses to lock down particular keys.
443             #
444             $self->_lockdown( sub {
445 40359     40359   159391 &Internals::SvREADONLY( $_, !!1 ) for @_;
446 93745         406601 } );
447            
448 93745         591280 return $self;
449             } #/ sub new
450              
451       53386     sub _lockdown {}
452              
453             sub DESTROY {
454 81506     81506   291000 my $self = shift;
455 81506         234504 delete( $ALL_TYPES{ $self->{uniq} } );
456 81506         170227 delete( $Moo::HandleMoose::TYPE_MAP{ $self->_stringify_no_magic } );
457 81506         834690 return;
458             }
459              
460             sub _clone {
461 96     96   211 my $self = shift;
462 96         188 my %opts;
463 96         1016 $opts{$_} = $self->{$_} for qw< name display_name message >;
464 96         482 $self->create_child_type( %opts );
465             }
466              
467             sub _stringify_no_magic {
468 175194     175194   1269596 sprintf(
469             '%s=%s(0x%08x)', blessed( $_[0] ), Scalar::Util::reftype( $_[0] ),
470             Scalar::Util::refaddr( $_[0] )
471             );
472             }
473              
474             our $DD;
475              
476             sub _dd {
477 2517 50   2517   6217 @_ = $_ unless @_;
478 2517         4636 my ( $value ) = @_;
479            
480 2517 100       6531 goto $DD if ref( $DD ) eq q(CODE);
481            
482 2515         10608 require B;
483            
484             !defined $value ? 'Undef'
485             : !ref $value ? sprintf( 'Value %s', B::perlstring( $value ) )
486 2515 100       20172 : do {
    100          
487 1497 50       3452 my $N = 0+ ( defined( $DD ) ? $DD : 72 );
488 1497         68508 require Data::Dumper;
489 1497         619564 local $Data::Dumper::Indent = 0;
490 1497         2328 local $Data::Dumper::Useqq = 1;
491 1497         2314 local $Data::Dumper::Terse = 1;
492 1497         2820 local $Data::Dumper::Sortkeys = 1;
493 1497         2344 local $Data::Dumper::Maxdepth = 2;
494 1497         2296 my $str;
495             eval {
496 1497         4306 $str = Data::Dumper::Dumper( $value );
497 1497 100       82618 $str = substr( $str, 0, $N - 12 ) . '...' . substr( $str, -1, 1 )
498             if length( $str ) >= $N;
499 1497         4223 1;
500 1497 50       2500 } or do { $str = 'which cannot be dumped' };
  0         0  
501 1497         14622 "Reference $str";
502             } #/ do
503             } #/ sub _dd
504              
505             sub _loose_to_TypeTiny {
506 29360     29360   45631 my $caller = caller( 1 ); # assumption
507             map +(
508             ref( $_ )
509             ? Types::TypeTiny::to_TypeTiny( $_ )
510 29360 100       74895 : do { require Type::Utils; Type::Utils::dwim_type( $_, for => $caller ) }
  2         612  
  2         8  
511             ), @_;
512             }
513              
514 93835     93835 1 450112 sub name { $_[0]{name} }
515 46457   66 46457 1 233269 sub display_name { $_[0]{display_name} ||= $_[0]->_build_display_name }
516 148634     148634 1 289814 sub parent { $_[0]{parent} }
517 416286   66 416286 1 1482398 sub constraint { $_[0]{constraint} ||= $_[0]->_build_constraint }
518              
519             sub compiled_check {
520 128716   66 128716 1 496392 $_[0]{compiled_type_constraint} ||= $_[0]->_build_compiled_check;
521             }
522 17107   66 17107 1 63808 sub coercion { $_[0]{coercion} ||= $_[0]->_build_coercion }
523 28     28 1 92 sub message { $_[0]{message} }
524 68     68 1 1058 sub library { $_[0]{library} }
525 46439     46439 1 132576 sub inlined { $_[0]{inlined} }
526 29052     29052 1 112418 sub deprecated { $_[0]{deprecated} }
527 1004     1004 1 7657 sub constraint_generator { $_[0]{constraint_generator} }
528 1060     1060 1 4047 sub inline_generator { $_[0]{inline_generator} }
529 872   66 872 1 4576 sub name_generator { $_[0]{name_generator} ||= $_[0]->_build_name_generator }
530 191     191 1 830 sub coercion_generator { $_[0]{coercion_generator} }
531 914     914 1 5536 sub parameters { $_[0]{parameters} }
532 0   0 0 1 0 sub moose_type { $_[0]{moose_type} ||= $_[0]->_build_moose_type }
533 0   0 0 1 0 sub mouse_type { $_[0]{mouse_type} ||= $_[0]->_build_mouse_type }
534 101     101 1 405 sub deep_explanation { $_[0]{deep_explanation} }
535 1892   66 1892 1 6674 sub my_methods { $_[0]{my_methods} ||= $_[0]->_build_my_methods }
536 25     25 1 55 sub sorter { $_[0]{sorter} }
537 21624   66 21624 1 89630 sub exception_class { $_[0]{exception_class} ||= $_[0]->_build_exception_class }
538              
539 551533     551533 1 1387545 sub has_parent { exists $_[0]{parent} }
540 0     0 1 0 sub has_library { exists $_[0]{library} }
541 135052     135052 1 443731 sub has_inlined { exists $_[0]{inlined} }
542 13661     13661 1 67289 sub has_constraint_generator { exists $_[0]{constraint_generator} }
543 795     795 1 3448 sub has_inline_generator { exists $_[0]{inline_generator} }
544 1758     1758 1 6412 sub has_coercion_generator { exists $_[0]{coercion_generator} }
545 492     492 1 2076 sub has_parameters { exists $_[0]{parameters} }
546 891     891 1 3683 sub has_message { defined $_[0]{message} }
547 101     101 1 462 sub has_deep_explanation { exists $_[0]{deep_explanation} }
548 74     74 1 187 sub has_sorter { exists $_[0]{sorter} }
549              
550             sub _default_message {
551 863   66 863   3280 $_[0]{_default_message} ||= $_[0]->_build_default_message;
552             }
553              
554             sub has_coercion {
555 26958 100   26958 1 66360 $_[0]->coercion if $_[0]{_build_coercion}; # trigger auto build thing
556 26958 100       114491 $_[0]{coercion} and !!@{ $_[0]{coercion}->type_coercion_map };
  16292         34877  
557             }
558              
559             sub _assert_coercion {
560 639     639   1155 my $self = shift;
561 639 100       2160 return $self->coercion if $self->{_build_coercion}; # trigger auto build thing
562             _croak "No coercion for this type constraint"
563             unless $self->has_coercion
564 503 100 66     1065 && @{ $self->coercion->type_coercion_map };
  494         1108  
565 494         1143 $self->coercion;
566             }
567              
568             my $null_constraint = sub { !!1 };
569              
570             sub _build_display_name {
571 11497     11497   23420 shift->name;
572             }
573              
574             sub _build_constraint {
575 4155     4155   24084 return $null_constraint;
576             }
577              
578             sub _is_null_constraint {
579 356912     356912   552046 shift->constraint == $null_constraint;
580             }
581              
582             sub _build_coercion {
583 11216     11216   163909 require Type::Coercion;
584 11216         17454 my $self = shift;
585 11216         22308 my %opts = ( type_constraint => $self );
586 11216 100       20402 $opts{display_name} = "to_$self" unless $self->is_anon;
587 11216         41788 my $coercion = "Type::Coercion"->new( %opts );
588 11216 100       26660 $self->{_build_coercion}->( $coercion ) if ref $self->{_build_coercion};
589 11216         33655 $coercion;
590             }
591              
592             sub _build_default_message {
593 178     178   344 my $self = shift;
594 178         786 $self->{is_using_default_message} = 1;
595 66     66   199 return sub { sprintf '%s did not pass type constraint', _dd( $_[0] ) }
596 178 100       510 if "$self" eq "__ANON__";
597 153         416 my $name = "$self";
598             return sub {
599 794     794   1935 sprintf '%s did not pass type constraint "%s"', _dd( $_[0] ), $name;
600 153         1134 };
601             } #/ sub _build_default_message
602              
603             sub _build_name_generator {
604 210     210   593 my $self = shift;
605             return sub {
606 723   33 723   4811 defined && s/[\x00-\x1F]//smg for ( my ( $s, @a ) = @_ );
607 723 100 100     7427 sprintf( '%s[%s]', $s, join q[,], map !defined() ? 'undef' : !ref() && /\W/ ? B::perlstring($_) : $_, @a );
    50          
608 210         1670 };
609             }
610              
611             sub _build_compiled_check {
612 47157     47157   81218 my $self = shift;
613            
614 47157         77746 local our $AvoidCallbacks = 0;
615            
616 47157 100 100     85762 if ( $self->_is_null_constraint and $self->has_parent ) {
617 3134         7014 return $self->parent->compiled_check;
618             }
619            
620 44023         209925 require Eval::TypeTiny;
621 44023 100       110606 return Eval::TypeTiny::eval_closure(
622             source => sprintf( 'sub ($) { %s }', $self->inline_check( '$_[0]' ) ),
623             description => sprintf( "compiled check '%s'", $self ),
624             ) if $self->can_be_inlined;
625            
626 40258         67238 my @constraints;
627 40258 100       64791 push @constraints, $self->parent->compiled_check if $self->has_parent;
628 40258 50       72529 push @constraints, $self->constraint if !$self->_is_null_constraint;
629 40258 50       101826 return $null_constraint unless @constraints;
630            
631             return sub ($) {
632 3480     3480   83064 local $_ = $_[0];
        576      
        575      
        558      
        572      
633 3480         5169 for my $c ( @constraints ) {
634 5910 100       14823 return unless $c->( @_ );
635             }
636 2312         12267 return !!1;
637 40258         224148 };
638             } #/ sub _build_compiled_check
639              
640             sub _build_exception_class {
641 11153     11153   15829 my $self = shift;
642 11153 100       17679 return $self->parent->exception_class if $self->has_parent;
643 947         103383 require Error::TypeTiny::Assertion;
644 947         4663 return 'Error::TypeTiny::Assertion';
645             }
646              
647             sub definition_context {
648 1     1 1 2 my $self = shift;
649             my $found = $self->find_parent(sub {
650 1 50   1   9 ref $_->{definition_context} and exists $_->{definition_context}{file};
651 1         6 });
652 1 50       4 $found ? $found->{definition_context} : {};
653             }
654              
655             sub find_constraining_type {
656 3769     3769 1 4668 my $self = shift;
657 3769 100 100     5533 if ( $self->_is_null_constraint and $self->has_parent ) {
658 736         1404 return $self->parent->find_constraining_type;
659             }
660 3033         5747 $self;
661             }
662              
663             sub type_default {
664 559     559 1 6367 my ( $self, @args ) = @_;
665 559 100       1938 if ( exists $self->{type_default} ) {
666 417 100       1227 if ( @args ) {
667 1         3 my $td = $self->{type_default};
668 1     1   5 return sub { local $_ = \@args; &$td; };
  1         813  
  1         4  
669             }
670 416         2173 return $self->{type_default};
671             }
672 142 100       482 if ( my $parent = $self->parent ) {
673 140 100       423 return $parent->type_default( @args ) if $self->_is_null_constraint;
674             }
675 59         432 return undef;
676             }
677              
678             our @CMP;
679              
680             sub CMP_SUPERTYPE () { -1 }
681             sub CMP_EQUAL () { 0 }
682             sub CMP_EQUIVALENT () { '0E0' }
683             sub CMP_SUBTYPE () { 1 }
684             sub CMP_UNKNOWN () { ''; }
685              
686             # avoid getting mixed up with cmp operator at compile time
687             *cmp = sub {
688 1477     1477   17401 my ( $A, $B ) = _loose_to_TypeTiny( $_[0], $_[1] );
689 1477 50 33     7002 return unless blessed( $A ) && $A->isa( "Type::Tiny" );
690 1477 50 33     5686 return unless blessed( $B ) && $B->isa( "Type::Tiny" );
691 1477         3510 for my $comparator ( @CMP ) {
692 1884         3951 my $result = $comparator->( $A, $B );
693 1884 100       4462 next if $result eq CMP_UNKNOWN;
694 1152 100       2413 if ( $result eq CMP_EQUIVALENT ) {
695 51 100       178 my $prefer = @_ == 3 ? $_[2] : CMP_EQUAL;
696 51         167 return $prefer;
697             }
698 1101         2486 return $result;
699             }
700 325         657 return CMP_UNKNOWN;
701             };
702              
703             push @CMP, sub {
704             my ( $A, $B ) = @_;
705             return CMP_EQUAL
706             if Scalar::Util::refaddr( $A ) == Scalar::Util::refaddr( $B );
707            
708             return CMP_EQUIVALENT
709             if Scalar::Util::refaddr( $A->compiled_check ) ==
710             Scalar::Util::refaddr( $B->compiled_check );
711            
712             my $A_stem = $A->find_constraining_type;
713             my $B_stem = $B->find_constraining_type;
714             return CMP_EQUIVALENT
715             if Scalar::Util::refaddr( $A_stem ) == Scalar::Util::refaddr( $B_stem );
716             return CMP_EQUIVALENT
717             if Scalar::Util::refaddr( $A_stem->compiled_check ) ==
718             Scalar::Util::refaddr( $B_stem->compiled_check );
719            
720             if ( $A_stem->can_be_inlined and $B_stem->can_be_inlined ) {
721             return CMP_EQUIVALENT
722             if $A_stem->inline_check( '$WOLFIE' ) eq $B_stem->inline_check( '$WOLFIE' );
723             }
724            
725             A_IS_SUBTYPE: {
726             my $A_prime = $A_stem;
727             while ( $A_prime->has_parent ) {
728             $A_prime = $A_prime->parent;
729             return CMP_SUBTYPE
730             if Scalar::Util::refaddr( $A_prime ) == Scalar::Util::refaddr( $B_stem );
731             return CMP_SUBTYPE
732             if Scalar::Util::refaddr( $A_prime->compiled_check ) ==
733             Scalar::Util::refaddr( $B_stem->compiled_check );
734             if ( $A_prime->can_be_inlined and $B_stem->can_be_inlined ) {
735             return CMP_SUBTYPE
736             if $A_prime->inline_check( '$WOLFIE' ) eq $B_stem->inline_check( '$WOLFIE' );
737             }
738             } #/ while ( $A_prime->has_parent)
739             } #/ A_IS_SUBTYPE:
740            
741             B_IS_SUBTYPE: {
742             my $B_prime = $B_stem;
743             while ( $B_prime->has_parent ) {
744             $B_prime = $B_prime->parent;
745             return CMP_SUPERTYPE
746             if Scalar::Util::refaddr( $B_prime ) == Scalar::Util::refaddr( $A_stem );
747             return CMP_SUPERTYPE
748             if Scalar::Util::refaddr( $B_prime->compiled_check ) ==
749             Scalar::Util::refaddr( $A_stem->compiled_check );
750             if ( $A_stem->can_be_inlined and $B_prime->can_be_inlined ) {
751             return CMP_SUPERTYPE
752             if $B_prime->inline_check( '$WOLFIE' ) eq $A_stem->inline_check( '$WOLFIE' );
753             }
754             } #/ while ( $B_prime->has_parent)
755             } #/ B_IS_SUBTYPE:
756            
757             return CMP_UNKNOWN;
758             };
759              
760             sub equals {
761 761     761 1 2003 my $result = Type::Tiny::cmp( $_[0], $_[1] );
762 761 50       1617 return unless defined $result;
763 761         3574 $result eq CMP_EQUAL;
764             }
765              
766             sub is_subtype_of {
767 101     101 1 298 my $result = Type::Tiny::cmp( $_[0], $_[1], CMP_SUBTYPE );
768 101 50       247 return unless defined $result;
769 101         476 $result eq CMP_SUBTYPE;
770             }
771              
772             sub is_supertype_of {
773 19     19 1 487 my $result = Type::Tiny::cmp( $_[0], $_[1], CMP_SUBTYPE );
774 19 50       48 return unless defined $result;
775 19         95 $result eq CMP_SUPERTYPE;
776             }
777              
778             sub is_a_type_of {
779 552     552 1 4704 my $result = Type::Tiny::cmp( $_[0], $_[1] );
780 552 50       1305 return unless defined $result;
781 552 100 100     4703 $result eq CMP_SUBTYPE or $result eq CMP_EQUAL or $result eq CMP_EQUIVALENT;
782             }
783              
784             sub strictly_equals {
785 13040     13040 1 20502 my ( $self, $other ) = _loose_to_TypeTiny( @_ );
786 13040 50 33     40863 return unless blessed( $self ) && $self->isa( "Type::Tiny" );
787 13040 50 33     39340 return unless blessed( $other ) && $other->isa( "Type::Tiny" );
788 13040         50662 $self->{uniq} == $other->{uniq};
789             }
790              
791             sub is_strictly_subtype_of {
792 12500     12500 1 20239 my ( $self, $other ) = _loose_to_TypeTiny( @_ );
793 12500 50 33     39421 return unless blessed( $self ) && $self->isa( "Type::Tiny" );
794 12500 50 33     38428 return unless blessed( $other ) && $other->isa( "Type::Tiny" );
795            
796 12500 100       24551 return unless $self->has_parent;
797 10682 100       18840 $self->parent->strictly_equals( $other )
798             or $self->parent->is_strictly_subtype_of( $other );
799             }
800              
801             sub is_strictly_supertype_of {
802 2     2 1 13 my ( $self, $other ) = _loose_to_TypeTiny( @_ );
803 2 50 33     16 return unless blessed( $self ) && $self->isa( "Type::Tiny" );
804 2 50 33     12 return unless blessed( $other ) && $other->isa( "Type::Tiny" );
805            
806 2         8 $other->is_strictly_subtype_of( $self );
807             }
808              
809             sub is_strictly_a_type_of {
810 2341     2341 1 12057 my ( $self, $other ) = _loose_to_TypeTiny( @_ );
811 2341 50 33     9888 return unless blessed( $self ) && $self->isa( "Type::Tiny" );
812 2341 50 33     8412 return unless blessed( $other ) && $other->isa( "Type::Tiny" );
813            
814 2341 50       6353 $self->strictly_equals( $other ) or $self->is_strictly_subtype_of( $other );
815             }
816              
817             sub qualified_name {
818 12789     12789 1 18188 my $self = shift;
819             ( exists $self->{library} and $self->name ne "__ANON__" )
820             ? "$self->{library}::$self->{name}"
821 12789 100 66     35260 : $self->{name};
822             }
823              
824             sub is_anon {
825 36442     36442 1 48040 my $self = shift;
826 36442         59153 $self->name eq "__ANON__";
827             }
828              
829             sub parents {
830 36257     36257 1 46317 my $self = shift;
831 36257 100       55586 return unless $self->has_parent;
832 30205         52943 return ( $self->parent, $self->parent->parents );
833             }
834              
835             sub find_parent {
836 462     462 1 895 my $self = shift;
837 462         940 my ( $test ) = @_;
838            
839 462         1583 local ( $_, $. );
840 462         733 my $type = $self;
841 462         731 my $count = 0;
842 462         1440 while ( $type ) {
843 570 100       1898 if ( $test->( $_ = $type, $. = $count ) ) {
844 459 100       2421 return wantarray ? ( $type, $count ) : $type;
845             }
846             else {
847 111         217 $type = $type->parent;
848 111         272 $count++;
849             }
850             }
851            
852 3         15 return;
853             } #/ sub find_parent
854              
855             sub check {
856 137288     137288 1 246088 my $self = shift;
857 137288   66     653107 ( $self->{compiled_type_constraint} ||= $self->_build_compiled_check )->( @_ );
858             }
859              
860             sub _strict_check {
861 5330     5330   11370 my $self = shift;
862 5330         10422 local $_ = $_[0];
863            
864             my @constraints =
865             reverse
866 19247         30855 map { $_->constraint }
867 5330         13822 grep { not $_->_is_null_constraint } ( $self, $self->parents );
  31640         52340  
868            
869 5330         12317 for my $c ( @constraints ) {
870 14772 100       45937 return unless $c->( @_ );
871             }
872            
873 1465         9470 return !!1;
874             } #/ sub _strict_check
875              
876             sub get_message {
877 891     891 1 1573 my $self = shift;
878 891         1464 local $_ = $_[0];
879 891 100       2082 $self->has_message
880             ? $self->message->( @_ )
881             : $self->_default_message->( @_ );
882             }
883              
884             sub validate {
885 2     2 1 3 my $self = shift;
886            
887             return undef
888 2 50 33     11 if ( $self->{compiled_type_constraint} ||= $self->_build_compiled_check )
889             ->( @_ );
890            
891 2         22 local $_ = $_[0];
892 2         7 return $self->get_message( @_ );
893             } #/ sub validate
894              
895             sub validate_explain {
896 2130     2130 1 4412 my $self = shift;
897 2130         3507 my ( $value, $varname ) = @_;
898 2130 100       3698 $varname = '$_' unless defined $varname;
899            
900 2130 100       3735 return undef if $self->check( $value );
901            
902 1684 100       7220 if ( $self->has_parent ) {
903 1676         2860 my $parent = $self->parent->validate_explain( $value, $varname );
904             return [
905 1676 100       4637 sprintf( '"%s" is a subtype of "%s"', $self, $self->parent ),
906             @$parent
907             ]
908             if $parent;
909             }
910            
911 454 100       1210 my $message = sprintf(
912             '%s%s',
913             $self->get_message( $value ),
914             $varname eq q{$_} ? '' : sprintf( ' (in %s)', $varname ),
915             );
916            
917 454 100 66     1370 if ( $self->is_parameterized and $self->parent->has_deep_explanation ) {
918 101         323 my $deep = $self->parent->deep_explanation->( $self, $value, $varname );
919 101 50       813 return [ $message, @$deep ] if $deep;
920             }
921              
922 353     0   2468 local $SIG{__WARN__} = sub {};
923             return [
924 353         1064 $message,
925             sprintf( '"%s" is defined as: %s', $self, $self->_perlcode )
926             ];
927             } #/ sub validate_explain
928              
929             my $b;
930              
931             sub _perlcode {
932 353     353   573 my $self = shift;
933            
934 353         642 local our $AvoidCallbacks = 1;
935 353 100       883 return $self->inline_check( '$_' )
936             if $self->can_be_inlined;
937            
938 12   66     77 $b ||= do {
939 7         27 local $@;
940 7         47 require B::Deparse;
941 7         413 my $tmp = "B::Deparse"->new;
942 7 50       558 $tmp->ambient_pragmas( strict => "all", warnings => "all" )
943             if $tmp->can( 'ambient_pragmas' );
944 7         42 $tmp;
945             };
946            
947 12         42 my $code = $b->coderef2text( $self->constraint );
948 12         127 $code =~ s/\s+/ /g;
949 12         81 return "sub $code";
950             } #/ sub _perlcode
951              
952             sub assert_valid {
953 85     85 1 5456 my $self = shift;
954            
955             return !!1
956 85 100 66     497 if ( $self->{compiled_type_constraint} ||= $self->_build_compiled_check )
957             ->( @_ );
958            
959 15         135 local $_ = $_[0];
960 15         64 $self->_failed_check( "$self", $_ );
961             } #/ sub assert_valid
962              
963             sub assert_return {
964 115083     115083 1 174453 my $self = shift;
965            
966             return $_[0]
967 115083 100 66     352157 if ( $self->{compiled_type_constraint} ||= $self->_build_compiled_check )
968             ->( @_ );
969            
970 1         9 local $_ = $_[0];
971 1         4 $self->_failed_check( "$self", $_ );
972             } #/ sub assert_return
973              
974             sub can_be_inlined {
975 175310     175310 1 234824 my $self = shift;
976 175310 100 100     276742 return $self->parent->can_be_inlined
977             if $self->has_parent && $self->_is_null_constraint;
978 149708 100 100     275307 return !!1
979             if !$self->has_parent && $self->_is_null_constraint;
980 137427         251752 return $self->has_inlined;
981             }
982              
983             sub inline_check {
984 63193     63193 1 113616 my $self = shift;
985 63193 50       99174 _croak 'Cannot inline type constraint check for "%s"', $self
986             unless $self->can_be_inlined;
987            
988 63193 100 100     109066 return $self->parent->inline_check( @_ )
989             if $self->has_parent && $self->_is_null_constraint;
990 51736 100 100     93106 return '(!!1)'
991             if !$self->has_parent && $self->_is_null_constraint;
992            
993 47699         81119 local $_ = $_[0];
994 47699         91568 my @r = $self->inlined->( $self, @_ );
995 47699 100 66     170695 if ( @r and not defined $r[0] ) {
996 6988 50       13430 _croak 'Inlining type constraint check for "%s" returned undef!', $self
997             unless $self->has_parent;
998 6988         15135 $r[0] = $self->parent->inline_check( @_ );
999             }
1000             my $r = join " && " => map {
1001 47699 100 100     87690 /[;{}]/ && !/\Ado \{.+\}\z/
  57837         337989  
1002             ? "do { $SafePackage $_ }"
1003             : "($_)"
1004             } @r;
1005 47699 100       962016 return @r == 1 ? $r : "($r)";
1006             } #/ sub inline_check
1007              
1008             sub inline_assert {
1009 11058     11058 1 42537 require B;
1010 11058         17096 my $self = shift;
1011 11058         32853 my ( $varname, $typevarname, %extras ) = @_;
1012            
1013 11058   33     38382 $extras{exception_class} ||= $self->exception_class;
1014            
1015 11058         15837 my $inline_check;
1016 11058 100       19667 if ( $self->can_be_inlined ) {
    100          
1017 10960         24556 $inline_check = sprintf( '(%s)', $self->inline_check( $varname ) );
1018             }
1019             elsif ( $typevarname ) {
1020 97         408 $inline_check = sprintf( '%s->check(%s)', $typevarname, $varname );
1021             }
1022             else {
1023 1         4 _croak 'Cannot inline type constraint check for "%s"', $self;
1024             }
1025            
1026 11057         30194 my $do_wrapper = !delete $extras{no_wrapper};
1027            
1028 11057         15592 my $inline_throw;
1029 11057 100       19064 if ( $typevarname ) {
1030             $inline_throw = sprintf(
1031             'Type::Tiny::_failed_check(%s, %s, %s, %s)',
1032             $typevarname,
1033             B::perlstring( "$self" ),
1034             $varname,
1035             join(
1036 98         360 ',', map +( B::perlstring( $_ ) => B::perlstring( $extras{$_} ) ),
1037             sort keys %extras
1038             ),
1039             );
1040             } #/ if ( $typevarname )
1041             else {
1042             $inline_throw = sprintf(
1043             'Type::Tiny::_failed_check(%s, %s, %s, %s)',
1044             $self->{uniq},
1045             B::perlstring( "$self" ),
1046             $varname,
1047             join(
1048 10959         37818 ',', map +( B::perlstring( $_ ) => B::perlstring( $extras{$_} ) ),
1049             sort keys %extras
1050             ),
1051             );
1052             } #/ else [ if ( $typevarname ) ]
1053            
1054 11057 100       83440 $do_wrapper
1055             ? qq[do { no warnings "void"; $SafePackage $inline_check or $inline_throw; $varname };]
1056             : qq[ no warnings "void"; $SafePackage $inline_check or $inline_throw; $varname ];
1057             } #/ sub inline_assert
1058              
1059             sub _failed_check {
1060 417     417   19741 my ( $self, $name, $value, %attrs ) = @_;
1061 417 100 100     2663 $self = $ALL_TYPES{$self} if defined $self && !ref $self;
1062            
1063             my $exception_class = delete( $attrs{exception_class} )
1064 417   66     2192 || ( ref $self ? $self->exception_class : 'Error::TypeTiny::Assertion' );
1065 417         811 my $callback = delete( $attrs{on_die} );
1066              
1067 417 100       1336 if ( $self ) {
1068 416         1330 return $exception_class->throw_cb(
1069             $callback,
1070             message => $self->get_message( $value ),
1071             type => $self,
1072             value => $value,
1073             %attrs,
1074             );
1075             }
1076             else {
1077 1         5 return $exception_class->throw_cb(
1078             $callback,
1079             message => sprintf( '%s did not pass type constraint "%s"', _dd( $value ), $name ),
1080             value => $value,
1081             %attrs,
1082             );
1083             }
1084             } #/ sub _failed_check
1085              
1086             sub coerce {
1087 567     567 1 66190 my $self = shift;
1088 567         1316 $self->_assert_coercion->coerce( @_ );
1089             }
1090              
1091             sub assert_coerce {
1092 64     64 1 431 my $self = shift;
1093 64         161 $self->_assert_coercion->assert_coerce( @_ );
1094             }
1095              
1096             sub is_parameterizable {
1097 13661     13661 1 30127 shift->has_constraint_generator;
1098             }
1099              
1100             sub is_parameterized {
1101 490     490 1 1642 shift->has_parameters;
1102             }
1103              
1104             {
1105             my %seen;
1106            
1107             sub ____make_key {
1108             #<<<
1109             join ',', map {
1110 1396     1396   2926 Types::TypeTiny::is_TypeTiny( $_ ) ? sprintf( '$Type::Tiny::ALL_TYPES{%s}', defined( $_->{uniq} ) ? $_->{uniq} : '____CANNOT_KEY____' ) :
1111 7 50       105 ref() eq 'ARRAY' ? do { $seen{$_}++ ? '____CANNOT_KEY____' : sprintf( '[%s]', ____make_key( @$_ ) ) } :
1112 18 50       190 ref() eq 'HASH' ? do { $seen{$_}++ ? '____CANNOT_KEY____' : sprintf( '{%s}', ____make_key( do { my %h = %$_; map +( $_, $h{$_} ), sort keys %h; } ) ) } :
  18         52  
  18         189  
1113 3 50       49 ref() eq 'SCALAR' || ref() eq 'REF' ? do { $seen{$_}++ ? '____CANNOT_KEY____' : sprintf( '\\(%s)', ____make_key( $$_ ) ) } :
1114             !defined() ? 'undef' :
1115 3449 50 66     69646 !ref() ? do { require B; B::perlstring( $_ ) } :
  975 100       13951  
  975 100       4921  
    100          
    100          
    100          
    100          
1116             '____CANNOT_KEY____';
1117             } @_;
1118             #>>>
1119             } #/ sub ____make_key
1120             my %param_cache;
1121            
1122             sub parameterize {
1123 1366     1366 1 133700 my $self = shift;
1124            
1125 1366 0       3637 $self->is_parameterizable
    50          
1126             or @_
1127             ? _croak( "Type '%s' does not accept parameters", "$self" )
1128             : return ( $self );
1129            
1130 1366         5847 @_ = map Types::TypeTiny::to_TypeTiny( $_ ), @_;
1131            
1132             # Generate a key for caching parameterized type constraints,
1133             # but only if all the parameters are strings or type constraints.
1134 1366         3356 %seen = ();
1135 1366         3821 my $key = $self->____make_key( @_ );
1136 1366 100       5623 undef( $key ) if $key =~ /____CANNOT_KEY____/;
1137 1366 100 100     7464 return $param_cache{$key} if defined $key && defined $param_cache{$key};
1138            
1139 1004         1956 local $Type::Tiny::parameterize_type = $self;
1140 1004         1783 local $_ = $_[0];
1141 1004         1523 my $P;
1142            
1143 1004         3196 my ( $constraint, $compiled ) = $self->constraint_generator->( @_ );
1144            
1145 963 100       21790 if ( Types::TypeTiny::is_TypeTiny( $constraint ) ) {
1146 168         442 $P = $constraint;
1147             }
1148             else {
1149 795         6037 my %options = (
1150             constraint => $constraint,
1151             display_name => $self->name_generator->( $self, @_ ),
1152             parameters => [@_],
1153             );
1154 795 100       2819 $options{compiled_type_constraint} = $compiled
1155             if $compiled;
1156 795 100       2253 $options{inlined} = $self->inline_generator->( @_ )
1157             if $self->has_inline_generator;
1158             $options{type_default} = $self->{type_default_generator}->( @_ )
1159 795 100       3900 if exists $self->{type_default_generator}; # undocumented
1160             exists $options{$_} && !defined $options{$_} && delete $options{$_}
1161 795   66     9831 for keys %options;
      66        
1162            
1163 795         3343 $P = $self->create_child_type( %options );
1164            
1165 795 100       2757 if ( $self->has_coercion_generator ) {
1166 388         1211 my @args = @_;
1167             $P->{_build_coercion} = sub {
1168 191     191   448 my $coercion = shift;
1169 191         732 my $built = $self->coercion_generator->( $self, $P, @args );
1170 191 100       606 $coercion->add_type_coercions( @{ $built->type_coercion_map } ) if $built;
  111         290  
1171 191         663 $coercion->freeze;
1172 388         2741 };
1173             }
1174             } #/ else [ if ( Types::TypeTiny::is_TypeTiny...)]
1175            
1176 963 100       3060 if ( defined $key ) {
1177 930         2672 $param_cache{$key} = $P;
1178 930         2445 Scalar::Util::weaken( $param_cache{$key} );
1179             }
1180            
1181 963 100       2190 $P->coercion->freeze unless $self->has_coercion_generator;
1182            
1183 963         4324 return $P;
1184             } #/ sub parameterize
1185             }
1186              
1187             sub child_type_class {
1188 1307     1307 1 5718 __PACKAGE__;
1189             }
1190              
1191             sub create_child_type {
1192 1307     1307 1 6984 my $self = shift;
1193 1307         2025 my %moreopts;
1194 1307 100       4076 $moreopts{is_object} = 1 if $self->{is_object};
1195 1307         3496 return $self->child_type_class->new( parent => $self, %moreopts, @_ );
1196             }
1197              
1198             sub complementary_type {
1199 76     76 1 164 my $self = shift;
1200 76   66     359 my $r = ( $self->{complementary_type} ||= $self->_build_complementary_type );
1201             Scalar::Util::weaken( $self->{complementary_type} )
1202 76 100       467 unless Scalar::Util::isweak( $self->{complementary_type} );
1203 76         1246 return $r;
1204             }
1205              
1206             sub _build_complementary_type {
1207 64     64   104 my $self = shift;
1208             my %opts = (
1209 108     108   228 constraint => sub { not $self->check( $_ ) },
1210 64         403 display_name => sprintf( "~%s", $self ),
1211             );
1212 64         196 $opts{display_name} =~ s/^\~{2}//;
1213 296     296   395 $opts{inlined} = sub { shift; "not(" . $self->inline_check( @_ ) . ")" }
  296         610  
1214 64 100       154 if $self->can_be_inlined;
1215             $opts{display_name} = $opts{name} = $self->{complement_name}
1216 64 100       192 if $self->{complement_name};
1217 64         301 return "Type::Tiny"->new( %opts );
1218             } #/ sub _build_complementary_type
1219              
1220             sub _instantiate_moose_type {
1221 0     0   0 my $self = shift;
1222 0         0 my %opts = @_;
1223 0         0 require Moose::Meta::TypeConstraint;
1224 0         0 return "Moose::Meta::TypeConstraint"->new( %opts );
1225             }
1226              
1227             sub _build_moose_type {
1228 0     0   0 my $self = shift;
1229            
1230 0         0 my $r;
1231 0 0       0 if ( $self->{_is_core} ) {
1232 0         0 require Moose::Util::TypeConstraints;
1233 0         0 $r = Moose::Util::TypeConstraints::find_type_constraint( $self->name );
1234 0         0 $r->{"Types::TypeTiny::to_TypeTiny"} = $self;
1235 0         0 Scalar::Util::weaken( $r->{"Types::TypeTiny::to_TypeTiny"} );
1236             }
1237             else {
1238             # Type::Tiny is more flexible than Moose, allowing
1239             # inlined to return a list. So we need to wrap the
1240             # inlined coderef to make sure Moose gets a single
1241             # string.
1242             #
1243             my $wrapped_inlined = sub {
1244 0     0   0 shift;
1245 0         0 $self->inline_check( @_ );
1246 0         0 };
1247            
1248 0         0 my %opts;
1249 0 0 0     0 $opts{name} = $self->qualified_name if $self->has_library && !$self->is_anon;
1250 0 0       0 $opts{parent} = $self->parent->moose_type if $self->has_parent;
1251 0 0       0 $opts{constraint} = $self->constraint unless $self->_is_null_constraint;
1252 0 0       0 $opts{message} = $self->message if $self->has_message;
1253 0 0       0 $opts{inlined} = $wrapped_inlined if $self->has_inlined;
1254            
1255 0         0 $r = $self->_instantiate_moose_type( %opts );
1256 0         0 $r->{"Types::TypeTiny::to_TypeTiny"} = $self;
1257 0         0 $self->{moose_type} = $r; # prevent recursion
1258 0 0       0 $r->coercion( $self->coercion->moose_coercion ) if $self->has_coercion;
1259             } #/ else [ if ( $self->{_is_core})]
1260            
1261 0         0 return $r;
1262             } #/ sub _build_moose_type
1263              
1264             sub _build_mouse_type {
1265 0     0   0 my $self = shift;
1266            
1267 0         0 my %options;
1268 0 0 0     0 $options{name} = $self->qualified_name if $self->has_library && !$self->is_anon;
1269 0 0       0 $options{parent} = $self->parent->mouse_type if $self->has_parent;
1270 0 0       0 $options{constraint} = $self->constraint unless $self->_is_null_constraint;
1271 0 0       0 $options{message} = $self->message if $self->has_message;
1272            
1273 0         0 require Mouse::Meta::TypeConstraint;
1274 0         0 my $r = "Mouse::Meta::TypeConstraint"->new( %options );
1275            
1276 0         0 $self->{mouse_type} = $r; # prevent recursion
1277 0 0       0 $r->_add_type_coercions(
1278             $self->coercion->freeze->_codelike_type_coercion_map( 'mouse_type' ) )
1279             if $self->has_coercion;
1280            
1281 0         0 return $r;
1282             } #/ sub _build_mouse_type
1283              
1284             sub exportables {
1285 12735     12735 1 29386 my ( $self, $base_name, $tag ) = ( shift, @_ ); # $tag is undocumented
1286 12735 100       21613 if ( not $self->is_anon ) {
1287 12734   66     33261 $base_name ||= $self->name;
1288             }
1289 12735   100     50565 $tag ||= 0;
1290              
1291 12735         18072 my @exportables;
1292 12735 50       23202 return \@exportables if ! $base_name;
1293              
1294 12735         65369 require Eval::TypeTiny;
1295              
1296 12735 100 66     63831 push @exportables, {
1297             name => $base_name,
1298             code => Eval::TypeTiny::type_to_coderef( $self ),
1299             tags => [ 'types' ],
1300             } if $tag eq 'types' || !$tag;
1301              
1302 12735 100 100     96762 push @exportables, {
1303             name => sprintf( 'is_%s', $base_name ),
1304             code => $self->compiled_check,
1305             tags => [ 'is' ],
1306             } if $tag eq 'is' || !$tag;
1307              
1308 12735 100 66     75565 push @exportables, {
1309             name => sprintf( 'assert_%s', $base_name ),
1310             code => $self->_overload_coderef,
1311             tags => [ 'assert' ],
1312             } if $tag eq 'assert' || !$tag;
1313              
1314             push @exportables, {
1315             name => sprintf( 'to_%s', $base_name ),
1316             code => $self->has_coercion && $self->coercion->frozen
1317             ? $self->coercion->compiled_coercion
1318 9     9   4947 : sub ($) { $self->coerce( $_[0] ) },
        9      
        18      
        18      
        27      
        27      
        22      
        18      
        18      
        18      
        22      
        18      
        22      
        22      
        23      
        18      
        18      
        27      
        27      
        18      
        18      
        23      
        32      
        32      
        23      
        23      
        28      
        28      
        28      
        28      
        33      
        37      
        38      
        33      
        32      
        32      
        23      
        649      
1319 12735 100 100     96605 tags => [ 'to' ],
    100 100        
1320             } if $tag eq 'to' || !$tag;
1321              
1322 12735         51741 return \@exportables;
1323             }
1324              
1325             sub exportables_by_tag {
1326 575     584 1 2101 my ( $self, $tag, $base_name ) = ( shift, @_ );
1327             my @matched = grep {
1328 575         1361 my $e = $_;
1329 575 50       1065 grep $_ eq $tag, @{ $e->{tags} || [] };
  575         4946  
1330 575         1171 } @{ $self->exportables( $base_name, $tag ) };
  575         1736  
1331 575 100       3145 return @matched if wantarray;
1332 1 50       3 _croak( 'Expected to find one exportable tagged "%s", found %d', $tag, scalar @matched )
1333             unless @matched == 1;
1334 1         3 return $matched[0];
1335             }
1336              
1337             sub _process_coercion_list {
1338 92     97   224 my $self = shift;
1339            
1340 92         165 my @pairs;
1341 92         297 while ( @_ ) {
1342 96         180 my $next = shift;
1343 96 100 66     661 if ( blessed( $next )
    100 100        
    50 66        
1344             and $next->isa( 'Type::Coercion' )
1345             and $next->is_parameterized )
1346             {
1347 7         12 push @pairs => ( @{ $next->_reparameterize( $self )->type_coercion_map } );
  7         24  
1348             }
1349             elsif ( blessed( $next ) and $next->can( 'type_coercion_map' ) ) {
1350             push @pairs => (
1351 9         16 @{ $next->type_coercion_map },
  9         25  
1352             );
1353             }
1354             elsif ( ref( $next ) eq q(ARRAY) ) {
1355 0         0 unshift @_, @$next;
1356             }
1357             else {
1358 80         348 push @pairs => (
1359             Types::TypeTiny::to_TypeTiny( $next ),
1360             shift,
1361             );
1362             }
1363             } #/ while ( @_ )
1364            
1365 92         318 return @pairs;
1366             } #/ sub _process_coercion_list
1367              
1368             sub plus_coercions {
1369 89     89 1 39126 my $self = shift;
1370 89         355 my $new = $self->_clone;
1371             $new->coercion->add_type_coercions(
1372             $self->_process_coercion_list( @_ ),
1373 89         350 @{ $self->coercion->type_coercion_map },
  89         315  
1374             );
1375 89         317 $new->coercion->freeze;
1376 89         663 return $new;
1377             } #/ sub plus_coercions
1378              
1379             sub plus_fallback_coercions {
1380 2     2 1 606 my $self = shift;
1381            
1382 2         7 my $new = $self->_clone;
1383             $new->coercion->add_type_coercions(
1384 2         6 @{ $self->coercion->type_coercion_map },
  2         6  
1385             $self->_process_coercion_list( @_ ),
1386             );
1387 2         10 $new->coercion->freeze;
1388 2         6 return $new;
1389             } #/ sub plus_fallback_coercions
1390              
1391             sub minus_coercions {
1392 1     1 1 605 my $self = shift;
1393            
1394 1         5 my $new = $self->_clone;
1395 1         5 my @not = grep Types::TypeTiny::is_TypeTiny( $_ ),
1396             $self->_process_coercion_list( $new, @_ );
1397            
1398 1         7 my @keep;
1399 1         4 my $c = $self->coercion->type_coercion_map;
1400 1         7 for ( my $i = 0 ; $i <= $#$c ; $i += 2 ) {
1401 4         6 my $keep_this = 1;
1402 4         7 NOT: for my $n ( @not ) {
1403 11 100       27 if ( $c->[$i] == $n ) {
1404 2         3 $keep_this = 0;
1405 2         8 last NOT;
1406             }
1407             }
1408            
1409 4 100       18 push @keep, $c->[$i], $c->[ $i + 1 ] if $keep_this;
1410             } #/ for ( my $i = 0 ; $i <=...)
1411            
1412 1         4 $new->coercion->add_type_coercions( @keep );
1413 1         4 $new->coercion->freeze;
1414 1         3 return $new;
1415             } #/ sub minus_coercions
1416              
1417             sub no_coercions {
1418 4     4 1 1126 my $new = shift->_clone;
1419 4         14 $new->coercion->freeze;
1420 4         15 $new;
1421             }
1422              
1423             sub coercibles {
1424 7     7 1 380 my $self = shift;
1425 7 100       21 $self->has_coercion ? $self->coercion->_source_type_union : $self;
1426             }
1427              
1428             sub isa {
1429 273697     273697 1 761985 my $self = shift;
1430            
1431 273697 0 33     544961 if ( $INC{"Moose.pm"}
      33        
1432             and ref( $self )
1433             and $_[0] =~ /^(?:Class::MOP|MooseX?::Meta)::(.+)$/ )
1434             {
1435 0         0 my $meta = $1;
1436            
1437 0 0       0 return !!1 if $meta eq 'TypeConstraint';
1438 0 0       0 return $self->is_parameterized if $meta eq 'TypeConstraint::Parameterized';
1439 0 0       0 return $self->is_parameterizable if $meta eq 'TypeConstraint::Parameterizable';
1440 0 0       0 return $self->isa( 'Type::Tiny::Union' ) if $meta eq 'TypeConstraint::Union';
1441            
1442 0         0 my $inflate = $self->moose_type;
1443 0         0 return $inflate->isa( @_ );
1444             } #/ if ( $INC{"Moose.pm"} ...)
1445            
1446 273697 0 33     518744 if ( $INC{"Mouse.pm"}
      33        
1447             and ref( $self )
1448             and $_[0] eq 'Mouse::Meta::TypeConstraint' )
1449             {
1450 0         0 return !!1;
1451             }
1452            
1453 273697         1201237 $self->SUPER::isa( @_ );
1454             } #/ sub isa
1455              
1456             sub _build_my_methods {
1457 141     141   731 return {};
1458             }
1459              
1460             sub _lookup_my_method {
1461 1278     1278   1794 my $self = shift;
1462 1278         2822 my ( $name ) = @_;
1463            
1464 1278 100       2354 if ( $self->my_methods->{$name} ) {
1465 614         1160 return $self->my_methods->{$name};
1466             }
1467            
1468 664 100       1380 if ( $self->has_parent ) {
1469 662         1370 return $self->parent->_lookup_my_method( @_ );
1470             }
1471            
1472 2         8 return;
1473             } #/ sub _lookup_my_method
1474              
1475             my %object_methods = (
1476             with_attribute_values => 1, stringifies_to => 1,
1477             numifies_to => 1
1478             );
1479              
1480             sub can {
1481 79920     79920 1 163625 my $self = shift;
1482            
1483 79920 50 66     191391 return !!0
      33        
1484             if $_[0] eq 'type_parameter'
1485             && blessed( $_[0] )
1486             && $_[0]->has_parameters;
1487            
1488 79920         251765 my $can = $self->SUPER::can( @_ );
1489 79920 100       632514 return $can if $can;
1490            
1491 42157 100       98758 if ( ref( $self ) ) {
1492 42156 50       85133 if ( $INC{"Moose.pm"} ) {
1493 0         0 my $method = $self->moose_type->can( @_ );
1494 0     0   0 return sub { shift->moose_type->$method( @_ ) }
1495 0 0       0 if $method;
1496             }
1497 42156 100       98406 if ( $_[0] =~ /\Amy_(.+)\z/ ) {
1498 4         9 my $method = $self->_lookup_my_method( $1 );
1499 4 100       13 return $method if $method;
1500             }
1501 42154 100 100     125118 if ( $self->{is_object} && $object_methods{ $_[0] } ) {
1502 1         949 require Type::Tiny::ConstrainedObject;
1503 1         14 return Type::Tiny::ConstrainedObject->can( $_[0] );
1504             }
1505 42153         89310 for my $util ( qw/ grep map sort rsort first any all assert_any assert_all / ) {
1506 379233 100       638143 if ( $_[0] eq $util ) {
1507 36   66     142 $self->{'_util'}{$util} ||= eval { $self->_build_util( $util ) };
  36         84  
1508 36 100       151 return unless $self->{'_util'}{$util};
1509 34     0   170 return sub { my $s = shift; $s->{'_util'}{$util}( @_ ) };
  0         0  
  0         0  
1510             }
1511             }
1512             } #/ if ( ref( $self ) )
1513            
1514 42118         261263 return;
1515             } #/ sub can
1516              
1517             sub AUTOLOAD {
1518 686     686   15581 my $self = shift;
1519 686         4135 my ( $m ) = ( our $AUTOLOAD =~ /::(\w+)$/ );
1520 686 50       1963 return if $m eq 'DESTROY';
1521            
1522 686 50       1653 if ( ref( $self ) ) {
1523 686 50       1660 if ( $INC{"Moose.pm"} ) {
1524 0         0 my $method = $self->moose_type->can( $m );
1525 0 0       0 return $self->moose_type->$method( @_ ) if $method;
1526             }
1527 686 100       2285 if ( $m =~ /\Amy_(.+)\z/ ) {
1528 612         1467 my $method = $self->_lookup_my_method( $1 );
1529 612 50       2563 return &$method( $self, @_ ) if $method;
1530             }
1531 74 50 66     223 if ( $self->{is_object} && $object_methods{$m} ) {
1532 3         1099 require Type::Tiny::ConstrainedObject;
1533 3         17 unshift @_, $self;
1534 279     279   3297 no strict 'refs';
  279         831  
  279         399904  
1535 3         7 goto \&{"Type::Tiny::ConstrainedObject::$m"};
  3         28  
1536             }
1537 71         154 for my $util ( qw/ grep map sort rsort first any all assert_any assert_all / ) {
1538 385 100       695 if ( $m eq $util ) {
1539 70   66     951 return ( $self->{'_util'}{$util} ||= $self->_build_util( $util ) )->( @_ );
1540             }
1541             }
1542             } #/ if ( ref( $self ) )
1543            
1544 1   33     5 _croak q[Can't locate object method "%s" via package "%s"], $m,
1545             ref( $self ) || $self;
1546             } #/ sub AUTOLOAD
1547              
1548             sub DOES {
1549 45     45 1 118 my $self = shift;
1550            
1551 45 50 33     202 return !!1
1552             if ref( $self )
1553             && $_[0] =~ m{^ Type::API::Constraint (?: ::Coercible | ::Inlinable )? $}x;
1554 45 50 33     117 return !!1 if !ref( $self ) && $_[0] eq 'Type::API::Constraint::Constructor';
1555            
1556 45 50       365 "UNIVERSAL"->can( "DOES" ) ? $self->SUPER::DOES( @_ ) : $self->isa( @_ );
1557             } #/ sub DOES
1558              
1559             sub _has_xsub {
1560 1     1   577 require B;
1561 1         4 !!B::svref_2object( shift->compiled_check )->XSUB;
1562             }
1563              
1564             sub _build_util {
1565 82     82   187 my ( $self, $func ) = @_;
1566 82         257 Scalar::Util::weaken( my $type = $self );
1567            
1568 82 100 100     726 if ( $func eq 'grep'
      100        
      100        
      100        
      100        
1569             || $func eq 'first'
1570             || $func eq 'any'
1571             || $func eq 'all'
1572             || $func eq 'assert_any'
1573             || $func eq 'assert_all' )
1574             {
1575 43         75 my ( $inline, $compiled );
1576            
1577 43 100       100 if ( $self->can_be_inlined ) {
1578 13         37 $inline = $self->inline_check( '$_' );
1579             }
1580             else {
1581 30         65 $compiled = $self->compiled_check;
1582 30         55 $inline = '$compiled->($_)';
1583             }
1584            
1585 43 100       187 if ( $func eq 'grep' ) {
    100          
    100          
    100          
    100          
    50          
1586 5         618 return eval "sub { grep { $inline } \@_ }";
1587             }
1588             elsif ( $func eq 'first' ) {
1589 5         567 return eval "sub { for (\@_) { return \$_ if ($inline) }; undef; }";
1590             }
1591             elsif ( $func eq 'any' ) {
1592 8         888 return eval "sub { for (\@_) { return !!1 if ($inline) }; !!0; }";
1593             }
1594             elsif ( $func eq 'assert_any' ) {
1595 8         20 my $qname = B::perlstring( $self->name );
1596             return
1597             eval
1598 8         1119 "sub { for (\@_) { return \@_ if ($inline) }; Type::Tiny::_failed_check(\$type, $qname, \@_ ? \$_[-1] : undef); }";
1599             }
1600             elsif ( $func eq 'all' ) {
1601 9         1037 return eval "sub { for (\@_) { return !!0 unless ($inline) }; !!1; }";
1602             }
1603             elsif ( $func eq 'assert_all' ) {
1604 8         21 my $qname = B::perlstring( $self->name );
1605             return
1606             eval
1607 8         1136 "sub { my \$idx = 0; for (\@_) { Type::Tiny::_failed_check(\$type, $qname, \$_, varname => sprintf('\$_[%d]', \$idx)) unless ($inline); ++\$idx }; \@_; }";
1608             }
1609             } #/ if ( $func eq 'grep' ||...)
1610            
1611 39 100       94 if ( $func eq 'map' ) {
1612 8         16 my ( $inline, $compiled );
1613 8         23 my $c = $self->_assert_coercion;
1614            
1615 4 100       14 if ( $c->can_be_inlined ) {
1616 1         5 $inline = $c->inline_coercion( '$_' );
1617             }
1618             else {
1619 3         10 $compiled = $c->compiled_coercion;
1620 3         7 $inline = '$compiled->($_)';
1621             }
1622            
1623 4         430 return eval "sub { map { $inline } \@_ }";
1624             } #/ if ( $func eq 'map' )
1625            
1626 31 100 100     190 if ( $func eq 'sort' || $func eq 'rsort' ) {
1627 29         48 my ( $inline, $compiled );
1628            
1629 29     76   148 my $ptype = $self->find_parent( sub { $_->has_sorter } );
  76         181  
1630 29 100       118 _croak "No sorter for this type constraint" unless $ptype;
1631            
1632 27         88 my $sorter = $ptype->sorter;
1633            
1634             # Schwarzian transformation
1635 27 100       87 if ( ref( $sorter ) eq 'ARRAY' ) {
1636 6         12 my $sort_key;
1637 6         19 ( $sorter, $sort_key ) = @$sorter;
1638            
1639 6 100       23 if ( $func eq 'sort' ) {
    50          
1640             return
1641             eval
1642 4         654 "our (\$a, \$b); sub { map \$_->[0], sort { \$sorter->(\$a->[1],\$b->[1]) } map [\$_,\$sort_key->(\$_)], \@_ }";
1643             }
1644             elsif ( $func eq 'rsort' ) {
1645             return
1646             eval
1647 2         291 "our (\$a, \$b); sub { map \$_->[0], sort { \$sorter->(\$b->[1],\$a->[1]) } map [\$_,\$sort_key->(\$_)], \@_ }";
1648             }
1649             } #/ if ( ref( $sorter ) eq...)
1650            
1651             # Simple sort
1652             else {
1653 21 100       57 if ( $func eq 'sort' ) {
    50          
1654 12         1352 return eval "our (\$a, \$b); sub { sort { \$sorter->(\$a,\$b) } \@_ }";
1655             }
1656             elsif ( $func eq 'rsort' ) {
1657 9         953 return eval "our (\$a, \$b); sub { sort { \$sorter->(\$b,\$a) } \@_ }";
1658             }
1659             }
1660             } #/ if ( $func eq 'sort' ||...)
1661            
1662 2         20 die "Unknown function: $func";
1663             } #/ sub _build_util
1664              
1665 287     287 1 7909 sub of { shift->parameterize( @_ ) }
1666 138     138 1 61114 sub where { shift->create_child_type( constraint => @_ ) }
1667              
1668             # fill out Moose-compatible API
1669 1     1 1 103 sub inline_environment { +{} }
1670 1     1   10 sub _inline_check { shift->inline_check( @_ ) }
1671 2     2   562 sub _compiled_type_constraint { shift->compiled_check( @_ ) }
1672 1     1 1 15 sub meta { _croak( "Not really a Moose::Meta::TypeConstraint. Sorry!" ) }
1673 2     2 1 16 sub compile_type_constraint { shift->compiled_check }
1674 2     2   31 sub _actually_compile_type_constraint { shift->_build_compiled_check }
1675 1     1 1 388 sub hand_optimized_type_constraint { shift->{hand_optimized_type_constraint} }
1676              
1677             sub has_hand_optimized_type_constraint {
1678 1     1 1 12 exists( shift->{hand_optimized_type_constraint} );
1679             }
1680 207   50 207 1 1656 sub type_parameter { ( shift->parameters || [] )->[0] }
1681              
1682             sub parameterized_from {
1683 5 50   5 1 20 $_[0]->is_parameterized ? shift->parent : _croak( "Not a parameterized type" );
1684             }
1685 2     2 1 15 sub has_parameterized_from { $_[0]->is_parameterized }
1686              
1687             # some stuff for Mouse-compatible API
1688 2     2   16 sub __is_parameterized { shift->is_parameterized( @_ ) }
1689 1     1   12 sub _add_type_coercions { shift->coercion->add_type_coercions( @_ ) }
1690 1     1   690 sub _as_string { shift->qualified_name( @_ ) }
1691 1     1   5 sub _compiled_type_coercion { shift->coercion->compiled_coercion( @_ ) }
1692 2     2   576 sub _identity { Scalar::Util::refaddr( shift ) }
1693              
1694             sub _unite {
1695 1     1   455 require Type::Tiny::Union;
1696 1         7 "Type::Tiny::Union"->new( type_constraints => \@_ );
1697             }
1698              
1699             # Hooks for Type::Tie
1700             sub TIESCALAR {
1701 1     1   1685 require Type::Tie;
1702 1         6 unshift @_, 'Type::Tie::SCALAR';
1703 1         5 goto \&Type::Tie::SCALAR::TIESCALAR;
1704             }
1705              
1706             sub TIEARRAY {
1707 1     1   2563 require Type::Tie;
1708 1         4 unshift @_, 'Type::Tie::ARRAY';
1709 1         6 goto \&Type::Tie::ARRAY::TIEARRAY;
1710             }
1711              
1712             sub TIEHASH {
1713 1     1   2273 require Type::Tie;
1714 1         4 unshift @_, 'Type::Tie::HASH';
1715 1         4 goto \&Type::Tie::HASH::TIEHASH;
1716             }
1717              
1718             1;
1719              
1720             __END__