type subtype class_type role_type maybe_type duck_type
as where message optimize_as inline_as
coerce from via
- enum
+ enum union
find_type_constraint
register_type_constraint
match_on_type )
}
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 )
"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 )
#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 {
# type constructors
sub type {
-
- # 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] );
- }
-
my $name = shift;
my %p = map { %{$_} } @_;
}
sub subtype {
-
- # crazy back-compat code for being called without sugar ...
- #
- # 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 };
- # 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(@_);
- }
-
if ( @_ == 1 && !ref $_[0] ) {
__PACKAGE__->_throw_error(
'A subtype cannot consist solely of a name, it must have a parent'
}
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 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 ) = @_;
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 )];
+
no Moose::Util::TypeConstraints;
=head1 DESCRIPTION
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
isa => enum([qw[ ascending descending ]]),
);
+=item B<union ($name, \@constraints)>
+
+This will create a basic subtype where any of the provided constraints
+may match in order to satisfy this constraint.
+
+=item B<union (\@constraints)>
+
+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<as 'Parent'>
This is just sugar for the type constraint construction syntax.
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.
projects / gitmo/Moose.git / blobdiff