use List::MoreUtils qw( all any );
use Scalar::Util qw( blessed reftype );
use Moose::Exporter;
+use Moose::Deprecated;
## --------------------------------------------------------
# Prototyped subs must be predeclared because we have a
}
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] );
- }
- 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");
-
- my @type_constraints = map {
- 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 );
+ _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 )
#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 {
#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 {
}
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 {
}
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 {
sub duck_type {
my ( $type_name, @methods ) = @_;
if ( ref $type_name eq 'ARRAY' && !@methods ) {
- @methods = @$type_name;
+ @methods = ($type_name);
$type_name = undef;
}
if ( @methods == 1 && ref $methods[0] eq 'ARRAY' ) {
@methods = @{ $methods[0] };
}
+ else {
+ Moose::Deprecated::deprecated(
+ feature => 'non-arrayref form of duck_type',
+ message => "Passing a list of values to duck_type is deprecated. "
+ . "The method names should be wrapped in an arrayref.",
+ );
+ }
register_type_constraint(
create_duck_type_constraint(
@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;
+ @values = ($type_name);
$type_name = undef;
}
if ( @values == 1 && ref $values[0] eq 'ARRAY' ) {
@values = @{ $values[0] };
}
+ else {
+ Moose::Deprecated::deprecated(
+ feature => 'non-arrayref form of enum',
+ message => "Passing a list of values to enum is deprecated. "
+ . "Enum values should be wrapped in an arrayref.",
+ );
+ }
register_type_constraint(
create_enum_type_constraint(
from 'Str',
via { 0+$_ };
+ class_type 'DateTimeClass', { class => 'DateTime' };
+
+ role_type 'Barks', { role => 'Some::Library::Role::Barks' };
+
enum 'RGBColors', [qw(red green blue)];
union 'StringOrArray', [qw( String Array )];
Creates a new subtype of C<Object> with the name C<$class> and the
metaclass L<Moose::Meta::TypeConstraint::Class>.
+ # 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<role_type ($role, ?$options)>
Creates a C<Role> type constraint with the name C<$role> and the
metaclass L<Moose::Meta::TypeConstraint::Role>.
+ # 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<maybe_type ($type)>
Creates a type constraint for either C<undef> or something of the
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<Value> 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<Defined> type. However, to avoid repeating code, this can be optimized as:
+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<Value> type, which is a subtype of C<Defined>:
sub {
$_[0]->parent()->_inline_check($_[1])
=item B<create_type_constraint_union($pipe_separated_types | @type_constraint_names)>
+=item B<create_named_type_constraint_union($name, $pipe_separated_types | @type_constraint_names)>
+
This can take a union type specification like C<'Int|ArrayRef[Int]'>,
or a list of names. It returns a new
L<Moose::Meta::TypeConstraint::Union> object.