X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FUtil%2FTypeConstraints.pm;h=b44a0eb89d3ebeb7be44792b65b84afa10045d2c;hb=97da20ef3707567e7aef8fa52598b2934a832de9;hp=458279ea40b20de34762b33c2c2ba6a9c7357f82;hpb=6e56c6e09ab419776522759fc65fb0e85af66538;p=gitmo%2FMoose.git diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm index 458279e..b44a0eb 100644 --- a/lib/Moose/Util/TypeConstraints.pm +++ b/lib/Moose/Util/TypeConstraints.pm @@ -6,10 +6,6 @@ use List::MoreUtils qw( all any ); use Scalar::Util qw( blessed reftype ); use Moose::Exporter; -our $VERSION = '0.89_02'; -$VERSION = eval $VERSION; -our $AUTHORITY = 'cpan:STEVAN'; - ## -------------------------------------------------------- # Prototyped subs must be predeclared because we have a # circular dependency with Moose::Meta::Attribute et. al. @@ -22,9 +18,11 @@ 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; @@ -36,19 +34,18 @@ 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 duck_type - as where message optimize_as + as where message optimize_as inline_as coerce from via - enum + enum union find_type_constraint - register_type_constraint ) + register_type_constraint + match_on_type ) ], - _export_to_main => 1, ); ## -------------------------------------------------------- @@ -72,13 +69,26 @@ sub export_type_constraints_as_functions { } sub create_type_constraint_union { + _create_type_constraint_union(\@_); +} + +sub create_named_type_constraint_union { + my $name = shift; + _create_type_constraint_union($name, \@_); +} + +sub _create_type_constraint_union { + my $name; + $name = shift if @_ > 1; + my @tcs = @{ shift() }; + my @type_constraint_names; - if ( scalar @_ == 1 && _detect_type_constraint_union( $_[0] ) ) { - @type_constraint_names = _parse_type_constraint_union( $_[0] ); + if ( scalar @tcs == 1 && _detect_type_constraint_union( $tcs[0] ) ) { + @type_constraint_names = _parse_type_constraint_union( $tcs[0] ); } else { - @type_constraint_names = @_; + @type_constraint_names = @tcs; } ( scalar @type_constraint_names >= 2 ) @@ -91,10 +101,15 @@ sub create_type_constraint_union { "Could not locate type constraint ($_) for the union"); } @type_constraint_names; - return Moose::Meta::TypeConstraint::Union->new( - type_constraints => \@type_constraints ); + my %options = ( + type_constraints => \@type_constraints + ); + $options{name} = $name if defined $name; + + return Moose::Meta::TypeConstraint::Union->new(%options); } + sub create_parameterized_type_constraint { my $type_constraint_name = shift; my ( $base_type, $type_parameter ) @@ -140,15 +155,33 @@ sub create_class_type_constraint { #find_type_constraint("ClassName")->check($class) # || __PACKAGE__->_throw_error("Can't create a class type constraint because '$class' is not a class name"); + my $pkg_defined_in = $options->{package_defined_in} || scalar( caller(1) ); + + if (my $type = $REGISTRY->get_type_constraint($class)) { + if (!($type->isa('Moose::Meta::TypeConstraint::Class') && $type->class eq $class)) { + _confess( + "The type constraint '$class' has already been created in " + . $type->_package_defined_in + . " and cannot be created again in " + . $pkg_defined_in ) + } + else { + return $type; + } + } + my %options = ( - class => $class, - name => $class, + class => $class, + name => $class, + package_defined_in => $pkg_defined_in, %{ $options || {} }, ); $options{name} ||= "__ANON__"; - Moose::Meta::TypeConstraint::Class->new(%options); + my $tc = Moose::Meta::TypeConstraint::Class->new(%options); + $REGISTRY->add_type_constraint($tc); + return $tc; } sub create_role_type_constraint { @@ -158,15 +191,33 @@ sub create_role_type_constraint { #find_type_constraint("ClassName")->check($class) # || __PACKAGE__->_throw_error("Can't create a class type constraint because '$class' is not a class name"); + my $pkg_defined_in = $options->{package_defined_in} || scalar( caller(1) ); + + if (my $type = $REGISTRY->get_type_constraint($role)) { + if (!($type->isa('Moose::Meta::TypeConstraint::Role') && $type->role eq $role)) { + _confess( + "The type constraint '$role' has already been created in " + . $type->_package_defined_in + . " and cannot be created again in " + . $pkg_defined_in ) + } + else { + return $type; + } + } + my %options = ( - role => $role, - name => $role, + role => $role, + name => $role, + package_defined_in => $pkg_defined_in, %{ $options || {} }, ); $options{name} ||= "__ANON__"; - Moose::Meta::TypeConstraint::Role->new(%options); + my $tc = Moose::Meta::TypeConstraint::Role->new(%options); + $REGISTRY->add_type_constraint($tc); + return $tc; } sub find_or_create_type_constraint { @@ -199,15 +250,15 @@ sub find_or_create_type_constraint { } sub find_or_create_isa_type_constraint { - my $type_constraint_name = shift; + my ($type_constraint_name, $options) = @_; find_or_parse_type_constraint($type_constraint_name) - || create_class_type_constraint($type_constraint_name); + || create_class_type_constraint($type_constraint_name, $options); } sub find_or_create_does_type_constraint { - my $type_constraint_name = shift; + my ($type_constraint_name, $options) = @_; find_or_parse_type_constraint($type_constraint_name) - || create_role_type_constraint($type_constraint_name); + || create_role_type_constraint($type_constraint_name, $options); } sub find_or_parse_type_constraint { @@ -272,43 +323,17 @@ sub register_type_constraint { # type constructors sub type { - - # 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} + $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' @@ -329,26 +354,16 @@ sub subtype { return _create_type_constraint( $name, $p{as}, $p{where}, $p{message}, - $p{optimize_as} + $p{optimize_as}, $p{inline_as}, ); } sub class_type { - register_type_constraint( - create_class_type_constraint( - $_[0], - ( defined( $_[1] ) ? $_[1] : () ), - ) - ); + create_class_type_constraint(@_); } sub role_type ($;$) { - register_type_constraint( - create_role_type_constraint( - $_[0], - ( defined( $_[1] ) ? $_[1] : () ), - ) - ); + create_role_type_constraint(@_); } sub maybe_type { @@ -365,6 +380,9 @@ sub duck_type { @methods = @$type_name; $type_name = undef; } + if ( @methods == 1 && ref $methods[0] eq 'ARRAY' ) { + @methods = @{ $methods[0] }; + } register_type_constraint( create_duck_type_constraint( @@ -390,12 +408,13 @@ sub coerce { # # subtype( 'Foo', as( 'Str', where { ... } ) ); # -# If as() returns all it's extra arguments, this just works, and +# 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] } @@ -407,14 +426,16 @@ sub enum { # 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( @@ -424,6 +445,25 @@ sub enum { ); } +sub union { + my ( $type_name, @constraints ) = @_; + if ( ref $type_name eq 'ARRAY' ) { + @constraints == 0 + || __PACKAGE__->_throw_error("union called with an array reference and additional arguments."); + @constraints = @$type_name; + $type_name = undef; + } + if ( @constraints == 1 && ref $constraints[0] eq 'ARRAY' ) { + @constraints = @{ $constraints[0] }; + } + if ( defined $type_name ) { + return register_type_constraint( + create_named_type_constraint_union( $type_name, @constraints ) + ); + } + return create_type_constraint_union( @constraints ); +} + sub create_enum_type_constraint { my ( $type_name, $values ) = @_; @@ -442,6 +482,39 @@ sub create_duck_type_constraint { ); } +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 ... ## -------------------------------------------------------- @@ -452,6 +525,7 @@ sub _create_type_constraint ($$$;$$) { my $check = shift; my $message = shift; my $optimized = shift; + my $inlined = shift; my $pkg_defined_in = scalar( caller(1) ); @@ -478,6 +552,7 @@ sub _create_type_constraint ($$$;$$) { ( $check ? ( constraint => $check ) : () ), ( $message ? ( message => $message ) : () ), ( $optimized ? ( optimized => $optimized ) : () ), + ( $inlined ? ( inlined => $inlined ) : () ), ); my $constraint; @@ -533,20 +608,54 @@ 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 @@ -585,8 +694,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", @@ -607,135 +717,11 @@ $_->make_immutable( Moose::Meta::TypeConstraint::Registry ); -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 '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; - -# NOTE: -# blessed(qr/.../) returns true,.. how odd -subtype 'Object' => as 'Ref' => - where { blessed($_) && blessed($_) ne 'Regexp' } => - optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Object; - -# This type is deprecated. -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 { - (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, - constraint_generator => sub { - my $type_parameter = shift; - my $check = $type_parameter->_compiled_type_constraint; - return sub { - foreach my $x (@$_) { - ( $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, - 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; - } - } - ) -); +require Moose::Util::TypeConstraints::Builtins; +Moose::Util::TypeConstraints::Builtins::define_builtins($REGISTRY); my @PARAMETERIZABLE_TYPES - = map { $REGISTRY->get_type_constraint($_) } qw[ArrayRef HashRef Maybe]; + = map { $REGISTRY->get_type_constraint($_) } qw[ScalarRef ArrayRef HashRef Maybe]; sub get_all_parameterizable_types {@PARAMETERIZABLE_TYPES} @@ -767,32 +753,36 @@ 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; - 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+$_ }; + class_type 'DateTimeClass', { class => 'DateTime' }; - enum 'RGBColors' => qw(red green blue); + role_type 'Barks', { role => 'Some::Library::Role::Barks' }; + + enum 'RGBColors', [qw(red green blue)]; + + union 'StringOrArray', [qw( String Array )]; no Moose::Util::TypeConstraints; @@ -834,7 +824,7 @@ this, as well as future proof your subtypes from classes which have 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 @@ -848,19 +838,19 @@ that hierarchy represented visually. Undef Defined Value - Num - Int Str + Num + Int ClassName RoleName Ref - ScalarRef + ScalarRef[`a] ArrayRef[`a] HashRef[`a] CodeRef RegexpRef GlobRef - FileHandle + FileHandle Object B Any type followed by a type parameter C<[`a]> can be @@ -868,6 +858,7 @@ 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 @@ -904,7 +895,7 @@ I instead. 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 it's first argument and returns 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. @@ -912,21 +903,21 @@ For instance, this is how you could use it with L to declare a completely new type. type 'HashOfArrayOfObjects', - { - where => IsHashRef( - -keys => HasLength, - -values => IsArrayRef(IsObject) - ) - }; - -For more examples see the F test + where { + IsHashRef( + -keys => HasLength, + -values => IsArrayRef(IsObject) + )->(@_); + }; + +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'), @@ -935,7 +926,23 @@ related C function. }; For a complete example see the -F test file. +F test file. + +=head2 Error messages + +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: + + subtype 'PositiveInt', + as 'Int', + where { $_ > 0 }, + message { "$_ is not a positive integer!" }; + +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. =head1 FUNCTIONS @@ -945,11 +952,11 @@ 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. -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<< subtype 'Name' => as 'Parent' => where { } ... >> +=item B<< subtype 'Name', as 'Parent', where { } ... >> This creates a named subtype. @@ -965,7 +972,7 @@ name and a hashref of parameters: The valid hashref keys are C (the parent), C, C, and C. -=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 @@ -982,20 +989,38 @@ just a hashref of parameters: Creates a new subtype of C with the name C<$class> and the metaclass L. + # Create a type called 'Box' which tests for objects which ->isa('Box') + class_type 'Box'; + +By default, the name of the type and the name of the class are the same, but +you can specify both separately. + + # Create a type called 'Box' which tests for objects which ->isa('ObjectLibrary::Box'); + class_type 'Box', { class => 'ObjectLibrary::Box' }; + =item B Creates a C type constraint with the name C<$role> and the metaclass L. + # Create a type called 'Walks' which tests for objects which ->does('Walks') + role_type 'Walks'; + +By default, the name of the type and the name of the role are the same, but +you can specify both separately. + + # Create a type called 'Walks' which tests for objects which ->does('MooseX::Role::Walks'); + role_type 'Walks', { role => 'MooseX::Role::Walks' }; + =item B 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>. +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 @@ -1003,36 +1028,63 @@ recommend that you use a C-only Role instead. =item B -If passed an ARRAY reference 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: +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 +=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 + +This will create a basic subtype where any of the provided constraints +may match in order to satisfy this constraint. + +=item B + +If passed an ARRAY reference as the only parameter instead of the +C<$name>, C<\@constraints> pair, this will create an unnamed union. +This can then be used in an attribute definition like so: + + has 'items' => ( + is => 'ro', + isa => union([qw[ Str ArrayRef ]]), + ); + +This is similar to the existing string union: + + isa => 'Str|ArrayRef' + +except that it supports anonymous elements as child constraints: + + has 'color' => ( + isa => 'ro', + isa => union([ 'Int', enum([qw[ red green blue ]]) ]), + ); + =item B This is just sugar for the type constraint construction syntax. @@ -1057,17 +1109,41 @@ 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. If your parent type constraint defines its own inlining, you can simply use +that to avoid repeating code. For example, here is the inlining code for the +C type, which is a subtype of C: + + sub { + $_[0]->parent()->_inline_check($_[1]) + . ' && !ref(' . $_[1] . ')' + } + =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 { } ... >> +=item B<< type 'Name', where { } ... >> This creates a base type, which has no parent. @@ -1077,7 +1153,79 @@ parameters: type( 'Foo', { where => ..., message => ... } ); -The valid hashref keys are C, C, and C. +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 @@ -1090,15 +1238,21 @@ 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<< coerce 'Name' => from 'OtherName' => via { ... } >> +=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. +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. @@ -1145,6 +1299,8 @@ form. This removes any whitespace in the string. =item B +=item B + This can take a union type specification like C<'Int|ArrayRef[Int]'>, or a list of names. It returns a new L object. @@ -1202,7 +1358,7 @@ global registry. =item B These functions will first call C. If -that function does not return a type, a new anonymous type object will +that function does not return a type, a new type object will be created. The C variant will use C and the @@ -1244,21 +1400,6 @@ Adds C<$type> to the list of parameterizable types =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