use
5.008001;
BEGIN {
}
BEGIN {
$Types::Standard::AUTHORITY
=
'cpan:TOBYINK'
;
$Types::Standard::VERSION
=
'2.006000'
;
}
$Types::Standard::VERSION
=~
tr
/_//d;
our
@EXPORT_OK
=
qw( slurpy )
;
my
$is_class_loaded
;
BEGIN {
$is_class_loaded
=
q{sub {
no strict 'refs';
return !!0 if ref $_[0];
return !!0 if not $_[0];
return !!0 if ref(do { my $tmpstr = $_[0]; \$tmpstr }
) ne
'SCALAR'
;
my
$stash
= \%{
"$_[0]\::"
};
return
!!1
if
exists
(
$stash
->{
'ISA'
}) && *{
$stash
->{
'ISA'
}}{ARRAY} && @{
$_
[0].
'::ISA'
};
return
!!1
if
exists
(
$stash
->{
'VERSION'
});
foreach
my
$globref
(
values
%$stash
) {
return
!!1
if
ref
\
$globref
eq
'GLOB'
? *{
$globref
}{CODE}
:
ref
$globref
;
}
return
!!0;
}};
*_is_class_loaded
=
Type::Tiny::_USE_XS
? \
&Type::Tiny::XS::Util::is_class_loaded
:
eval
$is_class_loaded
;
*_HAS_REFUTILXS
=
eval
{
Ref::Util::XS::->VERSION( 0.100 );
1;
}
?
sub
() { !!1 }
:
sub
() { !!0 };
}
my
$add_core_type
=
sub
{
my
$meta
=
shift
;
my
(
$typedef
) =
@_
;
my
$name
=
$typedef
->{name};
my
(
$xsub
,
$xsubname
);
$typedef
->{_is_core} = 1
unless
$name
eq
'Map'
||
$name
eq
'Tuple'
;
if
( Type::Tiny::_USE_XS
and not(
$name
eq
'RegexpRef'
) )
{
$xsub
= Type::Tiny::XS::get_coderef_for(
$name
);
$xsubname
= Type::Tiny::XS::get_subname_for(
$name
);
}
elsif
( Type::Tiny::_USE_MOUSE
and not(
$name
eq
'RegexpRef'
or
$name
eq
'Int'
or
$name
eq
'Object'
) )
{
$xsub
=
"Mouse::Util::TypeConstraints"
->can(
$name
);
$xsubname
=
"Mouse::Util::TypeConstraints::$name"
if
$xsub
;
}
if
( Type::Tiny::_USE_XS
and Type::Tiny::XS->VERSION < 0.014
and
$name
eq
'Bool'
)
{
$xsub
=
$xsubname
=
undef
;
}
if
( Type::Tiny::_USE_XS
and ( Type::Tiny::XS->VERSION < 0.016 or $] < 5.018 )
and
$name
eq
'Int'
)
{
$xsub
=
$xsubname
=
undef
;
}
$typedef
->{compiled_type_constraint} =
$xsub
if
$xsub
;
my
$orig_inlined
=
$typedef
->{inlined};
if
(
defined
(
$xsubname
) and (
$name
eq
'Str'
or
$name
eq
'Bool'
or
$name
eq
'Int'
or
$name
eq
'ClassName'
or
$name
eq
'RegexpRef'
or
$name
eq
'FileHandle'
)
)
{
$typedef
->{inlined} =
sub
{
$Type::Tiny::AvoidCallbacks
?
goto
(
$orig_inlined
) :
"$xsubname\($_[1])"
;
};
}
@_
= (
$meta
,
$typedef
);
goto
\
&Type::Library::add_type
;
};
my
$maybe_load_modules
=
sub
{
my
$code
=
pop
;
if
(
$Type::Tiny::AvoidCallbacks
) {
$code
=
sprintf
(
'do { %s %s; %s }'
,
$Type::Tiny::SafePackage
,
join
(
'; '
,
map
"use $_ ()"
,
@_
),
$code
,
);
}
$code
;
};
sub
_croak ($;@) {
require
Error::TypeTiny;
goto
\
&Error::TypeTiny::croak
}
my
$meta
= __PACKAGE__->meta;
{
sub
Stringable (&) {
bless
+{
code
=>
$_
[0] },
'Types::Standard::_Stringable'
;
}
Types::Standard::_Stringable->Type::Tiny::_install_overloads(
q[""]
=>
sub
{
$_
[0]{text} ||=
$_
[0]{code}->() } );
sub
LazyLoad ($$) {
bless
\
@_
,
'Types::Standard::LazyLoad'
;
}
'Types::Standard::LazyLoad'
->Type::Tiny::_install_overloads(
q[&{}]
=>
sub
{
my
(
$typename
,
$function
) = @{
$_
[0] };
my
$type
=
$meta
->get_type(
$typename
);
my
$class
=
"Types::Standard::$typename"
;
eval
"require $class; 1"
or
die
( $@ );
for
my
$key
(
keys
%$type
) {
next
unless
ref
(
$type
->{
$key
} ) eq
'Types::Standard::LazyLoad'
;
my
$f
=
$type
->{
$key
}[1];
$type
->{
$key
} =
$class
->can(
"__$f"
);
}
my
$mm
=
$type
->{my_methods} || {};
for
my
$key
(
keys
%$mm
) {
next
unless
ref
(
$mm
->{
$key
} ) eq
'Types::Standard::LazyLoad'
;
my
$f
=
$mm
->{
$key
}[1];
$mm
->{
$key
} =
$class
->can(
"__$f"
);
set_subname(
sprintf
(
"%s::my_%s"
,
$type
->qualified_name,
$key
),
$mm
->{
$key
},
);
}
return
$class
->can(
"__$function"
);
},
);
}
no
warnings;
BEGIN {
*STRICTNUM
=
$ENV
{PERL_TYPES_STANDARD_STRICTNUM}
?
sub
() { !!1 }
:
sub
() { !!0 }
}
my
$_any
=
$meta
->
$add_core_type
(
{
name
=>
"Any"
,
inlined
=>
sub
{
"!!1"
},
complement_name
=>
'None'
,
type_default
=>
sub
{
return
undef
; },
}
);
my
$_item
=
$meta
->
$add_core_type
(
{
name
=>
"Item"
,
inlined
=>
sub
{
"!!1"
},
parent
=>
$_any
,
}
);
my
$_bool
=
$meta
->
$add_core_type
(
{
name
=>
"Bool"
,
parent
=>
$_item
,
constraint
=>
sub
{
!
ref
$_
and ( !
defined
$_
or
$_
eq
q()
or
$_
eq
'0'
or
$_
eq
'1'
);
},
inlined
=>
sub
{
"!ref $_[1] and (!defined $_[1] or $_[1] eq q() or $_[1] eq '0' or $_[1] eq '1')"
;
},
type_default
=>
sub
{
return
!!0; },
}
);
$_bool
->coercion->add_type_coercions(
$_any
,
q{!!$_}
);
my
$_undef
=
$meta
->
$add_core_type
(
{
name
=>
"Undef"
,
parent
=>
$_item
,
constraint
=>
sub
{ !
defined
$_
},
inlined
=>
sub
{
"!defined($_[1])"
},
type_default
=>
sub
{
return
undef
; },
}
);
my
$_def
=
$meta
->
$add_core_type
(
{
name
=>
"Defined"
,
parent
=>
$_item
,
constraint
=>
sub
{
defined
$_
},
inlined
=>
sub
{
"defined($_[1])"
},
complementary_type
=>
$_undef
,
}
);
Scalar::Util::weaken(
$_undef
->{complementary_type} ||=
$_def
);
my
$_val
=
$meta
->
$add_core_type
(
{
name
=>
"Value"
,
parent
=>
$_def
,
constraint
=>
sub
{ not
ref
$_
},
inlined
=>
sub
{
"defined($_[1]) and not ref($_[1])"
},
}
);
my
$_str
=
$meta
->
$add_core_type
(
{
name
=>
"Str"
,
parent
=>
$_val
,
constraint
=>
sub
{
ref
( \
$_
) eq
'SCALAR'
or
ref
( \(
my
$val
=
$_
) ) eq
'SCALAR'
;
},
inlined
=>
sub
{
"defined($_[1]) and do { ref(\\$_[1]) eq 'SCALAR' or ref(\\(my \$val = $_[1])) eq 'SCALAR' }"
;
},
sorter
=>
sub
{
$_
[0] cmp
$_
[1] },
type_default
=>
sub
{
return
''
; },
}
);
my
$_laxnum
=
$meta
->add_type(
{
name
=>
"LaxNum"
,
parent
=>
$_str
,
constraint
=>
sub
{ looks_like_number(
$_
) and
ref
( \
$_
) ne
'GLOB'
},
inlined
=>
sub
{
$maybe_load_modules
->(
qw/ Scalar::Util /
,
'Scalar::Util'
->VERSION ge
'1.18'
?
"defined($_[1]) && !ref($_[1]) && Scalar::Util::looks_like_number($_[1])"
:
"defined($_[1]) && !ref($_[1]) && Scalar::Util::looks_like_number($_[1]) && ref(\\($_[1])) ne 'GLOB'"
);
},
sorter
=>
sub
{
$_
[0] <=>
$_
[1] },
type_default
=>
sub
{
return
0; },
}
);
my
$_strictnum
=
$meta
->add_type(
{
name
=>
"StrictNum"
,
parent
=>
$_str
,
constraint
=>
sub
{
my
$val
=
$_
;
(
$val
=~ /\A[+-]?[0-9]+\z/ )
|| (
$val
=~ /\A(?:[+-]?)
(?=[0-9]|\.[0-9])
[0-9]*
(?:\.[0-9]+)?
(?:[Ee](?:[+-]?[0-9]+))?
\z/x
);
},
inlined
=>
sub
{
'my $val = '
.
$_
[1] .
';'
. Value()->inline_check(
'$val'
)
.
' && ( $val =~ /\A[+-]?[0-9]+\z/ || '
. '
$val
=~ /\A(?:[+-]?)
(?=[0-9]|\.[0-9])
[0-9]*
(?:\.[0-9]+)?
(?:[Ee](?:[+-]?[0-9]+))?
\z/x ); '
},
sorter
=>
sub
{
$_
[0] <=>
$_
[1] },
type_default
=>
sub
{
return
0; },
}
);
my
$_num
=
$meta
->add_type(
{
name
=>
"Num"
,
parent
=> ( STRICTNUM ?
$_strictnum
:
$_laxnum
),
}
);
$meta
->
$add_core_type
(
{
name
=>
"Int"
,
parent
=>
$_num
,
constraint
=>
sub
{ /\A-?[0-9]+\z/ },
inlined
=>
sub
{
"do { my \$tmp = $_[1]; defined(\$tmp) and !ref(\$tmp) and \$tmp =~ /\\A-?[0-9]+\\z/ }"
;
},
type_default
=>
sub
{
return
0; },
}
);
my
$_classn
=
$meta
->add_type(
{
name
=>
"ClassName"
,
parent
=>
$_str
,
constraint
=> \
&_is_class_loaded
,
inlined
=>
sub
{
$Type::Tiny::AvoidCallbacks
?
"($is_class_loaded)->(do { my \$tmp = $_[1] })"
:
"Types::Standard::_is_class_loaded(do { my \$tmp = $_[1] })"
;
},
}
);
$meta
->add_type(
{
name
=>
"RoleName"
,
parent
=>
$_classn
,
constraint
=>
sub
{ not
$_
->can(
"new"
) },
inlined
=>
sub
{
$Type::Tiny::AvoidCallbacks
?
"($is_class_loaded)->(do { my \$tmp = $_[1] }) and not $_[1]\->can('new')"
:
"Types::Standard::_is_class_loaded(do { my \$tmp = $_[1] }) and not $_[1]\->can('new')"
;
},
}
);
my
$_ref
=
$meta
->
$add_core_type
(
{
name
=>
"Ref"
,
parent
=>
$_def
,
constraint
=>
sub
{
ref
$_
},
inlined
=>
sub
{
"!!ref($_[1])"
},
constraint_generator
=>
sub
{
return
$meta
->get_type(
'Ref'
)
unless
@_
;
my
$reftype
=
shift
;
$reftype
=~
/^(SCALAR|ARRAY|HASH|CODE|REF|GLOB|LVALUE|FORMAT|IO|VSTRING|REGEXP|Regexp)$/i
or _croak(
"Parameter to Ref[`a] expected to be a Perl ref type; got $reftype"
);
$reftype
=
"$reftype"
;
return
sub
{
ref
(
$_
[0] ) and Scalar::Util::reftype(
$_
[0] ) eq
$reftype
;
}
},
inline_generator
=>
sub
{
my
$reftype
=
shift
;
return
sub
{
my
$v
=
$_
[1];
$maybe_load_modules
->(
qw/ Scalar::Util /
,
"ref($v) and Scalar::Util::reftype($v) eq q($reftype)"
);
};
},
deep_explanation
=>
sub
{
my
(
$type
,
$value
,
$varname
) =
@_
;
my
$param
=
$type
->parameters->[0];
return
if
$type
->check(
$value
);
my
$reftype
= Scalar::Util::reftype(
$value
);
return
[
sprintf
(
'"%s" constrains reftype(%s) to be equal to %s'
,
$type
,
$varname
,
B::perlstring(
$param
)
),
sprintf
(
'reftype(%s) is %s'
,
$varname
,
defined
(
$reftype
) ? B::perlstring(
$reftype
) :
"undef"
),
];
},
}
);
$meta
->
$add_core_type
(
{
name
=>
"CodeRef"
,
parent
=>
$_ref
,
constraint
=>
sub
{
ref
$_
eq
"CODE"
},
inlined
=>
sub
{
_HAS_REFUTILXS && !
$Type::Tiny::AvoidCallbacks
?
"Ref::Util::XS::is_plain_coderef($_[1])"
:
"ref($_[1]) eq 'CODE'"
;
},
type_default
=>
sub
{
return
sub
{}; },
}
);
my
$_regexp
=
$meta
->
$add_core_type
(
{
name
=>
"RegexpRef"
,
parent
=>
$_ref
,
constraint
=>
sub
{
ref
(
$_
) && !!re::is_regexp(
$_
) or blessed(
$_
) &&
$_
->isa(
'Regexp'
);
},
inlined
=>
sub
{
my
$v
=
$_
[1];
$maybe_load_modules
->(
qw/ Scalar::Util re /
,
"ref($v) && !!re::is_regexp($v) or Scalar::Util::blessed($v) && $v\->isa('Regexp')"
);
},
type_default
=>
sub
{
return
qr//
; },
}
);
$meta
->
$add_core_type
(
{
name
=>
"GlobRef"
,
parent
=>
$_ref
,
constraint
=>
sub
{
ref
$_
eq
"GLOB"
},
inlined
=>
sub
{
_HAS_REFUTILXS && !
$Type::Tiny::AvoidCallbacks
?
"Ref::Util::XS::is_plain_globref($_[1])"
:
"ref($_[1]) eq 'GLOB'"
;
},
}
);
$meta
->
$add_core_type
(
{
name
=>
"FileHandle"
,
parent
=>
$_ref
,
constraint
=>
sub
{
(
ref
(
$_
) && Scalar::Util::openhandle(
$_
) )
or ( blessed(
$_
) &&
$_
->isa(
"IO::Handle"
) );
},
inlined
=>
sub
{
$maybe_load_modules
->(
qw/ Scalar::Util /
,
"(ref($_[1]) && Scalar::Util::openhandle($_[1])) "
.
"or (Scalar::Util::blessed($_[1]) && $_[1]\->isa(\"IO::Handle\"))"
);
},
}
);
my
$_arr
=
$meta
->
$add_core_type
(
{
name
=>
"ArrayRef"
,
parent
=>
$_ref
,
constraint
=>
sub
{
ref
$_
eq
"ARRAY"
},
inlined
=>
sub
{
_HAS_REFUTILXS && !
$Type::Tiny::AvoidCallbacks
?
"Ref::Util::XS::is_plain_arrayref($_[1])"
:
"ref($_[1]) eq 'ARRAY'"
;
},
constraint_generator
=> LazyLoad(
ArrayRef
=>
'constraint_generator'
),
inline_generator
=> LazyLoad(
ArrayRef
=>
'inline_generator'
),
deep_explanation
=> LazyLoad(
ArrayRef
=>
'deep_explanation'
),
coercion_generator
=> LazyLoad(
ArrayRef
=>
'coercion_generator'
),
type_default
=>
sub
{
return
[]; },
type_default_generator
=>
sub
{
return
$Type::Tiny::parameterize_type
->type_default
if
@_
< 2;
return
undef
;
},
}
);
my
$_hash
=
$meta
->
$add_core_type
(
{
name
=>
"HashRef"
,
parent
=>
$_ref
,
constraint
=>
sub
{
ref
$_
eq
"HASH"
},
inlined
=>
sub
{
_HAS_REFUTILXS && !
$Type::Tiny::AvoidCallbacks
?
"Ref::Util::XS::is_plain_hashref($_[1])"
:
"ref($_[1]) eq 'HASH'"
;
},
constraint_generator
=> LazyLoad(
HashRef
=>
'constraint_generator'
),
inline_generator
=> LazyLoad(
HashRef
=>
'inline_generator'
),
deep_explanation
=> LazyLoad(
HashRef
=>
'deep_explanation'
),
coercion_generator
=> LazyLoad(
HashRef
=>
'coercion_generator'
),
type_default
=>
sub
{
return
{}; },
type_default_generator
=>
sub
{
return
$Type::Tiny::parameterize_type
->type_default
if
@_
< 2;
return
undef
;
},
my_methods
=> {
hashref_allows_key
=> LazyLoad(
HashRef
=>
'hashref_allows_key'
),
hashref_allows_value
=> LazyLoad(
HashRef
=>
'hashref_allows_value'
),
},
}
);
$meta
->
$add_core_type
(
{
name
=>
"ScalarRef"
,
parent
=>
$_ref
,
constraint
=>
sub
{
ref
$_
eq
"SCALAR"
or
ref
$_
eq
"REF"
},
inlined
=>
sub
{
"ref($_[1]) eq 'SCALAR' or ref($_[1]) eq 'REF'"
},
constraint_generator
=> LazyLoad(
ScalarRef
=>
'constraint_generator'
),
inline_generator
=> LazyLoad(
ScalarRef
=>
'inline_generator'
),
deep_explanation
=> LazyLoad(
ScalarRef
=>
'deep_explanation'
),
coercion_generator
=> LazyLoad(
ScalarRef
=>
'coercion_generator'
),
type_default
=>
sub
{
my
$x
;
return
\
$x
; },
}
);
my
$_obj
=
$meta
->
$add_core_type
(
{
name
=>
"Object"
,
parent
=>
$_ref
,
constraint
=>
sub
{ blessed
$_
},
inlined
=>
sub
{
_HAS_REFUTILXS && !
$Type::Tiny::AvoidCallbacks
?
"Ref::Util::XS::is_blessed_ref($_[1])"
:
$maybe_load_modules
->(
'Scalar::Util'
,
"Scalar::Util::blessed($_[1])"
);
},
is_object
=> 1,
}
);
$meta
->
$add_core_type
(
{
name
=>
"Maybe"
,
parent
=>
$_item
,
constraint_generator
=>
sub
{
return
$meta
->get_type(
'Maybe'
)
unless
@_
;
my
$param
= Types::TypeTiny::to_TypeTiny(
shift
);
Types::TypeTiny::is_TypeTiny(
$param
)
or _croak(
"Parameter to Maybe[`a] expected to be a type constraint; got $param"
);
my
$param_compiled_check
=
$param
->compiled_check;
my
@xsub
;
if
( Type::Tiny::_USE_XS ) {
my
$paramname
= Type::Tiny::XS::is_known(
$param_compiled_check
);
push
@xsub
, Type::Tiny::XS::get_coderef_for(
"Maybe[$paramname]"
)
if
$paramname
;
}
elsif
( Type::Tiny::_USE_MOUSE and
$param
->_has_xsub ) {
my
$maker
=
"Mouse::Util::TypeConstraints"
->can(
"_parameterize_Maybe_for"
);
push
@xsub
,
$maker
->(
$param
)
if
$maker
;
}
return
(
sub
{
my
$value
=
shift
;
return
!!1
unless
defined
$value
;
return
$param
->check(
$value
);
},
@xsub
,
);
},
inline_generator
=>
sub
{
my
$param
=
shift
;
my
$param_compiled_check
=
$param
->compiled_check;
my
$xsubname
;
if
( Type::Tiny::_USE_XS ) {
my
$paramname
= Type::Tiny::XS::is_known(
$param_compiled_check
);
$xsubname
= Type::Tiny::XS::get_subname_for(
"Maybe[$paramname]"
);
}
return
unless
$param
->can_be_inlined;
return
sub
{
my
$v
=
$_
[1];
return
"$xsubname\($v\)"
if
$xsubname
&& !
$Type::Tiny::AvoidCallbacks
;
my
$param_check
=
$param
->inline_check(
$v
);
"!defined($v) or $param_check"
;
};
},
deep_explanation
=>
sub
{
my
(
$type
,
$value
,
$varname
) =
@_
;
my
$param
=
$type
->parameters->[0];
return
[
sprintf
(
'%s is defined'
, Type::Tiny::_dd(
$value
) ),
sprintf
(
'"%s" constrains the value with "%s" if it is defined'
,
$type
,
$param
),
@{
$param
->validate_explain(
$value
,
$varname
) },
];
},
coercion_generator
=>
sub
{
my
(
$parent
,
$child
,
$param
) =
@_
;
return
unless
$param
->has_coercion;
return
$param
->coercion;
},
type_default
=>
sub
{
return
undef
; },
type_default_generator
=>
sub
{
$_
[0]->type_default ||
$Type::Tiny::parameterize_type
->type_default ;
},
}
);
my
$_map
=
$meta
->
$add_core_type
(
{
name
=>
"Map"
,
parent
=>
$_hash
,
constraint_generator
=> LazyLoad(
Map
=>
'constraint_generator'
),
inline_generator
=> LazyLoad(
Map
=>
'inline_generator'
),
deep_explanation
=> LazyLoad(
Map
=>
'deep_explanation'
),
coercion_generator
=> LazyLoad(
Map
=>
'coercion_generator'
),
my_methods
=> {
hashref_allows_key
=> LazyLoad(
Map
=>
'hashref_allows_key'
),
hashref_allows_value
=> LazyLoad(
Map
=>
'hashref_allows_value'
),
},
type_default_generator
=>
sub
{
return
$Type::Tiny::parameterize_type
->type_default;
},
}
);
my
$_Optional
=
$meta
->add_type(
{
name
=>
"Optional"
,
parent
=>
$_item
,
constraint_generator
=>
sub
{
return
$meta
->get_type(
'Optional'
)
unless
@_
;
my
$param
= Types::TypeTiny::to_TypeTiny(
shift
);
Types::TypeTiny::is_TypeTiny(
$param
)
or _croak(
"Parameter to Optional[`a] expected to be a type constraint; got $param"
);
sub
{
$param
->check(
$_
[0] ) }
},
inline_generator
=>
sub
{
my
$param
=
shift
;
return
unless
$param
->can_be_inlined;
return
sub
{
my
$v
=
$_
[1];
$param
->inline_check(
$v
);
};
},
deep_explanation
=>
sub
{
my
(
$type
,
$value
,
$varname
) =
@_
;
my
$param
=
$type
->parameters->[0];
return
[
sprintf
(
'%s exists'
,
$varname
),
sprintf
(
'"%s" constrains %s with "%s" if it exists'
,
$type
,
$varname
,
$param
),
@{
$param
->validate_explain(
$value
,
$varname
) },
];
},
coercion_generator
=>
sub
{
my
(
$parent
,
$child
,
$param
) =
@_
;
return
unless
$param
->has_coercion;
return
$param
->coercion;
},
type_default_generator
=>
sub
{
return
$_
[0]->type_default;
},
}
);
my
$_slurpy
;
$_slurpy
=
$meta
->add_type(
{
name
=>
"Slurpy"
,
slurpy
=> 1,
parent
=>
$_item
,
constraint_generator
=>
sub
{
my
$self
=
$_slurpy
;
my
$param
=
@_
? Types::TypeTiny::to_TypeTiny(
shift
) :
$_any
;
Types::TypeTiny::is_TypeTiny(
$param
)
or _croak(
"Parameter to Slurpy[`a] expected to be a type constraint; got $param"
);
return
$self
->create_child_type(
slurpy
=> 1,
display_name
=>
$self
->name_generator->(
$self
,
$param
),
parameters
=> [
$param
],
constraint
=>
sub
{
$param
->check(
$_
[0] ) },
type_default
=>
$param
->type_default,
_build_coercion
=>
sub
{
my
$coercion
=
shift
;
$coercion
->add_type_coercions( @{
$param
->coercion->type_coercion_map } )
if
$param
->has_coercion;
$coercion
->freeze;
},
$param
->can_be_inlined
? (
inlined
=>
sub
{
$param
->inline_check(
$_
[1] ) } )
: (),
);
},
deep_explanation
=>
sub
{
my
(
$type
,
$value
,
$varname
) =
@_
;
my
$param
=
$type
->parameters->[0];
return
[
sprintf
(
'%s is slurpy'
,
$varname
),
@{
$param
->validate_explain(
$value
,
$varname
) },
];
},
my_methods
=> {
'unslurpy'
=>
sub
{
my
$self
=
shift
;
$self
->{_my_unslurpy} ||=
$self
->find_parent(
sub
{
$_
->parent->{uniq} ==
$_slurpy
->{uniq} }
)->type_parameter;
},
'slurp_into'
=>
sub
{
my
$self
=
shift
;
my
$parameters
=
$self
->find_parent(
sub
{
$_
->parent->{uniq} ==
$_slurpy
->{uniq} }
)->parameters;
if
(
$parameters
->[1] ) {
return
$parameters
->[1];
}
my
$constraint
=
$parameters
->[0];
return
'HASH'
if
$constraint
->is_a_type_of( HashRef() )
or
$constraint
->is_a_type_of( Map() )
or
$constraint
->is_a_type_of( Dict() );
return
'ARRAY'
;
},
},
}
);
sub
slurpy {
my
$t
=
shift
;
my
$s
=
$_slurpy
->of(
$t
);
$s
->{slurpy} ||= 1;
wantarray
? (
$s
,
@_
) :
$s
;
}
$meta
->
$add_core_type
(
{
name
=>
"Tuple"
,
parent
=>
$_arr
,
name_generator
=>
sub
{
my
(
$s
,
@a
) =
@_
;
sprintf
(
'%s[%s]'
,
$s
,
join
q[,]
,
@a
);
},
constraint_generator
=> LazyLoad(
Tuple
=>
'constraint_generator'
),
inline_generator
=> LazyLoad(
Tuple
=>
'inline_generator'
),
deep_explanation
=> LazyLoad(
Tuple
=>
'deep_explanation'
),
coercion_generator
=> LazyLoad(
Tuple
=>
'coercion_generator'
),
}
);
$meta
->add_type(
{
name
=>
"CycleTuple"
,
parent
=>
$_arr
,
name_generator
=>
sub
{
my
(
$s
,
@a
) =
@_
;
sprintf
(
'%s[%s]'
,
$s
,
join
q[,]
,
@a
);
},
constraint_generator
=> LazyLoad(
CycleTuple
=>
'constraint_generator'
),
inline_generator
=> LazyLoad(
CycleTuple
=>
'inline_generator'
),
deep_explanation
=> LazyLoad(
CycleTuple
=>
'deep_explanation'
),
coercion_generator
=> LazyLoad(
CycleTuple
=>
'coercion_generator'
),
}
);
$meta
->add_type(
{
name
=>
"Dict"
,
parent
=>
$_hash
,
name_generator
=>
sub
{
my
(
$s
,
@p
) =
@_
;
my
$l
=
@p
&& Types::TypeTiny::is_TypeTiny(
$p
[-1] )
&&
$p
[-1]->is_strictly_a_type_of( Types::Standard::Slurpy() )
?
pop
(
@p
)
:
undef
;
my
%a
=
@p
;
sprintf
(
'%s[%s%s]'
,
$s
,
join
(
q[,]
,
map
sprintf
(
"%s=>%s"
,
$_
,
$a
{
$_
} ),
sort
keys
%a
),
$l
?
",$l"
:
''
);
},
constraint_generator
=> LazyLoad(
Dict
=>
'constraint_generator'
),
inline_generator
=> LazyLoad(
Dict
=>
'inline_generator'
),
deep_explanation
=> LazyLoad(
Dict
=>
'deep_explanation'
),
coercion_generator
=> LazyLoad(
Dict
=>
'coercion_generator'
),
my_methods
=> {
dict_is_slurpy
=> LazyLoad(
Dict
=>
'dict_is_slurpy'
),
hashref_allows_key
=> LazyLoad(
Dict
=>
'hashref_allows_key'
),
hashref_allows_value
=> LazyLoad(
Dict
=>
'hashref_allows_value'
),
},
}
);
$meta
->add_type(
{
name
=>
"Overload"
,
parent
=>
$_obj
,
constraint
=>
sub
{
require
overload; overload::Overloaded(
$_
) },
inlined
=>
sub
{
$maybe_load_modules
->(
qw/ Scalar::Util overload /
,
$INC
{
'overload.pm'
}
?
"Scalar::Util::blessed($_[1]) and overload::Overloaded($_[1])"
:
"Scalar::Util::blessed($_[1]) and do { use overload (); overload::Overloaded($_[1]) }"
);
},
constraint_generator
=>
sub
{
return
$meta
->get_type(
'Overload'
)
unless
@_
;
my
@operations
=
map
{
Types::TypeTiny::is_StringLike(
$_
)
?
"$_"
: _croak(
"Parameters to Overload[`a] expected to be a strings; got $_"
);
}
@_
;
return
sub
{
my
$value
=
shift
;
for
my
$op
(
@operations
) {
return
unless
overload::Method(
$value
,
$op
);
}
return
!!1;
}
},
inline_generator
=>
sub
{
my
@operations
=
@_
;
return
sub
{
my
$v
=
$_
[1];
$maybe_load_modules
->(
qw/ Scalar::Util overload /
,
join
" and "
,
"Scalar::Util::blessed($v)"
,
map
"overload::Method($v, q[$_])"
,
@operations
);
};
},
is_object
=> 1,
}
);
$meta
->add_type(
{
name
=>
"StrMatch"
,
parent
=>
$_str
,
constraint_generator
=> LazyLoad(
StrMatch
=>
'constraint_generator'
),
inline_generator
=> LazyLoad(
StrMatch
=>
'inline_generator'
),
}
);
$meta
->add_type(
{
name
=>
"OptList"
,
parent
=>
$_arr
,
constraint
=>
sub
{
for
my
$inner
(
@$_
) {
return
unless
ref
(
$inner
) eq
q(ARRAY)
;
return
unless
@$inner
== 2;
return
unless
is_Str(
$inner
->[0] );
}
return
!!1;
},
inlined
=>
sub
{
my
(
$self
,
$var
) =
@_
;
my
$Str_check
= Str()->inline_check(
'$inner->[0]'
);
my
@code
=
'do { my $ok = 1; '
;
push
@code
,
sprintf
(
'for my $inner (@{%s}) { no warnings; '
,
$var
);
push
@code
,
sprintf
(
'($ok=0) && last unless ref($inner) eq q(ARRAY) && @$inner == 2 && (%s); '
,
$Str_check
);
push
@code
,
'} '
;
push
@code
,
'$ok }'
;
return
(
undef
,
join
(
q( )
,
@code
) );
},
type_default
=>
sub
{
return
[] },
}
);
$meta
->add_type(
{
name
=>
"Tied"
,
parent
=>
$_ref
,
constraint
=>
sub
{
!!
tied
(
Scalar::Util::reftype(
$_
) eq
'HASH'
? %{
$_
}
: Scalar::Util::reftype(
$_
) eq
'ARRAY'
? @{
$_
}
: Scalar::Util::reftype(
$_
) =~ /^(SCALAR|REF)$/ ? ${
$_
}
:
undef
);
},
inlined
=>
sub
{
my
(
$self
,
$var
) =
@_
;
$maybe_load_modules
->(
qw/ Scalar::Util /
,
$self
->parent->inline_check(
$var
)
.
" and !!tied(Scalar::Util::reftype($var) eq 'HASH' ? \%{$var} : Scalar::Util::reftype($var) eq 'ARRAY' ? \@{$var} : Scalar::Util::reftype($var) =~ /^(SCALAR|REF)\$/ ? \${$var} : undef)"
);
},
name_generator
=>
sub
{
my
$self
=
shift
;
my
$param
= Types::TypeTiny::to_TypeTiny(
shift
);
unless
( Types::TypeTiny::is_TypeTiny(
$param
) ) {
Types::TypeTiny::is_StringLike(
$param
)
or _croak(
"Parameter to Tied[`a] expected to be a class name; got $param"
);
return
sprintf
(
"%s[%s]"
,
$self
, B::perlstring(
$param
) );
}
return
sprintf
(
"%s[%s]"
,
$self
,
$param
);
},
constraint_generator
=> LazyLoad(
Tied
=>
'constraint_generator'
),
inline_generator
=> LazyLoad(
Tied
=>
'inline_generator'
),
}
);
$meta
->add_type(
{
name
=>
"InstanceOf"
,
parent
=>
$_obj
,
constraint_generator
=>
sub
{
return
$meta
->get_type(
'InstanceOf'
)
unless
@_
;
my
@classes
=
map
{
Types::TypeTiny::is_TypeTiny(
$_
)
?
$_
:
"Type::Tiny::Class"
->new(
class
=>
$_
,
display_name
=>
sprintf
(
'InstanceOf[%s]'
, B::perlstring(
$_
) )
)
}
@_
;
return
$classes
[0]
if
@classes
== 1;
return
"Type::Tiny::Union"
->new(
type_constraints
=> \
@classes
,
display_name
=>
sprintf
(
'InstanceOf[%s]'
,
join
q[,]
,
map
B::perlstring(
$_
->class ),
@classes
),
);
},
}
);
$meta
->add_type(
{
name
=>
"ConsumerOf"
,
parent
=>
$_obj
,
constraint_generator
=>
sub
{
return
$meta
->get_type(
'ConsumerOf'
)
unless
@_
;
my
@roles
=
map
{
Types::TypeTiny::is_TypeTiny(
$_
)
?
$_
:
"Type::Tiny::Role"
->new(
role
=>
$_
,
display_name
=>
sprintf
(
'ConsumerOf[%s]'
, B::perlstring(
$_
) )
)
}
@_
;
return
$roles
[0]
if
@roles
== 1;
return
"Type::Tiny::Intersection"
->new(
type_constraints
=> \
@roles
,
display_name
=>
sprintf
(
'ConsumerOf[%s]'
,
join
q[,]
,
map
B::perlstring(
$_
->role ),
@roles
),
);
},
}
);
$meta
->add_type(
{
name
=>
"HasMethods"
,
parent
=>
$_obj
,
constraint_generator
=>
sub
{
return
$meta
->get_type(
'HasMethods'
)
unless
@_
;
return
"Type::Tiny::Duck"
->new(
methods
=> \
@_
,
display_name
=>
sprintf
(
'HasMethods[%s]'
,
join
q[,]
,
map
B::perlstring(
$_
),
@_
),
);
},
}
);
$meta
->add_type(
{
name
=>
"Enum"
,
parent
=>
$_str
,
constraint_generator
=>
sub
{
return
$meta
->get_type(
'Enum'
)
unless
@_
;
my
$coercion
;
if
(
ref
(
$_
[0] ) and
ref
(
$_
[0] ) eq
'SCALAR'
) {
$coercion
= ${ +
shift
};
}
elsif
(
ref
(
$_
[0] ) && !blessed(
$_
[0] )
or blessed(
$_
[0] ) &&
$_
[0]->isa(
'Type::Coercion'
) )
{
$coercion
=
shift
;
}
return
"Type::Tiny::Enum"
->new(
values
=> \
@_
,
display_name
=>
sprintf
(
'Enum[%s]'
,
join
q[,]
,
map
B::perlstring(
$_
),
@_
),
$coercion
? (
coercion
=>
$coercion
) : (),
);
},
type_default
=>
undef
,
}
);
$meta
->add_coercion(
{
name
=>
"MkOpt"
,
type_constraint
=>
$meta
->get_type(
"OptList"
),
type_coercion_map
=> [
$_arr
,
q{ Exporter::Tiny::mkopt($_) }
,
$_hash
,
q{ Exporter::Tiny::mkopt($_) }
,
$_undef
,
q{ [] }
,
],
}
);
$meta
->add_coercion(
{
name
=>
"Join"
,
type_constraint
=>
$_str
,
coercion_generator
=>
sub
{
my
(
$self
,
$target
,
$sep
) =
@_
;
Types::TypeTiny::is_StringLike(
$sep
)
or _croak(
"Parameter to Join[`a] expected to be a string; got $sep"
);
$sep
= B::perlstring(
$sep
);
return
( ArrayRef(),
qq{ join($sep, \@\$_) }
);
},
}
);
$meta
->add_coercion(
{
name
=>
"Split"
,
type_constraint
=>
$_arr
,
coercion_generator
=>
sub
{
my
(
$self
,
$target
,
$re
) =
@_
;
ref
(
$re
) eq
q(Regexp)
or _croak(
"Parameter to Split[`a] expected to be a regular expression; got $re"
);
my
$regexp_string
=
"$re"
;
$regexp_string
=~ s/\\\//\\\\\//g;
return
( Str(),
qq{ [split /$regexp_string/, \$_] }
);
},
}
);
__PACKAGE__->meta->make_immutable;
1;