1package Types::TypeTiny; 2 3use strict; 4use warnings; 5 6our $AUTHORITY = 'cpan:TOBYINK'; 7our $VERSION = '1.012004'; 8 9$VERSION =~ tr/_//d; 10 11use Scalar::Util qw< blessed refaddr weaken >; 12 13BEGIN { 14 *__XS = eval { 15 require Type::Tiny::XS; 16 'Type::Tiny::XS'->VERSION( '0.022' ); 17 1; 18 } 19 ? sub () { !!1 } 20 : sub () { !!0 }; 21} 22 23our @EXPORT_OK = ( 24 map( @{ [ $_, "is_$_", "assert_$_" ] }, __PACKAGE__->type_names ), 25 qw/to_TypeTiny/ 26); 27our %EXPORT_TAGS = ( 28 types => [ __PACKAGE__->type_names ], 29 is => [ map "is_$_", __PACKAGE__->type_names ], 30 assert => [ map "assert_$_", __PACKAGE__->type_names ], 31); 32 33my %cache; 34 35# This `import` method is designed to avoid loading Exporter::Tiny. 36# This is so that if you stick to only using the purely OO parts of 37# Type::Tiny, you can skip loading the exporter. 38# 39sub import { 40 41 # If this sub succeeds, it will replace itself. 42 # uncoverable subroutine 43 return unless @_ > 1; # uncoverable statement 44 no warnings "redefine"; # uncoverable statement 45 our @ISA = qw( Exporter::Tiny ); # uncoverable statement 46 require Exporter::Tiny; # uncoverable statement 47 my $next = \&Exporter::Tiny::import; # uncoverable statement 48 *import = $next; # uncoverable statement 49 my $class = shift; # uncoverable statement 50 my $opts = { ref( $_[0] ) ? %{ +shift } : () }; # uncoverable statement 51 $opts->{into} ||= scalar( caller ); # uncoverable statement 52 _mkall(); # uncoverable statement 53 return $class->$next( $opts, @_ ); # uncoverable statement 54} #/ sub import 55 56for ( __PACKAGE__->type_names ) { # uncoverable statement 57 eval qq{ # uncoverable statement 58 sub is_$_ { $_()->check(shift) } # uncoverable statement 59 sub assert_$_ { $_()->assert_return(shift) } # uncoverable statement 60 }; # uncoverable statement 61} # uncoverable statement 62 63sub _reinstall_subs { 64 65 # uncoverable subroutine 66 my $type = shift; # uncoverable statement 67 no strict 'refs'; # uncoverable statement 68 no warnings 'redefine'; # uncoverable statement 69 *{ 'is_' . $type->name } = $type->compiled_check; # uncoverable statement 70 *{ 'assert_' . $type->name } = \&$type; # uncoverable statement 71 $type; # uncoverable statement 72} # uncoverable statement 73 74sub _mkall { 75 76 # uncoverable subroutine 77 return unless $INC{'Type/Tiny.pm'}; # uncoverable statement 78 __PACKAGE__->get_type( $_ ) for __PACKAGE__->type_names; # uncoverable statement 79} # uncoverable statement 80 81sub meta { 82 return $_[0]; 83} 84 85sub type_names { 86 qw( CodeLike StringLike TypeTiny HashLike ArrayLike _ForeignTypeConstraint ); 87} 88 89sub has_type { 90 my %has = map +( $_ => 1 ), shift->type_names; 91 !!$has{ $_[0] }; 92} 93 94sub get_type { 95 my $self = shift; 96 return unless $self->has_type( @_ ); 97 no strict qw(refs); 98 &{ $_[0] }(); 99} 100 101sub coercion_names { 102 qw(); 103} 104 105sub has_coercion { 106 my %has = map +( $_ => 1 ), shift->coercion_names; 107 !!$has{ $_[0] }; 108} 109 110sub get_coercion { 111 my $self = shift; 112 return unless $self->has_coercion( @_ ); 113 no strict qw(refs); 114 &{ $_[0] }(); # uncoverable statement 115} 116 117my ( $__get_linear_isa_dfs, $tried_mro ); 118$__get_linear_isa_dfs = sub { 119 if ( !$tried_mro && eval { require mro } ) { 120 $__get_linear_isa_dfs = \&mro::get_linear_isa; 121 goto $__get_linear_isa_dfs; 122 } 123 no strict 'refs'; 124 my $classname = shift; 125 my @lin = ( $classname ); 126 my %stored; 127 foreach my $parent ( @{"$classname\::ISA"} ) { 128 my $plin = $__get_linear_isa_dfs->( $parent ); 129 foreach ( @$plin ) { 130 next if exists $stored{$_}; 131 push( @lin, $_ ); 132 $stored{$_} = 1; 133 } 134 } 135 return \@lin; 136}; 137 138sub _check_overload { 139 my $package = shift; 140 if ( ref $package ) { 141 $package = blessed( $package ); 142 return !!0 if !defined $package; 143 } 144 my $op = shift; 145 my $mro = $__get_linear_isa_dfs->( $package ); 146 foreach my $p ( @$mro ) { 147 my $fqmeth = $p . q{::(} . $op; 148 return !!1 if defined &{$fqmeth}; 149 } 150 !!0; 151} #/ sub _check_overload 152 153sub _get_check_overload_sub { 154 if ( $Type::Tiny::AvoidCallbacks ) { 155 return 156 '(sub { require overload; overload::Overloaded(ref $_[0] or $_[0]) and overload::Method((ref $_[0] or $_[0]), $_[1]) })->'; 157 } 158 return 'Types::TypeTiny::_check_overload'; 159} 160 161sub StringLike () { 162 return $cache{StringLike} if defined $cache{StringLike}; 163 require Type::Tiny; 164 my %common = ( 165 name => "StringLike", 166 library => __PACKAGE__, 167 constraint => sub { 168 defined( $_ ) && !ref( $_ ) 169 or blessed( $_ ) && _check_overload( $_, q[""] ); 170 }, 171 inlined => sub { 172 qq/defined($_[1]) && !ref($_[1]) or Scalar::Util::blessed($_[1]) && ${\ +_get_check_overload_sub() }($_[1], q[""])/; 173 }, 174 ); 175 if ( __XS ) { 176 my $xsub = Type::Tiny::XS::get_coderef_for( 'StringLike' ); 177 my $xsubname = Type::Tiny::XS::get_subname_for( 'StringLike' ); 178 my $inlined = $common{inlined}; 179 $cache{StringLike} = "Type::Tiny"->new( 180 %common, 181 compiled_type_constraint => $xsub, 182 inlined => sub { 183 184 # uncoverable subroutine 185 ( $Type::Tiny::AvoidCallbacks or not $xsubname ) 186 ? goto( $inlined ) 187 : qq/$xsubname($_[1])/ # uncoverable statement 188 }, 189 ); 190 _reinstall_subs $cache{StringLike}; 191 } #/ if ( __XS ) 192 else { 193 $cache{StringLike} = "Type::Tiny"->new( %common ); 194 } 195} #/ sub StringLike 196 197sub HashLike (;@) { 198 return $cache{HashLike} if defined( $cache{HashLike} ) && !@_; 199 require Type::Tiny; 200 my %common = ( 201 name => "HashLike", 202 library => __PACKAGE__, 203 constraint => sub { 204 ref( $_ ) eq q[HASH] 205 or blessed( $_ ) && _check_overload( $_, q[%{}] ); 206 }, 207 inlined => sub { 208 qq/ref($_[1]) eq q[HASH] or Scalar::Util::blessed($_[1]) && ${\ +_get_check_overload_sub() }($_[1], q[\%{}])/; 209 }, 210 constraint_generator => sub { 211 my $param = TypeTiny()->assert_coerce( shift ); 212 my $check = $param->compiled_check; 213 sub { 214 my %hash = %$_; 215 for my $key ( sort keys %hash ) { 216 $check->( $hash{$key} ) or return 0; 217 } 218 return 1; 219 }; 220 }, 221 inline_generator => sub { 222 my $param = TypeTiny()->assert_coerce( shift ); 223 return unless $param->can_be_inlined; 224 sub { 225 my $var = pop; 226 my $code = sprintf( 227 'do { my $ok=1; my %%h = %%{%s}; for my $k (sort keys %%h) { ($ok=0,next) unless (%s) }; $ok }', 228 $var, 229 $param->inline_check( '$h{$k}' ), 230 ); 231 return ( undef, $code ); 232 }; 233 }, 234 coercion_generator => sub { 235 my ( $parent, $child, $param ) = @_; 236 return unless $param->has_coercion; 237 my $coercible = $param->coercion->_source_type_union->compiled_check; 238 my $C = "Type::Coercion"->new( type_constraint => $child ); 239 $C->add_type_coercions( 240 $parent => sub { 241 my $origref = @_ ? $_[0] : $_; 242 my %orig = %$origref; 243 my %new; 244 for my $k ( sort keys %orig ) { 245 return $origref unless $coercible->( $orig{$k} ); 246 $new{$k} = $param->coerce( $orig{$k} ); 247 } 248 \%new; 249 }, 250 ); 251 return $C; 252 }, 253 ); 254 if ( __XS ) { 255 my $xsub = Type::Tiny::XS::get_coderef_for( 'HashLike' ); 256 my $xsubname = Type::Tiny::XS::get_subname_for( 'HashLike' ); 257 my $inlined = $common{inlined}; 258 $cache{HashLike} = "Type::Tiny"->new( 259 %common, 260 compiled_type_constraint => $xsub, 261 inlined => sub { 262 263 # uncoverable subroutine 264 ( $Type::Tiny::AvoidCallbacks or not $xsubname ) 265 ? goto( $inlined ) 266 : qq/$xsubname($_[1])/ # uncoverable statement 267 }, 268 ); 269 _reinstall_subs $cache{HashLike}; 270 } #/ if ( __XS ) 271 else { 272 $cache{HashLike} = "Type::Tiny"->new( %common ); 273 } 274 275 @_ ? $cache{HashLike}->parameterize( @{ $_[0] } ) : $cache{HashLike}; 276} #/ sub HashLike (;@) 277 278sub ArrayLike (;@) { 279 return $cache{ArrayLike} if defined( $cache{ArrayLike} ) && !@_; 280 require Type::Tiny; 281 my %common = ( 282 name => "ArrayLike", 283 library => __PACKAGE__, 284 constraint => sub { 285 ref( $_ ) eq q[ARRAY] 286 or blessed( $_ ) && _check_overload( $_, q[@{}] ); 287 }, 288 inlined => sub { 289 qq/ref($_[1]) eq q[ARRAY] or Scalar::Util::blessed($_[1]) && ${\ +_get_check_overload_sub() }($_[1], q[\@{}])/; 290 }, 291 constraint_generator => sub { 292 my $param = TypeTiny()->assert_coerce( shift ); 293 my $check = $param->compiled_check; 294 sub { 295 my @arr = @$_; 296 for my $val ( @arr ) { 297 $check->( $val ) or return 0; 298 } 299 return 1; 300 }; 301 }, 302 inline_generator => sub { 303 my $param = TypeTiny()->assert_coerce( shift ); 304 return unless $param->can_be_inlined; 305 sub { 306 my $var = pop; 307 my $code = sprintf( 308 'do { my $ok=1; for my $v (@{%s}) { ($ok=0,next) unless (%s) }; $ok }', 309 $var, 310 $param->inline_check( '$v' ), 311 ); 312 return ( undef, $code ); 313 }; 314 }, 315 coercion_generator => sub { 316 my ( $parent, $child, $param ) = @_; 317 return unless $param->has_coercion; 318 my $coercible = $param->coercion->_source_type_union->compiled_check; 319 my $C = "Type::Coercion"->new( type_constraint => $child ); 320 $C->add_type_coercions( 321 $parent => sub { 322 my $origref = @_ ? $_[0] : $_; 323 my @orig = @$origref; 324 my @new; 325 for my $v ( @orig ) { 326 return $origref unless $coercible->( $v ); 327 push @new, $param->coerce( $v ); 328 } 329 \@new; 330 }, 331 ); 332 return $C; 333 }, 334 ); 335 if ( __XS ) { 336 my $xsub = Type::Tiny::XS::get_coderef_for( 'ArrayLike' ); 337 my $xsubname = Type::Tiny::XS::get_subname_for( 'ArrayLike' ); 338 my $inlined = $common{inlined}; 339 $cache{ArrayLike} = "Type::Tiny"->new( 340 %common, 341 compiled_type_constraint => $xsub, 342 inlined => sub { 343 344 # uncoverable subroutine 345 ( $Type::Tiny::AvoidCallbacks or not $xsubname ) 346 ? goto( $inlined ) 347 : qq/$xsubname($_[1])/ # uncoverable statement 348 }, 349 ); 350 _reinstall_subs $cache{ArrayLike}; 351 } #/ if ( __XS ) 352 else { 353 $cache{ArrayLike} = "Type::Tiny"->new( %common ); 354 } 355 356 @_ ? $cache{ArrayLike}->parameterize( @{ $_[0] } ) : $cache{ArrayLike}; 357} #/ sub ArrayLike (;@) 358 359if ( $] ge '5.014' ) { 360 &Scalar::Util::set_prototype( $_, ';$' ) for \&HashLike, \&ArrayLike; 361} 362 363sub CodeLike () { 364 return $cache{CodeLike} if $cache{CodeLike}; 365 require Type::Tiny; 366 my %common = ( 367 name => "CodeLike", 368 constraint => sub { 369 ref( $_ ) eq q[CODE] 370 or blessed( $_ ) && _check_overload( $_, q[&{}] ); 371 }, 372 inlined => sub { 373 qq/ref($_[1]) eq q[CODE] or Scalar::Util::blessed($_[1]) && ${\ +_get_check_overload_sub() }($_[1], q[\&{}])/; 374 }, 375 library => __PACKAGE__, 376 ); 377 if ( __XS ) { 378 my $xsub = Type::Tiny::XS::get_coderef_for( 'CodeLike' ); 379 my $xsubname = Type::Tiny::XS::get_subname_for( 'CodeLike' ); 380 my $inlined = $common{inlined}; 381 $cache{CodeLike} = "Type::Tiny"->new( 382 %common, 383 compiled_type_constraint => $xsub, 384 inlined => sub { 385 386 # uncoverable subroutine 387 ( $Type::Tiny::AvoidCallbacks or not $xsubname ) 388 ? goto( $inlined ) 389 : qq/$xsubname($_[1])/ # uncoverable statement 390 }, 391 ); 392 _reinstall_subs $cache{CodeLike}; 393 } #/ if ( __XS ) 394 else { 395 $cache{CodeLike} = "Type::Tiny"->new( %common ); 396 } 397} #/ sub CodeLike 398 399sub TypeTiny () { 400 return $cache{TypeTiny} if defined $cache{TypeTiny}; 401 require Type::Tiny; 402 $cache{TypeTiny} = "Type::Tiny"->new( 403 name => "TypeTiny", 404 constraint => sub { blessed( $_ ) && $_->isa( q[Type::Tiny] ) }, 405 inlined => sub { 406 my $var = $_[1]; 407 "Scalar::Util::blessed($var) && $var\->isa(q[Type::Tiny])"; 408 }, 409 library => __PACKAGE__, 410 _build_coercion => sub { 411 my $c = shift; 412 $c->add_type_coercions( _ForeignTypeConstraint(), \&to_TypeTiny ); 413 $c->freeze; 414 }, 415 ); 416} #/ sub TypeTiny 417 418sub _ForeignTypeConstraint () { 419 return $cache{_ForeignTypeConstraint} if defined $cache{_ForeignTypeConstraint}; 420 require Type::Tiny; 421 $cache{_ForeignTypeConstraint} = "Type::Tiny"->new( 422 name => "_ForeignTypeConstraint", 423 constraint => \&_is_ForeignTypeConstraint, 424 inlined => sub { 425 qq/ref($_[1]) && do { require Types::TypeTiny; Types::TypeTiny::_is_ForeignTypeConstraint($_[1]) }/; 426 }, 427 library => __PACKAGE__, 428 ); 429} #/ sub _ForeignTypeConstraint 430 431my %ttt_cache; 432 433sub _is_ForeignTypeConstraint { 434 my $t = @_ ? $_[0] : $_; 435 return !!1 if ref $t eq 'CODE'; 436 if ( my $class = blessed $t) { 437 return !!0 if $class->isa( "Type::Tiny" ); 438 return !!1 if $class->isa( "Moose::Meta::TypeConstraint" ); 439 return !!1 if $class->isa( "MooseX::Types::TypeDecorator" ); 440 return !!1 if $class->isa( "Validation::Class::Simple" ); 441 return !!1 if $class->isa( "Validation::Class" ); 442 return !!1 if $t->can( "check" ); 443 } 444 !!0; 445} #/ sub _is_ForeignTypeConstraint 446 447sub to_TypeTiny { 448 my $t = @_ ? $_[0] : $_; 449 450 return $t unless ( my $ref = ref $t ); 451 return $t if $ref =~ /^Type::Tiny\b/; 452 453 return $ttt_cache{ refaddr( $t ) } if $ttt_cache{ refaddr( $t ) }; 454 455 #<<< 456 if ( my $class = blessed $t) { 457 return $t if $class->isa( "Type::Tiny" ); 458 return _TypeTinyFromMoose( $t ) if $class eq "MooseX::Types::TypeDecorator"; # needed before MooseX::Types 0.35. 459 return _TypeTinyFromMoose( $t ) if $class->isa( "Moose::Meta::TypeConstraint" ); 460 return _TypeTinyFromMoose( $t ) if $class->isa( "MooseX::Types::TypeDecorator" ); 461 return _TypeTinyFromMouse( $t ) if $class->isa( "Mouse::Meta::TypeConstraint" ); 462 return _TypeTinyFromValidationClass( $t ) if $class->isa( "Validation::Class::Simple" ); 463 return _TypeTinyFromValidationClass( $t ) if $class->isa( "Validation::Class" ); 464 return _TypeTinyFromGeneric( $t ) if $t->can( "check" ); # i.e. Type::API::Constraint 465 } #/ if ( my $class = blessed...) 466 #>>> 467 468 return _TypeTinyFromCodeRef( $t ) if $ref eq q(CODE); 469 470 $t; 471} #/ sub to_TypeTiny 472 473sub _TypeTinyFromMoose { 474 my $t = $_[0]; 475 476 if ( ref $t->{"Types::TypeTiny::to_TypeTiny"} ) { 477 return $t->{"Types::TypeTiny::to_TypeTiny"}; 478 } 479 480 if ( $t->name ne '__ANON__' ) { 481 require Types::Standard; 482 my $ts = 'Types::Standard'->get_type( $t->name ); 483 return $ts if $ts->{_is_core}; 484 } 485 486 #<<< 487 my ( $tt_class, $tt_opts ) = 488 $t->can( 'parameterize' ) ? _TypeTinyFromMoose_parameterizable( $t ) : 489 $t->isa( 'Moose::Meta::TypeConstraint::Enum' ) ? _TypeTinyFromMoose_enum( $t ) : 490 $t->isa( 'Moose::Meta::TypeConstraint::Class' ) ? _TypeTinyFromMoose_class( $t ) : 491 $t->isa( 'Moose::Meta::TypeConstraint::Role' ) ? _TypeTinyFromMoose_role( $t ) : 492 $t->isa( 'Moose::Meta::TypeConstraint::Union' ) ? _TypeTinyFromMoose_union( $t ) : 493 $t->isa( 'Moose::Meta::TypeConstraint::DuckType' ) ? _TypeTinyFromMoose_ducktype( $t ) : 494 _TypeTinyFromMoose_baseclass( $t ); 495 #>>> 496 497 # Standard stuff to do with all type constraints from Moose, 498 # regardless of variety. 499 $tt_opts->{moose_type} = $t; 500 $tt_opts->{display_name} = $t->name; 501 $tt_opts->{message} = sub { $t->get_message( $_ ) } 502 if $t->has_message; 503 504 my $new = $tt_class->new( %$tt_opts ); 505 $ttt_cache{ refaddr( $t ) } = $new; 506 weaken( $ttt_cache{ refaddr( $t ) } ); 507 508 $new->{coercion} = do { 509 require Type::Coercion::FromMoose; 510 'Type::Coercion::FromMoose'->new( 511 type_constraint => $new, 512 moose_coercion => $t->coercion, 513 ); 514 } if $t->has_coercion; 515 516 return $new; 517} #/ sub _TypeTinyFromMoose 518 519sub _TypeTinyFromMoose_baseclass { 520 my $t = shift; 521 my %opts; 522 $opts{parent} = to_TypeTiny( $t->parent ) if $t->has_parent; 523 $opts{constraint} = $t->constraint; 524 $opts{inlined} = sub { shift; $t->_inline_check( @_ ) } 525 if $t->can( "can_be_inlined" ) && $t->can_be_inlined; 526 527 # Cowardly refuse to inline types that need to close over stuff 528 if ( $opts{inlined} ) { 529 my %env = %{ $t->inline_environment || {} }; 530 delete( $opts{inlined} ) if keys %env; 531 } 532 533 require Type::Tiny; 534 return 'Type::Tiny' => \%opts; 535} #/ sub _TypeTinyFromMoose_baseclass 536 537sub _TypeTinyFromMoose_union { 538 my $t = shift; 539 my @mapped = map _TypeTinyFromMoose( $_ ), @{ $t->type_constraints }; 540 require Type::Tiny::Union; 541 return 'Type::Tiny::Union' => { type_constraints => \@mapped }; 542} 543 544sub _TypeTinyFromMoose_enum { 545 my $t = shift; 546 require Type::Tiny::Enum; 547 return 'Type::Tiny::Enum' => { values => [ @{ $t->values } ] }; 548} 549 550sub _TypeTinyFromMoose_class { 551 my $t = shift; 552 require Type::Tiny::Class; 553 return 'Type::Tiny::Class' => { class => $t->class }; 554} 555 556sub _TypeTinyFromMoose_role { 557 my $t = shift; 558 require Type::Tiny::Role; 559 return 'Type::Tiny::Role' => { role => $t->role }; 560} 561 562sub _TypeTinyFromMoose_ducktype { 563 my $t = shift; 564 require Type::Tiny::Duck; 565 return 'Type::Tiny::Duck' => { methods => [ @{ $t->methods } ] }; 566} 567 568sub _TypeTinyFromMoose_parameterizable { 569 my $t = shift; 570 my ( $class, $opts ) = _TypeTinyFromMoose_baseclass( $t ); 571 $opts->{constraint_generator} = sub { 572 573 # convert args into Moose native types; not strictly necessary 574 my @args = map { is_TypeTiny( $_ ) ? $_->moose_type : $_ } @_; 575 _TypeTinyFromMoose( $t->parameterize( @args ) ); 576 }; 577 return ( $class, $opts ); 578} #/ sub _TypeTinyFromMoose_parameterizable 579 580sub _TypeTinyFromValidationClass { 581 my $t = $_[0]; 582 583 require Type::Tiny; 584 require Types::Standard; 585 586 my %opts = ( 587 parent => Types::Standard::HashRef(), 588 _validation_class => $t, 589 ); 590 591 if ( $t->VERSION >= "7.900048" ) { 592 $opts{constraint} = sub { 593 $t->params->clear; 594 $t->params->add( %$_ ); 595 my $f = $t->filtering; 596 $t->filtering( 'off' ); 597 my $r = eval { $t->validate }; 598 $t->filtering( $f || 'pre' ); 599 return $r; 600 }; 601 $opts{message} = sub { 602 $t->params->clear; 603 $t->params->add( %$_ ); 604 my $f = $t->filtering; 605 $t->filtering( 'off' ); 606 my $r = ( eval { $t->validate } ? "OK" : $t->errors_to_string ); 607 $t->filtering( $f || 'pre' ); 608 return $r; 609 }; 610 } #/ if ( $t->VERSION >= "7.900048") 611 else # need to use hackish method 612 { 613 $opts{constraint} = sub { 614 $t->params->clear; 615 $t->params->add( %$_ ); 616 no warnings "redefine"; 617 local *Validation::Class::Directive::Filters::execute_filtering = sub { $_[0] }; 618 eval { $t->validate }; 619 }; 620 $opts{message} = sub { 621 $t->params->clear; 622 $t->params->add( %$_ ); 623 no warnings "redefine"; 624 local *Validation::Class::Directive::Filters::execute_filtering = sub { $_[0] }; 625 eval { $t->validate } ? "OK" : $t->errors_to_string; 626 }; 627 } #/ else [ if ( $t->VERSION >= "7.900048")] 628 629 require Type::Tiny; 630 my $new = "Type::Tiny"->new( %opts ); 631 632 $new->coercion->add_type_coercions( 633 Types::Standard::HashRef() => sub { 634 my %params = %$_; 635 for my $k ( keys %params ) { delete $params{$_} unless $t->get_fields( $k ) } 636 $t->params->clear; 637 $t->params->add( %params ); 638 eval { $t->validate }; 639 $t->get_hash; 640 }, 641 ); 642 643 $ttt_cache{ refaddr( $t ) } = $new; 644 weaken( $ttt_cache{ refaddr( $t ) } ); 645 return $new; 646} #/ sub _TypeTinyFromValidationClass 647 648sub _TypeTinyFromGeneric { 649 my $t = $_[0]; 650 651 my %opts = ( 652 constraint => sub { $t->check( @_ ? @_ : $_ ) }, 653 ); 654 655 $opts{message} = sub { $t->get_message( @_ ? @_ : $_ ) } 656 if $t->can( "get_message" ); 657 658 $opts{display_name} = $t->name if $t->can( "name" ); 659 660 $opts{coercion} = sub { $t->coerce( @_ ? @_ : $_ ) } 661 if $t->can( "has_coercion" ) 662 && $t->has_coercion 663 && $t->can( "coerce" ); 664 665 if ( $t->can( 'can_be_inlined' ) 666 && $t->can_be_inlined 667 && $t->can( 'inline_check' ) ) 668 { 669 $opts{inlined} = sub { $t->inline_check( $_[1] ) }; 670 } 671 672 require Type::Tiny; 673 my $new = "Type::Tiny"->new( %opts ); 674 $ttt_cache{ refaddr( $t ) } = $new; 675 weaken( $ttt_cache{ refaddr( $t ) } ); 676 return $new; 677} #/ sub _TypeTinyFromGeneric 678 679sub _TypeTinyFromMouse { 680 my $t = $_[0]; 681 682 my %opts = ( 683 constraint => sub { $t->check( @_ ? @_ : $_ ) }, 684 message => sub { $t->get_message( @_ ? @_ : $_ ) }, 685 ); 686 687 $opts{display_name} = $t->name if $t->can( "name" ); 688 689 $opts{coercion} = sub { $t->coerce( @_ ? @_ : $_ ) } 690 if $t->can( "has_coercion" ) 691 && $t->has_coercion 692 && $t->can( "coerce" ); 693 694 if ( $t->{'constraint_generator'} ) { 695 $opts{constraint_generator} = sub { 696 697 # convert args into Moose native types; not strictly necessary 698 my @args = map { is_TypeTiny( $_ ) ? $_->mouse_type : $_ } @_; 699 _TypeTinyFromMouse( $t->parameterize( @args ) ); 700 }; 701 } 702 703 require Type::Tiny; 704 my $new = "Type::Tiny"->new( %opts ); 705 $ttt_cache{ refaddr( $t ) } = $new; 706 weaken( $ttt_cache{ refaddr( $t ) } ); 707 return $new; 708} #/ sub _TypeTinyFromMouse 709 710my $QFS; 711 712sub _TypeTinyFromCodeRef { 713 my $t = $_[0]; 714 715 my %opts = ( 716 constraint => sub { 717 return !!eval { $t->( $_ ) }; 718 }, 719 message => sub { 720 local $@; 721 eval { $t->( $_ ); 1 } or do { chomp $@; return $@ if $@ }; 722 return sprintf( '%s did not pass type constraint', Type::Tiny::_dd( $_ ) ); 723 }, 724 ); 725 726 if ( $QFS ||= "Sub::Quote"->can( "quoted_from_sub" ) ) { 727 my ( undef, $perlstring, $captures ) = @{ $QFS->( $t ) || [] }; 728 if ( $perlstring ) { 729 $perlstring = "!!eval{ $perlstring }"; 730 $opts{inlined} = sub { 731 my $var = $_[1]; 732 Sub::Quote::inlinify( 733 $perlstring, 734 $var, 735 $var eq q($_) ? '' : "local \$_ = $var;", 736 1, 737 ); 738 } 739 if $perlstring && !$captures; 740 } #/ if ( $perlstring ) 741 } #/ if ( $QFS ||= "Sub::Quote"...) 742 743 require Type::Tiny; 744 my $new = "Type::Tiny"->new( %opts ); 745 $ttt_cache{ refaddr( $t ) } = $new; 746 weaken( $ttt_cache{ refaddr( $t ) } ); 747 return $new; 748} #/ sub _TypeTinyFromCodeRef 749 7501; 751 752__END__ 753 754=pod 755 756=encoding utf-8 757 758=for stopwords arrayfication hashification 759 760=head1 NAME 761 762Types::TypeTiny - type constraints used internally by Type::Tiny 763 764=head1 STATUS 765 766This module is covered by the 767L<Type-Tiny stability policy|Type::Tiny::Manual::Policies/"STABILITY">. 768 769=head1 DESCRIPTION 770 771Dogfooding. 772 773This isn't a real Type::Library-based type library; that would involve 774too much circularity. But it exports some type constraints which, while 775designed for use within Type::Tiny, may be more generally useful. 776 777=head2 Types 778 779=over 780 781=item * 782 783B<< StringLike >> 784 785Accepts strings and objects overloading stringification. 786 787=item * 788 789B<< HashLike[`a] >> 790 791Accepts hashrefs and objects overloading hashification. 792 793Since Types::TypeTiny 1.012, may be parameterized with another type 794constraint like B<< HashLike[Int] >>. 795 796=item * 797 798B<< ArrayLike[`a] >> 799 800Accepts arrayrefs and objects overloading arrayfication. 801 802Since Types::TypeTiny 1.012, may be parameterized with another type 803constraint like B<< ArrayLike[Int] >>. 804 805=item * 806 807B<< CodeLike >> 808 809Accepts coderefs and objects overloading codification. 810 811=item * 812 813B<< TypeTiny >> 814 815Accepts blessed L<Type::Tiny> objects. 816 817=item * 818 819B<< _ForeignTypeConstraint >> 820 821Any reference which to_TypeTiny recognizes as something that can be coerced 822to a Type::Tiny object. 823 824Yes, the underscore is included. 825 826=back 827 828=head2 Coercion Functions 829 830=over 831 832=item C<< to_TypeTiny($constraint) >> 833 834Promotes (or "demotes" if you prefer) a Moose::Meta::TypeConstraint object 835to a Type::Tiny object. 836 837Can also handle L<Validation::Class> objects. Type constraints built from 838Validation::Class objects deliberately I<ignore> field filters when they 839do constraint checking (and go to great lengths to do so); using filters for 840coercion only. (The behaviour of C<coerce> if we don't do that is just too 841weird!) 842 843Can also handle any object providing C<check> and C<get_message> methods. 844(This includes L<Mouse::Meta::TypeConstraint> objects.) If the object also 845provides C<has_coercion> and C<coerce> methods, these will be used too. 846 847Can also handle coderefs (but not blessed coderefs or objects overloading 848C<< &{} >>). Coderefs are expected to return true iff C<< $_ >> passes the 849constraint. If C<< $_ >> fails the type constraint, they may either return 850false, or die with a helpful error message. 851 852=back 853 854=head2 Methods 855 856These are implemented so that C<< Types::TypeTiny->meta->get_type($foo) >> 857works, for rough compatibility with a real L<Type::Library> type library. 858 859=over 860 861=item C<< meta >> 862 863=item C<< type_names >> 864 865=item C<< get_type($name) >> 866 867=item C<< has_type($name) >> 868 869=item C<< coercion_names >> 870 871=item C<< get_coercion($name) >> 872 873=item C<< has_coercion($name) >> 874 875=back 876 877=head1 BUGS 878 879Please report any bugs to 880L<https://github.com/tobyink/p5-type-tiny/issues>. 881 882=head1 SEE ALSO 883 884L<Type::Tiny>. 885 886=head1 AUTHOR 887 888Toby Inkster E<lt>tobyink@cpan.orgE<gt>. 889 890=head1 COPYRIGHT AND LICENCE 891 892This software is copyright (c) 2013-2014, 2017-2021 by Toby Inkster. 893 894This is free software; you can redistribute it and/or modify it under 895the same terms as the Perl 5 programming language system itself. 896 897=head1 DISCLAIMER OF WARRANTIES 898 899THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED 900WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF 901MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. 902