use Scalar::Util qw( blessed reftype );
use Moose::Exporter;
-our $VERSION = '0.83';
-$VERSION = eval $VERSION;
-our $AUTHORITY = 'cpan:STEVAN';
-
## --------------------------------------------------------
# Prototyped subs must be predeclared because we have a
# circular dependency with Moose::Meta::Attribute et. al.
## --------------------------------------------------------
+use Moose::Deprecated;
use Moose::Meta::TypeConstraint;
use Moose::Meta::TypeConstraint::Union;
use Moose::Meta::TypeConstraint::Parameterized;
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;
coerce from via
enum
find_type_constraint
- register_type_constraint )
+ register_type_constraint
+ match_on_type )
],
- _export_to_main => 1,
);
## --------------------------------------------------------
# back-compat version, called without sugar
if ( !any { ( reftype($_) || '' ) eq 'HASH' } @_ ) {
+ Moose::Deprecated::deprecated(
+ feature => 'type without sugar',
+ message =>
+ 'Calling type() with a simple list of parameters is deprecated. This will be an error in Moose 2.0200.'
+ );
+
return _create_type_constraint( $_[0], undef, $_[1] );
}
#
# subtype 'Parent', sub { where };
if ( scalar @_ == 2 && ( reftype( $_[1] ) || '' ) eq 'CODE' ) {
+ Moose::Deprecated::deprecated(
+ feature => 'subtype without sugar',
+ message =>
+ 'Calling subtype() with a simple list of parameters is deprecated. This will be an error in Moose 2.0200.'
+ );
+
return _create_type_constraint( undef, @_ );
}
# subtype 'Parent', sub { where }, sub { message }, sub { optimized };
if ( scalar @_ >= 3 && all { ( reftype($_) || '' ) eq 'CODE' }
@_[ 1 .. $#_ ] ) {
+ Moose::Deprecated::deprecated(
+ feature => 'subtype without sugar',
+ message =>
+ 'Calling subtype() with a simple list of parameters is deprecated. This will be an error in Moose 2.0200.'
+ );
+
return _create_type_constraint( undef, @_ );
}
# subtype 'Name', 'Parent', ...
if ( scalar @_ >= 2 && all { !ref } @_[ 0, 1 ] ) {
+ Moose::Deprecated::deprecated(
+ feature => 'subtype without sugar',
+ message =>
+ 'Calling subtype() with a simple list of parameters is deprecated. This will be an error in Moose 2.0200.'
+ );
+
return _create_type_constraint(@_);
}
@methods = @$type_name;
$type_name = undef;
}
+ if ( @methods == 1 && ref $methods[0] eq 'ARRAY' ) {
+ @methods = @{ $methods[0] };
+ }
register_type_constraint(
- _create_type_constraint(
+ create_duck_type_constraint(
$type_name,
- 'Object',
- sub {
- my $obj = $_;
- return 0 unless all { $obj->can($_) } @methods;
- return 1;
- },
- sub {
- my $obj = $_;
- my $class = blessed($obj);
- my @missing_methods = grep { !$obj->can($_) } @methods;
- return
- "$class is missing methods '@missing_methods'";
- },
+ \@methods,
)
);
}
# 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(
);
}
+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 ...
## --------------------------------------------------------
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> $valid_chars)
+ (?<type_atom> $type_atom)
+ (?<ws> $ws)
+ (?<op_union> $op_union)
+ (?<type> $type_pattern)
+ (?<type_capture_parts> $type_capture_parts_pattern)
+ (?<type_with_parameter> $type_with_parameter_pattern)
+ (?<union> $union_pattern)
+ (?<any> $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
Moose::Meta::TypeConstraint::Class
Moose::Meta::TypeConstraint::Role
Moose::Meta::TypeConstraint::Enum
+ Moose::Meta::TypeConstraint::DuckType
Moose::Meta::TypeConstraint::Registry
);
subtype 'Ref' => as 'Defined' => where { ref($_) } =>
optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Ref;
-subtype 'Str' => as 'Value' => where {1} =>
+subtype 'Str' => as 'Value' => where { ref(\$_) eq 'SCALAR' } =>
optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Str;
subtype 'Num' => as 'Str' =>
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 'RegexpRef' => as 'Ref' =>
+ where(\&Moose::Util::TypeConstraints::OptimizedConstraints::RegexpRef) =>
+ optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::RegexpRef;
subtype 'GlobRef' => as 'Ref' => where { ref($_) eq 'GLOB' } =>
optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::GlobRef;
} => optimize_as
\&Moose::Util::TypeConstraints::OptimizedConstraints::FileHandle;
-# NOTE:
-# blessed(qr/.../) returns true,.. how odd
subtype 'Object' => as 'Ref' =>
- where { blessed($_) && blessed($_) ne 'Regexp' } =>
+ where { blessed($_) } =>
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;
$REGISTRY->add_type_constraint(
Moose::Meta::TypeConstraint::Parameterizable->new(
+ name => 'ScalarRef',
+ package_defined_in => __PACKAGE__,
+ parent => find_type_constraint('Ref'),
+ constraint => sub { ref($_) eq 'SCALAR' || ref($_) eq 'REF' },
+ optimized =>
+ \&Moose::Util::TypeConstraints::OptimizedConstraints::ScalarRef,
+ constraint_generator => sub {
+ my $type_parameter = shift;
+ my $check = $type_parameter->_compiled_type_constraint;
+ return sub {
+ return $check->(${ $_ });
+ };
+ }
+ )
+);
+
+$REGISTRY->add_type_constraint(
+ Moose::Meta::TypeConstraint::Parameterizable->new(
name => 'ArrayRef',
package_defined_in => __PACKAGE__,
parent => find_type_constraint('Ref'),
);
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}
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+$_ };
- enum 'RGBColors' => qw(red green blue);
+ enum 'RGBColors', [qw(red green blue)];
no Moose::Util::TypeConstraints;
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
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<NOTE:> 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
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
L<Declare::Constraints::Simple> to declare a completely new type.
type 'HashOfArrayOfObjects',
- {
- where => IsHashRef(
- -keys => HasLength,
- -values => IsArrayRef(IsObject)
- )
- };
-
-For more examples see the F<t/200_examples/004_example_w_DCS.t> test
+ where {
+ IsHashRef(
+ -keys => HasLength,
+ -values => IsArrayRef(IsObject)
+ )->(@_);
+ };
+
+For more examples see the F<t/examples/example_w_DCS.t> test
file.
Here is an example of using L<Test::Deep> and it's non-test
related C<eq_deeply> function.
- type 'ArrayOfHashOfBarsAndRandomNumbers'
- => where {
+ type 'ArrayOfHashOfBarsAndRandomNumbers',
+ where {
eq_deeply($_,
array_each(subhashof({
bar => isa('Bar'),
};
For a complete example see the
-F<t/200_examples/005_example_w_TestDeep.t> test file.
+F<t/examples/example_w_TestDeep.t> 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<Devel::PartialDump> (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
will also register the type constraints your create in a global
registry that is used to look types up by name.
-See the L<SYNOPSIS> for an example of how to use these.
+See the L</SYNOPSIS> 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.
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<duck_type ($name, @methods)>
+=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>.
+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
=item B<duck_type (\@methods)>
-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<enum ($name, @values)>
+=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.
-See the L<SYNOPSIS> for a simple example.
+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
a convenient constraint builder.
=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',
type constraint which can be used to avoid traversing a subtype
constraint hierarchy.
-B<NOTE:> 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<NOTE:> 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.
=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
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<SYNOPSIS> for an example of how to use these.
+See the L</SYNOPSIS> 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<Name> argument
is the type you are coercing I<to>.
+To define multiple coercions, supply more sets of from/via pairs:
+
+ coerce 'Name',
+ from 'OtherName', via { ... },
+ from 'ThirdName', via { ... };
+
=item B<from 'OtherName'>
This is just sugar for the type coercion construction syntax.
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
=item B<find_or_create_does_type_constraint($type_name)>
These functions will first call C<find_or_parse_type_constraint>. 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<isa> variant will use C<create_class_type_constraint> and the
=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 E<lt>stevan@iinteractive.comE<gt>
-
-=head1 COPYRIGHT AND LICENSE
-
-Copyright 2006-2009 by Infinity Interactive, Inc.
-
-L<http://www.iinteractive.com>
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
+See L<Moose/BUGS> for details on reporting bugs.
=cut
projects / gitmo/Moose.git / blobdiff