1package Type::Tiny; 2 3use 5.006001; 4use strict; 5use warnings; 6 7BEGIN { 8 if ( $] < 5.008 ) { require Devel::TypeTiny::Perl56Compat } 9 if ( $] < 5.010 ) { require Devel::TypeTiny::Perl58Compat } 10} 11 12BEGIN { 13 $Type::Tiny::AUTHORITY = 'cpan:TOBYINK'; 14 $Type::Tiny::VERSION = '1.012004'; 15 $Type::Tiny::XS_VERSION = '0.016'; 16} 17 18$Type::Tiny::VERSION =~ tr/_//d; 19$Type::Tiny::XS_VERSION =~ tr/_//d; 20 21use Scalar::Util qw( blessed ); 22use Types::TypeTiny (); 23 24sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak } 25 26sub _swap { $_[2] ? @_[ 1, 0 ] : @_[ 0, 1 ] } 27 28BEGIN { 29 my $support_smartmatch = 0+ !!( $] >= 5.010001 ); 30 eval qq{ sub SUPPORT_SMARTMATCH () { !! $support_smartmatch } }; 31 32 my $fixed_precedence = 0+ !!( $] >= 5.014 ); 33 eval qq{ sub _FIXED_PRECEDENCE () { !! $fixed_precedence } }; 34 35 my $try_xs = 36 exists( $ENV{PERL_TYPE_TINY_XS} ) ? !!$ENV{PERL_TYPE_TINY_XS} 37 : exists( $ENV{PERL_ONLY} ) ? !$ENV{PERL_ONLY} 38 : 1; 39 40 my $use_xs = 0; 41 $try_xs and eval { 42 require Type::Tiny::XS; 43 'Type::Tiny::XS'->VERSION( $Type::Tiny::XS_VERSION ); 44 $use_xs++; 45 }; 46 47 *_USE_XS = 48 $use_xs 49 ? sub () { !!1 } 50 : sub () { !!0 }; 51 52 *_USE_MOUSE = 53 $try_xs 54 ? sub () { $INC{'Mouse/Util.pm'} and Mouse::Util::MOUSE_XS() } 55 : sub () { !!0 }; 56} #/ BEGIN 57 58{ 59 60 sub _install_overloads { 61 no strict 'refs'; 62 no warnings 'redefine', 'once'; 63 64 # Coverage is checked on Perl 5.26 65 if ( $] < 5.010 ) { # uncoverable statement 66 require overload; # uncoverable statement 67 push @_, fallback => 1; # uncoverable statement 68 goto \&overload::OVERLOAD; # uncoverable statement 69 } 70 71 my $class = shift; 72 *{ $class . '::((' } = sub { }; 73 *{ $class . '::()' } = sub { }; 74 *{ $class . '::()' } = do { my $x = 1; \$x }; 75 while ( @_ ) { 76 my $f = shift; 77 *{ $class . '::(' . $f } = ref $_[0] ? shift : do { 78 my $m = shift; 79 sub { shift->$m( @_ ) } 80 }; 81 } 82 } #/ sub _install_overloads 83} 84 85__PACKAGE__->_install_overloads( 86 q("") => sub { 87 caller =~ m{^(Moo::HandleMoose|Sub::Quote)} 88 ? $_[0]->_stringify_no_magic 89 : $_[0]->display_name; 90 }, 91 q(bool) => sub { 1 }, 92 q(&{}) => "_overload_coderef", 93 q(|) => sub { 94 my @tc = _swap @_; 95 if ( !_FIXED_PRECEDENCE && $_[2] ) { 96 if ( blessed $tc[0] ) { 97 if ( blessed $tc[0] eq "Type::Tiny::_HalfOp" ) { 98 my $type = $tc[0]->{type}; 99 my $param = $tc[0]->{param}; 100 my $op = $tc[0]->{op}; 101 require Type::Tiny::Union; 102 return "Type::Tiny::_HalfOp"->new( 103 $op, 104 $param, 105 "Type::Tiny::Union"->new( type_constraints => [ $type, $tc[1] ] ), 106 ); 107 } #/ if ( blessed $tc[0] eq...) 108 } #/ if ( blessed $tc[0] ) 109 elsif ( ref $tc[0] eq 'ARRAY' ) { 110 require Type::Tiny::_HalfOp; 111 return "Type::Tiny::_HalfOp"->new( '|', @tc ); 112 } 113 } #/ if ( !_FIXED_PRECEDENCE...) 114 require Type::Tiny::Union; 115 return "Type::Tiny::Union"->new( type_constraints => \@tc ); 116 }, 117 q(&) => sub { 118 my @tc = _swap @_; 119 if ( !_FIXED_PRECEDENCE && $_[2] ) { 120 if ( blessed $tc[0] ) { 121 if ( blessed $tc[0] eq "Type::Tiny::_HalfOp" ) { 122 my $type = $tc[0]->{type}; 123 my $param = $tc[0]->{param}; 124 my $op = $tc[0]->{op}; 125 require Type::Tiny::Intersection; 126 return "Type::Tiny::_HalfOp"->new( 127 $op, 128 $param, 129 "Type::Tiny::Intersection"->new( type_constraints => [ $type, $tc[1] ] ), 130 ); 131 } #/ if ( blessed $tc[0] eq...) 132 } #/ if ( blessed $tc[0] ) 133 elsif ( ref $tc[0] eq 'ARRAY' ) { 134 require Type::Tiny::_HalfOp; 135 return "Type::Tiny::_HalfOp"->new( '&', @tc ); 136 } 137 } #/ if ( !_FIXED_PRECEDENCE...) 138 require Type::Tiny::Intersection; 139 "Type::Tiny::Intersection"->new( type_constraints => \@tc ); 140 }, 141 q(~) => sub { shift->complementary_type }, 142 q(==) => sub { $_[0]->equals( $_[1] ) }, 143 q(!=) => sub { not $_[0]->equals( $_[1] ) }, 144 q(<) => sub { my $m = $_[0]->can( 'is_subtype_of' ); $m->( _swap @_ ) }, 145 q(>) => sub { 146 my $m = $_[0]->can( 'is_subtype_of' ); 147 $m->( reverse _swap @_ ); 148 }, 149 q(<=) => sub { my $m = $_[0]->can( 'is_a_type_of' ); $m->( _swap @_ ) }, 150 q(>=) => sub { 151 my $m = $_[0]->can( 'is_a_type_of' ); 152 $m->( reverse _swap @_ ); 153 }, 154 q(eq) => sub { "$_[0]" eq "$_[1]" }, 155 q(cmp) => sub { $_[2] ? ( "$_[1]" cmp "$_[0]" ) : ( "$_[0]" cmp "$_[1]" ) }, 156); 157 158__PACKAGE__->_install_overloads( 159 q(~~) => sub { $_[0]->check( $_[1] ) }, 160) if Type::Tiny::SUPPORT_SMARTMATCH; 161 162# Would be easy to just return sub { $self->assert_return(@_) } 163# but try to build a more efficient coderef whenever possible. 164# 165sub _overload_coderef { 166 my $self = shift; 167 168 # Bypass generating a coderef if we've already got the best possible one. 169 # 170 return $self->{_overload_coderef} if $self->{_overload_coderef_no_rebuild}; 171 172 # Subclasses of Type::Tiny might override assert_return to do some kind 173 # of interesting thing. In that case, we can't rely on it having identical 174 # behaviour to Type::Tiny::inline_assert. 175 # 176 $self->{_overrides_assert_return} = 177 ( $self->can( 'assert_return' ) != \&assert_return ) 178 unless exists $self->{_overrides_assert_return}; 179 180 if ( $self->{_overrides_assert_return} ) { 181 $self->{_overload_coderef} ||= do { 182 Scalar::Util::weaken( my $weak = $self ); 183 sub { $weak->assert_return( @_ ) }; 184 }; 185 ++$self->{_overload_coderef_no_rebuild}; 186 } 187 elsif ( exists( &Sub::Quote::quote_sub ) ) { 188 189 # Use `=` instead of `||=` because we want to overwrite non-Sub::Quote 190 # coderef if possible. 191 $self->{_overload_coderef} = $self->can_be_inlined 192 ? Sub::Quote::quote_sub( 193 $self->inline_assert( '$_[0]' ), 194 ) 195 : Sub::Quote::quote_sub( 196 $self->inline_assert( '$_[0]', '$type' ), 197 { '$type' => \$self }, 198 ); 199 ++$self->{_overload_coderef_no_rebuild}; 200 } #/ elsif ( exists( &Sub::Quote::quote_sub...)) 201 else { 202 require Eval::TypeTiny; 203 $self->{_overload_coderef} ||= $self->can_be_inlined 204 ? Eval::TypeTiny::eval_closure( 205 source => sprintf( 206 'sub { %s }', $self->inline_assert( '$_[0]', undef, no_wrapper => 1 ) 207 ), 208 description => sprintf( "compiled assertion 'assert_%s'", $self ), 209 ) 210 : Eval::TypeTiny::eval_closure( 211 source => sprintf( 212 'sub { %s }', $self->inline_assert( '$_[0]', '$type', no_wrapper => 1 ) 213 ), 214 description => sprintf( "compiled assertion 'assert_%s'", $self ), 215 environment => { '$type' => \$self }, 216 ); 217 } #/ else [ if ( $self->{_overrides_assert_return...})] 218 219 $self->{_overload_coderef}; 220} #/ sub _overload_coderef 221 222our %ALL_TYPES; 223 224my $QFS; 225my $uniq = 1; 226my $subname; 227 228sub new { 229 my $class = shift; 230 my %params = ( @_ == 1 ) ? %{ $_[0] } : @_; 231 232 for ( qw/ name display_name library / ) { 233 $params{$_} = $params{$_} . '' if defined $params{$_}; 234 } 235 236 if ( exists $params{parent} ) { 237 $params{parent} = 238 ref( $params{parent} ) =~ /^Type::Tiny\b/ 239 ? $params{parent} 240 : Types::TypeTiny::to_TypeTiny( $params{parent} ); 241 242 _croak "Parent must be an instance of %s", __PACKAGE__ 243 unless blessed( $params{parent} ) 244 && $params{parent}->isa( __PACKAGE__ ); 245 246 if ( $params{parent}->deprecated and not exists $params{deprecated} ) { 247 $params{deprecated} = 1; 248 } 249 } #/ if ( exists $params{parent...}) 250 251 if ( exists $params{constraint} 252 and defined $params{constraint} 253 and not ref $params{constraint} ) 254 { 255 require Eval::TypeTiny; 256 my $code = $params{constraint}; 257 $params{constraint} = Eval::TypeTiny::eval_closure( 258 source => sprintf( 'sub ($) { %s }', $code ), 259 description => "anonymous check", 260 ); 261 $params{inlined} ||= sub { 262 my ( $type ) = @_; 263 my $inlined = $_ eq '$_' ? "do { $code }" : "do { local \$_ = $_; $code }"; 264 $type->has_parent ? ( undef, $inlined ) : $inlined; 265 } 266 if ( !exists $params{parent} or $params{parent}->can_be_inlined ); 267 } #/ if ( exists $params{constraint...}) 268 269 # canonicalize to a boolean 270 $params{deprecated} = !!$params{deprecated}; 271 272 $params{name} = "__ANON__" unless exists $params{name}; 273 $params{uniq} = $uniq++; 274 275 if ( $params{name} ne "__ANON__" ) { 276 277 # First try a fast ASCII-only expression, but fall back to Unicode 278 $params{name} =~ /^_{0,2}[A-Z][A-Za-z0-9_]+$/sm 279 or eval q( use 5.008; $params{name} =~ /^_{0,2}\p{Lu}[\p{L}0-9_]+$/sm ) 280 or _croak '"%s" is not a valid type name', $params{name}; 281 } 282 283 if ( exists $params{coercion} and !ref $params{coercion} and $params{coercion} ) 284 { 285 $params{parent}->has_coercion 286 or _croak 287 "coercion => 1 requires type to have a direct parent with a coercion"; 288 289 $params{coercion} = $params{parent}->coercion->type_coercion_map; 290 } 291 292 if ( !exists $params{inlined} 293 and exists $params{constraint} 294 and ( !exists $params{parent} or $params{parent}->can_be_inlined ) 295 and $QFS ||= "Sub::Quote"->can( "quoted_from_sub" ) ) 296 { 297 my ( undef, $perlstring, $captures ) = @{ $QFS->( $params{constraint} ) || [] }; 298 299 $params{inlined} = sub { 300 my ( $self, $var ) = @_; 301 my $code = Sub::Quote::inlinify( 302 $perlstring, 303 $var, 304 $var eq q($_) ? '' : "local \$_ = $var;", 305 1, 306 ); 307 $code = sprintf( '%s and %s', $self->parent->inline_check( $var ), $code ) 308 if $self->has_parent; 309 return $code; 310 } 311 if $perlstring && !$captures; 312 } #/ if ( !exists $params{inlined...}) 313 314 my $self = bless \%params, $class; 315 316 unless ( $params{tmp} ) { 317 my $uniq = $self->{uniq}; 318 319 $ALL_TYPES{$uniq} = $self; 320 Scalar::Util::weaken( $ALL_TYPES{$uniq} ); 321 322 my $tmp = $self; 323 Scalar::Util::weaken( $tmp ); 324 $Moo::HandleMoose::TYPE_MAP{ $self->_stringify_no_magic } = sub { $tmp }; 325 } #/ unless ( $params{tmp} ) 326 327 if ( ref( $params{coercion} ) eq q(CODE) ) { 328 require Types::Standard; 329 my $code = delete( $params{coercion} ); 330 $self->{coercion} = $self->_build_coercion; 331 $self->coercion->add_type_coercions( Types::Standard::Any(), $code ); 332 } 333 elsif ( ref( $params{coercion} ) eq q(ARRAY) ) { 334 my $arr = delete( $params{coercion} ); 335 $self->{coercion} = $self->_build_coercion; 336 $self->coercion->add_type_coercions( @$arr ); 337 } 338 339 # Documenting this here because it's too weird to be in the pod. 340 # There's a secret attribute called "_build_coercion" which takes a 341 # coderef. If present, then when $type->coercion is lazy built, 342 # the blank Type::Coercion object gets passed to the coderef, 343 # allowing the coderef to manipulate it a little. This is used by 344 # Types::TypeTiny to allow it to build a coercion for the TypeTiny 345 # type constraint without needing to load Type::Coercion yet. 346 347 if ( $params{my_methods} ) { 348 $subname = 349 eval { require Sub::Util } ? \&Sub::Util::set_subname 350 : eval { require Sub::Name } ? \&Sub::Name::subname 351 : 0 352 if not defined $subname; 353 if ( $subname ) { 354 ( Scalar::Util::reftype( $params{my_methods}{$_} ) eq 'CODE' ) && $subname->( 355 sprintf( "%s::my_%s", $self->qualified_name, $_ ), 356 $params{my_methods}{$_}, 357 ) for keys %{ $params{my_methods} }; 358 } 359 } #/ if ( $params{my_methods...}) 360 361 return $self; 362} #/ sub new 363 364sub DESTROY { 365 my $self = shift; 366 delete( $ALL_TYPES{ $self->{uniq} } ); 367 delete( $Moo::HandleMoose::TYPE_MAP{ $self->_stringify_no_magic } ); 368 return; 369} 370 371sub _clone { 372 my $self = shift; 373 my %opts; 374 $opts{$_} = $self->{$_} for qw< name display_name message >; 375 $self->create_child_type( %opts ); 376} 377 378sub _stringify_no_magic { 379 sprintf( 380 '%s=%s(0x%08x)', blessed( $_[0] ), Scalar::Util::reftype( $_[0] ), 381 Scalar::Util::refaddr( $_[0] ) 382 ); 383} 384 385our $DD; 386 387sub _dd { 388 @_ = $_ unless @_; 389 my ( $value ) = @_; 390 391 goto $DD if ref( $DD ) eq q(CODE); 392 393 require B; 394 395 !defined $value ? 'Undef' 396 : !ref $value ? sprintf( 'Value %s', B::perlstring( $value ) ) 397 : do { 398 my $N = 0+ ( defined( $DD ) ? $DD : 72 ); 399 require Data::Dumper; 400 local $Data::Dumper::Indent = 0; 401 local $Data::Dumper::Useqq = 1; 402 local $Data::Dumper::Terse = 1; 403 local $Data::Dumper::Sortkeys = 1; 404 local $Data::Dumper::Maxdepth = 2; 405 my $str; 406 eval { 407 $str = Data::Dumper::Dumper( $value ); 408 $str = substr( $str, 0, $N - 12 ) . '...' . substr( $str, -1, 1 ) 409 if length( $str ) >= $N; 410 1; 411 } or do { $str = 'which cannot be dumped' }; 412 "Reference $str"; 413 } #/ do 414} #/ sub _dd 415 416sub _loose_to_TypeTiny { 417 map +( 418 ref( $_ ) 419 ? Types::TypeTiny::to_TypeTiny( $_ ) 420 : do { require Type::Utils; Type::Utils::dwim_type( $_ ) } 421 ), @_; 422} 423 424sub name { $_[0]{name} } 425sub display_name { $_[0]{display_name} ||= $_[0]->_build_display_name } 426sub parent { $_[0]{parent} } 427sub constraint { $_[0]{constraint} ||= $_[0]->_build_constraint } 428 429sub compiled_check { 430 $_[0]{compiled_type_constraint} ||= $_[0]->_build_compiled_check; 431} 432sub coercion { $_[0]{coercion} ||= $_[0]->_build_coercion } 433sub message { $_[0]{message} } 434sub library { $_[0]{library} } 435sub inlined { $_[0]{inlined} } 436sub deprecated { $_[0]{deprecated} } 437sub constraint_generator { $_[0]{constraint_generator} } 438sub inline_generator { $_[0]{inline_generator} } 439sub name_generator { $_[0]{name_generator} ||= $_[0]->_build_name_generator } 440sub coercion_generator { $_[0]{coercion_generator} } 441sub parameters { $_[0]{parameters} } 442sub moose_type { $_[0]{moose_type} ||= $_[0]->_build_moose_type } 443sub mouse_type { $_[0]{mouse_type} ||= $_[0]->_build_mouse_type } 444sub deep_explanation { $_[0]{deep_explanation} } 445sub my_methods { $_[0]{my_methods} ||= $_[0]->_build_my_methods } 446sub sorter { $_[0]{sorter} } 447 448sub has_parent { exists $_[0]{parent} } 449sub has_library { exists $_[0]{library} } 450sub has_inlined { exists $_[0]{inlined} } 451sub has_constraint_generator { exists $_[0]{constraint_generator} } 452sub has_inline_generator { exists $_[0]{inline_generator} } 453sub has_coercion_generator { exists $_[0]{coercion_generator} } 454sub has_parameters { exists $_[0]{parameters} } 455sub has_message { defined $_[0]{message} } 456sub has_deep_explanation { exists $_[0]{deep_explanation} } 457sub has_sorter { exists $_[0]{sorter} } 458 459sub _default_message { 460 $_[0]{_default_message} ||= $_[0]->_build_default_message; 461} 462 463sub has_coercion { 464 $_[0]->coercion if $_[0]{_build_coercion}; # trigger auto build thing 465 $_[0]{coercion} and !!@{ $_[0]{coercion}->type_coercion_map }; 466} 467 468sub _assert_coercion { 469 my $self = shift; 470 return $self->coercion if $self->{_build_coercion}; # trigger auto build thing 471 _croak "No coercion for this type constraint" 472 unless $self->has_coercion 473 && @{ $self->coercion->type_coercion_map }; 474 $self->coercion; 475} 476 477my $null_constraint = sub { !!1 }; 478 479sub _build_display_name { 480 shift->name; 481} 482 483sub _build_constraint { 484 return $null_constraint; 485} 486 487sub _is_null_constraint { 488 shift->constraint == $null_constraint; 489} 490 491sub _build_coercion { 492 require Type::Coercion; 493 my $self = shift; 494 my %opts = ( type_constraint => $self ); 495 $opts{display_name} = "to_$self" unless $self->is_anon; 496 my $coercion = "Type::Coercion"->new( %opts ); 497 $self->{_build_coercion}->( $coercion ) if ref $self->{_build_coercion}; 498 $coercion; 499} 500 501sub _build_default_message { 502 my $self = shift; 503 $self->{is_using_default_message} = 1; 504 return sub { sprintf '%s did not pass type constraint', _dd( $_[0] ) } 505 if "$self" eq "__ANON__"; 506 my $name = "$self"; 507 return sub { 508 sprintf '%s did not pass type constraint "%s"', _dd( $_[0] ), $name; 509 }; 510} #/ sub _build_default_message 511 512sub _build_name_generator { 513 my $self = shift; 514 return sub { 515 my ( $s, @a ) = @_; 516 sprintf( '%s[%s]', $s, join q[,], @a ); 517 }; 518} 519 520sub _build_compiled_check { 521 my $self = shift; 522 523 local our $AvoidCallbacks = 0; 524 525 if ( $self->_is_null_constraint and $self->has_parent ) { 526 return $self->parent->compiled_check; 527 } 528 529 require Eval::TypeTiny; 530 return Eval::TypeTiny::eval_closure( 531 source => sprintf( 'sub ($) { %s }', $self->inline_check( '$_[0]' ) ), 532 description => sprintf( "compiled check '%s'", $self ), 533 ) if $self->can_be_inlined; 534 535 my @constraints; 536 push @constraints, $self->parent->compiled_check if $self->has_parent; 537 push @constraints, $self->constraint if !$self->_is_null_constraint; 538 return $null_constraint unless @constraints; 539 540 return sub ($) { 541 local $_ = $_[0]; 542 for my $c ( @constraints ) { 543 return unless $c->( @_ ); 544 } 545 return !!1; 546 }; 547} #/ sub _build_compiled_check 548 549sub find_constraining_type { 550 my $self = shift; 551 if ( $self->_is_null_constraint and $self->has_parent ) { 552 return $self->parent->find_constraining_type; 553 } 554 $self; 555} 556 557our @CMP; 558 559sub CMP_SUPERTYPE () { -1 } 560sub CMP_EQUAL () { 0 } 561sub CMP_EQUIVALENT () { '0E0' } 562sub CMP_SUBTYPE () { 1 } 563sub CMP_UNKNOWN () { ''; } 564 565# avoid getting mixed up with cmp operator at compile time 566*cmp = sub { 567 my ( $A, $B ) = _loose_to_TypeTiny( $_[0], $_[1] ); 568 return unless blessed( $A ) && $A->isa( "Type::Tiny" ); 569 return unless blessed( $B ) && $B->isa( "Type::Tiny" ); 570 for my $comparator ( @CMP ) { 571 my $result = $comparator->( $A, $B ); 572 next if $result eq CMP_UNKNOWN; 573 if ( $result eq CMP_EQUIVALENT ) { 574 my $prefer = @_ == 3 ? $_[2] : CMP_EQUAL; 575 return $prefer; 576 } 577 return $result; 578 } 579 return CMP_UNKNOWN; 580}; 581 582push @CMP, sub { 583 my ( $A, $B ) = @_; 584 return CMP_EQUAL 585 if Scalar::Util::refaddr( $A ) == Scalar::Util::refaddr( $B ); 586 587 return CMP_EQUIVALENT 588 if Scalar::Util::refaddr( $A->compiled_check ) == 589 Scalar::Util::refaddr( $B->compiled_check ); 590 591 my $A_stem = $A->find_constraining_type; 592 my $B_stem = $B->find_constraining_type; 593 return CMP_EQUIVALENT 594 if Scalar::Util::refaddr( $A_stem ) == Scalar::Util::refaddr( $B_stem ); 595 return CMP_EQUIVALENT 596 if Scalar::Util::refaddr( $A_stem->compiled_check ) == 597 Scalar::Util::refaddr( $B_stem->compiled_check ); 598 599 if ( $A_stem->can_be_inlined and $B_stem->can_be_inlined ) { 600 return 0 601 if $A_stem->inline_check( '$WOLFIE' ) eq $B_stem->inline_check( '$WOLFIE' ); 602 } 603 604 A_IS_SUBTYPE: { 605 my $A_prime = $A_stem; 606 while ( $A_prime->has_parent ) { 607 $A_prime = $A_prime->parent; 608 return CMP_SUBTYPE 609 if Scalar::Util::refaddr( $A_prime ) == Scalar::Util::refaddr( $B_stem ); 610 return CMP_SUBTYPE 611 if Scalar::Util::refaddr( $A_prime->compiled_check ) == 612 Scalar::Util::refaddr( $B_stem->compiled_check ); 613 if ( $A_prime->can_be_inlined and $B_stem->can_be_inlined ) { 614 return CMP_SUBTYPE 615 if $A_prime->inline_check( '$WOLFIE' ) eq $B_stem->inline_check( '$WOLFIE' ); 616 } 617 } #/ while ( $A_prime->has_parent) 618 } #/ A_IS_SUBTYPE: 619 620 B_IS_SUBTYPE: { 621 my $B_prime = $B_stem; 622 while ( $B_prime->has_parent ) { 623 $B_prime = $B_prime->parent; 624 return CMP_SUPERTYPE 625 if Scalar::Util::refaddr( $B_prime ) == Scalar::Util::refaddr( $A_stem ); 626 return CMP_SUPERTYPE 627 if Scalar::Util::refaddr( $B_prime->compiled_check ) == 628 Scalar::Util::refaddr( $A_stem->compiled_check ); 629 if ( $A_stem->can_be_inlined and $B_prime->can_be_inlined ) { 630 return CMP_SUPERTYPE 631 if $B_prime->inline_check( '$WOLFIE' ) eq $A_stem->inline_check( '$WOLFIE' ); 632 } 633 } #/ while ( $B_prime->has_parent) 634 } #/ B_IS_SUBTYPE: 635 636 return CMP_UNKNOWN; 637}; 638 639sub equals { 640 my $result = Type::Tiny::cmp( $_[0], $_[1] ); 641 return unless defined $result; 642 $result eq CMP_EQUAL; 643} 644 645sub is_subtype_of { 646 my $result = Type::Tiny::cmp( $_[0], $_[1], CMP_SUBTYPE ); 647 return unless defined $result; 648 $result eq CMP_SUBTYPE; 649} 650 651sub is_supertype_of { 652 my $result = Type::Tiny::cmp( $_[0], $_[1], CMP_SUBTYPE ); 653 return unless defined $result; 654 $result eq CMP_SUPERTYPE; 655} 656 657sub is_a_type_of { 658 my $result = Type::Tiny::cmp( $_[0], $_[1] ); 659 return unless defined $result; 660 $result eq CMP_SUBTYPE or $result eq CMP_EQUAL or $result eq CMP_EQUIVALENT; 661} 662 663sub strictly_equals { 664 my ( $self, $other ) = _loose_to_TypeTiny( @_ ); 665 return unless blessed( $self ) && $self->isa( "Type::Tiny" ); 666 return unless blessed( $other ) && $other->isa( "Type::Tiny" ); 667 $self->{uniq} == $other->{uniq}; 668} 669 670sub is_strictly_subtype_of { 671 my ( $self, $other ) = _loose_to_TypeTiny( @_ ); 672 return unless blessed( $self ) && $self->isa( "Type::Tiny" ); 673 return unless blessed( $other ) && $other->isa( "Type::Tiny" ); 674 675 return unless $self->has_parent; 676 $self->parent->strictly_equals( $other ) 677 or $self->parent->is_strictly_subtype_of( $other ); 678} 679 680sub is_strictly_supertype_of { 681 my ( $self, $other ) = _loose_to_TypeTiny( @_ ); 682 return unless blessed( $self ) && $self->isa( "Type::Tiny" ); 683 return unless blessed( $other ) && $other->isa( "Type::Tiny" ); 684 685 $other->is_strictly_subtype_of( $self ); 686} 687 688sub is_strictly_a_type_of { 689 my ( $self, $other ) = _loose_to_TypeTiny( @_ ); 690 return unless blessed( $self ) && $self->isa( "Type::Tiny" ); 691 return unless blessed( $other ) && $other->isa( "Type::Tiny" ); 692 693 $self->strictly_equals( $other ) or $self->is_strictly_subtype_of( $other ); 694} 695 696sub qualified_name { 697 my $self = shift; 698 ( exists $self->{library} and $self->name ne "__ANON__" ) 699 ? "$self->{library}::$self->{name}" 700 : $self->{name}; 701} 702 703sub is_anon { 704 my $self = shift; 705 $self->name eq "__ANON__"; 706} 707 708sub parents { 709 my $self = shift; 710 return unless $self->has_parent; 711 return ( $self->parent, $self->parent->parents ); 712} 713 714sub find_parent { 715 my $self = shift; 716 my ( $test ) = @_; 717 718 local ( $_, $. ); 719 my $type = $self; 720 my $count = 0; 721 while ( $type ) { 722 if ( $test->( $_ = $type, $. = $count ) ) { 723 return wantarray ? ( $type, $count ) : $type; 724 } 725 else { 726 $type = $type->parent; 727 $count++; 728 } 729 } 730 731 return; 732} #/ sub find_parent 733 734sub check { 735 my $self = shift; 736 ( $self->{compiled_type_constraint} ||= $self->_build_compiled_check )->( @_ ); 737} 738 739sub _strict_check { 740 my $self = shift; 741 local $_ = $_[0]; 742 743 my @constraints = 744 reverse 745 map { $_->constraint } 746 grep { not $_->_is_null_constraint } ( $self, $self->parents ); 747 748 for my $c ( @constraints ) { 749 return unless $c->( @_ ); 750 } 751 752 return !!1; 753} #/ sub _strict_check 754 755sub get_message { 756 my $self = shift; 757 local $_ = $_[0]; 758 $self->has_message 759 ? $self->message->( @_ ) 760 : $self->_default_message->( @_ ); 761} 762 763sub validate { 764 my $self = shift; 765 766 return undef 767 if ( $self->{compiled_type_constraint} ||= $self->_build_compiled_check ) 768 ->( @_ ); 769 770 local $_ = $_[0]; 771 return $self->get_message( @_ ); 772} #/ sub validate 773 774sub validate_explain { 775 my $self = shift; 776 my ( $value, $varname ) = @_; 777 $varname = '$_' unless defined $varname; 778 779 return undef if $self->check( $value ); 780 781 if ( $self->has_parent ) { 782 my $parent = $self->parent->validate_explain( $value, $varname ); 783 return [ 784 sprintf( '"%s" is a subtype of "%s"', $self, $self->parent ), 785 @$parent 786 ] 787 if $parent; 788 } 789 790 my $message = sprintf( 791 '%s%s', 792 $self->get_message( $value ), 793 $varname eq q{$_} ? '' : sprintf( ' (in %s)', $varname ), 794 ); 795 796 if ( $self->is_parameterized and $self->parent->has_deep_explanation ) { 797 my $deep = $self->parent->deep_explanation->( $self, $value, $varname ); 798 return [ $message, @$deep ] if $deep; 799 } 800 801 return [ 802 $message, 803 sprintf( '"%s" is defined as: %s', $self, $self->_perlcode ) 804 ]; 805} #/ sub validate_explain 806 807my $b; 808 809sub _perlcode { 810 my $self = shift; 811 812 local our $AvoidCallbacks = 1; 813 return $self->inline_check( '$_' ) 814 if $self->can_be_inlined; 815 816 $b ||= do { 817 require B::Deparse; 818 my $tmp = "B::Deparse"->new; 819 $tmp->ambient_pragmas( strict => "all", warnings => "all" ) 820 if $tmp->can( 'ambient_pragmas' ); 821 $tmp; 822 }; 823 824 my $code = $b->coderef2text( $self->constraint ); 825 $code =~ s/\s+/ /g; 826 return "sub $code"; 827} #/ sub _perlcode 828 829sub assert_valid { 830 my $self = shift; 831 832 return !!1 833 if ( $self->{compiled_type_constraint} ||= $self->_build_compiled_check ) 834 ->( @_ ); 835 836 local $_ = $_[0]; 837 $self->_failed_check( "$self", $_ ); 838} #/ sub assert_valid 839 840sub assert_return { 841 my $self = shift; 842 843 return $_[0] 844 if ( $self->{compiled_type_constraint} ||= $self->_build_compiled_check ) 845 ->( @_ ); 846 847 local $_ = $_[0]; 848 $self->_failed_check( "$self", $_ ); 849} #/ sub assert_return 850 851sub can_be_inlined { 852 my $self = shift; 853 return $self->parent->can_be_inlined 854 if $self->has_parent && $self->_is_null_constraint; 855 return !!1 856 if !$self->has_parent && $self->_is_null_constraint; 857 return $self->has_inlined; 858} 859 860sub inline_check { 861 my $self = shift; 862 _croak 'Cannot inline type constraint check for "%s"', $self 863 unless $self->can_be_inlined; 864 865 return $self->parent->inline_check( @_ ) 866 if $self->has_parent && $self->_is_null_constraint; 867 return '(!!1)' 868 if !$self->has_parent && $self->_is_null_constraint; 869 870 local $_ = $_[0]; 871 my @r = $self->inlined->( $self, @_ ); 872 if ( @r and not defined $r[0] ) { 873 _croak 'Inlining type constraint check for "%s" returned undef!', $self 874 unless $self->has_parent; 875 $r[0] = $self->parent->inline_check( @_ ); 876 } 877 my $r = join " && " => map { 878 /[;{}]/ && !/\Ado \{.+\}\z/ 879 ? "do { package Type::Tiny; $_ }" 880 : "($_)" 881 } @r; 882 return @r == 1 ? $r : "($r)"; 883} #/ sub inline_check 884 885sub inline_assert { 886 require B; 887 my $self = shift; 888 my ( $varname, $typevarname, %extras ) = @_; 889 890 my $inline_check; 891 if ( $self->can_be_inlined ) { 892 $inline_check = sprintf( '(%s)', $self->inline_check( $varname ) ); 893 } 894 elsif ( $typevarname ) { 895 $inline_check = sprintf( '%s->check(%s)', $typevarname, $varname ); 896 } 897 else { 898 _croak 'Cannot inline type constraint check for "%s"', $self; 899 } 900 901 my $do_wrapper = !delete $extras{no_wrapper}; 902 903 my $inline_throw; 904 if ( $typevarname ) { 905 $inline_throw = sprintf( 906 'Type::Tiny::_failed_check(%s, %s, %s, %s)', 907 $typevarname, 908 B::perlstring( "$self" ), 909 $varname, 910 join( 911 ',', map +( B::perlstring( $_ ) => B::perlstring( $extras{$_} ) ), 912 sort keys %extras 913 ), 914 ); 915 } #/ if ( $typevarname ) 916 else { 917 $inline_throw = sprintf( 918 'Type::Tiny::_failed_check(%s, %s, %s, %s)', 919 $self->{uniq}, 920 B::perlstring( "$self" ), 921 $varname, 922 join( 923 ',', map +( B::perlstring( $_ ) => B::perlstring( $extras{$_} ) ), 924 sort keys %extras 925 ), 926 ); 927 } #/ else [ if ( $typevarname ) ] 928 929 $do_wrapper 930 ? qq[do { no warnings "void"; package Type::Tiny; $inline_check or $inline_throw; $varname };] 931 : qq[ no warnings "void"; package Type::Tiny; $inline_check or $inline_throw; $varname ]; 932} #/ sub inline_assert 933 934sub _failed_check { 935 require Error::TypeTiny::Assertion; 936 937 my ( $self, $name, $value, %attrs ) = @_; 938 $self = $ALL_TYPES{$self} if defined $self && !ref $self; 939 940 my $exception_class = 941 delete( $attrs{exception_class} ) || "Error::TypeTiny::Assertion"; 942 943 if ( $self ) { 944 $exception_class->throw( 945 message => $self->get_message( $value ), 946 type => $self, 947 value => $value, 948 %attrs, 949 ); 950 } 951 else { 952 $exception_class->throw( 953 message => 954 sprintf( '%s did not pass type constraint "%s"', _dd( $value ), $name ), 955 value => $value, 956 %attrs, 957 ); 958 } 959} #/ sub _failed_check 960 961sub coerce { 962 my $self = shift; 963 $self->_assert_coercion->coerce( @_ ); 964} 965 966sub assert_coerce { 967 my $self = shift; 968 $self->_assert_coercion->assert_coerce( @_ ); 969} 970 971sub is_parameterizable { 972 shift->has_constraint_generator; 973} 974 975sub is_parameterized { 976 shift->has_parameters; 977} 978 979{ 980 my %seen; 981 982 sub ____make_key { 983 #<<< 984 join ',', map { 985 Types::TypeTiny::is_TypeTiny( $_ ) ? sprintf( '$Type::Tiny::ALL_TYPES{%s}', defined( $_->{uniq} ) ? $_->{uniq} : '____CANNOT_KEY____' ) : 986 ref() eq 'ARRAY' ? do { $seen{$_}++ ? '____CANNOT_KEY____' : sprintf( '[%s]', ____make_key( @$_ ) ) } : 987 ref() eq 'HASH' ? do { $seen{$_}++ ? '____CANNOT_KEY____' : sprintf( '{%s}', ____make_key( %$_ ) ) } : 988 ref() eq 'SCALAR' || ref() eq 'REF' ? do { $seen{$_}++ ? '____CANNOT_KEY____' : sprintf( '\\(%s)', ____make_key( $$_ ) ) } : 989 !defined() ? 'undef' : 990 !ref() ? do { require B; B::perlstring( $_ ) } : 991 '____CANNOT_KEY____'; 992 } @_; 993 #>>> 994 } #/ sub ____make_key 995 my %param_cache; 996 997 sub parameterize { 998 my $self = shift; 999 1000 $self->is_parameterizable 1001 or @_ 1002 ? _croak( "Type '%s' does not accept parameters", "$self" ) 1003 : return ( $self ); 1004 1005 @_ = map Types::TypeTiny::to_TypeTiny( $_ ), @_; 1006 1007 # Generate a key for caching parameterized type constraints, 1008 # but only if all the parameters are strings or type constraints. 1009 %seen = (); 1010 my $key = $self->____make_key( @_ ); 1011 undef( $key ) if $key =~ /____CANNOT_KEY____/; 1012 return $param_cache{$key} if defined $key && defined $param_cache{$key}; 1013 1014 local $Type::Tiny::parameterize_type = $self; 1015 local $_ = $_[0]; 1016 my $P; 1017 1018 my ( $constraint, $compiled ) = $self->constraint_generator->( @_ ); 1019 1020 if ( Types::TypeTiny::is_TypeTiny( $constraint ) ) { 1021 $P = $constraint; 1022 } 1023 else { 1024 my %options = ( 1025 constraint => $constraint, 1026 display_name => $self->name_generator->( $self, @_ ), 1027 parameters => [@_], 1028 ); 1029 $options{compiled_type_constraint} = $compiled 1030 if $compiled; 1031 $options{inlined} = $self->inline_generator->( @_ ) 1032 if $self->has_inline_generator; 1033 exists $options{$_} && !defined $options{$_} && delete $options{$_} 1034 for keys %options; 1035 1036 $P = $self->create_child_type( %options ); 1037 1038 if ( $self->has_coercion_generator ) { 1039 my @args = @_; 1040 $P->{_build_coercion} = sub { 1041 my $coercion = shift; 1042 my $built = $self->coercion_generator->( $self, $P, @args ); 1043 $coercion->add_type_coercions( @{ $built->type_coercion_map } ) if $built; 1044 $coercion->freeze; 1045 }; 1046 } 1047 } #/ else [ if ( Types::TypeTiny::is_TypeTiny...)] 1048 1049 if ( defined $key ) { 1050 $param_cache{$key} = $P; 1051 Scalar::Util::weaken( $param_cache{$key} ); 1052 } 1053 1054 $P->coercion->freeze unless $self->has_coercion_generator; 1055 1056 return $P; 1057 } #/ sub parameterize 1058} 1059 1060sub child_type_class { 1061 __PACKAGE__; 1062} 1063 1064sub create_child_type { 1065 my $self = shift; 1066 my %moreopts; 1067 $moreopts{is_object} = 1 if $self->{is_object}; 1068 return $self->child_type_class->new( parent => $self, %moreopts, @_ ); 1069} 1070 1071sub complementary_type { 1072 my $self = shift; 1073 my $r = ( $self->{complementary_type} ||= $self->_build_complementary_type ); 1074 Scalar::Util::weaken( $self->{complementary_type} ) 1075 unless Scalar::Util::isweak( $self->{complementary_type} ); 1076 return $r; 1077} 1078 1079sub _build_complementary_type { 1080 my $self = shift; 1081 my %opts = ( 1082 constraint => sub { not $self->check( $_ ) }, 1083 display_name => sprintf( "~%s", $self ), 1084 ); 1085 $opts{display_name} =~ s/^\~{2}//; 1086 $opts{inlined} = sub { shift; "not(" . $self->inline_check( @_ ) . ")" } 1087 if $self->can_be_inlined; 1088 $opts{display_name} = $opts{name} = $self->{complement_name} 1089 if $self->{complement_name}; 1090 return "Type::Tiny"->new( %opts ); 1091} #/ sub _build_complementary_type 1092 1093sub _instantiate_moose_type { 1094 my $self = shift; 1095 my %opts = @_; 1096 require Moose::Meta::TypeConstraint; 1097 return "Moose::Meta::TypeConstraint"->new( %opts ); 1098} 1099 1100sub _build_moose_type { 1101 my $self = shift; 1102 1103 my $r; 1104 if ( $self->{_is_core} ) { 1105 require Moose::Util::TypeConstraints; 1106 $r = Moose::Util::TypeConstraints::find_type_constraint( $self->name ); 1107 $r->{"Types::TypeTiny::to_TypeTiny"} = $self; 1108 Scalar::Util::weaken( $r->{"Types::TypeTiny::to_TypeTiny"} ); 1109 } 1110 else { 1111 # Type::Tiny is more flexible than Moose, allowing 1112 # inlined to return a list. So we need to wrap the 1113 # inlined coderef to make sure Moose gets a single 1114 # string. 1115 # 1116 my $wrapped_inlined = sub { 1117 shift; 1118 $self->inline_check( @_ ); 1119 }; 1120 1121 my %opts; 1122 $opts{name} = $self->qualified_name if $self->has_library && !$self->is_anon; 1123 $opts{parent} = $self->parent->moose_type if $self->has_parent; 1124 $opts{constraint} = $self->constraint unless $self->_is_null_constraint; 1125 $opts{message} = $self->message if $self->has_message; 1126 $opts{inlined} = $wrapped_inlined if $self->has_inlined; 1127 1128 $r = $self->_instantiate_moose_type( %opts ); 1129 $r->{"Types::TypeTiny::to_TypeTiny"} = $self; 1130 $self->{moose_type} = $r; # prevent recursion 1131 $r->coercion( $self->coercion->moose_coercion ) if $self->has_coercion; 1132 } #/ else [ if ( $self->{_is_core})] 1133 1134 return $r; 1135} #/ sub _build_moose_type 1136 1137sub _build_mouse_type { 1138 my $self = shift; 1139 1140 my %options; 1141 $options{name} = $self->qualified_name if $self->has_library && !$self->is_anon; 1142 $options{parent} = $self->parent->mouse_type if $self->has_parent; 1143 $options{constraint} = $self->constraint unless $self->_is_null_constraint; 1144 $options{message} = $self->message if $self->has_message; 1145 1146 require Mouse::Meta::TypeConstraint; 1147 my $r = "Mouse::Meta::TypeConstraint"->new( %options ); 1148 1149 $self->{mouse_type} = $r; # prevent recursion 1150 $r->_add_type_coercions( 1151 $self->coercion->freeze->_codelike_type_coercion_map( 'mouse_type' ) ) 1152 if $self->has_coercion; 1153 1154 return $r; 1155} #/ sub _build_mouse_type 1156 1157sub _process_coercion_list { 1158 my $self = shift; 1159 1160 my @pairs; 1161 while ( @_ ) { 1162 my $next = shift; 1163 if ( blessed( $next ) 1164 and $next->isa( 'Type::Coercion' ) 1165 and $next->is_parameterized ) 1166 { 1167 push @pairs => ( @{ $next->_reparameterize( $self )->type_coercion_map } ); 1168 } 1169 elsif ( blessed( $next ) and $next->can( 'type_coercion_map' ) ) { 1170 push @pairs => ( 1171 @{ $next->type_coercion_map }, 1172 ); 1173 } 1174 elsif ( ref( $next ) eq q(ARRAY) ) { 1175 unshift @_, @$next; 1176 } 1177 else { 1178 push @pairs => ( 1179 Types::TypeTiny::to_TypeTiny( $next ), 1180 shift, 1181 ); 1182 } 1183 } #/ while ( @_ ) 1184 1185 return @pairs; 1186} #/ sub _process_coercion_list 1187 1188sub plus_coercions { 1189 my $self = shift; 1190 my $new = $self->_clone; 1191 $new->coercion->add_type_coercions( 1192 $self->_process_coercion_list( @_ ), 1193 @{ $self->coercion->type_coercion_map }, 1194 ); 1195 $new->coercion->freeze; 1196 return $new; 1197} #/ sub plus_coercions 1198 1199sub plus_fallback_coercions { 1200 my $self = shift; 1201 1202 my $new = $self->_clone; 1203 $new->coercion->add_type_coercions( 1204 @{ $self->coercion->type_coercion_map }, 1205 $self->_process_coercion_list( @_ ), 1206 ); 1207 $new->coercion->freeze; 1208 return $new; 1209} #/ sub plus_fallback_coercions 1210 1211sub minus_coercions { 1212 my $self = shift; 1213 1214 my $new = $self->_clone; 1215 my @not = grep Types::TypeTiny::is_TypeTiny( $_ ), 1216 $self->_process_coercion_list( $new, @_ ); 1217 1218 my @keep; 1219 my $c = $self->coercion->type_coercion_map; 1220 for ( my $i = 0 ; $i <= $#$c ; $i += 2 ) { 1221 my $keep_this = 1; 1222 NOT: for my $n ( @not ) { 1223 if ( $c->[$i] == $n ) { 1224 $keep_this = 0; 1225 last NOT; 1226 } 1227 } 1228 1229 push @keep, $c->[$i], $c->[ $i + 1 ] if $keep_this; 1230 } #/ for ( my $i = 0 ; $i <=...) 1231 1232 $new->coercion->add_type_coercions( @keep ); 1233 $new->coercion->freeze; 1234 return $new; 1235} #/ sub minus_coercions 1236 1237sub no_coercions { 1238 my $new = shift->_clone; 1239 $new->coercion->freeze; 1240 $new; 1241} 1242 1243sub coercibles { 1244 my $self = shift; 1245 $self->has_coercion ? $self->coercion->_source_type_union : $self; 1246} 1247 1248sub isa { 1249 my $self = shift; 1250 1251 if ( $INC{"Moose.pm"} 1252 and ref( $self ) 1253 and $_[0] =~ /^(?:Class::MOP|MooseX?::Meta)::(.+)$/ ) 1254 { 1255 my $meta = $1; 1256 1257 return !!1 if $meta eq 'TypeConstraint'; 1258 return $self->is_parameterized if $meta eq 'TypeConstraint::Parameterized'; 1259 return $self->is_parameterizable if $meta eq 'TypeConstraint::Parameterizable'; 1260 return $self->isa( 'Type::Tiny::Union' ) if $meta eq 'TypeConstraint::Union'; 1261 1262 my $inflate = $self->moose_type; 1263 return $inflate->isa( @_ ); 1264 } #/ if ( $INC{"Moose.pm"} ...) 1265 1266 if ( $INC{"Mouse.pm"} 1267 and ref( $self ) 1268 and $_[0] eq 'Mouse::Meta::TypeConstraint' ) 1269 { 1270 return !!1; 1271 } 1272 1273 $self->SUPER::isa( @_ ); 1274} #/ sub isa 1275 1276sub _build_my_methods { 1277 return {}; 1278} 1279 1280sub _lookup_my_method { 1281 my $self = shift; 1282 my ( $name ) = @_; 1283 1284 if ( $self->my_methods->{$name} ) { 1285 return $self->my_methods->{$name}; 1286 } 1287 1288 if ( $self->has_parent ) { 1289 return $self->parent->_lookup_my_method( @_ ); 1290 } 1291 1292 return; 1293} #/ sub _lookup_my_method 1294 1295my %object_methods = ( 1296 with_attribute_values => 1, stringifies_to => 1, 1297 numifies_to => 1 1298); 1299 1300sub can { 1301 my $self = shift; 1302 1303 return !!0 1304 if $_[0] eq 'type_parameter' 1305 && blessed( $_[0] ) 1306 && $_[0]->has_parameters; 1307 1308 my $can = $self->SUPER::can( @_ ); 1309 return $can if $can; 1310 1311 if ( ref( $self ) ) { 1312 if ( $INC{"Moose.pm"} ) { 1313 my $method = $self->moose_type->can( @_ ); 1314 return sub { shift->moose_type->$method( @_ ) } 1315 if $method; 1316 } 1317 if ( $_[0] =~ /\Amy_(.+)\z/ ) { 1318 my $method = $self->_lookup_my_method( $1 ); 1319 return $method if $method; 1320 } 1321 if ( $self->{is_object} && $object_methods{ $_[0] } ) { 1322 require Type::Tiny::ConstrainedObject; 1323 return Type::Tiny::ConstrainedObject->can( $_[0] ); 1324 } 1325 for my $util ( qw/ grep map sort rsort first any all assert_any assert_all / ) { 1326 if ( $_[0] eq $util ) { 1327 $self->{'_util'}{$util} ||= eval { $self->_build_util( $util ) }; 1328 return unless $self->{'_util'}{$util}; 1329 return sub { my $s = shift; $s->{'_util'}{$util}( @_ ) }; 1330 } 1331 } 1332 } #/ if ( ref( $self ) ) 1333 1334 return; 1335} #/ sub can 1336 1337sub AUTOLOAD { 1338 my $self = shift; 1339 my ( $m ) = ( our $AUTOLOAD =~ /::(\w+)$/ ); 1340 return if $m eq 'DESTROY'; 1341 1342 if ( ref( $self ) ) { 1343 if ( $INC{"Moose.pm"} ) { 1344 my $method = $self->moose_type->can( $m ); 1345 return $self->moose_type->$method( @_ ) if $method; 1346 } 1347 if ( $m =~ /\Amy_(.+)\z/ ) { 1348 my $method = $self->_lookup_my_method( $1 ); 1349 return &$method( $self, @_ ) if $method; 1350 } 1351 if ( $self->{is_object} && $object_methods{$m} ) { 1352 require Type::Tiny::ConstrainedObject; 1353 unshift @_, $self; 1354 no strict 'refs'; 1355 goto \&{"Type::Tiny::ConstrainedObject::$m"}; 1356 } 1357 for my $util ( qw/ grep map sort rsort first any all assert_any assert_all / ) { 1358 if ( $m eq $util ) { 1359 return ( $self->{'_util'}{$util} ||= $self->_build_util( $util ) )->( @_ ); 1360 } 1361 } 1362 } #/ if ( ref( $self ) ) 1363 1364 _croak q[Can't locate object method "%s" via package "%s"], $m, 1365 ref( $self ) || $self; 1366} #/ sub AUTOLOAD 1367 1368sub DOES { 1369 my $self = shift; 1370 1371 return !!1 1372 if ref( $self ) 1373 && $_[0] =~ m{^ Type::API::Constraint (?: ::Coercible | ::Inlinable )? $}x; 1374 return !!1 if !ref( $self ) && $_[0] eq 'Type::API::Constraint::Constructor'; 1375 1376 "UNIVERSAL"->can( "DOES" ) ? $self->SUPER::DOES( @_ ) : $self->isa( @_ ); 1377} #/ sub DOES 1378 1379sub _has_xsub { 1380 require B; 1381 !!B::svref_2object( shift->compiled_check )->XSUB; 1382} 1383 1384sub _build_util { 1385 my ( $self, $func ) = @_; 1386 Scalar::Util::weaken( my $type = $self ); 1387 1388 if ( $func eq 'grep' 1389 || $func eq 'first' 1390 || $func eq 'any' 1391 || $func eq 'all' 1392 || $func eq 'assert_any' 1393 || $func eq 'assert_all' ) 1394 { 1395 my ( $inline, $compiled ); 1396 1397 if ( $self->can_be_inlined ) { 1398 $inline = $self->inline_check( '$_' ); 1399 } 1400 else { 1401 $compiled = $self->compiled_check; 1402 $inline = '$compiled->($_)'; 1403 } 1404 1405 if ( $func eq 'grep' ) { 1406 return eval "sub { grep { $inline } \@_ }"; 1407 } 1408 elsif ( $func eq 'first' ) { 1409 return eval "sub { for (\@_) { return \$_ if ($inline) }; undef; }"; 1410 } 1411 elsif ( $func eq 'any' ) { 1412 return eval "sub { for (\@_) { return !!1 if ($inline) }; !!0; }"; 1413 } 1414 elsif ( $func eq 'assert_any' ) { 1415 my $qname = B::perlstring( $self->name ); 1416 return 1417 eval 1418 "sub { for (\@_) { return \@_ if ($inline) }; Type::Tiny::_failed_check(\$type, $qname, \@_ ? \$_[-1] : undef); }"; 1419 } 1420 elsif ( $func eq 'all' ) { 1421 return eval "sub { for (\@_) { return !!0 unless ($inline) }; !!1; }"; 1422 } 1423 elsif ( $func eq 'assert_all' ) { 1424 my $qname = B::perlstring( $self->name ); 1425 return 1426 eval 1427 "sub { my \$idx = 0; for (\@_) { Type::Tiny::_failed_check(\$type, $qname, \$_, varname => sprintf('\$_[%d]', \$idx)) unless ($inline); ++\$idx }; \@_; }"; 1428 } 1429 } #/ if ( $func eq 'grep' ||...) 1430 1431 if ( $func eq 'map' ) { 1432 my ( $inline, $compiled ); 1433 my $c = $self->_assert_coercion; 1434 1435 if ( $c->can_be_inlined ) { 1436 $inline = $c->inline_coercion( '$_' ); 1437 } 1438 else { 1439 $compiled = $c->compiled_coercion; 1440 $inline = '$compiled->($_)'; 1441 } 1442 1443 return eval "sub { map { $inline } \@_ }"; 1444 } #/ if ( $func eq 'map' ) 1445 1446 if ( $func eq 'sort' || $func eq 'rsort' ) { 1447 my ( $inline, $compiled ); 1448 1449 my $ptype = $self->find_parent( sub { $_->has_sorter } ); 1450 _croak "No sorter for this type constraint" unless $ptype; 1451 1452 my $sorter = $ptype->sorter; 1453 1454 # Schwarzian transformation 1455 if ( ref( $sorter ) eq 'ARRAY' ) { 1456 my $sort_key; 1457 ( $sorter, $sort_key ) = @$sorter; 1458 1459 if ( $func eq 'sort' ) { 1460 return 1461 eval 1462 "our (\$a, \$b); sub { map \$_->[0], sort { \$sorter->(\$a->[1],\$b->[1]) } map [\$_,\$sort_key->(\$_)], \@_ }"; 1463 } 1464 elsif ( $func eq 'rsort' ) { 1465 return 1466 eval 1467 "our (\$a, \$b); sub { map \$_->[0], sort { \$sorter->(\$b->[1],\$a->[1]) } map [\$_,\$sort_key->(\$_)], \@_ }"; 1468 } 1469 } #/ if ( ref( $sorter ) eq...) 1470 1471 # Simple sort 1472 else { 1473 if ( $func eq 'sort' ) { 1474 return eval "our (\$a, \$b); sub { sort { \$sorter->(\$a,\$b) } \@_ }"; 1475 } 1476 elsif ( $func eq 'rsort' ) { 1477 return eval "our (\$a, \$b); sub { sort { \$sorter->(\$b,\$a) } \@_ }"; 1478 } 1479 } 1480 } #/ if ( $func eq 'sort' ||...) 1481 1482 die "Unknown function: $func"; 1483} #/ sub _build_util 1484 1485sub of { shift->parameterize( @_ ) } 1486sub where { shift->create_child_type( constraint => @_ ) } 1487 1488# fill out Moose-compatible API 1489sub inline_environment { +{} } 1490sub _inline_check { shift->inline_check( @_ ) } 1491sub _compiled_type_constraint { shift->compiled_check( @_ ) } 1492sub meta { _croak( "Not really a Moose::Meta::TypeConstraint. Sorry!" ) } 1493sub compile_type_constraint { shift->compiled_check } 1494sub _actually_compile_type_constraint { shift->_build_compiled_check } 1495sub hand_optimized_type_constraint { shift->{hand_optimized_type_constraint} } 1496 1497sub has_hand_optimized_type_constraint { 1498 exists( shift->{hand_optimized_type_constraint} ); 1499} 1500sub type_parameter { ( shift->parameters || [] )->[0] } 1501 1502sub parameterized_from { 1503 $_[0]->is_parameterized ? shift->parent : _croak( "Not a parameterized type" ); 1504} 1505sub has_parameterized_from { $_[0]->is_parameterized } 1506 1507# some stuff for Mouse-compatible API 1508sub __is_parameterized { shift->is_parameterized( @_ ) } 1509sub _add_type_coercions { shift->coercion->add_type_coercions( @_ ) } 1510sub _as_string { shift->qualified_name( @_ ) } 1511sub _compiled_type_coercion { shift->coercion->compiled_coercion( @_ ) } 1512sub _identity { Scalar::Util::refaddr( shift ) } 1513 1514sub _unite { 1515 require Type::Tiny::Union; 1516 "Type::Tiny::Union"->new( type_constraints => \@_ ); 1517} 1518 1519# Hooks for Type::Tie 1520sub TIESCALAR { 1521 require Type::Tie; 1522 unshift @_, 'Type::Tie::SCALAR'; 1523 goto \&Type::Tie::SCALAR::TIESCALAR; 1524} 1525 1526sub TIEARRAY { 1527 require Type::Tie; 1528 unshift @_, 'Type::Tie::ARRAY'; 1529 goto \&Type::Tie::ARRAY::TIEARRAY; 1530} 1531 1532sub TIEHASH { 1533 require Type::Tie; 1534 unshift @_, 'Type::Tie::HASH'; 1535 goto \&Type::Tie::HASH::TIEHASH; 1536} 1537 15381; 1539 1540__END__ 1541 1542=pod 1543 1544=encoding utf-8 1545 1546=for stopwords Moo(se)-compatible MooseX MouseX MooX Moose-compat invocant 1547 1548=head1 NAME 1549 1550Type::Tiny - tiny, yet Moo(se)-compatible type constraint 1551 1552=head1 SYNOPSIS 1553 1554 use v5.12; 1555 use strict; 1556 use warnings; 1557 1558 package Horse { 1559 use Moo; 1560 use Types::Standard qw( Str Int Enum ArrayRef Object ); 1561 use Type::Params qw( compile ); 1562 use namespace::autoclean; 1563 1564 has name => ( 1565 is => 'ro', 1566 isa => Str, 1567 required => 1, 1568 ); 1569 has gender => ( 1570 is => 'ro', 1571 isa => Enum[qw( f m )], 1572 ); 1573 has age => ( 1574 is => 'rw', 1575 isa => Int->where( '$_ >= 0' ), 1576 ); 1577 has children => ( 1578 is => 'ro', 1579 isa => ArrayRef[Object], 1580 default => sub { return [] }, 1581 ); 1582 1583 sub add_child { 1584 state $check = compile( Object, Object ); # method signature 1585 1586 my ($self, $child) = $check->(@_); # unpack @_ 1587 push @{ $self->children }, $child; 1588 1589 return $self; 1590 } 1591 } 1592 1593 package main; 1594 1595 my $boldruler = Horse->new( 1596 name => "Bold Ruler", 1597 gender => 'm', 1598 age => 16, 1599 ); 1600 1601 my $secretariat = Horse->new( 1602 name => "Secretariat", 1603 gender => 'm', 1604 age => 0, 1605 ); 1606 1607 $boldruler->add_child( $secretariat ); 1608 1609=head1 STATUS 1610 1611This module is covered by the 1612L<Type-Tiny stability policy|Type::Tiny::Manual::Policies/"STABILITY">. 1613 1614=head1 DESCRIPTION 1615 1616This documents the internals of the L<Type::Tiny> class. L<Type::Tiny::Manual> 1617is a better starting place if you're new. 1618 1619L<Type::Tiny> is a small class for creating Moose-like type constraint 1620objects which are compatible with Moo, Moose and Mouse. 1621 1622 use Scalar::Util qw(looks_like_number); 1623 use Type::Tiny; 1624 1625 my $NUM = "Type::Tiny"->new( 1626 name => "Number", 1627 constraint => sub { looks_like_number($_) }, 1628 message => sub { "$_ ain't a number" }, 1629 ); 1630 1631 package Ermintrude { 1632 use Moo; 1633 has favourite_number => (is => "ro", isa => $NUM); 1634 } 1635 1636 package Bullwinkle { 1637 use Moose; 1638 has favourite_number => (is => "ro", isa => $NUM); 1639 } 1640 1641 package Maisy { 1642 use Mouse; 1643 has favourite_number => (is => "ro", isa => $NUM); 1644 } 1645 1646Maybe now we won't need to have separate MooseX, MouseX and MooX versions 1647of everything? We can but hope... 1648 1649=head2 Constructor 1650 1651=over 1652 1653=item C<< new(%attributes) >> 1654 1655Moose-style constructor function. 1656 1657=back 1658 1659=head2 Attributes 1660 1661Attributes are named values that may be passed to the constructor. For 1662each attribute, there is a corresponding reader method. For example: 1663 1664 my $type = Type::Tiny->new( name => "Foo" ); 1665 print $type->name, "\n"; # says "Foo" 1666 1667=head3 Important attributes 1668 1669These are the attributes you are likely to be most interested in 1670providing when creating your own type constraints, and most interested 1671in reading when dealing with type constraint objects. 1672 1673=over 1674 1675=item C<< constraint >> 1676 1677Coderef to validate a value (C<< $_ >>) against the type constraint. 1678The coderef will not be called unless the value is known to pass any 1679parent type constraint (see C<parent> below). 1680 1681Alternatively, a string of Perl code checking C<< $_ >> can be passed 1682as a parameter to the constructor, and will be converted to a coderef. 1683 1684Defaults to C<< sub { 1 } >> - i.e. a coderef that passes all values. 1685 1686=item C<< parent >> 1687 1688Optional attribute; parent type constraint. For example, an "Integer" 1689type constraint might have a parent "Number". 1690 1691If provided, must be a Type::Tiny object. 1692 1693=item C<< inlined >> 1694 1695A coderef which returns a string of Perl code suitable for inlining this 1696type. Optional. 1697 1698(The coderef will be called in list context and can actually return 1699a list of strings which will be joined with C<< && >>. If the first item 1700on the list is undef, it will be substituted with the type's parent's 1701inline check.) 1702 1703If C<constraint> (above) is a coderef generated via L<Sub::Quote>, then 1704Type::Tiny I<may> be able to automatically generate C<inlined> for you. 1705If C<constraint> (above) is a string, it will be able to. 1706 1707=item C<< name >> 1708 1709The name of the type constraint. These need to conform to certain naming 1710rules (they must begin with an uppercase letter and continue using only 1711letters, digits 0-9 and underscores). 1712 1713Optional; if not supplied will be an anonymous type constraint. 1714 1715=item C<< display_name >> 1716 1717A name to display for the type constraint when stringified. These don't 1718have to conform to any naming rules. Optional; a default name will be 1719calculated from the C<name>. 1720 1721=item C<< library >> 1722 1723The package name of the type library this type is associated with. 1724Optional. Informational only: setting this attribute does not install 1725the type into the package. 1726 1727=item C<< deprecated >> 1728 1729Optional boolean indicating whether a type constraint is deprecated. 1730L<Type::Library> will issue a warning if you attempt to import a deprecated 1731type constraint, but otherwise the type will continue to function as normal. 1732There will not be deprecation warnings every time you validate a value, for 1733instance. If omitted, defaults to the parent's deprecation status (or false 1734if there's no parent). 1735 1736=item C<< message >> 1737 1738Coderef that returns an error message when C<< $_ >> does not validate 1739against the type constraint. Optional (there's a vaguely sensible default.) 1740 1741=item C<< coercion >> 1742 1743A L<Type::Coercion> object associated with this type. 1744 1745Generally speaking this attribute should not be passed to the constructor; 1746you should rely on the default lazily-built coercion object. 1747 1748You may pass C<< coercion => 1 >> to the constructor to inherit coercions 1749from the constraint's parent. (This requires the parent constraint to have 1750a coercion.) 1751 1752=item C<< sorter >> 1753 1754A coderef which can be passed two values conforming to this type constraint 1755and returns -1, 0, or 1 to put them in order. Alternatively an arrayref 1756containing a pair of coderefs — a sorter and a pre-processor for the 1757Schwarzian transform. Optional. 1758 1759The idea is to allow for: 1760 1761 @sorted = Int->sort( 2, 1, 11 ); # => 1, 2, 11 1762 @sorted = Str->sort( 2, 1, 11 ); # => 1, 11, 2 1763 1764=item C<< my_methods >> 1765 1766Experimental hashref of additional methods that can be called on the type 1767constraint object. 1768 1769=back 1770 1771=head3 Attributes related to parameterizable and parameterized types 1772 1773The following additional attributes are used for parameterizable (e.g. 1774C<ArrayRef>) and parameterized (e.g. C<< ArrayRef[Int] >>) type 1775constraints. Unlike Moose, these aren't handled by separate subclasses. 1776 1777=over 1778 1779=item C<< constraint_generator >> 1780 1781Coderef that is called when a type constraint is parameterized. When called, 1782it is passed the list of parameters, though any parameter which looks like a 1783foreign type constraint (Moose type constraints, Mouse type constraints, etc, 1784I<< and coderefs(!!!) >>) is first coerced to a native Type::Tiny object. 1785 1786Note that for compatibility with the Moose API, the base type is I<not> 1787passed to the constraint generator, but can be found in the package variable 1788C<< $Type::Tiny::parameterize_type >>. The first parameter is also available 1789as C<< $_ >>. 1790 1791Types I<can> be parameterized with an empty parameter list. For example, 1792in L<Types::Standard>, C<Tuple> is just an alias for C<ArrayRef> but 1793C<< Tuple[] >> will only allow zero-length arrayrefs to pass the constraint. 1794If you wish C<< YourType >> and C<< YourType[] >> to mean the same thing, 1795then do: 1796 1797 return $Type::Tiny::parameterize_type unless @_; 1798 1799The constraint generator should generate and return a new constraint coderef 1800based on the parameters. Alternatively, the constraint generator can return a 1801fully-formed Type::Tiny object, in which case the C<name_generator>, 1802C<inline_generator>, and C<coercion_generator> attributes documented below 1803are ignored. 1804 1805Optional; providing a generator makes this type into a parameterizable 1806type constraint. If there is no generator, attempting to parameterize the 1807type constraint will throw an exception. 1808 1809=item C<< name_generator >> 1810 1811A coderef which generates a new display_name based on parameters. Called with 1812the same parameters and package variables as the C<constraint_generator>. 1813Expected to return a string. 1814 1815Optional; the default is reasonable. 1816 1817=item C<< inline_generator >> 1818 1819A coderef which generates a new inlining coderef based on parameters. Called 1820with the same parameters and package variables as the C<constraint_generator>. 1821Expected to return a coderef. 1822 1823Optional. 1824 1825=item C<< coercion_generator >> 1826 1827A coderef which generates a new L<Type::Coercion> object based on parameters. 1828Called with the same parameters and package variables as the 1829C<constraint_generator>. Expected to return a blessed object. 1830 1831Optional. 1832 1833=item C<< deep_explanation >> 1834 1835This API is not finalized. Coderef used by L<Error::TypeTiny::Assertion> to 1836peek inside parameterized types and figure out why a value doesn't pass the 1837constraint. 1838 1839=item C<< parameters >> 1840 1841In parameterized types, returns an arrayref of the parameters. 1842 1843=back 1844 1845=head3 Lazy generated attributes 1846 1847The following attributes should not be usually passed to the constructor; 1848unless you're doing something especially unusual, you should rely on the 1849default lazily-built return values. 1850 1851=over 1852 1853=item C<< compiled_check >> 1854 1855Coderef to validate a value (C<< $_[0] >>) against the type constraint. 1856This coderef is expected to also handle all validation for the parent 1857type constraints. 1858 1859=item C<< complementary_type >> 1860 1861A complementary type for this type. For example, the complementary type 1862for an integer type would be all things that are not integers, including 1863floating point numbers, but also alphabetic strings, arrayrefs, filehandles, 1864etc. 1865 1866=item C<< moose_type >>, C<< mouse_type >> 1867 1868Objects equivalent to this type constraint, but as a 1869L<Moose::Meta::TypeConstraint> or L<Mouse::Meta::TypeConstraint>. 1870 1871It should rarely be necessary to obtain a L<Moose::Meta::TypeConstraint> 1872object from L<Type::Tiny> because the L<Type::Tiny> object itself should 1873be usable pretty much anywhere a L<Moose::Meta::TypeConstraint> is expected. 1874 1875=back 1876 1877=head2 Methods 1878 1879=head3 Predicate methods 1880 1881These methods return booleans indicating information about the type 1882constraint. They are each tightly associated with a particular attribute. 1883(See L</"Attributes">.) 1884 1885=over 1886 1887=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> 1888 1889Simple Moose-style predicate methods indicating the presence or 1890absence of an attribute. 1891 1892=item C<has_coercion> 1893 1894Predicate method with a little extra DWIM. Returns false if the coercion is 1895a no-op. 1896 1897=item C<< is_anon >> 1898 1899Returns true iff the type constraint does not have a C<name>. 1900 1901=item C<< is_parameterized >>, C<< is_parameterizable >> 1902 1903Indicates whether a type has been parameterized (e.g. C<< ArrayRef[Int] >>) 1904or could potentially be (e.g. C<< ArrayRef >>). 1905 1906=item C<< has_parameterized_from >> 1907 1908Useless alias for C<is_parameterized>. 1909 1910=back 1911 1912=head3 Validation and coercion 1913 1914The following methods are used for coercing and validating values 1915against a type constraint: 1916 1917=over 1918 1919=item C<< check($value) >> 1920 1921Returns true iff the value passes the type constraint. 1922 1923=item C<< validate($value) >> 1924 1925Returns the error message for the value; returns an explicit undef if the 1926value passes the type constraint. 1927 1928=item C<< assert_valid($value) >> 1929 1930Like C<< check($value) >> but dies if the value does not pass the type 1931constraint. 1932 1933Yes, that's three very similar methods. Blame L<Moose::Meta::TypeConstraint> 1934whose API I'm attempting to emulate. :-) 1935 1936=item C<< assert_return($value) >> 1937 1938Like C<< assert_valid($value) >> but returns the value if it passes the type 1939constraint. 1940 1941This seems a more useful behaviour than C<< assert_valid($value) >>. I would 1942have just changed C<< assert_valid($value) >> to do this, except that there 1943are edge cases where it could break Moose compatibility. 1944 1945=item C<< get_message($value) >> 1946 1947Returns the error message for the value; even if the value passes the type 1948constraint. 1949 1950=item C<< validate_explain($value, $varname) >> 1951 1952Like C<validate> but instead of a string error message, returns an arrayref 1953of strings explaining the reasoning why the value does not meet the type 1954constraint, examining parent types, etc. 1955 1956The C<< $varname >> is an optional string like C<< '$foo' >> indicating the 1957name of the variable being checked. 1958 1959=item C<< coerce($value) >> 1960 1961Attempt to coerce C<< $value >> to this type. 1962 1963=item C<< assert_coerce($value) >> 1964 1965Attempt to coerce C<< $value >> to this type. Throws an exception if this is 1966not possible. 1967 1968=back 1969 1970=head3 Child type constraint creation and parameterization 1971 1972These methods generate new type constraint objects that inherit from the 1973constraint they are called upon: 1974 1975=over 1976 1977=item C<< create_child_type(%attributes) >> 1978 1979Construct a new Type::Tiny object with this object as its parent. 1980 1981=item C<< where($coderef) >> 1982 1983Shortcut for creating an anonymous child type constraint. Use it like 1984C<< HashRef->where(sub { exists($_->{name}) }) >>. That said, you can 1985get a similar result using overloaded C<< & >>: 1986 1987 HashRef & sub { exists($_->{name}) } 1988 1989Like the C<< constraint >> attribute, this will accept a string of Perl 1990code: 1991 1992 HashRef->where('exists($_->{name})') 1993 1994=item C<< child_type_class >> 1995 1996The class that create_child_type will construct by default. 1997 1998=item C<< parameterize(@parameters) >> 1999 2000Creates a new parameterized type; throws an exception if called on a 2001non-parameterizable type. 2002 2003=item C<< of(@parameters) >> 2004 2005A cute alias for C<parameterize>. Use it like C<< ArrayRef->of(Int) >>. 2006 2007=item C<< plus_coercions($type1, $code1, ...) >> 2008 2009Shorthand for creating a new child type constraint with the same coercions 2010as this one, but then adding some extra coercions (at a higher priority than 2011the existing ones). 2012 2013=item C<< plus_fallback_coercions($type1, $code1, ...) >> 2014 2015Like C<plus_coercions>, but added at a lower priority. 2016 2017=item C<< minus_coercions($type1, ...) >> 2018 2019Shorthand for creating a new child type constraint with fewer type coercions. 2020 2021=item C<< no_coercions >> 2022 2023Shorthand for creating a new child type constraint with no coercions at all. 2024 2025=back 2026 2027=head3 Type relationship introspection methods 2028 2029These methods allow you to determine a type constraint's relationship to 2030other type constraints in an organised hierarchy: 2031 2032=over 2033 2034=item C<< equals($other) >>, C<< is_subtype_of($other) >>, C<< is_supertype_of($other) >>, C<< is_a_type_of($other) >> 2035 2036Compare two types. See L<Moose::Meta::TypeConstraint> for what these all mean. 2037(OK, Moose doesn't define C<is_supertype_of>, but you get the idea, right?) 2038 2039Note that these have a slightly DWIM side to them. If you create two 2040L<Type::Tiny::Class> objects which test the same class, they're considered 2041equal. And: 2042 2043 my $subtype_of_Num = Types::Standard::Num->create_child_type; 2044 my $subtype_of_Int = Types::Standard::Int->create_child_type; 2045 $subtype_of_Int->is_subtype_of( $subtype_of_Num ); # true 2046 2047=item C<< strictly_equals($other) >>, C<< is_strictly_subtype_of($other) >>, C<< is_strictly_supertype_of($other) >>, C<< is_strictly_a_type_of($other) >> 2048 2049Stricter versions of the type comparison functions. These only care about 2050explicit inheritance via C<parent>. 2051 2052 my $subtype_of_Num = Types::Standard::Num->create_child_type; 2053 my $subtype_of_Int = Types::Standard::Int->create_child_type; 2054 $subtype_of_Int->is_strictly_subtype_of( $subtype_of_Num ); # false 2055 2056=item C<< parents >> 2057 2058Returns a list of all this type constraint's ancestor constraints. For 2059example, if called on the C<Str> type constraint would return the list 2060C<< (Value, Defined, Item, Any) >>. 2061 2062I<< Due to a historical misunderstanding, this differs from the Moose 2063implementation of the C<parents> method. In Moose, C<parents> only returns the 2064immediate parent type constraints, and because type constraints only have 2065one immediate parent, this is effectively an alias for C<parent>. The 2066extension module L<MooseX::Meta::TypeConstraint::Intersection> is the only 2067place where multiple type constraints are returned; and they are returned 2068as an arrayref in violation of the base class' documentation. I'm keeping 2069my behaviour as it seems more useful. >> 2070 2071=item C<< find_parent($coderef) >> 2072 2073Loops through the parent type constraints I<< including the invocant 2074itself >> and returns the nearest ancestor type constraint where the 2075coderef evaluates to true. Within the coderef the ancestor currently 2076being checked is C<< $_ >>. Returns undef if there is no match. 2077 2078In list context also returns the number of type constraints which had 2079been looped through before the matching constraint was found. 2080 2081=item C<< find_constraining_type >> 2082 2083Finds the nearest ancestor type constraint (including the type itself) 2084which has a C<constraint> coderef. 2085 2086Equivalent to: 2087 2088 $type->find_parent(sub { not $_->_is_null_constraint }) 2089 2090=item C<< coercibles >> 2091 2092Return a type constraint which is the union of type constraints that can be 2093coerced to this one (including this one). If this type constraint has no 2094coercions, returns itself. 2095 2096=item C<< type_parameter >> 2097 2098In parameterized type constraints, returns the first item on the list of 2099parameters; otherwise returns undef. For example: 2100 2101 ( ArrayRef[Int] )->type_parameter; # returns Int 2102 ( ArrayRef[Int] )->parent; # returns ArrayRef 2103 2104Note that parameterizable type constraints can perfectly legitimately take 2105multiple parameters (several of the parameterizable type constraints in 2106L<Types::Standard> do). This method only returns the first such parameter. 2107L</"Attributes related to parameterizable and parameterized types"> 2108documents the C<parameters> attribute, which returns an arrayref of all 2109the parameters. 2110 2111=item C<< parameterized_from >> 2112 2113Harder to spell alias for C<parent> that only works for parameterized 2114types. 2115 2116=back 2117 2118I<< Hint for people subclassing Type::Tiny: >> 2119Since version 1.006000, the methods for determining subtype, supertype, and 2120type equality should I<not> be overridden in subclasses of Type::Tiny. This 2121is because of the problem of diamond inheritance. If X and Y are both 2122subclasses of Type::Tiny, they I<both> need to be consulted to figure out 2123how type constraints are related; not just one of them should be overriding 2124these methods. See the source code for L<Type::Tiny::Enum> for an example of 2125how subclasses can give hints about type relationships to Type::Tiny. 2126Summary: push a coderef onto C<< @Type::Tiny::CMP >>. This coderef will be 2127passed two type constraints. It should then return one of the constants 2128Type::Tiny::CMP_SUBTYPE (first type is a subtype of second type), 2129Type::Tiny::CMP_SUPERTYPE (second type is a subtype of first type), 2130Type::Tiny::CMP_EQUAL (the two types are exactly the same), 2131Type::Tiny::CMP_EQUIVALENT (the two types are effectively the same), or 2132Type::Tiny::CMP_UNKNOWN (your coderef couldn't establish any relationship). 2133 2134=head3 Type relationship introspection function 2135 2136=over 2137 2138=item C<< Type::Tiny::cmp($type1, $type2) >> 2139 2140The subtype/supertype relationship between types results in a partial 2141ordering of type constraints. 2142 2143This function will return one of the constants: 2144Type::Tiny::CMP_SUBTYPE (first type is a subtype of second type), 2145Type::Tiny::CMP_SUPERTYPE (second type is a subtype of first type), 2146Type::Tiny::CMP_EQUAL (the two types are exactly the same), 2147Type::Tiny::CMP_EQUIVALENT (the two types are effectively the same), or 2148Type::Tiny::CMP_UNKNOWN (couldn't establish any relationship). 2149In numeric contexts, these evaluate to -1, 1, 0, 0, and 0, making it 2150potentially usable with C<sort> (though you may need to silence warnings 2151about treating the empty string as a numeric value). 2152 2153=back 2154 2155=head3 List processing methods 2156 2157=over 2158 2159=item C<< grep(@list) >> 2160 2161Filters a list to return just the items that pass the type check. 2162 2163 @integers = Int->grep(@list); 2164 2165=item C<< first(@list) >> 2166 2167Filters the list to return the first item on the list that passes 2168the type check, or undef if none do. 2169 2170 $first_lady = Woman->first(@people); 2171 2172=item C<< map(@list) >> 2173 2174Coerces a list of items. Only works on types which have a coercion. 2175 2176 @truths = Bool->map(@list); 2177 2178=item C<< sort(@list) >> 2179 2180Sorts a list of items according to the type's preferred sorting mechanism, 2181or if the type doesn't have a sorter coderef, uses the parent type. If no 2182ancestor type constraint has a sorter, throws an exception. The C<Str>, 2183C<StrictNum>, C<LaxNum>, and C<Enum> type constraints include sorters. 2184 2185 @sorted_numbers = Num->sort( Num->grep(@list) ); 2186 2187=item C<< rsort(@list) >> 2188 2189Like C<sort> but backwards. 2190 2191=item C<< any(@list) >> 2192 2193Returns true if any of the list match the type. 2194 2195 if ( Int->any(@numbers) ) { 2196 say "there was at least one integer"; 2197 } 2198 2199=item C<< all(@list) >> 2200 2201Returns true if all of the list match the type. 2202 2203 if ( Int->all(@numbers) ) { 2204 say "they were all integers"; 2205 } 2206 2207=item C<< assert_any(@list) >> 2208 2209Like C<any> but instead of returning a boolean, returns the entire original 2210list if any item on it matches the type, and dies if none does. 2211 2212=item C<< assert_all(@list) >> 2213 2214Like C<all> but instead of returning a boolean, returns the original list if 2215all items on it match the type, but dies as soon as it finds one that does 2216not. 2217 2218=back 2219 2220=head3 Inlining methods 2221 2222=for stopwords uated 2223 2224The following methods are used to generate strings of Perl code which 2225may be pasted into stringy C<eval>uated subs to perform type checks: 2226 2227=over 2228 2229=item C<< can_be_inlined >> 2230 2231Returns boolean indicating if this type can be inlined. 2232 2233=item C<< inline_check($varname) >> 2234 2235Creates a type constraint check for a particular variable as a string of 2236Perl code. For example: 2237 2238 print( Types::Standard::Num->inline_check('$foo') ); 2239 2240prints the following output: 2241 2242 (!ref($foo) && Scalar::Util::looks_like_number($foo)) 2243 2244For Moose-compat, there is an alias C<< _inline_check >> for this method. 2245 2246=item C<< inline_assert($varname) >> 2247 2248Much like C<inline_check> but outputs a statement of the form: 2249 2250 ... or die ...; 2251 2252Can also be called line C<< inline_assert($varname, $typevarname, %extras) >>. 2253In this case, it will generate a string of code that may include 2254C<< $typevarname >> which is supposed to be the name of a variable holding 2255the type itself. (This is kinda complicated, but it allows a useful string 2256to still be produced if the type is not inlineable.) The C<< %extras >> are 2257additional options to be passed to L<Error::TypeTiny::Assertion>'s constructor 2258and must be key-value pairs of strings only, no references or undefs. 2259 2260=back 2261 2262=head3 Other methods 2263 2264=over 2265 2266=item C<< qualified_name >> 2267 2268For non-anonymous type constraints that have a library, returns a qualified 2269C<< "MyLib::MyType" >> sort of name. Otherwise, returns the same as C<name>. 2270 2271=item C<< isa($class) >>, C<< can($method) >>, C<< AUTOLOAD(@args) >> 2272 2273If Moose is loaded, then the combination of these methods is used to mock 2274a Moose::Meta::TypeConstraint. 2275 2276If Mouse is loaded, then C<isa> mocks Mouse::Meta::TypeConstraint. 2277 2278=item C<< DOES($role) >> 2279 2280Overridden to advertise support for various roles. 2281 2282See also L<Type::API::Constraint>, etc. 2283 2284=item C<< TIESCALAR >>, C<< TIEARRAY >>, C<< TIEHASH >> 2285 2286These are provided as hooks that wrap L<Type::Tie>. (Type::Tie is distributed 2287separately, and can be used with non-Type::Tiny type constraints too.) They 2288allow the following to work: 2289 2290 use Types::Standard qw(Int); 2291 tie my @list, Int; 2292 push @list, 123, 456; # ok 2293 push @list, "Hello"; # dies 2294 2295=back 2296 2297The following methods exist for Moose/Mouse compatibility, but do not do 2298anything useful. 2299 2300=over 2301 2302=item C<< compile_type_constraint >> 2303 2304=item C<< hand_optimized_type_constraint >> 2305 2306=item C<< has_hand_optimized_type_constraint >> 2307 2308=item C<< inline_environment >> 2309 2310=item C<< meta >> 2311 2312=back 2313 2314=head2 Overloading 2315 2316=over 2317 2318=item * 2319 2320Stringification is overloaded to return the qualified name. 2321 2322=item * 2323 2324Boolification is overloaded to always return true. 2325 2326=item * 2327 2328Coderefification is overloaded to call C<assert_return>. 2329 2330=item * 2331 2332On Perl 5.10.1 and above, smart match is overloaded to call C<check>. 2333 2334=item * 2335 2336The C<< == >> operator is overloaded to call C<equals>. 2337 2338=item * 2339 2340The C<< < >> and C<< > >> operators are overloaded to call C<is_subtype_of> 2341and C<is_supertype_of>. 2342 2343=item * 2344 2345The C<< ~ >> operator is overloaded to call C<complementary_type>. 2346 2347=item * 2348 2349The C<< | >> operator is overloaded to build a union of two type constraints. 2350See L<Type::Tiny::Union>. 2351 2352=item * 2353 2354The C<< & >> operator is overloaded to build the intersection of two type 2355constraints. See L<Type::Tiny::Intersection>. 2356 2357=back 2358 2359Previous versions of Type::Tiny would overload the C<< + >> operator to 2360call C<plus_coercions> or C<plus_fallback_coercions> as appropriate. 2361Support for this was dropped after 0.040. 2362 2363=head2 Constants 2364 2365=over 2366 2367=item C<< Type::Tiny::SUPPORT_SMARTMATCH >> 2368 2369Indicates whether the smart match overload is supported on your 2370version of Perl. 2371 2372=back 2373 2374=head2 Package Variables 2375 2376=over 2377 2378=item C<< $Type::Tiny::DD >> 2379 2380This undef by default but may be set to a coderef that Type::Tiny 2381and related modules will use to dump data structures in things like 2382error messages. 2383 2384Otherwise Type::Tiny uses it's own routine to dump data structures. 2385C<< $DD >> may then be set to a number to limit the lengths of the 2386dumps. (Default limit is 72.) 2387 2388This is a package variable (rather than get/set class methods) to allow 2389for easy localization. 2390 2391=item C<< $Type::Tiny::AvoidCallbacks >> 2392 2393If this variable is set to true (you should usually do it in a 2394C<local> scope), it acts as a hint for type constraints, when 2395generating inlined code, to avoid making any callbacks to 2396variables and functions defined outside the inlined code itself. 2397 2398This should have the effect that C<< $type->inline_check('$foo') >> 2399will return a string of code capable of checking the type on 2400Perl installations that don't have Type::Tiny installed. This 2401is intended to allow Type::Tiny to be used with things like 2402L<Mite>. 2403 2404The variable works on the honour system. Types need to explicitly 2405check it and decide to generate different code based on its 2406truth value. The bundled types in L<Types::Standard>, 2407L<Types::Common::Numeric>, and L<Types::Common::String> all do. 2408(B<StrMatch> is sometimes unable to, and will issue a warning 2409if it needs to rely on callbacks when asked not to.) 2410 2411Most normal users can ignore this. 2412 2413=back 2414 2415=head2 Environment 2416 2417=over 2418 2419=item C<PERL_TYPE_TINY_XS> 2420 2421Currently this has more effect on L<Types::Standard> than Type::Tiny. In 2422future it may be used to trigger or suppress the loading XS implementations 2423of parts of Type::Tiny. 2424 2425=back 2426 2427=head1 BUGS 2428 2429Please report any bugs to 2430L<https://github.com/tobyink/p5-type-tiny/issues>. 2431 2432=head1 SEE ALSO 2433 2434L<The Type::Tiny homepage|https://typetiny.toby.ink/>. 2435 2436L<Type::Tiny::Manual>, L<Type::API>. 2437 2438L<Type::Library>, L<Type::Utils>, L<Types::Standard>, L<Type::Coercion>. 2439 2440L<Type::Tiny::Class>, L<Type::Tiny::Role>, L<Type::Tiny::Duck>, 2441L<Type::Tiny::Enum>, L<Type::Tiny::Union>, L<Type::Tiny::Intersection>. 2442 2443L<Moose::Meta::TypeConstraint>, 2444L<Mouse::Meta::TypeConstraint>. 2445 2446L<Type::Params>. 2447 2448L<Type::Tiny on GitHub|https://github.com/tobyink/p5-type-tiny>, 2449L<Type::Tiny on Travis-CI|https://travis-ci.com/tobyink/p5-type-tiny>, 2450L<Type::Tiny on AppVeyor|https://ci.appveyor.com/project/tobyink/p5-type-tiny>, 2451L<Type::Tiny on Codecov|https://codecov.io/gh/tobyink/p5-type-tiny>, 2452L<Type::Tiny on Coveralls|https://coveralls.io/github/tobyink/p5-type-tiny>. 2453 2454=head1 AUTHOR 2455 2456Toby Inkster E<lt>tobyink@cpan.orgE<gt>. 2457 2458=head1 THANKS 2459 2460Thanks to Matt S Trout for advice on L<Moo> integration. 2461 2462=head1 COPYRIGHT AND LICENCE 2463 2464This software is copyright (c) 2013-2014, 2017-2021 by Toby Inkster. 2465 2466This is free software; you can redistribute it and/or modify it under 2467the same terms as the Perl 5 programming language system itself. 2468 2469=head1 DISCLAIMER OF WARRANTIES 2470 2471THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED 2472WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF 2473MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. 2474