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