File Coverage

blib/lib/Type/Tiny.pm
Criterion Covered Total %
statement 755 763 99.2
branch 395 462 85.5
condition 220 300 73.3
subroutine 227 231 98.2
pod 85 85 100.0
total 1682 1841 91.4


line stmt bran cond sub pod time code
1             package Type::Tiny;
2              
3 316     316   321326 use 5.008001;
  316         1269  
4 316     316   1848 use strict;
  316         696  
  316         8341  
5 316     316   1675 use warnings;
  316         808  
  316         16588  
6              
7             BEGIN {
8 316 50   316   14345 if ( $] < 5.010 ) { require Devel::TypeTiny::Perl58Compat }
  0         0  
9             }
10              
11             BEGIN {
12 316     316   1123 $Type::Tiny::AUTHORITY = 'cpan:TOBYINK';
13 316         684 $Type::Tiny::VERSION = '2.003_000';
14 316         35047 $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 316     316   2565 use Scalar::Util qw( blessed );
  316         758  
  316         16298  
80 316     316   83364 use Types::TypeTiny ();
  316         1614  
  316         133178  
81              
82             our $SafePackage = sprintf 'package %s;', __PACKAGE__;
83              
84 16     16   94 sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak }
  16         80  
85              
86 40159 50   40159   132488 sub _swap { $_[2] ? @_[ 1, 0 ] : @_[ 0, 1 ] }
87              
88             BEGIN {
89 316     316   1760 my $support_smartmatch = 0+ !!( $] >= 5.010001 );
90 316         20771 eval qq{ sub SUPPORT_SMARTMATCH () { !! $support_smartmatch } };
91            
92 316         1694 my $fixed_precedence = 0+ !!( $] >= 5.014 );
93 316         11730 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 316 50       2918 : 1;
    50          
