X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FUtil%2FTypeConstraints.pm;h=9dd4ff10a457a387a266c83e5b6a6b4a1dd75d13;hb=f75f625dfbf7c765bdfa127a59b49a4503344298;hp=038607003487d02c61df2ce45e366b67597dad38;hpb=6549b0d1ae8b084898ac2d8ad60d6a57cccf4124;p=gitmo%2FMoose.git diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm index 0386070..9dd4ff1 100644 --- a/lib/Moose/Util/TypeConstraints.pm +++ b/lib/Moose/Util/TypeConstraints.pm @@ -5,11 +5,11 @@ use strict; use warnings; use Carp (); -use List::MoreUtils qw( all ); -use Scalar::Util 'blessed'; +use List::MoreUtils qw( all any ); +use Scalar::Util qw( blessed reftype ); use Moose::Exporter; -our $VERSION = '0.67'; +our $VERSION = '0.72'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; @@ -26,10 +26,6 @@ sub via (&); sub message (&); sub optimize_as (&); -## private stuff ... -sub _create_type_constraint ($$$;$$); -sub _install_type_coercions ($$); - ## -------------------------------------------------------- use Moose::Meta::TypeConstraint; @@ -260,28 +256,55 @@ sub register_type_constraint { # type constructors sub type { - splice(@_, 1, 0, undef); - goto &_create_type_constraint; + # back-compat version, called without sugar + if ( ! any { ( reftype($_) || '' ) eq 'HASH' } @_ ) { + return _create_type_constraint( $_[0], undef, $_[1] ); + } + + my $name = shift; + + my %p = map { %{$_} } @_; + + return _create_type_constraint( $name, undef, $p{where}, $p{message}, $p{optimize_as} ); } sub subtype { - # NOTE: - # this adds an undef for the name - # if this is an anon-subtype: - # subtype(Num => where { $_ % 2 == 0 }) # anon 'even' subtype - # or - # subtype(Num => where { $_ % 2 == 0 }) message { "$_ must be an even number" } + # crazy back-compat code for being called without sugar ... # - # but if the last arg is not a code ref then it is a subtype - # alias: - # - # subtype(MyNumbers => as Num); # now MyNumbers is the same as Num - # ... yeah I know it's ugly code - # - SL - unshift @_ => undef if scalar @_ == 2 && ( 'CODE' eq ref( $_[-1] ) ); - unshift @_ => undef - if scalar @_ == 3 && all { ref($_) =~ /^(?:CODE|HASH)$/ } @_[ 1, 2 ]; - goto &_create_type_constraint; + # 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'); + } + + # 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{as} ) { + $p{as} = $name; + $name = undef; + } + + return _create_type_constraint( $name, $p{as}, $p{where}, $p{message}, $p{optimize_as} ); } sub class_type { @@ -315,13 +338,26 @@ sub coerce { _install_type_coercions($type_name, \@coercion_map); } -sub as { @_ } -sub from { @_ } -sub where (&) { $_[0] } -sub via (&) { $_[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 it's 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 from {@_} +sub via (&) { $_[0] } sub enum { my ($type_name, @values) = @_; @@ -359,17 +395,13 @@ sub create_enum_type_constraint { ## -------------------------------------------------------- sub _create_type_constraint ($$$;$$) { - my $name = shift; - my $parent = shift; - my $check = shift; - - my ( $message, $optimized ); - for (@_) { - $message = $_->{message} if exists $_->{message}; - $optimized = $_->{optimized} if exists $_->{optimized}; - } + my $name = shift; + my $parent = shift; + my $check = shift; + my $message = shift; + my $optimized = shift; - my $pkg_defined_in = scalar( caller(0) ); + my $pkg_defined_in = scalar( caller(1) ); if ( defined $name ) { my $type = $REGISTRY->get_type_constraint($name); @@ -384,11 +416,11 @@ sub _create_type_constraint ($$$;$$) { $name =~ /^[\w:\.]+$/ or die qq{$name contains invalid characters for a type name.} - . qq{Names can contain alphanumeric character, ":", and "."\n}; + . qq{ Names can contain alphanumeric character, ":", and "."\n}; } my %opts = ( - name => $name, + name => $name, package_defined_in => $pkg_defined_in, ( $check ? ( constraint => $check ) : () ), @@ -575,14 +607,18 @@ subtype 'Role' => 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 'RoleName' + => as 'ClassName' + => where { (($_->can('meta') || return)->($_) || return)->isa('Moose::Meta::Role') } + => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::RoleName; ; + ## -------------------------------------------------------- # parameterizable types ... @@ -663,6 +699,7 @@ sub add_parameterizable_type { } sub _throw_error { + shift; require Moose; unshift @_, 'Moose'; goto &Moose::throw_error; @@ -755,6 +792,7 @@ that hierarchy represented visually. Int Str ClassName + RoleName Ref ScalarRef ArrayRef[`a] @@ -790,6 +828,10 @@ 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. +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. + =head2 Type Constraint Naming Type name declared via this module can only contain alphanumeric @@ -812,10 +854,13 @@ 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( + type 'HashOfArrayOfObjects', + { + where => IsHashRef( -keys => HasLength, - -values => IsArrayRef( IsObject )); + -values => IsArrayRef(IsObject) + ) + }; For more examples see the F test file. @@ -847,32 +892,55 @@ See the L for an example of how to use these. =over 4 -=item B +=item B where { } ... > This creates a base type, which has no parent. -=item B +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. + +=item B 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. -=item B +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 => ... } ); + +The valid hashref keys are C (the parent), C, C, +and C. + +=item B 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 type constraint with the name C<$class> and the metaclass -L. +Creates a new subtype of C with the name C<$class> and the +metaclass L. =item B -Creates a type constraint with the name C<$role> and the metaclass -L. +Creates a C type constraint with the name C<$role> and the +metaclass L. =item B