package Moose::Util::TypeConstraints;
-use strict;
-use warnings;
-
use Carp ();
use List::MoreUtils qw( all any );
use Scalar::Util qw( blessed reftype );
use Moose::Exporter;
-our $VERSION = '0.72_01';
+our $VERSION = '0.95';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
# compiled.
# dah sugah!
-sub where (&);
-sub via (&);
-sub message (&);
+sub where (&);
+sub via (&);
+sub message (&);
sub optimize_as (&);
## --------------------------------------------------------
use Moose::Meta::TypeConstraint::Class;
use Moose::Meta::TypeConstraint::Role;
use Moose::Meta::TypeConstraint::Enum;
+use Moose::Meta::TypeConstraint::DuckType;
use Moose::Meta::TypeCoercion;
use Moose::Meta::TypeCoercion::Union;
use Moose::Meta::TypeConstraint::Registry;
Moose::Exporter->setup_import_methods(
as_is => [
qw(
- type subtype class_type role_type maybe_type
+ type subtype class_type role_type maybe_type duck_type
as where message optimize_as
coerce from via
enum
find_type_constraint
- register_type_constraint )
+ register_type_constraint
+ match_on_type )
],
- _export_to_main => 1,
);
## --------------------------------------------------------
my $REGISTRY = Moose::Meta::TypeConstraint::Registry->new;
-sub get_type_constraint_registry { $REGISTRY }
-sub list_all_type_constraints { keys %{$REGISTRY->type_constraints} }
+sub get_type_constraint_registry {$REGISTRY}
+sub list_all_type_constraints { keys %{ $REGISTRY->type_constraints } }
+
sub export_type_constraints_as_functions {
my $pkg = caller();
no strict 'refs';
- foreach my $constraint (keys %{$REGISTRY->type_constraints}) {
- my $tc = $REGISTRY->get_type_constraint($constraint)->_compiled_type_constraint;
- *{"${pkg}::${constraint}"} = sub { $tc->($_[0]) ? 1 : undef }; # the undef is for compat
+ foreach my $constraint ( keys %{ $REGISTRY->type_constraints } ) {
+ my $tc = $REGISTRY->get_type_constraint($constraint)
+ ->_compiled_type_constraint;
+ *{"${pkg}::${constraint}"}
+ = sub { $tc->( $_[0] ) ? 1 : undef }; # the undef is for compat
}
}
sub create_type_constraint_union {
my @type_constraint_names;
- if (scalar @_ == 1 && _detect_type_constraint_union($_[0])) {
- @type_constraint_names = _parse_type_constraint_union($_[0]);
+ if ( scalar @_ == 1 && _detect_type_constraint_union( $_[0] ) ) {
+ @type_constraint_names = _parse_type_constraint_union( $_[0] );
}
else {
@type_constraint_names = @_;
}
-
- (scalar @type_constraint_names >= 2)
- || __PACKAGE__->_throw_error("You must pass in at least 2 type names to make a union");
+
+ ( scalar @type_constraint_names >= 2 )
+ || __PACKAGE__->_throw_error(
+ "You must pass in at least 2 type names to make a union");
my @type_constraints = map {
- find_or_parse_type_constraint($_) ||
- __PACKAGE__->_throw_error("Could not locate type constraint ($_) for the union");
+ find_or_parse_type_constraint($_)
+ || __PACKAGE__->_throw_error(
+ "Could not locate type constraint ($_) for the union");
} @type_constraint_names;
return Moose::Meta::TypeConstraint::Union->new(
- type_constraints => \@type_constraints
- );
+ type_constraints => \@type_constraints );
}
sub create_parameterized_type_constraint {
my $type_constraint_name = shift;
- my ($base_type, $type_parameter) = _parse_parameterized_type_constraint($type_constraint_name);
+ my ( $base_type, $type_parameter )
+ = _parse_parameterized_type_constraint($type_constraint_name);
- (defined $base_type && defined $type_parameter)
- || __PACKAGE__->_throw_error("Could not parse type name ($type_constraint_name) correctly");
+ ( defined $base_type && defined $type_parameter )
+ || __PACKAGE__->_throw_error(
+ "Could not parse type name ($type_constraint_name) correctly");
- if ($REGISTRY->has_type_constraint($base_type)) {
+ if ( $REGISTRY->has_type_constraint($base_type) ) {
my $base_type_tc = $REGISTRY->get_type_constraint($base_type);
return _create_parameterized_type_constraint(
$base_type_tc,
$type_parameter
);
- } else {
- __PACKAGE__->_throw_error("Could not locate the base type ($base_type)");
+ }
+ else {
+ __PACKAGE__->_throw_error(
+ "Could not locate the base type ($base_type)");
}
}
my ( $base_type_tc, $type_parameter ) = @_;
if ( $base_type_tc->can('parameterize') ) {
return $base_type_tc->parameterize($type_parameter);
- } else {
+ }
+ else {
return Moose::Meta::TypeConstraint::Parameterized->new(
- name => $base_type_tc->name . '[' . $type_parameter . ']',
+ name => $base_type_tc->name . '[' . $type_parameter . ']',
parent => $base_type_tc,
- type_parameter => find_or_create_isa_type_constraint($type_parameter),
+ type_parameter =>
+ find_or_create_isa_type_constraint($type_parameter),
);
}
-}
+}
#should we also support optimized checks?
sub create_class_type_constraint {
my ( $class, $options ) = @_;
- # too early for this check
- #find_type_constraint("ClassName")->check($class)
- # || __PACKAGE__->_throw_error("Can't create a class type constraint because '$class' is not a class name");
+# too early for this check
+#find_type_constraint("ClassName")->check($class)
+# || __PACKAGE__->_throw_error("Can't create a class type constraint because '$class' is not a class name");
my %options = (
class => $class,
$options{name} ||= "__ANON__";
- Moose::Meta::TypeConstraint::Class->new( %options );
+ Moose::Meta::TypeConstraint::Class->new(%options);
}
sub create_role_type_constraint {
my ( $role, $options ) = @_;
- # too early for this check
- #find_type_constraint("ClassName")->check($class)
- # || __PACKAGE__->_throw_error("Can't create a class type constraint because '$class' is not a class name");
+# too early for this check
+#find_type_constraint("ClassName")->check($class)
+# || __PACKAGE__->_throw_error("Can't create a class type constraint because '$class' is not a class name");
my %options = (
role => $role,
$options{name} ||= "__ANON__";
- Moose::Meta::TypeConstraint::Role->new( %options );
+ Moose::Meta::TypeConstraint::Role->new(%options);
}
-
sub find_or_create_type_constraint {
my ( $type_constraint_name, $options_for_anon_type ) = @_;
- if ( my $constraint = find_or_parse_type_constraint($type_constraint_name) ) {
+ if ( my $constraint
+ = find_or_parse_type_constraint($type_constraint_name) ) {
return $constraint;
}
elsif ( defined $options_for_anon_type ) {
+
# NOTE:
# if there is no $options_for_anon_type
# specified, then we assume they don't
sub find_or_create_isa_type_constraint {
my $type_constraint_name = shift;
- find_or_parse_type_constraint($type_constraint_name) || create_class_type_constraint($type_constraint_name)
+ find_or_parse_type_constraint($type_constraint_name)
+ || create_class_type_constraint($type_constraint_name);
}
sub find_or_create_does_type_constraint {
my $type_constraint_name = shift;
- find_or_parse_type_constraint($type_constraint_name) || create_role_type_constraint($type_constraint_name)
+ find_or_parse_type_constraint($type_constraint_name)
+ || create_role_type_constraint($type_constraint_name);
}
sub find_or_parse_type_constraint {
my $type_constraint_name = normalize_type_constraint_name(shift);
my $constraint;
-
- if ($constraint = find_type_constraint($type_constraint_name)) {
+
+ if ( $constraint = find_type_constraint($type_constraint_name) ) {
return $constraint;
- } elsif (_detect_type_constraint_union($type_constraint_name)) {
+ }
+ elsif ( _detect_type_constraint_union($type_constraint_name) ) {
$constraint = create_type_constraint_union($type_constraint_name);
- } elsif (_detect_parameterized_type_constraint($type_constraint_name)) {
- $constraint = create_parameterized_type_constraint($type_constraint_name);
- } else {
+ }
+ elsif ( _detect_parameterized_type_constraint($type_constraint_name) ) {
+ $constraint
+ = create_parameterized_type_constraint($type_constraint_name);
+ }
+ else {
return;
}
sub register_type_constraint {
my $constraint = shift;
- __PACKAGE__->_throw_error("can't register an unnamed type constraint") unless defined $constraint->name;
+ __PACKAGE__->_throw_error("can't register an unnamed type constraint")
+ unless defined $constraint->name;
$REGISTRY->add_type_constraint($constraint);
return $constraint;
}
# type constructors
sub type {
+
# back-compat version, called without sugar
- if ( ! any { ( reftype($_) || '' ) eq 'HASH' } @_ ) {
+ if ( !any { ( reftype($_) || '' ) eq 'HASH' } @_ ) {
return _create_type_constraint( $_[0], undef, $_[1] );
}
my %p = map { %{$_} } @_;
- return _create_type_constraint( $name, undef, $p{where}, $p{message}, $p{optimize_as} );
+ return _create_type_constraint(
+ $name, undef, $p{where}, $p{message},
+ $p{optimize_as}
+ );
}
sub subtype {
+
# crazy back-compat code for being called without sugar ...
#
# subtype 'Parent', sub { where };
# subtype 'Parent', sub { where }, sub { message };
# subtype 'Parent', sub { where }, sub { message }, sub { optimized };
if ( scalar @_ >= 3 && all { ( reftype($_) || '' ) eq 'CODE' }
- @_[ 1 .. $#_ ] ) {
+ @_[ 1 .. $#_ ] ) {
return _create_type_constraint( undef, @_ );
}
return _create_type_constraint(@_);
}
- if ( @_ == 1 && ! ref $_[0] ) {
- __PACKAGE__->_throw_error('A subtype cannot consist solely of a name, it must have a parent');
+ if ( @_ == 1 && !ref $_[0] ) {
+ __PACKAGE__->_throw_error(
+ 'A subtype cannot consist solely of a name, it must have a parent'
+ );
}
# The blessed check is mostly to accommodate MooseX::Types, which
# uses an object which overloads stringification as a type name.
- my $name = ref $_[0] && ! blessed $_[0] ? undef : shift;
+ my $name = ref $_[0] && !blessed $_[0] ? undef : shift;
my %p = map { %{$_} } @_;
# subtype Str => where { ... };
- if ( ! exists $p{as} ) {
+ if ( !exists $p{as} ) {
$p{as} = $name;
$name = undef;
}
- return _create_type_constraint( $name, $p{as}, $p{where}, $p{message}, $p{optimize_as} );
+ return _create_type_constraint(
+ $name, $p{as}, $p{where}, $p{message},
+ $p{optimize_as}
+ );
}
sub class_type {
register_type_constraint(
create_class_type_constraint(
$_[0],
- ( defined($_[1]) ? $_[1] : () ),
+ ( defined( $_[1] ) ? $_[1] : () ),
)
);
}
register_type_constraint(
create_role_type_constraint(
$_[0],
- ( defined($_[1]) ? $_[1] : () ),
+ ( defined( $_[1] ) ? $_[1] : () ),
)
);
}
);
}
+sub duck_type {
+ my ( $type_name, @methods ) = @_;
+ if ( ref $type_name eq 'ARRAY' && !@methods ) {
+ @methods = @$type_name;
+ $type_name = undef;
+ }
+ if ( @methods == 1 && ref $methods[0] eq 'ARRAY' ) {
+ @methods = @{ $methods[0] };
+ }
+
+ register_type_constraint(
+ create_duck_type_constraint(
+ $type_name,
+ \@methods,
+ )
+ );
+}
+
sub coerce {
- my ($type_name, @coercion_map) = @_;
- _install_type_coercions($type_name, \@coercion_map);
+ my ( $type_name, @coercion_map ) = @_;
+ _install_type_coercions( $type_name, \@coercion_map );
}
# The trick of returning @_ lets us avoid having to specify a
#
# If as() returns all it's extra arguments, this just works, and
# preserves backwards compatibility.
-sub as { { as => shift }, @_ }
+sub as { { as => shift }, @_ }
sub where (&) { { where => $_[0] } }
sub message (&) { { message => $_[0] } }
sub optimize_as (&) { { optimize_as => $_[0] } }
sub via (&) { $_[0] }
sub enum {
- my ($type_name, @values) = @_;
+ my ( $type_name, @values ) = @_;
+
# NOTE:
# if only an array-ref is passed then
# you get an anon-enum
# - SL
- if (ref $type_name eq 'ARRAY' && !@values) {
+ if ( ref $type_name eq 'ARRAY' && !@values ) {
@values = @$type_name;
$type_name = undef;
}
- (scalar @values >= 2)
- || __PACKAGE__->_throw_error("You must have at least two values to enumerate through");
+ if ( @values == 1 && ref $values[0] eq 'ARRAY' ) {
+ @values = @{ $values[0] };
+ }
+ ( scalar @values >= 2 )
+ || __PACKAGE__->_throw_error(
+ "You must have at least two values to enumerate through");
my %valid = map { $_ => 1 } @values;
register_type_constraint(
my ( $type_name, $values ) = @_;
Moose::Meta::TypeConstraint::Enum->new(
- name => $type_name || '__ANON__',
+ name => $type_name || '__ANON__',
values => $values,
);
}
+sub create_duck_type_constraint {
+ my ( $type_name, $methods ) = @_;
+
+ Moose::Meta::TypeConstraint::DuckType->new(
+ name => $type_name || '__ANON__',
+ methods => $methods,
+ );
+}
+
+sub match_on_type {
+ my ($to_match, @cases) = @_;
+ my $default;
+ if (@cases % 2 != 0) {
+ $default = pop @cases;
+ (ref $default eq 'CODE')
+ || __PACKAGE__->_throw_error("Default case must be a CODE ref, not $default");
+ }
+ while (@cases) {
+ my ($type, $action) = splice @cases, 0, 2;
+
+ unless (blessed $type && $type->isa('Moose::Meta::TypeConstraint')) {
+ $type = find_or_parse_type_constraint($type)
+ || __PACKAGE__->_throw_error("Cannot find or parse the type '$type'")
+ }
+
+ (ref $action eq 'CODE')
+ || __PACKAGE__->_throw_error("Match action must be a CODE ref, not $action");
+
+ if ($type->check($to_match)) {
+ local $_ = $to_match;
+ return $action->($to_match);
+ }
+ }
+ (defined $default)
+ || __PACKAGE__->_throw_error("No cases matched for $to_match");
+ {
+ local $_ = $to_match;
+ return $default->($to_match);
+ }
+}
+
+
## --------------------------------------------------------
## desugaring functions ...
## --------------------------------------------------------
);
my $constraint;
- if ( defined $parent
+ if (
+ defined $parent
and $parent
- = blessed $parent ? $parent : find_or_create_isa_type_constraint($parent) )
- {
+ = blessed $parent
+ ? $parent
+ : find_or_create_isa_type_constraint($parent)
+ ) {
$constraint = $parent->create_child_type(%opts);
}
else {
}
sub _install_type_coercions ($$) {
- my ($type_name, $coercion_map) = @_;
+ my ( $type_name, $coercion_map ) = @_;
my $type = find_type_constraint($type_name);
- (defined $type)
- || __PACKAGE__->_throw_error("Cannot find type '$type_name', perhaps you forgot to load it.");
- if ($type->has_coercion) {
+ ( defined $type )
+ || __PACKAGE__->_throw_error(
+ "Cannot find type '$type_name', perhaps you forgot to load it");
+ if ( $type->has_coercion ) {
$type->coercion->add_type_coercions(@$coercion_map);
}
else {
## --------------------------------------------------------
{
+
# All I have to say is mugwump++ cause I know
# do not even have enough regexp-fu to be able
# to have written this (I can only barely
use re "eval";
my $valid_chars = qr{[\w:\.]};
- my $type_atom = qr{ $valid_chars+ };
+ my $type_atom = qr{ (?>$valid_chars+) }x;
+ my $ws = qr{ (?>\s*) }x;
my $any;
- my $type = qr{ $valid_chars+ (?: \[ \s* (??{$any}) \s* \] )? }x;
- my $type_capture_parts = qr{ ($valid_chars+) (?: \[ \s* ((??{$any})) \s* \] )? }x;
- my $type_with_parameter = qr{ $valid_chars+ \[ \s* (??{$any}) \s* \] }x;
+ my $type = qr{ $type_atom (?: \[ $ws (??{$any}) $ws \] )? }x;
+ my $type_capture_parts
+ = qr{ ($type_atom) (?: \[ $ws ((??{$any})) $ws \] )? }x;
+ my $type_with_parameter
+ = qr{ $type_atom \[ $ws (??{$any}) $ws \] }x;
- my $op_union = qr{ \s* \| \s* }x;
- my $union = qr{ $type (?: $op_union $type )+ }x;
+ my $op_union = qr{ $ws \| $ws }x;
+ my $union = qr{ $type (?> (?: $op_union $type )+ ) }x;
$any = qr{ $type | $union }x;
sub _parse_parameterized_type_constraint {
- { no warnings 'void'; $any; } # force capture of interpolated lexical
+ { no warnings 'void'; $any; } # force capture of interpolated lexical
$_[0] =~ m{ $type_capture_parts }x;
- return ($1, $2);
+ return ( $1, $2 );
}
sub _detect_parameterized_type_constraint {
- { no warnings 'void'; $any; } # force capture of interpolated lexical
+ { no warnings 'void'; $any; } # force capture of interpolated lexical
$_[0] =~ m{ ^ $type_with_parameter $ }x;
}
sub _parse_type_constraint_union {
- { no warnings 'void'; $any; } # force capture of interpolated lexical
+ { no warnings 'void'; $any; } # force capture of interpolated lexical
my $given = shift;
my @rv;
while ( $given =~ m{ \G (?: $op_union )? ($type) }gcx ) {
push @rv => $1;
}
- (pos($given) eq length($given))
- || __PACKAGE__->_throw_error("'$given' didn't parse (parse-pos="
- . pos($given)
- . " and str-length="
- . length($given)
- . ")");
+ ( pos($given) eq length($given) )
+ || __PACKAGE__->_throw_error( "'$given' didn't parse (parse-pos="
+ . pos($given)
+ . " and str-length="
+ . length($given)
+ . ")" );
@rv;
}
sub _detect_type_constraint_union {
- { no warnings 'void'; $any; } # force capture of interpolated lexical
+ { no warnings 'void'; $any; } # force capture of interpolated lexical
$_[0] =~ m{^ $type $op_union $type ( $op_union .* )? $}x;
}
}
# these are Class::MOP accessors, so they need inlining
inline_accessors => 1
) for grep { $_->is_mutable }
- map { $_->meta }
+ map { Class::MOP::class_of($_) }
qw(
Moose::Meta::TypeConstraint
Moose::Meta::TypeConstraint::Union
Moose::Meta::TypeConstraint::Class
Moose::Meta::TypeConstraint::Role
Moose::Meta::TypeConstraint::Enum
+ Moose::Meta::TypeConstraint::DuckType
Moose::Meta::TypeConstraint::Registry
);
-type 'Any' => where { 1 }; # meta-type including all
-type 'Item' => where { 1 }; # base-type
+type 'Any' => where {1}; # meta-type including all
+subtype 'Item' => as 'Any'; # base-type
subtype 'Undef' => as 'Item' => where { !defined($_) };
-subtype 'Defined' => as 'Item' => where { defined($_) };
-
-subtype 'Bool'
- => as 'Item'
- => where { !defined($_) || $_ eq "" || "$_" eq '1' || "$_" eq '0' };
-
-subtype 'Value'
- => as 'Defined'
- => where { !ref($_) }
- => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Value;
-
-subtype 'Ref'
- => as 'Defined'
- => where { ref($_) }
- => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Ref;
-
-subtype 'Str'
- => as 'Value'
- => where { 1 }
- => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Str;
-
-subtype 'Num'
- => as 'Value'
- => where { Scalar::Util::looks_like_number($_) }
- => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Num;
-
-subtype 'Int'
- => as 'Num'
- => where { "$_" =~ /^-?[0-9]+$/ }
- => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Int;
-
-subtype 'ScalarRef' => as 'Ref' => where { ref($_) eq 'SCALAR' } => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::ScalarRef;
-subtype 'CodeRef' => as 'Ref' => where { ref($_) eq 'CODE' } => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::CodeRef;
-subtype 'RegexpRef' => as 'Ref' => where { ref($_) eq 'Regexp' } => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::RegexpRef;
-subtype 'GlobRef' => as 'Ref' => where { ref($_) eq 'GLOB' } => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::GlobRef;
+subtype 'Defined' => as 'Item' => where { defined($_) };
+
+subtype 'Bool' => as 'Item' =>
+ where { !defined($_) || $_ eq "" || "$_" eq '1' || "$_" eq '0' };
+
+subtype 'Value' => as 'Defined' => where { !ref($_) } =>
+ optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Value;
+
+subtype 'Ref' => as 'Defined' => where { ref($_) } =>
+ optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Ref;
+
+subtype 'Str' => as 'Value' => where { ref(\$_) eq 'SCALAR' } =>
+ optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Str;
+
+subtype 'Num' => as 'Str' =>
+ where { Scalar::Util::looks_like_number($_) } =>
+ optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Num;
+
+subtype 'Int' => as 'Num' => where { "$_" =~ /^-?[0-9]+$/ } =>
+ optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Int;
+
+subtype 'ScalarRef' => as 'Ref' => where { ref($_) eq 'SCALAR' } =>
+ optimize_as
+ \&Moose::Util::TypeConstraints::OptimizedConstraints::ScalarRef;
+subtype 'CodeRef' => as 'Ref' => where { ref($_) eq 'CODE' } =>
+ optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::CodeRef;
+subtype 'RegexpRef' => as 'Ref' => where { ref($_) eq 'Regexp' } =>
+ optimize_as
+ \&Moose::Util::TypeConstraints::OptimizedConstraints::RegexpRef;
+subtype 'GlobRef' => as 'Ref' => where { ref($_) eq 'GLOB' } =>
+ optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::GlobRef;
# NOTE:
# scalar filehandles are GLOB refs,
# but a GLOB ref is not always a filehandle
-subtype 'FileHandle'
- => as 'GlobRef'
- => where { Scalar::Util::openhandle($_) || ( blessed($_) && $_->isa("IO::Handle") ) }
- => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::FileHandle;
+subtype 'FileHandle' => as 'GlobRef' => where {
+ Scalar::Util::openhandle($_) || ( blessed($_) && $_->isa("IO::Handle") );
+} => optimize_as
+ \&Moose::Util::TypeConstraints::OptimizedConstraints::FileHandle;
# NOTE:
# blessed(qr/.../) returns true,.. how odd
-subtype 'Object'
- => as 'Ref'
- => where { blessed($_) && blessed($_) ne 'Regexp' }
- => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Object;
+subtype 'Object' => as 'Ref' =>
+ where { blessed($_) && blessed($_) ne 'Regexp' } =>
+ optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Object;
-subtype 'Role'
- => as 'Object'
- => where { $_->can('does') }
- => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Role;
+# This type is deprecated.
+subtype 'Role' => as 'Object' => where { $_->can('does') } =>
+ optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Role;
-my $_class_name_checker = sub {};
+my $_class_name_checker = sub { };
-subtype 'ClassName'
- => as 'Str'
- => where { Class::MOP::is_class_loaded($_) }
- => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::ClassName;
+subtype 'ClassName' => as 'Str' =>
+ where { Class::MOP::is_class_loaded($_) } => optimize_as
+ \&Moose::Util::TypeConstraints::OptimizedConstraints::ClassName;
-subtype 'RoleName'
- => as 'ClassName'
- => where { (($_->can('meta') || return)->($_) || return)->isa('Moose::Meta::Role') }
- => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::RoleName; ;
+subtype 'RoleName' => as 'ClassName' => where {
+ (Class::MOP::class_of($_) || return)->isa('Moose::Meta::Role');
+} => optimize_as
+ \&Moose::Util::TypeConstraints::OptimizedConstraints::RoleName;
## --------------------------------------------------------
# parameterizable types ...
$REGISTRY->add_type_constraint(
Moose::Meta::TypeConstraint::Parameterizable->new(
- name => 'ArrayRef',
- package_defined_in => __PACKAGE__,
- parent => find_type_constraint('Ref'),
- constraint => sub { ref($_) eq 'ARRAY' },
- optimized => \&Moose::Util::TypeConstraints::OptimizedConstraints::ArrayRef,
+ name => 'ArrayRef',
+ package_defined_in => __PACKAGE__,
+ parent => find_type_constraint('Ref'),
+ constraint => sub { ref($_) eq 'ARRAY' },
+ optimized =>
+ \&Moose::Util::TypeConstraints::OptimizedConstraints::ArrayRef,
constraint_generator => sub {
my $type_parameter = shift;
- my $check = $type_parameter->_compiled_type_constraint;
+ my $check = $type_parameter->_compiled_type_constraint;
return sub {
foreach my $x (@$_) {
- ($check->($x)) || return
- } 1;
- }
+ ( $check->($x) ) || return;
+ }
+ 1;
+ }
}
)
);
$REGISTRY->add_type_constraint(
Moose::Meta::TypeConstraint::Parameterizable->new(
- name => 'HashRef',
- package_defined_in => __PACKAGE__,
- parent => find_type_constraint('Ref'),
- constraint => sub { ref($_) eq 'HASH' },
- optimized => \&Moose::Util::TypeConstraints::OptimizedConstraints::HashRef,
+ name => 'HashRef',
+ package_defined_in => __PACKAGE__,
+ parent => find_type_constraint('Ref'),
+ constraint => sub { ref($_) eq 'HASH' },
+ optimized =>
+ \&Moose::Util::TypeConstraints::OptimizedConstraints::HashRef,
constraint_generator => sub {
my $type_parameter = shift;
- my $check = $type_parameter->_compiled_type_constraint;
+ my $check = $type_parameter->_compiled_type_constraint;
return sub {
- foreach my $x (values %$_) {
- ($check->($x)) || return
- } 1;
- }
+ foreach my $x ( values %$_ ) {
+ ( $check->($x) ) || return;
+ }
+ 1;
+ }
}
)
);
name => 'Maybe',
package_defined_in => __PACKAGE__,
parent => find_type_constraint('Item'),
- constraint => sub { 1 },
+ constraint => sub {1},
constraint_generator => sub {
my $type_parameter = shift;
- my $check = $type_parameter->_compiled_type_constraint;
+ my $check = $type_parameter->_compiled_type_constraint;
return sub {
- return 1 if not(defined($_)) || $check->($_);
+ return 1 if not( defined($_) ) || $check->($_);
return;
- }
+ }
}
)
);
-my @PARAMETERIZABLE_TYPES = map {
- $REGISTRY->get_type_constraint($_)
-} qw[ArrayRef HashRef Maybe];
+my @PARAMETERIZABLE_TYPES
+ = map { $REGISTRY->get_type_constraint($_) } qw[ArrayRef HashRef Maybe];
+
+sub get_all_parameterizable_types {@PARAMETERIZABLE_TYPES}
-sub get_all_parameterizable_types { @PARAMETERIZABLE_TYPES }
sub add_parameterizable_type {
my $type = shift;
- (blessed $type && $type->isa('Moose::Meta::TypeConstraint::Parameterizable'))
- || __PACKAGE__->_throw_error("Type must be a Moose::Meta::TypeConstraint::Parameterizable not $type");
+ ( blessed $type
+ && $type->isa('Moose::Meta::TypeConstraint::Parameterizable') )
+ || __PACKAGE__->_throw_error(
+ "Type must be a Moose::Meta::TypeConstraint::Parameterizable not $type"
+ );
push @PARAMETERIZABLE_TYPES => $type;
}
{
my @BUILTINS = list_all_type_constraints();
- sub list_all_builtin_type_constraints { @BUILTINS }
+ sub list_all_builtin_type_constraints {@BUILTINS}
}
sub _throw_error {
Undef
Defined
Value
- Num
- Int
Str
- ClassName
- RoleName
+ Num
+ Int
+ ClassName
+ RoleName
Ref
ScalarRef
ArrayRef[`a]
CodeRef
RegexpRef
GlobRef
- FileHandle
+ FileHandle
Object
- Role
B<NOTE:> Any type followed by a type parameter C<[`a]> can be
parameterized, this means you can say:
type constraint to pass.
B<NOTE:> The C<RoleName> constraint checks a string is a I<package
-name> which is a role, like C<'MyApp::Role::Comparable'>. The C<Role>
-constraint checks that an I<object does> the named role.
+name> which is a role, like C<'MyApp::Role::Comparable'>.
=head2 Type Constraint Naming
=over 4
-=item B<subtype 'Name' => as 'Parent' => where { } ...>
+=item B<< subtype 'Name' => as 'Parent' => where { } ... >>
This creates a named subtype.
The valid hashref keys are C<as> (the parent), C<where>, C<message>,
and C<optimize_as>.
-=item B<subtype as 'Parent' => where { } ...>
+=item B<< subtype as 'Parent' => where { } ... >>
This creates an unnamed subtype and will return the type
constraint meta-object, which will be an instance of
Creates a type constraint for either C<undef> or something of the
given type.
-=item B<enum ($name, @values)>
+=item B<duck_type ($name, \@methods)>
+
+This will create a subtype of Object and test to make sure the value
+C<can()> do the methods in C<\@methods>.
+
+This is intended as an easy way to accept non-Moose objects that
+provide a certain interface. If you're using Moose classes, we
+recommend that you use a C<requires>-only Role instead.
+
+=item B<duck_type (\@methods)>
+
+If passed an ARRAY reference as the only parameter instead of the
+C<$name>, C<\@methods> pair, this will create an unnamed duck type.
+This can be used in an attribute definition like so:
+
+ has 'cache' => (
+ is => 'ro',
+ isa => duck_type( [qw( get_set )] ),
+ );
+
+=item B<enum ($name, \@values)>
This will create a basic subtype for a given set of strings.
The resulting constraint will be a subtype of C<Str> and
-will match any of the items in C<@values>. It is case sensitive.
+will match any of the items in C<\@values>. It is case sensitive.
See the L<SYNOPSIS> for a simple example.
B<NOTE:> This is not a true proper enum type, it is simply
=item B<enum (\@values)>
-If passed an ARRAY reference instead of the C<$name>, C<@values> pair,
-this will create an unnamed enum. This can then be used in an attribute
-definition like so:
+If passed an ARRAY reference as the only parameter instead of the
+C<$name>, C<\@values> pair, this will create an unnamed enum. This
+can then be used in an attribute definition like so:
has 'sort_order' => (
is => 'ro',
all the built in types use this, so your subtypes (assuming they
are shallow) will not likely need to use this.
-=item B<type 'Name' => where { } ... >
+=item B<< type 'Name' => where { } ... >>
This creates a base type, which has no parent.
=back
+=head2 Type Constraint Utilities
+
+=over 4
+
+=item B<< match_on_type $value => ( $type => \&action, ... ?\&default ) >>
+
+This is a utility function for doing simple type based dispatching similar to
+match/case in OCaml and case/of in Haskell. It is not as featureful as those
+languages, nor does not it support any kind of automatic destructuring
+bind. Here is a simple Perl pretty printer dispatching over the core Moose
+types.
+
+ sub ppprint {
+ my $x = shift;
+ match_on_type $x => (
+ HashRef => sub {
+ my $hash = shift;
+ '{ '
+ . (
+ join ", " => map { $_ . ' => ' . ppprint( $hash->{$_} ) }
+ sort keys %$hash
+ ) . ' }';
+ },
+ ArrayRef => sub {
+ my $array = shift;
+ '[ ' . ( join ", " => map { ppprint($_) } @$array ) . ' ]';
+ },
+ CodeRef => sub {'sub { ... }'},
+ RegexpRef => sub { 'qr/' . $_ . '/' },
+ GlobRef => sub { '*' . B::svref_2object($_)->NAME },
+ Object => sub { $_->can('to_string') ? $_->to_string : $_ },
+ ScalarRef => sub { '\\' . ppprint( ${$_} ) },
+ Num => sub {$_},
+ Str => sub { '"' . $_ . '"' },
+ Undef => sub {'undef'},
+ => sub { die "I don't know what $_ is" }
+ );
+ }
+
+Or a simple JSON serializer:
+
+ sub to_json {
+ my $x = shift;
+ match_on_type $x => (
+ HashRef => sub {
+ my $hash = shift;
+ '{ '
+ . (
+ join ", " =>
+ map { '"' . $_ . '" : ' . to_json( $hash->{$_} ) }
+ sort keys %$hash
+ ) . ' }';
+ },
+ ArrayRef => sub {
+ my $array = shift;
+ '[ ' . ( join ", " => map { to_json($_) } @$array ) . ' ]';
+ },
+ Num => sub {$_},
+ Str => sub { '"' . $_ . '"' },
+ Undef => sub {'null'},
+ => sub { die "$_ is not acceptable json type" }
+ );
+ }
+
+The matcher is done by mapping a C<$type> to an C<\&action>. The C<$type> can
+be either a string type or a L<Moose::Meta::TypeConstraint> object, and
+C<\&action> is a subroutine reference. This function will dispatch on the
+first match for C<$value>. It is possible to have a catch-all by providing an
+additional subroutine reference as the final argument to C<match_on_type>.
+
+=back
+
=head2 Type Coercion Constructors
You can define coercions for type constraints, which allow you to
The C<$options> is a hash reference that will be passed to the
L<Moose::Meta::TypeConstraint::Role> constructor (as a hash).
+=item B<create_enum_type_constraint($name, $values)>
+
+Given a enum name this function will create a new
+L<Moose::Meta::TypeConstraint::Enum> object for that enum name.
+
+=item B<create_duck_type_constraint($name, $methods)>
+
+Given a duck type name this function will create a new
+L<Moose::Meta::TypeConstraint::DuckType> object for that enum name.
+
=item B<find_or_parse_type_constraint($type_name)>
Given a type name, this first attempts to find a matching constraint
=head1 BUGS
-All complex software has bugs lurking in it, and this module is no
-exception. If you find a bug please either email me, or add the bug
-to cpan-RT.
+See L<Moose/BUGS> for details on reporting bugs.
=head1 AUTHOR
=head1 COPYRIGHT AND LICENSE
-Copyright 2006-2009 by Infinity Interactive, Inc.
+Copyright 2006-2010 by Infinity Interactive, Inc.
L<http://www.iinteractive.com>
projects / gitmo/Moose.git / blobdiff