99            
100 316         662 my $use_xs = 0;
101 316 50       1146 $try_xs and eval {
102 316         2039 require Type::Tiny::XS;
103 316         3591 'Type::Tiny::XS'->VERSION( $Type::Tiny::XS_VERSION );
104 316         1202 $use_xs++;
105             };
106            
107             *_USE_XS =
108             $use_xs
109             ? sub () { !!1 }
110 316 50       1412 : sub () { !!0 };
111            
112             *_USE_MOUSE =
113             $try_xs
114 290 100   290   2913 ? sub () { $INC{'Mouse/Util.pm'} and Mouse::Util::MOUSE_XS() }
115 316 50       1638 : sub () { !!0 };
116            
117 316         728 my $strict_mode = 0;
118 316   100     3342 $ENV{$_} && ++$strict_mode for qw(
119             EXTENDED_TESTING
120             AUTHOR_TESTING
121             RELEASE_TESTING
122             PERL_STRICT
123             );
124 316 100       10985 *_STRICT_MODE = $strict_mode ? sub () { !!1 } : sub () { !!0 };
125             } #/ BEGIN
126              
127             {
128              
129             sub _install_overloads {
130 316     316   2084 no strict 'refs';
  316         805  
  316         11372  
131 316     316   3601 no warnings 'redefine', 'once';
  316         2488  
  316         3661222  
132            
133             # Coverage is checked on Perl 5.26
134 2183 50   2183   8024 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 2183         4296 my $class = shift;
141 2183     0   6047 *{ $class . '::((' } = sub { };
  2183         12417  
142 2183     0   6364 *{ $class . '::()' } = sub { };
  2183         9016  
143 2183         3637 *{ $class . '::()' } = do { my $x = 1; \$x };
  2183         5164  
  2183         3263  
  2183         3687  
144 2183         6031 while ( @_ ) {
145 7818         12219 my $f = shift;
146 7818 100       14839 *{ $class . '::(' . $f } = ref $_[0] ? shift : do {
  7818         35794  
147 620         1413 my $m = shift;
148 839     839   86508 sub { shift->$m( @_ ) }
149 620         2431 };
150             }
151             } #/ sub _install_overloads
152             }
153              
154             __PACKAGE__->_install_overloads(
155             q("") => sub {
156 49864 100   49864   319012 caller =~ m{^(Moo::HandleMoose|Sub::Quote)}
157             ? $_[0]->_stringify_no_magic
158             : $_[0]->display_name;
159             },
160 46784     46784   200399 q(bool) => sub { 1 },
161             q(&{}) => "_overload_coderef",
162             q(|) => sub {
163 70     70   5060 my @tc = _swap @_;
164 70         108 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 70         11066 require Type::Tiny::Union;
184 70         390 return "Type::Tiny::Union"->new_by_overload( type_constraints => \@tc );
185             },
186             q(&) => sub {
187 40059     40059   1832913 my @tc = _swap @_;
188 40059         61014 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         216357 require Type::Tiny::Intersection;
208 40059         144529 "Type::Tiny::Intersection"->new_by_overload( type_constraints => \@tc );
209             },
210 69     69   1407 q(~) => sub { shift->complementary_type },
211 702     702   7075 q(==) => sub { $_[0]->equals( $_[1] ) },
212 1     1   7 q(!=) => sub { not $_[0]->equals( $_[1] ) },
213 8     8   68 q(<) => sub { my $m = $_[0]->can( 'is_subtype_of' ); $m->( _swap @_ ) },
  8         45  
214             q(>) => sub {
215 10     10   113 my $m = $_[0]->can( 'is_subtype_of' );
216 10         27 $m->( reverse _swap @_ );
217             },
218 6     6   57 q(<=) => sub { my $m = $_[0]->can( 'is_a_type_of' ); $m->( _swap @_ ) },
  6         16  
219             q(>=) => sub {
220 6     6   64 my $m = $_[0]->can( 'is_a_type_of' );
221 6         15 $m->( reverse _swap @_ );
222             },
223 28     28   10785 q(eq) => sub { "$_[0]" eq "$_[1]" },
224 1 50   1   54 q(cmp) => sub { $_[2] ? ( "$_[1]" cmp "$_[0]" ) : ( "$_[0]" cmp "$_[1]" ) },
225 1     1   46 q(0+) => sub { $_[0]{uniq} },
226 4 100 50 4   2626 q(/) => sub { ( _STRICT_MODE xor $_[2] ) ? $_[0] : $_[1] },
227             );
228              
229             __PACKAGE__->_install_overloads(
230 3     3   475 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 14387     14387   32322 my $self = shift;
238            
239             # Bypass generating a coderef if we've already got the best possible one.
240             #
241 14387 100       43924 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 14368 100       43671 unless exists $self->{_overrides_assert_return};
250            
251 14368 100       44722 if ( $self->{_overrides_assert_return} ) {
    100          
252 1   33     8 $self->{_overload_coderef} ||= do {
253 1         5 Scalar::Util::weaken( my $weak = $self );
254 1     2   6 sub { $weak->assert_return( @_ ) };
  2         7  
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 245 100       568 $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 245         20538 ++$self->{_overload_coderef_no_rebuild};
271             } #/ elsif ( exists( &Sub::Quote::quote_sub...))
272             else {
273 14122         74415 require Eval::TypeTiny;
274 14122 100 66     50177 $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 14368         91848 $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 95438     95438 1 175616 my $class = shift;
300 95438 50       316602 my %params = ( @_ == 1 ) ? %{ $_[0] } : @_;
  0         0  
301            
302 95438         219001 for ( qw/ name display_name library / ) {
303 286314 100       603648 $params{$_} = $params{$_} . '' if defined $params{$_};
304             }
305            
306 95438         152546 my $level = 0;
307 95438   66     329376 while ( not exists $params{definition_context} and $level < 20 ) {
308 232692   66     406692 our $_TT_GUTS ||= do {
309 305         16203 my $g = join '|', map quotemeta, grep !m{^Types::}, @InternalPackages;
310 305         155576 qr/\A(?:$g)\z/o
311             };
312 232692         404130 my $package = caller $level;
313 232692 100       1127630 if ( $package !~ $_TT_GUTS ) {
314 95438         506905 @{ $params{definition_context} = {} }{ qw/ package file line / } = caller $level;
  95438         391950  
315             }
316 232692         719828 ++$level;
317             }
318            
319 95438 100       196542 if ( exists $params{parent} ) {
320             $params{parent} =
321             ref( $params{parent} ) =~ /^Type::Tiny\b/
322             ? $params{parent}
323 12565 50       50410 : Types::TypeTiny::to_TypeTiny( $params{parent} );
324            
325             _croak "Parent must be an instance of %s", __PACKAGE__
326             unless blessed( $params{parent} )
327 12565 50 33     61746 && $params{parent}->isa( __PACKAGE__ );
328            
329 12565 100 100     36557 if ( $params{parent}->deprecated and not exists $params{deprecated} ) {
330 3         19 $params{deprecated} = 1;
331             }
332             } #/ if ( exists $params{parent...})
333            
334 95438 100 66     367943 if ( exists $params{constraint}
      100        
335             and defined $params{constraint}
336             and not ref $params{constraint} )
337             {
338 79         414 require Eval::TypeTiny;
339 79         179 my $code = $params{constraint};
340 79         468 $params{constraint} = Eval::TypeTiny::eval_closure(
341             source => sprintf( 'sub ($) { %s }', $code ),
342             description => "anonymous check",
343             );
344             $params{inlined} ||= sub {
345 269     269   554 my ( $type ) = @_;
346 269 100       1064 my $inlined = $_ eq '$_' ? "do { $code }" : "do { local \$_ = $_; $code }";
347 269 100       521 $type->has_parent ? ( undef, $inlined ) : $inlined;
348             }
349 79 50 50     518 if ( !exists $params{parent} or $params{parent}->can_be_inlined );
      66        
350             } #/ if ( exists $params{constraint...})
351            
352             # canonicalize to a boolean
353 95438         187374 $params{deprecated} = !!$params{deprecated};
354            
355 95438 100       226142 $params{name} = "__ANON__" unless exists $params{name};
356 95438         159771 $params{uniq} = $uniq++;
357            
358 95438 100       220348 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 13053 100 66     66501 or _croak '"%s" is not a valid type name', $params{name};
  1         26  
  1         4  
  1         672  
  1         44  
  1         16  
364             }
365            
366 95437 100 100     212314 if ( exists $params{coercion} and !ref $params{coercion} and $params{coercion} )
      100        
367             {
368             $params{parent}->has_coercion
369 6 50       30 or _croak
370             "coercion => 1 requires type to have a direct parent with a coercion";
371            
372 6         44 $params{coercion} = $params{parent}->coercion->type_coercion_map;
373             }
374            
375 95437 100 100     537359 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 10 100       20 my ( undef, $perlstring, $captures ) = @{ $QFS->( $params{constraint} ) || [] };
  10         36  
381            
382             $params{inlined} = sub {
383 28     28   50 my ( $self, $var ) = @_;
384 28 50       124 my $code = Sub::Quote::inlinify(
385             $perlstring,
386             $var,
387             $var eq q($_) ? '' : "local \$_ = $var;",
388             1,
389             );
390 28 100       577 $code = sprintf( '%s and %s', $self->parent->inline_check( $var ), $code )
391             if $self->has_parent;
392 28         63 return $code;
393             }
394 10 100 100     410 if $perlstring && !$captures;
395             } #/ if ( !exists $params{inlined...})
396            
397 95437         204150 my $self = bless \%params, $class;
398            
399 95437 100       198321 unless ( $params{tmp} ) {
400 95373         205924 my $uniq = $self->{uniq};
401            
402 95373         337516 $ALL_TYPES{$uniq} = $self;
403 95373         279652 Scalar::Util::weaken( $ALL_TYPES{$uniq} );
404            
405 95373         142541 my $tmp = $self;
406 95373         236571 Scalar::Util::weaken( $tmp );
407 95373     3   379712 $Moo::HandleMoose::TYPE_MAP{ $self->_stringify_no_magic } = sub { $tmp };
  3         18  
408             } #/ unless ( $params{tmp} )
409            
410 95437 100       327416 if ( ref( $params{coercion} ) eq q(CODE) ) {
    100          
411 3         18 require Types::Standard;
412 3         12 my $code = delete( $params{coercion} );
413 3         11 $self->{coercion} = $self->_build_coercion;
414 3         24 $self->coercion->add_type_coercions( Types::Standard::Any(), $code );
415             }
416             elsif ( ref( $params{coercion} ) eq q(ARRAY) ) {
417 9         31 my $arr = delete( $params{coercion} );
418 9         37 $self->{coercion} = $self->_build_coercion;
419 9         36 $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 95437 100       209089 if ( $params{my_methods} ) {
431 1129         6525 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 1129   66     2320 ) for keys %{ $params{my_methods} };
  1129         12109  
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 40422     40422   157659 &Internals::SvREADONLY( $_, !!1 ) for @_;
446 95437         400487 } );
447            
448 95437         610712 return $self;
449             } #/ sub new
450              
451       55015     sub _lockdown {}
452              
453             sub DESTROY {
454 81631     81631   315664 my $self = shift;
455 81631         228933 delete( $ALL_TYPES{ $self->{uniq} } );
456 81631         167653 delete( $Moo::HandleMoose::TYPE_MAP{ $self->_stringify_no_magic } );
457 81631         837530 return;
458             }
459              
460             sub _clone {
461 106     106   222 my $self = shift;
462 106         186 my %opts;
463 106         1077 $opts{$_} = $self->{$_} for qw< name display_name message >;
464 106         520 $self->create_child_type( %opts );
465             }
466              
467             sub _stringify_no_magic {
468 177008     177008   1336558 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 4562 50   4562   11812 @_ = $_ unless @_;
478 4562         9050 my ( $value ) = @_;
479            
480 4562 100       11334 goto $DD if ref( $DD ) eq q(CODE);
481            
482 4560         21173 require B;
483            
484             !defined $value ? 'Undef'
485             : !ref $value ? sprintf( 'Value %s', B::perlstring( $value ) )
486 4560 100       35075 : do {
    100          
487 2523 50       6035 my $N = 0+ ( defined( $DD ) ? $DD : 72 );
488 2523         88838 require Data::Dumper;
489 2523         781368 local $Data::Dumper::Indent = 0;
490 2523         3936 local $Data::Dumper::Useqq = 1;
491 2523         3925 local $Data::Dumper::Terse = 1;
492 2523         3895 local $Data::Dumper::Sortkeys = 1;
493 2523         3915 local $Data::Dumper::Maxdepth = 2;
494 2523         3454 my $str;
495             eval {
496 2523         7448 $str = Data::Dumper::Dumper( $value );
497 2523 100       136807 $str = substr( $str, 0, $N - 12 ) . '...' . substr( $str, -1, 1 )
498             if length( $str ) >= $N;
499 2523         6629 1;
500 2523 50       4090 } or do { $str = 'which cannot be dumped' };
  0         0  
501 2523         22389 "Reference $str";
502             } #/ do
503             } #/ sub _dd
504              
505             sub _loose_to_TypeTiny {
506 29794     29794   47043 my $caller = caller( 1 ); # assumption
507             map +(
508             ref( $_ )
509             ? Types::TypeTiny::to_TypeTiny( $_ )
510 29794 100       77646 : do { require Type::Utils; Type::Utils::dwim_type( $_, for => $caller ) }
  64         2216  
  64         349  
511             ), @_;
512             }
513              
514 104788     104788 1 503329 sub name { $_[0]{name} }
515 51356   66 51356 1 262641 sub display_name { $_[0]{display_name} ||= $_[0]->_build_display_name }
516 155477     155477 1 312895 sub parent { $_[0]{parent} }
517 434147   66 434147 1 1575019 sub constraint { $_[0]{constraint} ||= $_[0]->_build_constraint }
518              
519             sub compiled_check {
520 133796   66 133796 1 524555 $_[0]{compiled_type_constraint} ||= $_[0]->_build_compiled_check;
521             }
522 18775   66 18775 1 74948 sub coercion { $_[0]{coercion} ||= $_[0]->_build_coercion }
523 62     62 1 270 sub message { $_[0]{message} }
524 68     68 1 1067 sub library { $_[0]{library} }
525 49398     49398 1 141868 sub inlined { $_[0]{inlined} }
526 32221     32221 1 127327 sub deprecated { $_[0]{deprecated} }
527 1106     1106 1 8614 sub constraint_generator { $_[0]{constraint_generator} }
528 1137     1137 1 4495 sub inline_generator { $_[0]{inline_generator} }
529 949   66 949 1 5302 sub name_generator { $_[0]{name_generator} ||= $_[0]->_build_name_generator }
530 251     251 1 1384 sub coercion_generator { $_[0]{coercion_generator} }
531 1088     1088 1 6717 sub parameters { $_[0]{parameters} }
532 589   66 589 1 6146 sub moose_type { $_[0]{moose_type} ||= $_[0]->_build_moose_type }
533 4   66 4 1 43 sub mouse_type { $_[0]{mouse_type} ||= $_[0]->_build_mouse_type }
534 101     101 1 394 sub deep_explanation { $_[0]{deep_explanation} }
535 1892   66 1892 1 6902 sub my_methods { $_[0]{my_methods} ||= $_[0]->_build_my_methods }
536 25     25 1 58 sub sorter { $_[0]{sorter} }
537 24076   66 24076 1 100707 sub exception_class { $_[0]{exception_class} ||= $_[0]->_build_exception_class }
538              
539 581668     581668 1 1465069 sub has_parent { exists $_[0]{parent} }
540 110     110 1 647 sub has_library { exists $_[0]{library} }
541 142682     142682 1 468772 sub has_inlined { exists $_[0]{inlined} }
542 15231     15231 1 75525 sub has_constraint_generator { exists $_[0]{constraint_generator} }
543 872     872 1 5529 sub has_inline_generator { exists $_[0]{inline_generator} }
544 1937     1937 1 7501 sub has_coercion_generator { exists $_[0]{coercion_generator} }
545 550     550 1 2296 sub has_parameters { exists $_[0]{parameters} }
546 2151     2151 1 10161 sub has_message { defined $_[0]{message} }
547 103     103 1 413 sub has_deep_explanation { exists $_[0]{deep_explanation} }
548 74     74 1 179 sub has_sorter { exists $_[0]{sorter} }
549              
550             sub _default_message {
551 1992   66 1992   8914 $_[0]{_default_message} ||= $_[0]->_build_default_message;
552             }
553              
554             sub has_coercion {
555 30129 100   30129 1 103130 $_[0]->coercion if $_[0]{_build_coercion}; # trigger auto build thing
556 30129 100       131090 $_[0]{coercion} and !!@{ $_[0]{coercion}->type_coercion_map };
  18133         39172  
557             }
558              
559             sub _assert_coercion {
560 697     697   1229 my $self = shift;
561 697 100       2296 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 552 100 66     1074 && @{ $self->coercion->type_coercion_map };
  543         1260  
565 543         1271 $self->coercion;
566             }
567              
568             my $null_constraint = sub { !!1 };
569              
570             sub _build_display_name {
571 12832     12832   25948 shift->name;
572             }
573              
574             sub _build_constraint {
575 4651     4651   26853 return $null_constraint;
576             }
577              
578             sub _is_null_constraint {
579 373873     373873   586828 shift->constraint == $null_constraint;
580             }
581              
582             sub _build_coercion {
583 12409     12409   188166 require Type::Coercion;
584 12409         19578 my $self = shift;
585 12409         25028 my %opts = ( type_constraint => $self );
586 12409 100       22947 $opts{display_name} = "to_$self" unless $self->is_anon;
587 12409         47850 my $coercion = "Type::Coercion"->new( %opts );
588 12409 100       30088 $self->{_build_coercion}->( $coercion ) if ref $self->{_build_coercion};
589 12409         37777 $coercion;
590             }
591              
592             sub _build_default_message {
593 308     308   638 my $self = shift;
594 308         964 $self->{is_using_default_message} = 1;
595 66     66   245 return sub { sprintf '%s did not pass type constraint', _dd( $_[0] ) }
596 308 100       939 if "$self" eq "__ANON__";
597 278         782 my $name = "$self";
598             return sub {
599 2554     2554   277551 sprintf '%s did not pass type constraint "%s"', _dd( $_[0] ), $name;
600 278         2321 };
601             } #/ sub _build_default_message
602              
603             sub _build_name_generator {
604 227     227   555 my $self = shift;
605             return sub {
606 799   33 799   5571 defined && s/[\x00-\x1F]//smg for ( my ( $s, @a ) = @_ );
607 799 100 100     8387 sprintf( '%s[%s]', $s, join q[,], map !defined() ? 'undef' : !ref() && /\W/ ? B::perlstring($_) : $_, @a );
    50          
608 227         1859 };
609             }
610              
611             sub _build_compiled_check {
612 48003     48003   82352 my $self = shift;
613            
614 48003         75826 local our $AvoidCallbacks = 0;
615            
616 48003 100 100     104169 if ( $self->_is_null_constraint and $self->has_parent ) {
617 3515         7933 return $self->parent->compiled_check;
618             }
619            
620 44488         238023 require Eval::TypeTiny;
621 44488 100       116609 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 40387         62906 my @constraints;
627 40387 100       76925 push @constraints, $self->parent->compiled_check if $self->has_parent;
628 40387 50       70930 push @constraints, $self->constraint if !$self->_is_null_constraint;
629 40387 50       96293 return $null_constraint unless @constraints;
630            
631             return sub ($) {
632 5512     5512   80407 local $_ = $_[0];
        1173      
        1172      
        1143      
        1157      
        24      
633 5512         8908 for my $c ( @constraints ) {
634 8780 100       25398 return unless $c->( @_ );
635             }
636 3005         19694 return !!1;
637 40387         232064 };
638             } #/ sub _build_compiled_check
639              
640             sub _build_exception_class {
641 12477     12477   17543 my $self = shift;
642 12477 100       20067 return $self->parent->exception_class if $self->has_parent;
643 1114         119708 require Error::TypeTiny::Assertion;
644 1114         5503 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   7 ref $_->{definition_context} and exists $_->{definition_context}{file};
651 1         5 });
652 1 50       5 $found ? $found->{definition_context} : {};
653             }
654              
655             sub find_constraining_type {
656 4185     4185 1 5160 my $self = shift;
657 4185 100 100     6230 if ( $self->_is_null_constraint and $self->has_parent ) {
658 764         1593 return $self->parent->find_constraining_type;
659             }
660 3421         6428 $self;
661             }
662              
663             sub type_default {
664 635     635 1 6157 my ( $self, @args ) = @_;
665 635 100       2297 if ( exists $self->{type_default} ) {
666 491 100       1506 if ( @args ) {
667 1         2 my $td = $self->{type_default};
668 1     1   6 return sub { local $_ = \@args; &$td; };
  1         673  
  1         3  
669             }
670 490         2533 return $self->{type_default};
671             }
672 144 100       470 if ( my $parent = $self->parent ) {
673 142 100       406 return $parent->type_default( @args ) if $self->_is_null_constraint;
674             }
675 59         424 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 1614     1614   17723 my ( $A, $B ) = _loose_to_TypeTiny( $_[0], $_[1] );
689 1614 50 33     8290 return unless blessed( $A ) && $A->isa( "Type::Tiny" );
690 1614 50 33     6808 return unless blessed( $B ) && $B->isa( "Type::Tiny" );
691 1614         4047 for my $comparator ( @CMP ) {
692 2103         4878 my $result = $comparator->( $A, $B );
693 2103 100       5226 next if $result eq CMP_UNKNOWN;
694 1246 100       2775 if ( $result eq CMP_EQUIVALENT ) {
695 53 100       186 my $prefer = @_ == 3 ? $_[2] : CMP_EQUAL;
696 53         178 return $prefer;
697             }
698 1193         2885 return $result;
699             }
700 368         817 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 764     764 1 2155 my $result = Type::Tiny::cmp( $_[0], $_[1] );
762 764 50       1701 return unless defined $result;
763 764         4034 $result eq CMP_EQUAL;
764             }
765              
766             sub is_subtype_of {
767 101     101 1 356 my $result = Type::Tiny::cmp( $_[0], $_[1], CMP_SUBTYPE );
768 101 50       236 return unless defined $result;
769 101         517 $result eq CMP_SUBTYPE;
770             }
771              
772             sub is_supertype_of {
773 19     19 1 426 my $result = Type::Tiny::cmp( $_[0], $_[1], CMP_SUBTYPE );
774 19 50       66 return unless defined $result;
775 19         97 $result eq CMP_SUPERTYPE;
776             }
777              
778             sub is_a_type_of {
779 686     686 1 5537 my $result = Type::Tiny::cmp( $_[0], $_[1] );
780 686 50       1702 return unless defined $result;
781 686 100 100     7623 $result eq CMP_SUBTYPE or $result eq CMP_EQUAL or $result eq CMP_EQUIVALENT;
782             }
783              
784             sub strictly_equals {
785 13175     13175 1 21329 my ( $self, $other ) = _loose_to_TypeTiny( @_ );
786 13175 50 33     44364 return unless blessed( $self ) && $self->isa( "Type::Tiny" );
787 13175 50 33     42298 return unless blessed( $other ) && $other->isa( "Type::Tiny" );
788 13175         52860 $self->{uniq} == $other->{uniq};
789             }
790              
791             sub is_strictly_subtype_of {
792 12635     12635 1 21147 my ( $self, $other ) = _loose_to_TypeTiny( @_ );
793 12635 50 33     42898 return unless blessed( $self ) && $self->isa( "Type::Tiny" );
794 12635 50 33     40703 return unless blessed( $other ) && $other->isa( "Type::Tiny" );
795            
796 12635 100       25903 return unless $self->has_parent;
797 10790 100       19211 $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 17 my ( $self, $other ) = _loose_to_TypeTiny( @_ );
803 2 50 33     18 return unless blessed( $self ) && $self->isa( "Type::Tiny" );
804 2 50 33     23 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 2368     2368 1 12107 my ( $self, $other ) = _loose_to_TypeTiny( @_ );
811 2368 50 33     10843 return unless blessed( $self ) && $self->isa( "Type::Tiny" );
812 2368 50 33     9150 return unless blessed( $other ) && $other->isa( "Type::Tiny" );
813            
814 2368 50       6435 $self->strictly_equals( $other ) or $self->is_strictly_subtype_of( $other );
815             }
816              
817             sub qualified_name {
818 14326     14326 1 20604 my $self = shift;
819             ( exists $self->{library} and $self->name ne "__ANON__" )
820             ? "$self->{library}::$self->{name}"
821 14326 100 66     40325 : $self->{name};
822             }
823              
824             sub is_anon {
825 40650     40650 1 53376 my $self = shift;
826 40650         65456 $self->name eq "__ANON__";
827             }
828              
829             sub parents {
830 37375     37375 1 48113 my $self = shift;
831 37375 100       56812 return unless $self->has_parent;
832 31076         54214 return ( $self->parent, $self->parent->parents );
833             }
834              
835             sub find_parent {
836 462     462 1 890 my $self = shift;
837 462         887 my ( $test ) = @_;
838            
839 462         1561 local ( $_, $. );
840 462         698 my $type = $self;
841 462         733 my $count = 0;
842 462         1387 while ( $type ) {
843 570 100       1987 if ( $test->( $_ = $type, $. = $count ) ) {
844 459 100       2506 return wantarray ? ( $type, $count ) : $type;
845             }
846             else {
847 111         215 $type = $type->parent;
848 111         270 $count++;
849             }
850             }
851            
852 3         12 return;
853             } #/ sub find_parent
854              
855             sub check {
856 143154     143154 1 1866699 my $self = shift;
857 143154   66     698701 ( $self->{compiled_type_constraint} ||= $self->_build_compiled_check )->( @_ );
858             }
859              
860             sub _strict_check {
861 5546     5546   12180 my $self = shift;
862 5546         10962 local $_ = $_[0];
863            
864             my @constraints =
865             reverse
866 19903         32055 map { $_->constraint }
867 5546         14383 grep { not $_->_is_null_constraint } ( $self, $self->parents );
  32598         54664  
868            
869 5546         12770 for my $c ( @constraints ) {
870 15411 100       47912 return unless $c->( @_ );
871             }
872            
873 1592         14553 return !!1;
874             } #/ sub _strict_check
875              
876             sub get_message {
877 1817     1817 1 194915 my $self = shift;
878 1817         3671 local $_ = $_[0];
879 1817 100       4559 $self->has_message
880             ? $self->message->( @_ )
881             : $self->_default_message->( @_ );
882             }
883              
884             sub validate {
885 3     3 1 6 my $self = shift;
886            
887             return undef
888 3 50 33     16 if ( $self->{compiled_type_constraint} ||= $self->_build_compiled_check )
889             ->( @_ );
890            
891 3         40 local $_ = $_[0];
892 3         11 return $self->get_message( @_ );
893             } #/ sub validate
894              
895             sub validate_explain {
896 2138     2138 1 4506 my $self = shift;
897 2138         3523 my ( $value, $varname ) = @_;
898 2138 100       3790 $varname = '$_' unless defined $varname;
899            
900 2138 100       3655 return undef if $self->check( $value );
901            
902 1688 100       5565 if ( $self->has_parent ) {
903 1680         2884 my $parent = $self->parent->validate_explain( $value, $varname );
904             return [
905 1680 100       4570 sprintf( '"%s" is a subtype of "%s"', $self, $self->parent ),
906             @$parent
907             ]
908             if $parent;
909             }
910            
911 458 100       1101 my $message = sprintf(
912             '%s%s',
913             $self->get_message( $value ),
914             $varname eq q{$_} ? '' : sprintf( ' (in %s)', $varname ),
915             );
916            
917 458 100 100     1404 if ( $self->is_parameterized and $self->parent->has_deep_explanation ) {
918 101         287 my $deep = $self->parent->deep_explanation->( $self, $value, $varname );
919 101 50       804 return [ $message, @$deep ] if $deep;
920             }
921              
922 357     0   2525 local $SIG{__WARN__} = sub {};
923             return [
924 357         1063 $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 357     357   564 my $self = shift;
933            
934 357         600 local our $AvoidCallbacks = 1;
935 357 100       896 return $self->inline_check( '$_' )
936             if $self->can_be_inlined;
937            
938 12   66     58 $b ||= do {
939 7         25 local $@;
940 7         43 require B::Deparse;
941 7         439 my $tmp = "B::Deparse"->new;
942 7 50       531 $tmp->ambient_pragmas( strict => "all", warnings => "all" )
943             if $tmp->can( 'ambient_pragmas' );
944 7         36 $tmp;
945             };
946            
947 12         43 my $code = $b->coderef2text( $self->constraint );
948 12         131 $code =~ s/\s+/ /g;
949 12         82 return "sub $code";
950             } #/ sub _perlcode
951              
952             sub assert_valid {
953 85     85 1 6948 my $self = shift;
954            
955             return !!1
956 85 100 66     458 if ( $self->{compiled_type_constraint} ||= $self->_build_compiled_check )
957             ->( @_ );
958            
959 15         147 local $_ = $_[0];
960 15         54 $self->_failed_check( "$self", $_ );
961             } #/ sub assert_valid
962              
963             sub assert_return {
964 115094     115094 1 176009 my $self = shift;
965            
966             return $_[0]
967 115094 100 66     371698 if ( $self->{compiled_type_constraint} ||= $self->_build_compiled_check )
968             ->( @_ );
969            
970 1         8 local $_ = $_[0];
971 1         10 $self->_failed_check( "$self", $_ );
972             } #/ sub assert_return
973              
974             sub can_be_inlined {
975 186235     186235 1 306831 my $self = shift;
976 186235 100 100     304836 return $self->parent->can_be_inlined
977             if $self->has_parent && $self->_is_null_constraint;
978 158605 100 100     297060 return !!1
979             if !$self->has_parent && $self->_is_null_constraint;
980 145226         277778 return $self->has_inlined;
981             }
982              
983             sub inline_check {
984 67234     67234 1 119348 my $self = shift;
985 67234 50       105652 _croak 'Cannot inline type constraint check for "%s"', $self
986             unless $self->can_be_inlined;
987            
988 67234 100 100     117383 return $self->parent->inline_check( @_ )
989             if $self->has_parent && $self->_is_null_constraint;
990 55124 100 100     99993 return '(!!1)'
991             if !$self->has_parent && $self->_is_null_constraint;
992            
993 50779         87002 local $_ = $_[0];
994 50779         98545 my @r = $self->inlined->( $self, @_ );
995 50779 100 66     279672 if ( @r and not defined $r[0] ) {
996 7046 50       13723 _croak 'Inlining type constraint check for "%s" returned undef!', $self
997             unless $self->has_parent;
998 7046         15009 $r[0] = $self->parent->inline_check( @_ );
999             }
1000             my $r = join " && " => map {
1001 50779 100 100     93219 /[;{}]/ && !/\Ado \{.+\}\z/
  60975         358099  
1002             ? "do { $SafePackage $_ }"
1003             : "($_)"
1004             } @r;
1005 50779 100       1001555 return @r == 1 ? $r : "($r)";
1006             } #/ sub inline_check
1007              
1008             sub inline_assert {
1009 12353     12353 1 46842 require B;
1010 12353         19810 my $self = shift;
1011 12353         36449 my ( $varname, $typevarname, %extras ) = @_;
1012            
1013 12353   33     43651 $extras{exception_class} ||= $self->exception_class;
1014            
1015 12353         18366 my $inline_check;
1016 12353 100       21977 if ( $self->can_be_inlined ) {
    100          
1017 12202         29970 $inline_check = sprintf( '(%s)', $self->inline_check( $varname ) );
1018             }
1019             elsif ( $typevarname ) {
1020 150         513 $inline_check = sprintf( '%s->check(%s)', $typevarname, $varname );
1021             }
1022             else {
1023 1         3 _croak 'Cannot inline type constraint check for "%s"', $self;
1024             }
1025            
1026 12352         34186 my $do_wrapper = !delete $extras{no_wrapper};
1027            
1028 12352         17438 my $inline_throw;
1029 12352 100       21345 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 151         502 ',', 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 12201         42174 ',', map +( B::perlstring( $_ ) => B::perlstring( $extras{$_} ) ),
1049             sort keys %extras
1050             ),
1051             );
1052             } #/ else [ if ( $typevarname ) ]
1053            
1054 12352 100       94495 $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 421     421   19901 my ( $self, $name, $value, %attrs ) = @_;
1061 421 100 100     2587 $self = $ALL_TYPES{$self} if defined $self && !ref $self;
1062            
1063             my $exception_class = delete( $attrs{exception_class} )
1064 421   66     2068 || ( ref $self ? $self->exception_class : 'Error::TypeTiny::Assertion' );
1065 421         833 my $callback = delete( $attrs{on_die} );
1066              
1067 421 100       1658 if ( $self ) {
1068 420         3192 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 625     625 1 68420 my $self = shift;
1088 625         1515 $self->_assert_coercion->coerce( @_ );
1089             }
1090              
1091             sub assert_coerce {
1092 64     64 1 395 my $self = shift;
1093 64         153 $self->_assert_coercion->assert_coerce( @_ );
1094             }
1095              
1096             sub is_parameterizable {
1097 15231     15231 1 33723 shift->has_constraint_generator;
1098             }
1099              
1100             sub is_parameterized {
1101 548     548 1 1836 shift->has_parameters;
1102             }
1103              
1104             {
1105             my %seen;
1106            
1107             sub ____make_key {
1108             #<<<
1109             join ',', map {
1110 1515     1515   3338 Types::TypeTiny::is_TypeTiny( $_ ) ? sprintf( '$Type::Tiny::ALL_TYPES{%s}', defined( $_->{uniq} ) ? $_->{uniq} : '____CANNOT_KEY____' ) :
1111 7 50       120 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         55  
  18         90  
1113 3 50       70 ref() eq 'SCALAR' || ref() eq 'REF' ? do { $seen{$_}++ ? '____CANNOT_KEY____' : sprintf( '\\(%s)', ____make_key( $$_ ) ) } :
1114             !defined() ? 'undef' :
1115 3695 50 66     76010 !ref() ? do { require B; B::perlstring( $_ ) } :
  988 100       12659  
  988 100       5098  
    100          
    100          
    100          
    100          
1116             '____CANNOT_KEY____';
1117             } @_;
1118             #>>>
1119             } #/ sub ____make_key
1120             my %param_cache;
1121            
1122             sub parameterize {
1123 1485     1485 1 212690 my $self = shift;
1124            
1125 1485 0       4550 $self->is_parameterizable
    50          
1126             or @_
1127             ? _croak( "Type '%s' does not accept parameters", "$self" )
1128             : return ( $self );
1129            
1130 1485         7028 @_ = 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 1485         3694 %seen = ();
1135 1485         5772 my $key = $self->____make_key( @_ );
1136 1485 100       6462 undef( $key ) if $key =~ /____CANNOT_KEY____/;
1137 1485 100 100     8471 return $param_cache{$key} if defined $key && defined $param_cache{$key};
1138            
1139 1106         2198 local $Type::Tiny::parameterize_type = $self;
1140 1106         2097 local $_ = $_[0];
1141 1106         1944 my $P;
1142            
1143 1106         3592 my ( $constraint, $compiled ) = $self->constraint_generator->( @_ );
1144            
1145 1065 100       24659 if ( Types::TypeTiny::is_TypeTiny( $constraint ) ) {
1146 193         564 $P = $constraint;
1147             }
1148             else {
1149 872         7409 my %options = (
1150             constraint => $constraint,
1151             display_name => $self->name_generator->( $self, @_ ),
1152             parameters => [@_],
1153             );
1154 872 100       3211 $options{compiled_type_constraint} = $compiled
1155             if $compiled;
1156 872 100       2648 $options{inlined} = $self->inline_generator->( @_ )
1157             if $self->has_inline_generator;
1158             $options{type_default} = $self->{type_default_generator}->( @_ )
1159 872 100       4980 if exists $self->{type_default_generator}; # undocumented
1160             exists $options{$_} && !defined $options{$_} && delete $options{$_}
1161 872   66     11433 for keys %options;
      66        
1162            
1163 872         3941 $P = $self->create_child_type( %options );
1164            
1165 872 100       3390 if ( $self->has_coercion_generator ) {
1166 463         1694 my @args = @_;
1167             $P->{_build_coercion} = sub {
1168 251     251   571 my $coercion = shift;
1169 251         927 my $built = $self->coercion_generator->( $self, $P, @args );
1170 251 100       952 $coercion->add_type_coercions( @{ $built->type_coercion_map } ) if $built;
  117         319  
1171 251         1023 $coercion->freeze;
1172 463         3337 };
1173             }
1174             } #/ else [ if ( Types::TypeTiny::is_TypeTiny...)]
1175            
1176 1065 100       3605 if ( defined $key ) {
1177 1030         3077 $param_cache{$key} = $P;
1178 1030         2960 Scalar::Util::weaken( $param_cache{$key} );
1179             }
1180            
1181 1065 100       2572 $P->coercion->freeze unless $self->has_coercion_generator;
1182            
1183 1065         5168 return $P;
1184             } #/ sub parameterize
1185             }
1186              
1187             sub child_type_class {
1188 1526     1526 1 7191 __PACKAGE__;
1189             }
1190              
1191             sub create_child_type {
1192 1526     1526 1 8147 my $self = shift;
1193 1526         2421 my %moreopts;
1194 1526 100       4812 $moreopts{is_object} = 1 if $self->{is_object};
1195 1526         3959 return $self->child_type_class->new( parent => $self, %moreopts, @_ );
1196             }
1197              
1198             sub complementary_type {
1199 90     90 1 207 my $self = shift;
1200 90   66     405 my $r = ( $self->{complementary_type} ||= $self->_build_complementary_type );
1201             Scalar::Util::weaken( $self->{complementary_type} )
1202 90 100       403 unless Scalar::Util::isweak( $self->{complementary_type} );
1203 90         1312 return $r;
1204             }
1205              
1206             sub _build_complementary_type {
1207 78     78   118 my $self = shift;
1208             my %opts = (
1209 116     116   255 constraint => sub { not $self->check( $_ ) },
1210 78         458 display_name => sprintf( "~%s", $self ),
1211             );
1212 78         583 $opts{display_name} =~ s/^\~{2}//;
1213 339     339   452 $opts{inlined} = sub { shift; "not(" . $self->inline_check( @_ ) . ")" }
  339         739  
1214 78 100       184 if $self->can_be_inlined;
1215             $opts{display_name} = $opts{name} = $self->{complement_name}
1216 78 100       220 if $self->{complement_name};
1217 78         340 return "Type::Tiny"->new( %opts );
1218             } #/ sub _build_complementary_type
1219              
1220             sub _instantiate_moose_type {
1221 102     102   215 my $self = shift;
1222 102         364 my %opts = @_;
1223 102         641 require Moose::Meta::TypeConstraint;
1224 102         911 return "Moose::Meta::TypeConstraint"->new( %opts );
1225             }
1226              
1227             sub _build_moose_type {
1228 208     208   416 my $self = shift;
1229            
1230 208         342 my $r;
1231 208 100       654 if ( $self->{_is_core} ) {
1232 101         542 require Moose::Util::TypeConstraints;
1233 101         321 $r = Moose::Util::TypeConstraints::find_type_constraint( $self->name );
1234 101         12480 $r->{"Types::TypeTiny::to_TypeTiny"} = $self;
1235 101         365 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 74     74   44382 shift;
1245 74         306 $self->inline_check( @_ );
1246 107         518 };
1247            
1248 107         244 my %opts;
1249 107 100 66     319 $opts{name} = $self->qualified_name if $self->has_library && !$self->is_anon;
1250 107 100       406 $opts{parent} = $self->parent->moose_type if $self->has_parent;
1251 107 100       1193 $opts{constraint} = $self->constraint unless $self->_is_null_constraint;
1252 107 100       357 $opts{message} = $self->message if $self->has_message;
1253 107 100       398 $opts{inlined} = $wrapped_inlined if $self->has_inlined;
1254            
1255 107         487 $r = $self->_instantiate_moose_type( %opts );
1256 107         74861 $r->{"Types::TypeTiny::to_TypeTiny"} = $self;
1257 107         352 $self->{moose_type} = $r; # prevent recursion
1258 107 100       465 $r->coercion( $self->coercion->moose_coercion ) if $self->has_coercion;
1259             } #/ else [ if ( $self->{_is_core})]
1260            
1261 208         1662 return $r;
1262             } #/ sub _build_moose_type
1263              
1264             sub _build_mouse_type {
1265 3     3   7 my $self = shift;
1266            
1267 3         4 my %options;
1268 3 50 33     7 $options{name} = $self->qualified_name if $self->has_library && !$self->is_anon;
1269 3 100       8 $options{parent} = $self->parent->mouse_type if $self->has_parent;
1270 3 100       12 $options{constraint} = $self->constraint unless $self->_is_null_constraint;
1271 3 100       8 $options{message} = $self->message if $self->has_message;
1272            
1273 3         18 require Mouse::Meta::TypeConstraint;
1274 3         31 my $r = "Mouse::Meta::TypeConstraint"->new( %options );
1275            
1276 3         150 $self->{mouse_type} = $r; # prevent recursion
1277 3 50       10 $r->_add_type_coercions(
1278             $self->coercion->freeze->_codelike_type_coercion_map( 'mouse_type' ) )
1279             if $self->has_coercion;
1280            
1281 3         48 return $r;
1282             } #/ sub _build_mouse_type
1283              
1284             sub exportables {
1285 14197     14197 1 36479 my ( $self, $base_name, $tag ) = ( shift, @_ ); # $tag is undocumented
1286 14197 100       23994 if ( not $self->is_anon ) {
1287 14196   66     38291 $base_name ||= $self->name;
1288             }
1289 14197   100     52434 $tag ||= 0;
1290              
1291 14197         19716 my @exportables;
1292 14197 50       26072 return \@exportables if ! $base_name;
1293              
1294 14197         74153 require Eval::TypeTiny;
1295              
1296 14197 100 66     72681 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 14197 100 100     106683 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 14197 100 66     85744 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   4715 : 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      
        1250      
        24      
        12      
        12      
        12      
        12      
        12      
1319 14197 100 100     109181 tags => [ 'to' ],
    100 100        
1320             } if $tag eq 'to' || !$tag;
1321              
1322 14197         57592 return \@exportables;
1323             }
1324              
1325             sub exportables_by_tag {
1326 604     613 1 2341 my ( $self, $tag, $base_name ) = ( shift, @_ );
1327             my @matched = grep {
1328 604         1497 my $e = $_;
1329 604 50       1190 grep $_ eq $tag, @{ $e->{tags} || [] };
  604         5459  
1330 604         1747 } @{ $self->exportables( $base_name, $tag ) };
  604         2959  
1331 604 100       3298 return @matched if wantarray;
1332 1 50       4 _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 100     105   254 my $self = shift;
1339            
1340 100         196 my @pairs;
1341 100         360 while ( @_ ) {
1342 108         234 my $next = shift;
1343 108 100 100     710 if ( blessed( $next )
    100 100        
    100 100        
1344             and $next->isa( 'Type::Coercion' )
1345             and $next->is_parameterized )
1346             {
1347 8         17 push @pairs => ( @{ $next->_reparameterize( $self )->type_coercion_map } );
  8         23  
1348             }
1349             elsif ( blessed( $next ) and $next->can( 'type_coercion_map' ) ) {
1350             push @pairs => (
1351 9         16 @{ $next->type_coercion_map },
  9         19  
1352             );
1353             }
1354             elsif ( ref( $next ) eq q(ARRAY) ) {
1355 3         16 unshift @_, @$next;
1356             }
1357             else {
1358 88         401 push @pairs => (
1359             Types::TypeTiny::to_TypeTiny( $next ),
1360             shift,
1361             );
1362             }
1363             } #/ while ( @_ )
1364            
1365 100         328 return @pairs;
1366             } #/ sub _process_coercion_list
1367              
1368             sub plus_coercions {
1369 97     97 1 34883 my $self = shift;
1370 97         378 my $new = $self->_clone;
1371             $new->coercion->add_type_coercions(
1372             $self->_process_coercion_list( @_ ),
1373 97         405 @{ $self->coercion->type_coercion_map },
  97         648  
1374             );
1375 97         500 $new->coercion->freeze;
1376 97         453 return $new;
1377             } #/ sub plus_coercions
1378              
1379             sub plus_fallback_coercions {
1380 2     2 1 642 my $self = shift;
1381            
1382 2         7 my $new = $self->_clone;
1383             $new->coercion->add_type_coercions(
1384 2         7 @{ $self->coercion->type_coercion_map },
  2         5  
1385             $self->_process_coercion_list( @_ ),
1386             );
1387 2         7 $new->coercion->freeze;
1388 2         5 return $new;
1389             } #/ sub plus_fallback_coercions
1390              
1391             sub minus_coercions {
1392 1     1 1 574 my $self = shift;
1393            
1394 1         3 my $new = $self->_clone;
1395 1         9 my @not = grep Types::TypeTiny::is_TypeTiny( $_ ),
1396             $self->_process_coercion_list( $new, @_ );
1397            
1398 1         7 my @keep;
1399 1         5 my $c = $self->coercion->type_coercion_map;
1400 1         7 for ( my $i = 0 ; $i <= $#$c ; $i += 2 ) {
1401 4         8 my $keep_this = 1;
1402 4         5 NOT: for my $n ( @not ) {
1403 11 100       28 if ( $c->[$i] == $n ) {
1404 2         3 $keep_this = 0;
1405 2         3 last NOT;
1406             }
1407             }
1408            
1409 4 100       25 push @keep, $c->[$i], $c->[ $i + 1 ] if $keep_this;
1410             } #/ for ( my $i = 0 ; $i <=...)
1411            
1412 1         3 $new->coercion->add_type_coercions( @keep );
1413 1         6 $new->coercion->freeze;
1414 1         4 return $new;
1415             } #/ sub minus_coercions
1416              
1417             sub no_coercions {
1418 6     6 1 1235 my $new = shift->_clone;
1419 6         29 $new->coercion->freeze;
1420 6         33 $new;
1421             }
1422              
1423             sub coercibles {
1424 7     7 1 251 my $self = shift;
1425 7 100       26 $self->has_coercion ? $self->coercion->_source_type_union : $self;
1426             }
1427              
1428             sub isa {
1429 280532     280532 1 2505020 my $self = shift;
1430            
1431 280532 100 100     591782 if ( $INC{"Moose.pm"}
      100        
1432             and ref( $self )
1433             and $_[0] =~ /^(?:Class::MOP|MooseX?::Meta)::(.+)$/ )
1434             {
1435 143         515 my $meta = $1;
1436            
1437 143 100       559 return !!1 if $meta eq 'TypeConstraint';
1438 58 100       424 return $self->is_parameterized if $meta eq 'TypeConstraint::Parameterized';
1439 4 100       23 return $self->is_parameterizable if $meta eq 'TypeConstraint::Parameterizable';
1440 3 100       9 return $self->isa( 'Type::Tiny::Union' ) if $meta eq 'TypeConstraint::Union';
1441            
1442 1         3 my $inflate = $self->moose_type;
1443 1         16 return $inflate->isa( @_ );
1444             } #/ if ( $INC{"Moose.pm"} ...)
1445            
1446 280389 100 100     505320 if ( $INC{"Mouse.pm"}
      100        
1447             and ref( $self )
1448             and $_[0] eq 'Mouse::Meta::TypeConstraint' )
1449             {
1450 1         4 return !!1;
1451             }
1452            
1453 280388         1241625 $self->SUPER::isa( @_ );
1454             } #/ sub isa
1455              
1456             sub _build_my_methods {
1457 141     141   702 return {};
1458             }
1459              
1460             sub _lookup_my_method {
1461 1278     1278   1768 my $self = shift;
1462 1278         2868 my ( $name ) = @_;
1463            
1464 1278 100       2386 if ( $self->my_methods->{$name} ) {
1465 614         1195 return $self->my_methods->{$name};
1466             }
1467            
1468 664 100       1430 if ( $self->has_parent ) {
1469 662         1468 return $self->parent->_lookup_my_method( @_ );
1470             }
1471            
1472 2         9 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 84836     84836 1 637062 my $self = shift;
1482            
1483 84836 50 66     203228 return !!0
      33        
1484             if $_[0] eq 'type_parameter'
1485             && blessed( $_[0] )
1486             && $_[0]->has_parameters;
1487            
1488 84836         264559 my $can = $self->SUPER::can( @_ );
1489 84836 100       756520 return $can if $can;
1490            
1491 42657 100       102432 if ( ref( $self ) ) {
1492 42656 100       85206 if ( $INC{"Moose.pm"} ) {
1493 443         1208 my $method = $self->moose_type->can( @_ );
1494 1     1   4 return sub { shift->moose_type->$method( @_ ) }
1495 443 100       4852 if $method;
1496             }
1497 42646 100       109253 if ( $_[0] =~ /\Amy_(.+)\z/ ) {
1498 4         10 my $method = $self->_lookup_my_method( $1 );
1499 4 100       11 return $method if $method;
1500             }
1501 42644 100 100     106400 if ( $self->{is_object} && $object_methods{ $_[0] } ) {
1502 1         754 require Type::Tiny::ConstrainedObject;
1503 1         15 return Type::Tiny::ConstrainedObject->can( $_[0] );
1504             }
1505 42643         93177 for my $util ( qw/ grep map sort rsort first any all assert_any assert_all / ) {
1506 383643 100       644811 if ( $_[0] eq $util ) {
1507 36   66     132 $self->{'_util'}{$util} ||= eval { $self->_build_util( $util ) };
  36         85  
1508 36 100       138 return unless $self->{'_util'}{$util};
1509 34     0   164 return sub { my $s = shift; $s->{'_util'}{$util}( @_ ) };
  0         0  
  0         0  
1510             }
1511             }
1512             } #/ if ( ref( $self ) )
1513            
1514 42608         269557 return;
1515             } #/ sub can
1516              
1517             sub AUTOLOAD {
1518 689     689   17617 my $self = shift;
1519 689         4269 my ( $m ) = ( our $AUTOLOAD =~ /::(\w+)$/ );
1520 689 50       2053 return if $m eq 'DESTROY';
1521            
1522 689 50       1702 if ( ref( $self ) ) {
1523 689 100       1702 if ( $INC{"Moose.pm"} ) {
1524 3         10 my $method = $self->moose_type->can( $m );
1525 3 100       38 return $self->moose_type->$method( @_ ) if $method;
1526             }
1527 687 100       2375 if ( $m =~ /\Amy_(.+)\z/ ) {
1528 612         1565 my $method = $self->_lookup_my_method( $1 );
1529 612 50       2765 return &$method( $self, @_ ) if $method;
1530             }
1531 75 50 66     228 if ( $self->{is_object} && $object_methods{$m} ) {
1532 3         1106 require Type::Tiny::ConstrainedObject;
1533 3         11 unshift @_, $self;
1534 316     316   3427 no strict 'refs';
  316         876  
  316         463573  
1535 3         9 goto \&{"Type::Tiny::ConstrainedObject::$m"};
  3         29  
1536             }
1537 72         169 for my $util ( qw/ grep map sort rsort first any all assert_any assert_all / ) {
1538 394 100       715 if ( $m eq $util ) {
1539 70   66     912 return ( $self->{'_util'}{$util} ||= $self->_build_util( $util ) )->( @_ );
1540             }
1541             }
1542             } #/ if ( ref( $self ) )
1543            
1544 2   33     33 _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 127 my $self = shift;
1550            
1551 45 50 33     201 return !!1
1552             if ref( $self )
1553             && $_[0] =~ m{^ Type::API::Constraint (?: ::Coercible | ::Inlinable )? $}x;
1554 45 50 33     118 return !!1 if !ref( $self ) && $_[0] eq 'Type::API::Constraint::Constructor';
1555            
1556 45 50       346 "UNIVERSAL"->can( "DOES" ) ? $self->SUPER::DOES( @_ ) : $self->isa( @_ );
1557             } #/ sub DOES
1558              
1559             sub _has_xsub {
1560 1     1   69937 require B;
1561 1         7 !!B::svref_2object( shift->compiled_check )->XSUB;
1562             }
1563              
1564             sub _build_util {
1565 82     82   194 my ( $self, $func ) = @_;
1566 82         278 Scalar::Util::weaken( my $type = $self );
1567            
1568 82 100 100     702 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         80 my ( $inline, $compiled );
1576            
1577 43 100       101 if ( $self->can_be_inlined ) {
1578 13         42 $inline = $self->inline_check( '$_' );
1579             }
1580             else {
1581 30         66 $compiled = $self->compiled_check;
1582 30         60 $inline = '$compiled->($_)';
1583             }
1584            
1585 43 100       192 if ( $func eq 'grep' ) {
    100          
    100          
    100          
    100          
    50          
1586 5         585 return eval "sub { grep { $inline } \@_ }";
1587             }
1588             elsif ( $func eq 'first' ) {
1589 5         586 return eval "sub { for (\@_) { return \$_ if ($inline) }; undef; }";
1590             }
1591             elsif ( $func eq 'any' ) {
1592 8         878 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         1152 "sub { for (\@_) { return \@_ if ($inline) }; Type::Tiny::_failed_check(\$type, $qname, \@_ ? \$_[-1] : undef); }";
1599             }
1600             elsif ( $func eq 'all' ) {
1601 9         1137 return eval "sub { for (\@_) { return !!0 unless ($inline) }; !!1; }";
1602             }
1603             elsif ( $func eq 'assert_all' ) {
1604 8         18 my $qname = B::perlstring( $self->name );
1605             return
1606             eval
1607 8         1120 "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       101 if ( $func eq 'map' ) {
1612 8         11 my ( $inline, $compiled );
1613 8         18 my $c = $self->_assert_coercion;
1614            
1615 4 100       12 if ( $c->can_be_inlined ) {
1616 1         5 $inline = $c->inline_coercion( '$_' );
1617             }
1618             else {
1619 3         8 $compiled = $c->compiled_coercion;
1620 3         6 $inline = '$compiled->($_)';
1621             }
1622            
1623 4         440 return eval "sub { map { $inline } \@_ }";
1624             } #/ if ( $func eq 'map' )
1625            
1626 31 100 100     186 if ( $func eq 'sort' || $func eq 'rsort' ) {
1627 29         51 my ( $inline, $compiled );
1628            
1629 29     76   166 my $ptype = $self->find_parent( sub { $_->has_sorter } );
  76         155  
1630 29 100       115 _croak "No sorter for this type constraint" unless $ptype;
1631            
1632 27         104 my $sorter = $ptype->sorter;
1633            
1634             # Schwarzian transformation
1635 27 100       75 if ( ref( $sorter ) eq 'ARRAY' ) {
1636 6         9 my $sort_key;
1637 6         16 ( $sorter, $sort_key ) = @$sorter;
1638            
1639 6 100       31 if ( $func eq 'sort' ) {
    50          
1640             return
1641             eval
1642 4         624 "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         282 "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       68 if ( $func eq 'sort' ) {
    50          
1654 12         1362 return eval "our (\$a, \$b); sub { sort { \$sorter->(\$a,\$b) } \@_ }";
1655             }
1656             elsif ( $func eq 'rsort' ) {
1657 9         920 return eval "our (\$a, \$b); sub { sort { \$sorter->(\$b,\$a) } \@_ }";
1658             }
1659             }
1660             } #/ if ( $func eq 'sort' ||...)
1661            
1662 2         22 die "Unknown function: $func";
1663             } #/ sub _build_util
1664              
1665 304     304 1 9720 sub of { shift->parameterize( @_ ) }
1666 138     138 1 45229 sub where { shift->create_child_type( constraint => @_ ) }
1667              
1668             # fill out Moose-compatible API
1669 277     277 1 3908 sub inline_environment { +{} }
1670 144     144   2685 sub _inline_check { shift->inline_check( @_ ) }
1671 85     85   3884 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 18 sub compile_type_constraint { shift->compiled_check }
1674 2     2   33 sub _actually_compile_type_constraint { shift->_build_compiled_check }
1675 1     1 1 394 sub hand_optimized_type_constraint { shift->{hand_optimized_type_constraint} }
1676              
1677             sub has_hand_optimized_type_constraint {
1678 1     1 1 19 exists( shift->{hand_optimized_type_constraint} );
1679             }
1680 381   100 381 1 2385 sub type_parameter { ( shift->parameters || [] )->[0] }
1681              
1682             sub parameterized_from {
1683 5 50   5 1 22 $_[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   660 sub _as_string { shift->qualified_name( @_ ) }
1691 1     1   5 sub _compiled_type_coercion { shift->coercion->compiled_coercion( @_ ) }
1692 2     2   600 sub _identity { Scalar::Util::refaddr( shift ) }
1693              
1694             sub _unite {
1695 1     1   486 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   1623 require Type::Tie;
1702 1         7 unshift @_, 'Type::Tie::SCALAR';
1703 1         5 goto \&Type::Tie::SCALAR::TIESCALAR;
1704             }
1705              
1706             sub TIEARRAY {
1707 1     1   2737 require Type::Tie;
1708 1         5 unshift @_, 'Type::Tie::ARRAY';
1709 1         4 goto \&Type::Tie::ARRAY::TIEARRAY;
1710             }
1711              
1712             sub TIEHASH {
1713 1     1   2291 require Type::Tie;
1714 1         3 unshift @_, 'Type::Tie::HASH';
1715 1         4 goto \&Type::Tie::HASH::TIEHASH;
1716             }
1717              
1718             1;
1719              
1720             __END__
1721              
1722             =pod
1723              
1724             =encoding utf-8
1725              
1726             =for stopwords Moo(se)-compatible MooseX MouseX MooX Moose-compat invocant
1727              
1728             =head1 NAME
1729              
1730             Type::Tiny - tiny, yet Moo(se)-compatible type constraint
1731              
1732             =head1 SYNOPSIS
1733              
1734             use v5.12;
1735             use strict;
1736             use warnings;
1737            
1738             package Horse {
1739             use Moo;
1740             use Types::Standard qw( Str Int Enum ArrayRef Object );
1741             use Type::Params qw( signature );
1742             use namespace::autoclean;
1743            
1744             has name => (
1745             is => 'ro',
1746             isa => Str,
1747             required => 1,
1748             );
1749             has gender => (
1750             is => 'ro',
1751             isa => Enum[qw( f m )],
1752             );
1753             has age => (
1754             is => 'rw',
1755             isa => Int->where( '$_ >= 0' ),
1756             );
1757             has children => (
1758             is => 'ro',
1759             isa => ArrayRef[Object],
1760             default => sub { return [] },
1761             );
1762            
1763             sub add_child {
1764             state $check = signature(
1765             method => Object,
1766             positional => [ Object ],
1767             ); # method signature
1768             my ( $self, $child ) = $check->( @_ ); # unpack @_
1769            
1770             push @{ $self->children }, $child;
1771             return $self;
1772             }
1773             }
1774            
1775             package main;
1776            
1777             my $boldruler = Horse->new(
1778             name => "Bold Ruler",
1779             gender => 'm',
1780             age => 16,
1781             );
1782            
1783             my $secretariat = Horse->new(
1784             name => "Secretariat",
1785             gender => 'm',
1786             age => 0,
1787             );
1788            
1789             $boldruler->add_child( $secretariat );
1790              
1791             =head1 STATUS
1792              
1793             This module is covered by the
1794             L<Type-Tiny stability policy|Type::Tiny::Manual::Policies/"STABILITY">.
1795              
1796             =head1 DESCRIPTION
1797              
1798             This documents the internals of the L<Type::Tiny> class. L<Type::Tiny::Manual>
1799             is a better starting place if you're new.
1800              
1801             L<Type::Tiny> is a small class for creating Moose-like type constraint
1802             objects which are compatible with Moo, Moose and Mouse.
1803              
1804             use Scalar::Util qw(looks_like_number);
1805             use Type::Tiny;
1806            
1807             my $NUM = "Type::Tiny"->new(
1808             name => "Number",
1809             constraint => sub { looks_like_number($_) },
1810             message => sub { "$_ ain't a number" },
1811             );
1812            
1813             package Ermintrude {
1814             use Moo;
1815             has favourite_number => (is => "ro", isa => $NUM);
1816             }
1817            
1818             package Bullwinkle {
1819             use Moose;
1820             has favourite_number => (is => "ro", isa => $NUM);
1821             }
1822            
1823             package Maisy {
1824             use Mouse;
1825             has favourite_number => (is => "ro", isa => $NUM);
1826             }
1827              
1828             Type::Tiny conforms to L<Type::API::Constraint>,
1829             L<Type::API::Constraint::Coercible>,
1830             L<Type::API::Constraint::Constructor>, and
1831             L<Type::API::Constraint::Inlinable>.
1832              
1833             Maybe now we won't need to have separate MooseX, MouseX and MooX versions
1834             of everything? We can but hope...
1835              
1836             =head2 Constructor
1837              
1838             =over
1839              
1840             =item C<< new(%attributes) >>
1841              
1842             Moose-style constructor function.
1843              
1844             =back
1845              
1846             =head2 Attributes
1847              
1848             Attributes are named values that may be passed to the constructor. For
1849             each attribute, there is a corresponding reader method. For example:
1850              
1851             my $type = Type::Tiny->new( name => "Foo" );
1852             print $type->name, "\n"; # says "Foo"
1853              
1854             =head3 Important attributes
1855              
1856             These are the attributes you are likely to be most interested in
1857             providing when creating your own type constraints, and most interested
1858             in reading when dealing with type constraint objects.
1859              
1860             =over
1861              
1862             =item C<< constraint >>
1863              
1864             Coderef to validate a value (C<< $_ >>) against the type constraint.
1865             The coderef will not be called unless the value is known to pass any
1866             parent type constraint (see C<parent> below).
1867              
1868             Alternatively, a string of Perl code checking C<< $_ >> can be passed
1869             as a parameter to the constructor, and will be converted to a coderef.
1870              
1871             Defaults to C<< sub { 1 } >> - i.e. a coderef that passes all values.
1872              
1873             =item C<< parent >>
1874              
1875             Optional attribute; parent type constraint. For example, an "Integer"
1876             type constraint might have a parent "Number".
1877              
1878             If provided, must be a Type::Tiny object.
1879              
1880             =item C<< inlined >>
1881              
1882             A coderef which returns a string of Perl code suitable for inlining this
1883             type. Optional.
1884              
1885             (The coderef will be called in list context and can actually return
1886             a list of strings which will be joined with C<< && >>. If the first item
1887             on the list is undef, it will be substituted with the type's parent's
1888             inline check.)
1889              
1890             If C<constraint> (above) is a coderef generated via L<Sub::Quote>, then
1891             Type::Tiny I<may> be able to automatically generate C<inlined> for you.
1892             If C<constraint> (above) is a string, it will be able to.
1893              
1894             =item C<< name >>
1895              
1896             The name of the type constraint. These need to conform to certain naming
1897             rules (they must begin with an uppercase letter and continue using only
1898             letters, digits 0-9 and underscores).
1899              
1900             Optional; if not supplied will be an anonymous type constraint.
1901              
1902             =item C<< display_name >>
1903              
1904             A name to display for the type constraint when stringified. These don't
1905             have to conform to any naming rules. Optional; a default name will be
1906             calculated from the C<name>.
1907              
1908             =item C<< library >>
1909              
1910             The package name of the type library this type is associated with.
1911             Optional. Informational only: setting this attribute does not install
1912             the type into the package.
1913              
1914             =item C<< deprecated >>
1915              
1916             Optional boolean indicating whether a type constraint is deprecated.
1917             L<Type::Library> will issue a warning if you attempt to import a deprecated
1918             type constraint, but otherwise the type will continue to function as normal.
1919             There will not be deprecation warnings every time you validate a value, for
1920             instance. If omitted, defaults to the parent's deprecation status (or false
1921             if there's no parent).
1922              
1923             =item C<< message >>
1924              
1925             Coderef that returns an error message when C<< $_ >> does not validate
1926             against the type constraint. Optional (there's a vaguely sensible default.)
1927              
1928             =item C<< coercion >>
1929              
1930             A L<Type::Coercion> object associated with this type.
1931              
1932             Generally speaking this attribute should not be passed to the constructor;
1933             you should rely on the default lazily-built coercion object.
1934              
1935             You may pass C<< coercion => 1 >> to the constructor to inherit coercions
1936             from the constraint's parent. (This requires the parent constraint to have
1937             a coercion.)
1938              
1939             =item C<< sorter >>
1940              
1941             A coderef which can be passed two values conforming to this type constraint
1942             and returns -1, 0, or 1 to put them in order. Alternatively an arrayref
1943             containing a pair of coderefs — a sorter and a pre-processor for the
1944             Schwarzian transform. Optional.
1945              
1946             The idea is to allow for:
1947              
1948             @sorted = Int->sort( 2, 1, 11 ); # => 1, 2, 11
1949             @sorted = Str->sort( 2, 1, 11 ); # => 1, 11, 2
1950              
1951             =item C<< type_default >>
1952              
1953             A coderef which returns a sensible default value for this type. For example,
1954             for a B<Counter> type, a sensible default might be "0":
1955              
1956             my $Size = Type::Tiny->new(
1957             name => 'Size',
1958             parent => Types::Standard::Enum[ qw( XS S M L XL ) ],
1959             type_default => sub { return 'M'; },
1960             );
1961            
1962             package Tshirt {
1963             use Moo;
1964             has size => (
1965             is => 'ro',
1966             isa => $Size,
1967             default => $Size->type_default,
1968             );
1969             }
1970              
1971             Child types will inherit a type default from their parent unless the child
1972             has a C<constraint>. If a type neither has nor inherits a type default, then
1973             calling C<type_default> will return undef.
1974              
1975             As a special case, this:
1976              
1977             $type->type_default( @args )
1978              
1979             Will return:
1980              
1981             sub {
1982             local $_ = \@args;
1983             $type->type_default->( @_ );
1984             }
1985              
1986             Many of the types defined in L<Types::Standard> and other bundled type
1987             libraries have type defaults, but discovering them is left as an exercise
1988             for the reader.
1989              
1990             =item C<< my_methods >>
1991              
1992             Experimental hashref of additional methods that can be called on the type
1993             constraint object.
1994              
1995             =item C<< exception_class >>
1996              
1997             The class used to throw an exception when a value fails its type check.
1998             Defaults to "Error::TypeTiny::Assertion", which is usually good. This class
1999             is expected to provide a C<throw_cb> method compatible with the method of
2000             that name in L<Error::TypeTiny>.
2001              
2002             If a parent type constraint has a custom C<exception_class>, then this
2003             will be "inherited" by its children.
2004              
2005             =back
2006              
2007             =head3 Attributes related to parameterizable and parameterized types
2008              
2009             The following additional attributes are used for parameterizable (e.g.
2010             C<ArrayRef>) and parameterized (e.g. C<< ArrayRef[Int] >>) type
2011             constraints. Unlike Moose, these aren't handled by separate subclasses.
2012              
2013             =over
2014              
2015             =item C<< constraint_generator >>
2016              
2017             Coderef that is called when a type constraint is parameterized. When called,
2018             it is passed the list of parameters, though any parameter which looks like a
2019             foreign type constraint (Moose type constraints, Mouse type constraints, etc,
2020             I<< and coderefs(!!!) >>) is first coerced to a native Type::Tiny object.
2021              
2022             Note that for compatibility with the Moose API, the base type is I<not>
2023             passed to the constraint generator, but can be found in the package variable
2024             C<< $Type::Tiny::parameterize_type >>. The first parameter is also available
2025             as C<< $_ >>.
2026              
2027             Types I<can> be parameterized with an empty parameter list. For example,
2028             in L<Types::Standard>, C<Tuple> is just an alias for C<ArrayRef> but
2029             C<< Tuple[] >> will only allow zero-length arrayrefs to pass the constraint.
2030             If you wish C<< YourType >> and C<< YourType[] >> to mean the same thing,
2031             then do:
2032              
2033             return $Type::Tiny::parameterize_type unless @_;
2034              
2035             The constraint generator should generate and return a new constraint coderef
2036             based on the parameters. Alternatively, the constraint generator can return a
2037             fully-formed Type::Tiny object, in which case the C<name_generator>,
2038             C<inline_generator>, and C<coercion_generator> attributes documented below
2039             are ignored.
2040              
2041             Optional; providing a generator makes this type into a parameterizable
2042             type constraint. If there is no generator, attempting to parameterize the
2043             type constraint will throw an exception.
2044              
2045             =item C<< name_generator >>
2046              
2047             A coderef which generates a new display_name based on parameters. Called with
2048             the same parameters and package variables as the C<constraint_generator>.
2049             Expected to return a string.
2050              
2051             Optional; the default is reasonable.
2052              
2053             =item C<< inline_generator >>
2054              
2055             A coderef which generates a new inlining coderef based on parameters. Called
2056             with the same parameters and package variables as the C<constraint_generator>.
2057             Expected to return a coderef.
2058              
2059             Optional.
2060              
2061             =item C<< coercion_generator >>
2062              
2063             A coderef which generates a new L<Type::Coercion> object based on parameters.
2064             Called with the same parameters and package variables as the
2065             C<constraint_generator>. Expected to return a blessed object.
2066              
2067             Optional.
2068              
2069             =item C<< deep_explanation >>
2070              
2071             This API is not finalized. Coderef used by L<Error::TypeTiny::Assertion> to
2072             peek inside parameterized types and figure out why a value doesn't pass the
2073             constraint.
2074              
2075             =item C<< parameters >>
2076              
2077             In parameterized types, returns an arrayref of the parameters.
2078              
2079             =back
2080              
2081             =head3 Lazy generated attributes
2082              
2083             The following attributes should not be usually passed to the constructor;
2084             unless you're doing something especially unusual, you should rely on the
2085             default lazily-built return values.
2086              
2087             =over
2088              
2089             =item C<< compiled_check >>
2090              
2091             Coderef to validate a value (C<< $_[0] >>) against the type constraint.
2092             This coderef is expected to also handle all validation for the parent
2093             type constraints.
2094              
2095             =item C<< definition_context >>
2096              
2097             Hashref of information indicating where the type constraint was originally
2098             defined. Type::Tiny will generate this based on C<caller> if you do not
2099             supply it. The hashref will ordinarily contain keys C<"package">, C<"file">,
2100             and C<"line">.
2101              
2102             For parameterized types and compound types (e.g. unions and intersections),
2103             this may not be especially meaningful information.
2104              
2105             =item C<< complementary_type >>
2106              
2107             A complementary type for this type. For example, the complementary type
2108             for an integer type would be all things that are not integers, including
2109             floating point numbers, but also alphabetic strings, arrayrefs, filehandles,
2110             etc.
2111              
2112             =item C<< moose_type >>, C<< mouse_type >>
2113              
2114             Objects equivalent to this type constraint, but as a
2115             L<Moose::Meta::TypeConstraint> or L<Mouse::Meta::TypeConstraint>.
2116              
2117             It should rarely be necessary to obtain a L<Moose::Meta::TypeConstraint>
2118             object from L<Type::Tiny> because the L<Type::Tiny> object itself should
2119             be usable pretty much anywhere a L<Moose::Meta::TypeConstraint> is expected.
2120              
2121             =back
2122              
2123             =head2 Methods
2124              
2125             =head3 Predicate methods
2126              
2127             These methods return booleans indicating information about the type
2128             constraint. They are each tightly associated with a particular attribute.
2129             (See L</"Attributes">.)
2130              
2131             =over
2132              
2133             =item C<has_parent>, C<has_library>, C<has_inlined>, C<has_constraint_generator>, C<has_inline_generator>, C<has_coercion_generator>, C<has_parameters>, C<has_message>, C<has_deep_explanation>, C<has_sorter>
2134              
2135             Simple Moose-style predicate methods indicating the presence or
2136             absence of an attribute.
2137              
2138             =item C<has_coercion>
2139              
2140             Predicate method with a little extra DWIM. Returns false if the coercion is
2141             a no-op.
2142              
2143             =item C<< is_anon >>
2144              
2145             Returns true iff the type constraint does not have a C<name>.
2146              
2147             =item C<< is_parameterized >>, C<< is_parameterizable >>
2148              
2149             Indicates whether a type has been parameterized (e.g. C<< ArrayRef[Int] >>)
2150             or could potentially be (e.g. C<< ArrayRef >>).
2151              
2152             =item C<< has_parameterized_from >>
2153              
2154             Useless alias for C<is_parameterized>.
2155              
2156             =back
2157              
2158             =head3 Validation and coercion
2159              
2160             The following methods are used for coercing and validating values
2161             against a type constraint:
2162              
2163             =over
2164              
2165             =item C<< check($value) >>
2166              
2167             Returns true iff the value passes the type constraint.
2168              
2169             =item C<< validate($value) >>
2170              
2171             Returns the error message for the value; returns an explicit undef if the
2172             value passes the type constraint.
2173              
2174             =item C<< assert_valid($value) >>
2175              
2176             Like C<< check($value) >> but dies if the value does not pass the type
2177             constraint.
2178              
2179             Yes, that's three very similar methods. Blame L<Moose::Meta::TypeConstraint>
2180             whose API I'm attempting to emulate. :-)
2181              
2182             =item C<< assert_return($value) >>
2183              
2184             Like C<< assert_valid($value) >> but returns the value if it passes the type
2185             constraint.
2186              
2187             This seems a more useful behaviour than C<< assert_valid($value) >>. I would
2188             have just changed C<< assert_valid($value) >> to do this, except that there
2189             are edge cases where it could break Moose compatibility.
2190              
2191             =item C<< get_message($value) >>
2192              
2193             Returns the error message for the value; even if the value passes the type
2194             constraint.
2195              
2196             =item C<< validate_explain($value, $varname) >>
2197              
2198             Like C<validate> but instead of a string error message, returns an arrayref
2199             of strings explaining the reasoning why the value does not meet the type
2200             constraint, examining parent types, etc.
2201              
2202             The C<< $varname >> is an optional string like C<< '$foo' >> indicating the
2203             name of the variable being checked.
2204              
2205             =item C<< coerce($value) >>
2206              
2207             Attempt to coerce C<< $value >> to this type.
2208              
2209             =item C<< assert_coerce($value) >>
2210              
2211             Attempt to coerce C<< $value >> to this type. Throws an exception if this is
2212             not possible.
2213              
2214             =back
2215              
2216             =head3 Child type constraint creation and parameterization
2217              
2218             These methods generate new type constraint objects that inherit from the
2219             constraint they are called upon:
2220              
2221             =over
2222              
2223             =item C<< create_child_type(%attributes) >>
2224              
2225             Construct a new Type::Tiny object with this object as its parent.
2226              
2227             =item C<< where($coderef) >>
2228              
2229             Shortcut for creating an anonymous child type constraint. Use it like
2230             C<< HashRef->where(sub { exists($_->{name}) }) >>. That said, you can
2231             get a similar result using overloaded C<< & >>:
2232              
2233             HashRef & sub { exists($_->{name}) }
2234              
2235             Like the C<< constraint >> attribute, this will accept a string of Perl
2236             code:
2237              
2238             HashRef->where('exists($_->{name})')
2239              
2240             =item C<< child_type_class >>
2241              
2242             The class that create_child_type will construct by default.
2243              
2244             =item C<< parameterize(@parameters) >>
2245              
2246             Creates a new parameterized type; throws an exception if called on a
2247             non-parameterizable type.
2248              
2249             =item C<< of(@parameters) >>
2250              
2251             A cute alias for C<parameterize>. Use it like C<< ArrayRef->of(Int) >>.
2252              
2253             =item C<< plus_coercions($type1, $code1, ...) >>
2254              
2255             Shorthand for creating a new child type constraint with the same coercions
2256             as this one, but then adding some extra coercions (at a higher priority than
2257             the existing ones).
2258              
2259             =item C<< plus_fallback_coercions($type1, $code1, ...) >>
2260              
2261             Like C<plus_coercions>, but added at a lower priority.
2262              
2263             =item C<< minus_coercions($type1, ...) >>
2264              
2265             Shorthand for creating a new child type constraint with fewer type coercions.
2266              
2267             =item C<< no_coercions >>
2268              
2269             Shorthand for creating a new child type constraint with no coercions at all.
2270              
2271             =back
2272              
2273             =head3 Type relationship introspection methods
2274              
2275             These methods allow you to determine a type constraint's relationship to
2276             other type constraints in an organised hierarchy:
2277              
2278             =over
2279              
2280             =item C<< equals($other) >>, C<< is_subtype_of($other) >>, C<< is_supertype_of($other) >>, C<< is_a_type_of($other) >>
2281              
2282             Compare two types. See L<Moose::Meta::TypeConstraint> for what these all mean.
2283             (OK, Moose doesn't define C<is_supertype_of>, but you get the idea, right?)
2284              
2285             Note that these have a slightly DWIM side to them. If you create two
2286             L<Type::Tiny::Class> objects which test the same class, they're considered
2287             equal. And:
2288              
2289             my $subtype_of_Num = Types::Standard::Num->create_child_type;
2290             my $subtype_of_Int = Types::Standard::Int->create_child_type;
2291             $subtype_of_Int->is_subtype_of( $subtype_of_Num ); # true
2292              
2293             =item C<< strictly_equals($other) >>, C<< is_strictly_subtype_of($other) >>, C<< is_strictly_supertype_of($other) >>, C<< is_strictly_a_type_of($other) >>
2294              
2295             Stricter versions of the type comparison functions. These only care about
2296             explicit inheritance via C<parent>.
2297              
2298             my $subtype_of_Num = Types::Standard::Num->create_child_type;
2299             my $subtype_of_Int = Types::Standard::Int->create_child_type;
2300             $subtype_of_Int->is_strictly_subtype_of( $subtype_of_Num ); # false
2301              
2302             =item C<< parents >>
2303              
2304             Returns a list of all this type constraint's ancestor constraints. For
2305             example, if called on the C<Str> type constraint would return the list
2306             C<< (Value, Defined, Item, Any) >>.
2307              
2308             I<< Due to a historical misunderstanding, this differs from the Moose
2309             implementation of the C<parents> method. In Moose, C<parents> only returns the
2310             immediate parent type constraints, and because type constraints only have
2311             one immediate parent, this is effectively an alias for C<parent>. The
2312             extension module L<MooseX::Meta::TypeConstraint::Intersection> is the only
2313             place where multiple type constraints are returned; and they are returned
2314             as an arrayref in violation of the base class' documentation. I'm keeping
2315             my behaviour as it seems more useful. >>
2316              
2317             =item C<< find_parent($coderef) >>
2318              
2319             Loops through the parent type constraints I<< including the invocant
2320             itself >> and returns the nearest ancestor type constraint where the
2321             coderef evaluates to true. Within the coderef the ancestor currently
2322             being checked is C<< $_ >>. Returns undef if there is no match.
2323              
2324             In list context also returns the number of type constraints which had
2325             been looped through before the matching constraint was found.
2326              
2327             =item C<< find_constraining_type >>
2328              
2329             Finds the nearest ancestor type constraint (including the type itself)
2330             which has a C<constraint> coderef.
2331              
2332             Equivalent to:
2333              
2334             $type->find_parent(sub { not $_->_is_null_constraint })
2335              
2336             =item C<< coercibles >>
2337              
2338             Return a type constraint which is the union of type constraints that can be
2339             coerced to this one (including this one). If this type constraint has no
2340             coercions, returns itself.
2341              
2342             =item C<< type_parameter >>
2343              
2344             In parameterized type constraints, returns the first item on the list of
2345             parameters; otherwise returns undef. For example:
2346              
2347             ( ArrayRef[Int] )->type_parameter; # returns Int
2348             ( ArrayRef[Int] )->parent; # returns ArrayRef
2349              
2350             Note that parameterizable type constraints can perfectly legitimately take
2351             multiple parameters (several of the parameterizable type constraints in
2352             L<Types::Standard> do). This method only returns the first such parameter.
2353             L</"Attributes related to parameterizable and parameterized types">
2354             documents the C<parameters> attribute, which returns an arrayref of all
2355             the parameters.
2356              
2357             =item C<< parameterized_from >>
2358              
2359             Harder to spell alias for C<parent> that only works for parameterized
2360             types.
2361              
2362             =back
2363              
2364             I<< Hint for people subclassing Type::Tiny: >>
2365             Since version 1.006000, the methods for determining subtype, supertype, and
2366             type equality should I<not> be overridden in subclasses of Type::Tiny. This
2367             is because of the problem of diamond inheritance. If X and Y are both
2368             subclasses of Type::Tiny, they I<both> need to be consulted to figure out
2369             how type constraints are related; not just one of them should be overriding
2370             these methods. See the source code for L<Type::Tiny::Enum> for an example of
2371             how subclasses can give hints about type relationships to Type::Tiny.
2372             Summary: push a coderef onto C<< @Type::Tiny::CMP >>. This coderef will be
2373             passed two type constraints. It should then return one of the constants
2374             Type::Tiny::CMP_SUBTYPE (first type is a subtype of second type),
2375             Type::Tiny::CMP_SUPERTYPE (second type is a subtype of first type),
2376             Type::Tiny::CMP_EQUAL (the two types are exactly the same),
2377             Type::Tiny::CMP_EQUIVALENT (the two types are effectively the same), or
2378             Type::Tiny::CMP_UNKNOWN (your coderef couldn't establish any relationship).
2379              
2380             =head3 Type relationship introspection function
2381              
2382             =over
2383              
2384             =item C<< Type::Tiny::cmp($type1, $type2) >>
2385              
2386             The subtype/supertype relationship between types results in a partial
2387             ordering of type constraints.
2388              
2389             This function will return one of the constants:
2390             Type::Tiny::CMP_SUBTYPE (first type is a subtype of second type),
2391             Type::Tiny::CMP_SUPERTYPE (second type is a subtype of first type),
2392             Type::Tiny::CMP_EQUAL (the two types are exactly the same),
2393             Type::Tiny::CMP_EQUIVALENT (the two types are effectively the same), or
2394             Type::Tiny::CMP_UNKNOWN (couldn't establish any relationship).
2395             In numeric contexts, these evaluate to -1, 1, 0, 0, and 0, making it
2396             potentially usable with C<sort> (though you may need to silence warnings
2397             about treating the empty string as a numeric value).
2398              
2399             =back
2400              
2401             =head3 List processing methods
2402              
2403             =over
2404              
2405             =item C<< grep(@list) >>
2406              
2407             Filters a list to return just the items that pass the type check.
2408              
2409             @integers = Int->grep(@list);
2410              
2411             =item C<< first(@list) >>
2412              
2413             Filters the list to return the first item on the list that passes
2414             the type check, or undef if none do.
2415              
2416             $first_lady = Woman->first(@people);
2417              
2418             =item C<< map(@list) >>
2419              
2420             Coerces a list of items. Only works on types which have a coercion.
2421              
2422             @truths = Bool->map(@list);
2423              
2424             =item C<< sort(@list) >>
2425              
2426             Sorts a list of items according to the type's preferred sorting mechanism,
2427             or if the type doesn't have a sorter coderef, uses the parent type. If no
2428             ancestor type constraint has a sorter, throws an exception. The C<Str>,
2429             C<StrictNum>, C<LaxNum>, and C<Enum> type constraints include sorters.
2430              
2431             @sorted_numbers = Num->sort( Num->grep(@list) );
2432              
2433             =item C<< rsort(@list) >>
2434              
2435             Like C<sort> but backwards.
2436              
2437             =item C<< any(@list) >>
2438              
2439             Returns true if any of the list match the type.
2440              
2441             if ( Int->any(@numbers) ) {
2442             say "there was at least one integer";
2443             }
2444              
2445             =item C<< all(@list) >>
2446              
2447             Returns true if all of the list match the type.
2448              
2449             if ( Int->all(@numbers) ) {
2450             say "they were all integers";
2451             }
2452              
2453             =item C<< assert_any(@list) >>
2454              
2455             Like C<any> but instead of returning a boolean, returns the entire original
2456             list if any item on it matches the type, and dies if none does.
2457              
2458             =item C<< assert_all(@list) >>
2459              
2460             Like C<all> but instead of returning a boolean, returns the original list if
2461             all items on it match the type, but dies as soon as it finds one that does
2462             not.
2463              
2464             =back
2465              
2466             =head3 Inlining methods
2467              
2468             =for stopwords uated
2469              
2470             The following methods are used to generate strings of Perl code which
2471             may be pasted into stringy C<eval>uated subs to perform type checks:
2472              
2473             =over
2474              
2475             =item C<< can_be_inlined >>
2476              
2477             Returns boolean indicating if this type can be inlined.
2478              
2479             =item C<< inline_check($varname) >>
2480              
2481             Creates a type constraint check for a particular variable as a string of
2482             Perl code. For example:
2483              
2484             print( Types::Standard::Num->inline_check('$foo') );
2485              
2486             prints the following output:
2487              
2488             (!ref($foo) && Scalar::Util::looks_like_number($foo))
2489              
2490             For Moose-compat, there is an alias C<< _inline_check >> for this method.
2491              
2492             =item C<< inline_assert($varname) >>
2493              
2494             Much like C<inline_check> but outputs a statement of the form:
2495              
2496             ... or die ...;
2497              
2498             Can also be called line C<< inline_assert($varname, $typevarname, %extras) >>.
2499             In this case, it will generate a string of code that may include
2500             C<< $typevarname >> which is supposed to be the name of a variable holding
2501             the type itself. (This is kinda complicated, but it allows a useful string
2502             to still be produced if the type is not inlineable.) The C<< %extras >> are
2503             additional options to be passed to L<Error::TypeTiny::Assertion>'s constructor
2504             and must be key-value pairs of strings only, no references or undefs.
2505              
2506             =back
2507              
2508             =head3 Other methods
2509              
2510             =over
2511              
2512             =item C<< qualified_name >>
2513              
2514             For non-anonymous type constraints that have a library, returns a qualified
2515             C<< "MyLib::MyType" >> sort of name. Otherwise, returns the same as C<name>.
2516              
2517             =item C<< isa($class) >>, C<< can($method) >>, C<< AUTOLOAD(@args) >>
2518              
2519             If Moose is loaded, then the combination of these methods is used to mock
2520             a Moose::Meta::TypeConstraint.
2521              
2522             If Mouse is loaded, then C<isa> mocks Mouse::Meta::TypeConstraint.
2523              
2524             =item C<< DOES($role) >>
2525              
2526             Overridden to advertise support for various roles.
2527              
2528             See also L<Type::API::Constraint>, etc.
2529              
2530             =item C<< TIESCALAR >>, C<< TIEARRAY >>, C<< TIEHASH >>
2531              
2532             These are provided as hooks that wrap L<Type::Tie>. They allow the following
2533             to work:
2534              
2535             use Types::Standard qw(Int);
2536             tie my @list, Int;
2537             push @list, 123, 456; # ok
2538             push @list, "Hello"; # dies
2539              
2540             =item C<< exportables( $base_name ) >>
2541              
2542             Returns a list of the functions a type library should export if it contains
2543             this type constraint.
2544              
2545             Example:
2546              
2547             [
2548             { name => 'Int', tags => [ 'types' ], code => sub { ... } },
2549             { name => 'is_Int', tags => [ 'is' ], code => sub { ... } },
2550             { name => 'assert_Int', tags => [ 'assert' ], code => sub { ... } },
2551             { name => 'to_Int', tags => [ 'to' ], code => sub { ... } },
2552             ]
2553              
2554             C<< $base_name >> is optional, but allows you to get a list of exportables
2555             using a specific name. This is useful if the type constraint has a name
2556             which wouldn't be a legal Perl function name.
2557              
2558             =item C<< exportables_by_tag( $tag, $base_name ) >>
2559              
2560             Filters C<exportables> by a specific tag name. In list context, returns all
2561             matching exportables. In scalar context returns a single matching exportable
2562             and dies if multiple exportables match, or none do!
2563              
2564             =back
2565              
2566             The following methods exist for Moose/Mouse compatibility, but do not do
2567             anything useful.
2568              
2569             =over
2570              
2571             =item C<< compile_type_constraint >>
2572              
2573             =item C<< hand_optimized_type_constraint >>
2574              
2575             =item C<< has_hand_optimized_type_constraint >>
2576              
2577             =item C<< inline_environment >>
2578              
2579             =item C<< meta >>
2580              
2581             =back
2582              
2583             =head2 Overloading
2584              
2585             =over
2586              
2587             =item *
2588              
2589             Stringification is overloaded to return the qualified name.
2590              
2591             =item *
2592              
2593             Boolification is overloaded to always return true.
2594              
2595             =item *
2596              
2597             Coderefification is overloaded to call C<assert_return>.
2598              
2599             =item *
2600              
2601             On Perl 5.10.1 and above, smart match is overloaded to call C<check>.
2602              
2603             =item *
2604              
2605             The C<< == >> operator is overloaded to call C<equals>.
2606              
2607             =item *
2608              
2609             The C<< < >> and C<< > >> operators are overloaded to call C<is_subtype_of>
2610             and C<is_supertype_of>.
2611              
2612             =item *
2613              
2614             The C<< ~ >> operator is overloaded to call C<complementary_type>.
2615              
2616             =item *
2617              
2618             The C<< | >> operator is overloaded to build a union of two type constraints.
2619             See L<Type::Tiny::Union>.
2620              
2621             =item *
2622              
2623             The C<< & >> operator is overloaded to build the intersection of two type
2624             constraints. See L<Type::Tiny::Intersection>.
2625              
2626             =item *
2627              
2628             The C<< / >> operator provides magical L<Devel::StrictMode> support.
2629             If C<< $ENV{PERL_STRICT} >> (or a few other environment variables) is true,
2630             then it returns the left operand. Normally it returns the right operand.
2631              
2632             =back
2633              
2634             Previous versions of Type::Tiny would overload the C<< + >> operator to
2635             call C<plus_coercions> or C<plus_fallback_coercions> as appropriate.
2636             Support for this was dropped after 0.040.
2637              
2638             =head2 Constants
2639              
2640             =over
2641              
2642             =item C<< Type::Tiny::SUPPORT_SMARTMATCH >>
2643              
2644             Indicates whether the smart match overload is supported on your
2645             version of Perl.
2646              
2647             =back
2648              
2649             =head2 Package Variables
2650              
2651             =over
2652              
2653             =item C<< $Type::Tiny::DD >>
2654              
2655             This undef by default but may be set to a coderef that Type::Tiny
2656             and related modules will use to dump data structures in things like
2657             error messages.
2658              
2659             Otherwise Type::Tiny uses it's own routine to dump data structures.
2660             C<< $DD >> may then be set to a number to limit the lengths of the
2661             dumps. (Default limit is 72.)
2662              
2663             This is a package variable (rather than get/set class methods) to allow
2664             for easy localization.
2665              
2666             =item C<< $Type::Tiny::AvoidCallbacks >>
2667              
2668             If this variable is set to true (you should usually do it in a
2669             C<local> scope), it acts as a hint for type constraints, when
2670             generating inlined code, to avoid making any callbacks to
2671             variables and functions defined outside the inlined code itself.
2672              
2673             This should have the effect that C<< $type->inline_check('$foo') >>
2674             will return a string of code capable of checking the type on
2675             Perl installations that don't have Type::Tiny installed. This
2676             is intended to allow Type::Tiny to be used with things like
2677             L<Mite>.
2678              
2679             The variable works on the honour system. Types need to explicitly
2680             check it and decide to generate different code based on its
2681             truth value. The bundled types in L<Types::Standard>,
2682             L<Types::Common::Numeric>, and L<Types::Common::String> all do.
2683             (B<StrMatch> is sometimes unable to, and will issue a warning
2684             if it needs to rely on callbacks when asked not to.)
2685              
2686             Most normal users can ignore this.
2687              
2688             =item C<< $Type::Tiny::SafePackage >>
2689              
2690             This is the string "package Type::Tiny;" which is sometimes inserted
2691             into strings of inlined code to avoid namespace clashes. In most cases,
2692             you do not need to change this. However, if you are inlining type
2693             constraint code, saving that code into Perl modules, and uploading them
2694             to CPAN, you may wish to change it to avoid problems with the CPAN
2695             indexer. Most normal users of Type::Tiny do not need to be aware of this.
2696              
2697             =back
2698              
2699             =head2 Environment
2700              
2701             =over
2702              
2703             =item C<PERL_TYPE_TINY_XS>
2704              
2705             Currently this has more effect on L<Types::Standard> than Type::Tiny. In
2706             future it may be used to trigger or suppress the loading XS implementations
2707             of parts of Type::Tiny.
2708              
2709             =back
2710              
2711             =head1 BUGS
2712              
2713             Please report any bugs to
2714             L<https://github.com/tobyink/p5-type-tiny/issues>.
2715              
2716             =head1 SEE ALSO
2717              
2718             L<The Type::Tiny homepage|https://typetiny.toby.ink/>.
2719              
2720             L<Type::Tiny::Manual>, L<Type::API>.
2721              
2722             L<Type::Library>, L<Type::Utils>, L<Types::Standard>, L<Type::Coercion>.
2723              
2724             L<Type::Tiny::Class>, L<Type::Tiny::Role>, L<Type::Tiny::Duck>,
2725             L<Type::Tiny::Enum>, L<Type::Tiny::Union>, L<Type::Tiny::Intersection>.
2726              
2727             L<Moose::Meta::TypeConstraint>,
2728             L<Mouse::Meta::TypeConstraint>.
2729              
2730             L<Type::Params>.
2731              
2732             L<Type::Tiny on GitHub|https://github.com/tobyink/p5-type-tiny>,
2733             L<Type::Tiny on Travis-CI|https://travis-ci.com/tobyink/p5-type-tiny>,
2734             L<Type::Tiny on AppVeyor|https://ci.appveyor.com/project/tobyink/p5-type-tiny>,
2735             L<Type::Tiny on Codecov|https://codecov.io/gh/tobyink/p5-type-tiny>,
2736             L<Type::Tiny on Coveralls|https://coveralls.io/github/tobyink/p5-type-tiny>.
2737              
2738             =head1 AUTHOR
2739              
2740             Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
2741              
2742             =head1 THANKS
2743              
2744             Thanks to Matt S Trout for advice on L<Moo> integration.
2745              
2746             =head1 COPYRIGHT AND LICENCE
2747              
2748             This software is copyright (c) 2013-2014, 2017-2023 by Toby Inkster.
2749              
2750             This is free software; you can redistribute it and/or modify it under
2751             the same terms as the Perl 5 programming language system itself.
2752              
2753             =head1 DISCLAIMER OF WARRANTIES
2754              
2755             THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
2756             WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
2757             MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.