X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FUtil%2FTypeConstraints.pm;h=4ab0006902304a5a835adea991b9e8d9794e4ffb;hb=eea9eb4d0a9d6d7453cfb6fca6bb6aae618254c4;hp=1046c44db33b4fc580b3f9662a086eb541599580;hpb=9a63fabaeba45a7cad289ab21527e7470c4d569a;p=gitmo%2FMoose.git diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm index 1046c44..4ab0006 100644 --- a/lib/Moose/Util/TypeConstraints.pm +++ b/lib/Moose/Util/TypeConstraints.pm @@ -1,18 +1,11 @@ package Moose::Util::TypeConstraints; -use strict; -use warnings; - use Carp (); -use List::MoreUtils qw( all ); +use List::MoreUtils qw( all any ); use Scalar::Util qw( blessed reftype ); use Moose::Exporter; -our $VERSION = '0.71'; -$VERSION = eval $VERSION; -our $AUTHORITY = 'cpan:STEVAN'; - ## -------------------------------------------------------- # Prototyped subs must be predeclared because we have a # circular dependency with Moose::Meta::Attribute et. al. @@ -21,13 +14,15 @@ our $AUTHORITY = 'cpan:STEVAN'; # compiled. # dah sugah! -sub where (&); -sub via (&); -sub message (&); +sub where (&); +sub via (&); +sub message (&); sub optimize_as (&); +sub inline_as (&); ## -------------------------------------------------------- +use Moose::Deprecated; use Moose::Meta::TypeConstraint; use Moose::Meta::TypeConstraint::Union; use Moose::Meta::TypeConstraint::Parameterized; @@ -35,22 +30,22 @@ use Moose::Meta::TypeConstraint::Parameterizable; 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; -use Moose::Util::TypeConstraints::OptimizedConstraints; Moose::Exporter->setup_import_methods( as_is => [ qw( - type subtype class_type role_type maybe_type - as where message optimize_as + type subtype class_type role_type maybe_type duck_type + as where message optimize_as inline_as coerce from via enum find_type_constraint - register_type_constraint ) + register_type_constraint + match_on_type ) ], - _export_to_main => 1, ); ## -------------------------------------------------------- @@ -59,55 +54,63 @@ Moose::Exporter->setup_import_methods( 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)"); } } @@ -115,22 +118,24 @@ sub _create_parameterized_type_constraint { 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, @@ -140,15 +145,15 @@ sub create_class_type_constraint { $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, @@ -158,17 +163,18 @@ sub create_role_type_constraint { $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 @@ -191,25 +197,31 @@ sub find_or_create_type_constraint { 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; } @@ -248,7 +260,8 @@ sub find_type_constraint { 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; } @@ -256,57 +269,46 @@ sub register_type_constraint { # type constructors sub type { - if ( all { ( reftype($_) || '' ) eq 'CODE' || ! ref $_ } @_ ) { - # back-compat version, called without sugar - _create_type_constraint( $_[0], undef, $_[1] ); - } - else { - my $name = shift; + my $name = shift; - my %p = map { %{$_} } @_; + my %p = map { %{$_} } @_; - _create_type_constraint( $name, undef, $p{check}, $p{message}, $p{optimized} ); - } + return _create_type_constraint( + $name, undef, $p{where}, $p{message}, + $p{optimize_as}, $p{inline_as}, + ); } sub subtype { - # crazy back-compat code for being called without sugar ... - # - # subtype 'Parent', sub { where }; - if ( scalar @_ == 2 && ( reftype( $_[1] ) || '' ) eq 'CODE' ) { - return _create_type_constraint( undef, @_ ); - } - - # subtype 'Parent', sub { where }, sub { message }; - # subtype 'Parent', sub { where }, sub { message }, sub { optimized }; - if ( scalar @_ >= 3 && all { ( reftype($_) || '' ) eq 'CODE' } - @_[ 1 .. $#_ ] ) { - return _create_type_constraint( undef, @_ ); - } - - # subtype 'Name', 'Parent', ... - if ( scalar @_ >= 2 && all { !ref } @_[ 0, 1 ] ) { - return _create_type_constraint(@_); + if ( @_ == 1 && !ref $_[0] ) { + __PACKAGE__->_throw_error( + 'A subtype cannot consist solely of a name, it must have a parent' + ); } - my $name = ref $_[0] ? undef : shift; + # 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 %p = map { %{$_} } @_; # subtype Str => where { ... }; - if ( ! exists $p{parent} ) { - $p{parent} = $name; + if ( !exists $p{as} ) { + $p{as} = $name; $name = undef; } - _create_type_constraint( $name, $p{parent}, $p{check}, $p{message}, $p{optimized} ); + return _create_type_constraint( + $name, $p{as}, $p{where}, $p{message}, + $p{optimize_as}, $p{inline_as}, + ); } sub class_type { register_type_constraint( create_class_type_constraint( $_[0], - ( defined($_[1]) ? $_[1] : () ), + ( defined( $_[1] ) ? $_[1] : () ), ) ); } @@ -315,7 +317,7 @@ sub role_type ($;$) { register_type_constraint( create_role_type_constraint( $_[0], - ( defined($_[1]) ? $_[1] : () ), + ( defined( $_[1] ) ? $_[1] : () ), ) ); } @@ -328,32 +330,68 @@ sub maybe_type { ); } +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 ); } -sub as ($) { { parent => $_[0] } } -sub where (&) { { check => $_[0] } } -sub message (&) { { message => $_[0] } } -sub optimize_as (&) { { optimized => $_[0] } } +# The trick of returning @_ lets us avoid having to specify a +# prototype. Perl will parse this: +# +# subtype 'Foo' +# => as 'Str' +# => where { ... } +# +# as this: +# +# subtype( 'Foo', as( 'Str', where { ... } ) ); +# +# If as() returns all its extra arguments, this just works, and +# preserves backwards compatibility. +sub as { { as => shift }, @_ } +sub where (&) { { where => $_[0] } } +sub message (&) { { message => $_[0] } } +sub optimize_as (&) { { optimize_as => $_[0] } } +sub inline_as (&) { { inline_as => $_[0] } } sub from {@_} 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 == 0 + || __PACKAGE__->_throw_error("enum called with an array reference and additional arguments. Did you mean to parenthesize the enum call's parameters?"); + @values = @$type_name; $type_name = undef; } - (scalar @values >= 2) - || __PACKAGE__->_throw_error("You must have at least two values to enumerate through"); - my %valid = map { $_ => 1 } @values; + if ( @values == 1 && ref $values[0] eq 'ARRAY' ) { + @values = @{ $values[0] }; + } register_type_constraint( create_enum_type_constraint( @@ -367,11 +405,53 @@ sub create_enum_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 ... ## -------------------------------------------------------- @@ -382,6 +462,7 @@ sub _create_type_constraint ($$$;$$) { my $check = shift; my $message = shift; my $optimized = shift; + my $inlined = shift; my $pkg_defined_in = scalar( caller(1) ); @@ -408,13 +489,17 @@ sub _create_type_constraint ($$$;$$) { ( $check ? ( constraint => $check ) : () ), ( $message ? ( message => $message ) : () ), ( $optimized ? ( optimized => $optimized ) : () ), + ( $inlined ? ( inlined => $inlined ) : () ), ); 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 { @@ -428,11 +513,12 @@ sub _create_type_constraint ($$$;$$) { } 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 { @@ -449,6 +535,7 @@ sub _install_type_coercions ($$) { ## -------------------------------------------------------- { + # 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 @@ -458,48 +545,84 @@ sub _install_type_coercions ($$) { use re "eval"; my $valid_chars = qr{[\w:\.]}; - my $type_atom = qr{ $valid_chars+ }; - - 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 $op_union = qr{ \s* \| \s* }x; - my $union = qr{ $type (?: $op_union $type )+ }x; + my $type_atom = qr{ (?>$valid_chars+) }x; + my $ws = qr{ (?>\s*) }x; + my $op_union = qr{ $ws \| $ws }x; + + my ($type, $type_capture_parts, $type_with_parameter, $union, $any); + if (Class::MOP::IS_RUNNING_ON_5_10) { + my $type_pattern + = q{ (?&type_atom) (?: \[ (?&ws) (?&any) (?&ws) \] )? }; + my $type_capture_parts_pattern + = q{ ((?&type_atom)) (?: \[ (?&ws) ((?&any)) (?&ws) \] )? }; + my $type_with_parameter_pattern + = q{ (?&type_atom) \[ (?&ws) (?&any) (?&ws) \] }; + my $union_pattern + = q{ (?&type) (?> (?: (?&op_union) (?&type) )+ ) }; + my $any_pattern + = q{ (?&type) | (?&union) }; + + my $defines = qr{(?(DEFINE) + (? $valid_chars) + (? $type_atom) + (? $ws) + (? $op_union) + (? $type_pattern) + (? $type_capture_parts_pattern) + (? $type_with_parameter_pattern) + (? $union_pattern) + (? $any_pattern) + )}x; + + $type = qr{ $type_pattern $defines }x; + $type_capture_parts = qr{ $type_capture_parts_pattern $defines }x; + $type_with_parameter = qr{ $type_with_parameter_pattern $defines }x; + $union = qr{ $union_pattern $defines }x; + $any = qr{ $any_pattern $defines }x; + } + else { + $type + = qr{ $type_atom (?: \[ $ws (??{$any}) $ws \] )? }x; + $type_capture_parts + = qr{ ($type_atom) (?: \[ $ws ((??{$any})) $ws \] )? }x; + $type_with_parameter + = qr{ $type_atom \[ $ws (??{$any}) $ws \] }x; + $union + = qr{ $type (?> (?: $op_union $type )+ ) }x; + $any + = qr{ $type | $union }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; } } @@ -508,8 +631,9 @@ sub _install_type_coercions ($$) { # define some basic built-in types ## -------------------------------------------------------- -# By making these classes immutable before creating all the types we -# below, we avoid repeatedly calling the slow MOP-based accessors. +# By making these classes immutable before creating all the types in +# Moose::Util::TypeConstraints::Builtin , we avoid repeatedly calling the slow +# MOP-based accessors. $_->make_immutable( inline_constructor => 1, constructor_name => "_new", @@ -517,7 +641,7 @@ $_->make_immutable( # 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 @@ -526,148 +650,25 @@ $_->make_immutable( 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 - -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; - -# 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; - -# NOTE: -# blessed(qr/.../) returns true,.. how odd -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; - -my $_class_name_checker = sub {}; - -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; ; +require Moose::Util::TypeConstraints::Builtins; +Moose::Util::TypeConstraints::Builtins::define_builtins($REGISTRY); -## -------------------------------------------------------- -# 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, - constraint_generator => sub { - my $type_parameter = shift; - my $check = $type_parameter->_compiled_type_constraint; - return sub { - foreach my $x (@$_) { - ($check->($x)) || return - } 1; - } - } - ) -); +my @PARAMETERIZABLE_TYPES + = map { $REGISTRY->get_type_constraint($_) } qw[ScalarRef ArrayRef HashRef Maybe]; -$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, - constraint_generator => sub { - my $type_parameter = shift; - my $check = $type_parameter->_compiled_type_constraint; - return sub { - foreach my $x (values %$_) { - ($check->($x)) || return - } 1; - } - } - ) -); - -$REGISTRY->add_type_constraint( - Moose::Meta::TypeConstraint::Parameterizable->new( - name => 'Maybe', - package_defined_in => __PACKAGE__, - parent => find_type_constraint('Item'), - constraint => sub { 1 }, - constraint_generator => sub { - my $type_parameter = shift; - my $check = $type_parameter->_compiled_type_constraint; - return sub { - return 1 if not(defined($_)) || $check->($_); - return; - } - } - ) -); +sub get_all_parameterizable_types {@PARAMETERIZABLE_TYPES} -my @PARAMETERIZABLE_TYPES = map { - $REGISTRY->get_type_constraint($_) -} qw[ArrayRef HashRef Maybe]; - -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; } @@ -677,7 +678,7 @@ sub add_parameterizable_type { { my @BUILTINS = list_all_type_constraints(); - sub list_all_builtin_type_constraints { @BUILTINS } + sub list_all_builtin_type_constraints {@BUILTINS} } sub _throw_error { @@ -689,34 +690,32 @@ sub _throw_error { 1; +# ABSTRACT: Type constraint system for Moose + __END__ =pod -=head1 NAME - -Moose::Util::TypeConstraints - Type constraint system for Moose - =head1 SYNOPSIS use Moose::Util::TypeConstraints; - type 'Num' => where { Scalar::Util::looks_like_number($_) }; + subtype 'Natural', + as 'Int', + where { $_ > 0 }; - subtype 'Natural' - => as 'Int' - => where { $_ > 0 }; + subtype 'NaturalLessThanTen', + as 'Natural', + where { $_ < 10 }, + message { "This number ($_) is not less than ten!" }; - subtype 'NaturalLessThanTen' - => as 'Natural' - => where { $_ < 10 } - => message { "This number ($_) is not less than ten!" }; + coerce 'Num', + from 'Str', + via { 0+$_ }; - coerce 'Num' - => from 'Str' - => via { 0+$_ }; + enum 'RGBColors', [qw(red green blue)]; - enum 'RGBColors' => qw(red green blue); + no Moose::Util::TypeConstraints; =head1 DESCRIPTION @@ -727,36 +726,36 @@ constraints to be used in attribute definition. This is B a type system for Perl 5. These are type constraints, and they are not used by Moose unless you tell it to. No type -inference is performed, expression are not typed, etc. etc. etc. +inference is performed, expressions are not typed, etc. etc. etc. -This is simply a means of creating small constraint functions which -can be used to simplify your own type-checking code, with the added -side benefit of making your intentions clearer through self-documentation. +A type constraint is at heart a small "check if a value is valid" +function. A constraint can be associated with an attribute. This +simplifies parameter validation, and makes your code clearer to read, +because you can refer to constraints by name. =head2 Slightly Less Important Caveat -It is B a good idea to quote your type and subtype names. +It is B a good idea to quote your type names. -This is to prevent perl from trying to execute the call as an indirect -object call. This issue only seems to come up when you have a subtype -the same name as a valid class, but when the issue does arise it tends -to be quite annoying to debug. +This prevents Perl from trying to execute the call as an indirect +object call. This can be an issue when you have a subtype with the +same name as a valid class. -So for instance, this: +For instance: subtype DateTime => as Object => where { $_->isa('DateTime') }; -will I, while this: +will I, while this: use DateTime; subtype DateTime => as Object => where { $_->isa('DateTime') }; will fail silently and cause many headaches. The simple way to solve this, as well as future proof your subtypes from classes which have -yet to have been created yet, is to simply do this: +yet to have been created, is to quote the type name: use DateTime; - subtype 'DateTime' => as 'Object' => where { $_->isa('DateTime') }; + subtype 'DateTime', as 'Object', where { $_->isa('DateTime') }; =head2 Default Type Constraints @@ -770,49 +769,47 @@ that hierarchy represented visually. Undef Defined Value - Num - Int Str - ClassName - RoleName + Num + Int + ClassName + RoleName Ref - ScalarRef + ScalarRef[`a] ArrayRef[`a] HashRef[`a] CodeRef RegexpRef GlobRef - FileHandle + FileHandle Object - Role B Any type followed by a type parameter C<[`a]> can be parameterized, this means you can say: ArrayRef[Int] # an array of integers HashRef[CodeRef] # a hash of str to CODE ref mappings + ScalarRef[Int] # a reference to an integer Maybe[Str] # value may be a string, may be undefined If Moose finds a name in brackets that it does not recognize as an existing type, it assumes that this is a class name, for example C. -B Unless you parameterize a type, then it is invalid to -include the square brackets. I.e. C will be -literally interpreted as a type name. +B Unless you parameterize a type, then it is invalid to include +the square brackets. I.e. C will be treated as a new type +name, I as a parameterization of C. B The C type constraint for the most part works correctly now, but edge cases may still exist, please use it sparingly. B The C type constraint does a complex package -existence check. This means that your class B be loaded for -this type constraint to pass. I know this is not ideal for all, -but it is a saner restriction than most others. +existence check. This means that your class B be loaded for this +type constraint to pass. -B The C constraint checks a string is I -which is a role, like C<'MyApp::Role::Comparable'>. The C -constraint checks that an I does the named role. +B The C constraint checks a string is a I which is a role, like C<'MyApp::Role::Comparable'>. =head2 Type Constraint Naming @@ -821,34 +818,37 @@ characters, colons (:), and periods (.). Since the types created by this module are global, it is suggested that you namespace your types just as you would namespace your -modules. So instead of creating a I type for your B -module, you would call the type I instead. +modules. So instead of creating a I type for your +B module, you would call the type +I instead. =head2 Use with Other Constraint Modules -This module should play fairly nicely with other constraint -modules with only some slight tweaking. The C clause -in types is expected to be a C reference which checks -it's first argument and returns a boolean. Since most constraint -modules work in a similar way, it should be simple to adapt -them to work with Moose. +This module can play nicely with other constraint modules with some +slight tweaking. The C clause in types is expected to be a +C reference which checks its first argument and returns a +boolean. Since most constraint modules work in a similar way, it +should be simple to adapt them to work with Moose. For instance, this is how you could use it with L to declare a completely new type. - type 'HashOfArrayOfObjects' - => IsHashRef( - -keys => HasLength, - -values => IsArrayRef( IsObject )); + type 'HashOfArrayOfObjects', + where { + IsHashRef( + -keys => HasLength, + -values => IsArrayRef(IsObject) + )->(@_); + }; -For more examples see the F -test file. +For more examples see the F test +file. -Here is an example of using L and it's non-test +Here is an example of using L and its non-test related C function. - type 'ArrayOfHashOfBarsAndRandomNumbers' - => where { + type 'ArrayOfHashOfBarsAndRandomNumbers', + where { eq_deeply($_, array_each(subhashof({ bar => isa('Bar'), @@ -857,43 +857,64 @@ related C function. }; For a complete example see the -F test file. +F test file. -=head1 FUNCTIONS +=head2 Error messages -=head2 Type Constraint Constructors +Type constraints can also specify custom error messages, for when they fail to +validate. This is provided as just another coderef, which receives the invalid +value in C<$_>, as in: -The following functions are used to create type constraints. -They will then register the type constraints in a global store -where Moose can get to them if it needs to. + subtype 'PositiveInt', + as 'Int', + where { $_ > 0 }, + message { "$_ is not a positive integer!" }; -See the L for an example of how to use these. +If no message is specified, a default message will be used, which indicates +which type constraint was being used and what value failed. If +L (version 0.14 or higher) is installed, it will be used to +display the invalid value, otherwise it will just be printed as is. -=over 4 +=head1 FUNCTIONS -=item B where { } ... > +=head2 Type Constraint Constructors -This creates a base type, which has no parent. +The following functions are used to create type constraints. They +will also register the type constraints your create in a global +registry that is used to look types up by name. -Note that calling C I the sugar helpers (C, -C, etc), is deprecated. +See the L for an example of how to use these. -=item B as 'Parent' => where { } ...> +=over 4 + +=item B<< subtype 'Name', as 'Parent', where { } ... >> This creates a named subtype. If you provide a parent that Moose does not recognize, it will automatically create a new class type constraint for this name. -Note that calling C I the sugar helpers (C, -C, etc), is deprecated. +When creating a named type, the C function should either be +called with the sugar helpers (C, C, etc), or with a +name and a hashref of parameters: + + subtype( 'Foo', { where => ..., message => ... } ); -=item B where { } ...> +The valid hashref keys are C (the parent), C, C, +and C. + +=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 L. +When creating an anonymous type, the C function should either +be called with the sugar helpers (C, C, etc), or with +just a hashref of parameters: + + subtype( { where => ..., message => ... } ); + =item B Creates a new subtype of C with the name C<$class> and the @@ -909,218 +930,366 @@ metaclass L. Creates a type constraint for either C or something of the given type. -=item B +=item B + +This will create a subtype of Object and test to make sure the value +C 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-only Role instead. + +=item B + +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 This will create a basic subtype for a given set of strings. The resulting constraint will be a subtype of C and -will match any of the items in C<@values>. It is case sensitive. -See the L for a simple example. +will match any of the items in C<\@values>. It is case sensitive. +See the L for a simple example. B This is not a true proper enum type, it is simply a convenient constraint builder. =item B -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', isa => enum([qw[ ascending descending ]]), ); -=item B +=item B This is just sugar for the type constraint construction syntax. -=item B +It takes a single argument, which is the name of a parent type. + +=item B This is just sugar for the type constraint construction syntax. -Takes a block/code ref as an argument. When the type constraint is -tested, the supplied code is run with the value to be tested in -$_. This block should return true or false to indicate whether or not -the constraint check passed. +It takes a subroutine reference as an argument. When the type +constraint is tested, the reference is run with the value to be tested +in C<$_>. This reference should return true or false to indicate +whether or not the constraint check passed. -=item B +=item B This is just sugar for the type constraint construction syntax. -Takes a block/code ref as an argument. When the type constraint fails, -then the code block is run (with the value provided in $_). This code -ref should return a string, which will be used in the text of the -exception thrown. +It takes a subroutine reference as an argument. When the type +constraint fails, then the code block is run with the value provided +in C<$_>. This reference should return a string, which will be used in +the text of the exception thrown. + +=item B + +This can be used to define a "hand optimized" inlinable version of your type +constraint. + +You provide a subroutine which will be called I on a +L object. It will receive a single parameter, the +name of the variable to check, typically something like C<"$_"> or C<"$_[0]">. + +The subroutine should return a code string suitable for inlining. You can +assume that the check will be wrapped in parentheses when it is inlined. + +The inlined code should include any checks that your type's parent types +do. For example, the C type's inlining sub looks like this: + + sub { + 'defined(' . $_[1] . ')' + . ' && !ref(' . $_[1] . ')' + } + +Note that it checks if the variable is defined, since it is a subtype of +the C type. However, to avoid repeating code, this can be optimized as: + + sub { + $_[0]->parent()->_inline_check($_[1]) + . ' && !ref(' . $_[1] . ')' + } + +=item B -=item B +B instead.> This can be used to define a "hand optimized" version of your type constraint which can be used to avoid traversing a subtype constraint hierarchy. -B You should only use this if you know what you are doing, -all the built in types use this, so your subtypes (assuming they +B You should only use this if you know what you are doing. +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 { } ... >> + +This creates a base type, which has no parent. + +The C function should either be called with the sugar helpers +(C, C, etc), or with a name and a hashref of +parameters: + + type( 'Foo', { where => ..., message => ... } ); + +The valid hashref keys are C, C, and C. + +=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 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. + =back =head2 Type Coercion Constructors -Type constraints can also contain type coercions as well. If you -ask your accessor to coerce, then Moose will run the type-coercion -code first, followed by the type constraint check. This feature -should be used carefully as it is very powerful and could easily -take off a limb if you are not careful. +You can define coercions for type constraints, which allow you to +automatically transform values to something valid for the type +constraint. If you ask your accessor to coerce, then Moose will run +the type-coercion code first, followed by the type constraint +check. This feature should be used carefully as it is very powerful +and could easily take off a limb if you are not careful. -See the L for an example of how to use these. +See the L for an example of how to use these. =over 4 -=item B +=item B<< coerce 'Name', from 'OtherName', via { ... } >> + +This defines a coercion from one type to another. The C argument +is the type you are coercing I. -=item B +To define multiple coercions, supply more sets of from/via pairs: + + coerce 'Name', + from 'OtherName', via { ... }, + from 'ThirdName', via { ... }; + +=item B This is just sugar for the type coercion construction syntax. -=item B +It takes a single type name (or type object), which is the type being +coerced I. + +=item B This is just sugar for the type coercion construction syntax. +It takes a subroutine reference. This reference will be called with +the value to be coerced in C<$_>. It is expected to return a new value +of the proper type for the coercion. + =back -=head2 Type Constraint Construction & Locating +=head2 Creating and Finding Type Constraints + +These are additional functions for creating and finding type +constraints. Most of these functions are not available for +importing. The ones that are importable as specified. =over 4 -=item B +=item B + +This function can be used to locate the L +object for a named type. + +This function is importable. + +=item B + +This function will register a L with the +global type registry. -Given a string that is expected to match a type constraint, will normalize the -string so that extra whitespace and newlines are removed. +This function is importable. -=item B +=item B -Given string with C<$pipe_separated_types> or a list of C<@type_constraint_names>, -this will return a L instance. +This method takes a type constraint name and returns the normalized +form. This removes any whitespace in the string. -=item B +=item B -Given a C<$type_name> in the form of: +This can take a union type specification like C<'Int|ArrayRef[Int]'>, +or a list of names. It returns a new +L object. - BaseType[ContainerType] +=item B -this will extract the base type and container type and build an instance of -L for it. +Given a C<$type_name> in the form of C<'BaseType[ContainerType]'>, +this will create a new L +object. The C must exist already exist as a parameterizable +type. -=item B +=item B -Given a class name it will create a new L -object for that class name. +Given a class name this function will create a new +L object for that class name. -=item B +The C<$options> is a hash reference that will be passed to the +L constructor (as a hash). -Given a role name it will create a new L -object for that role name. +=item B -=item B +Given a role name this function will create a new +L object for that role name. -=item B +The C<$options> is a hash reference that will be passed to the +L constructor (as a hash). -This will attempt to find or create a type constraint given the a C<$type_name>. -If it cannot find it in the registry, it will see if it should be a union or -container type an create one if appropriate +=item B -=item B +Given a enum name this function will create a new +L object for that enum name. -This function will first call C with the type name. +=item B -If no type is found or created, but C<$options_for_anon_type> are provided, it -will create the corresponding type. +Given a duck type name this function will create a new +L object for that enum name. -This was used by the C and C parameters to L -and are now superseded by C and -C. +=item B -=item B +Given a type name, this first attempts to find a matching constraint +in the global registry. -=item B +If the type name is a union or parameterized type, it will create a +new object of the appropriate, but if given a "regular" type that does +not yet exist, it simply returns false. -Attempts to parse the type name using C and if -no appropriate constraint is found will create a new anonymous one. +When given a union or parameterized type, the member or base type must +already exist. -The C variant will use C and the C -variant will use C. +If it creates a new union or parameterized type, it will add it to the +global registry. -=item B +=item B -This function can be used to locate a specific type constraint -meta-object, of the class L or a -derivative. What you do with it from there is up to you :) +=item B -=item B +These functions will first call C. If +that function does not return a type, a new type object will +be created. -This function will register a named type constraint with the type registry. +The C variant will use C and the +C variant will use C. =item B -Fetch the L object which +Returns the L object which keeps track of all type constraints. =item B -This will return a list of type constraint names, you can then -fetch them using C if you -want to. +This will return a list of type constraint names in the global +registry. You can then fetch the actual type object using +C. =item B -This will return a list of builtin type constraints, meaning, -those which are defined in this module. See the section -labeled L for a complete list. +This will return a list of builtin type constraints, meaning those +which are defined in this module. See the L +section for a complete list. =item B -This will export all the current type constraints as functions -into the caller's namespace. Right now, this is mostly used for -testing, but it might prove useful to others. +This will export all the current type constraints as functions into +the caller's namespace (C, C, etc). Right now, this is +mostly used for testing, but it might prove useful to others. =item B -This returns all the parameterizable types that have been registered. +This returns all the parameterizable types that have been registered, +as a list of type objects. -=item B +=item B Adds C<$type> to the list of parameterizable types =back -=head2 Namespace Management - -=over 4 - -=item B - -This will remove all the type constraint keywords from the -calling class namespace. - -=back - =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. - -=head1 AUTHOR - -Stevan Little Estevan@iinteractive.comE - -=head1 COPYRIGHT AND LICENSE - -Copyright 2006-2009 by Infinity Interactive, Inc. - -L - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. +See L for details on reporting bugs. =cut