use Moose::Meta::Class;
use Moose::Meta::TypeConstraint;
-use Moose::Meta::TypeConstraint::Class;
use Moose::Meta::TypeCoercion;
use Moose::Meta::Attribute;
use Moose::Meta::Instance;
$type_constraint = $options{isa};
}
else {
- $type_constraint = Moose::Util::TypeConstraints::find_or_create_type_constraint(
- $options{isa}
- );
+ # FIXME this causes a failing test, not sure it should
+ # $type_constraint = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($options{isa});
+ $type_constraint = Moose::Util::TypeConstraints::find_or_parse_type_constraint($options{isa});
(defined $type_constraint)
|| confess "Could not find the type constraint '" . $options{isa} . "'";
}
$type_constraint = $options{does};
}
else {
- $type_constraint = Moose::Util::TypeConstraints::find_or_create_type_constraint(
- $options{does}
- );
+ # FIXME see above
+ # $type_constraint = Moose::Util::TypeConstraints::find_or_create_does_type_constraint($options{does});
+ $type_constraint = Moose::Util::TypeConstraints::find_or_parse_type_constraint($options{does});
(defined $type_constraint)
|| confess "Could not find the type constraint '" . $options{does} . "'";
}
$options->{type_constraint} = $options->{isa};
}
else {
- $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_type_constraint(
- $options->{isa} => {
- parent => Moose::Util::TypeConstraints::find_type_constraint('Object'),
- constraint => sub { $_[0]->isa($options->{isa}) }
- }
- );
+ $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($options->{isa});
}
}
elsif (exists $options->{does}) {
$options->{type_constraint} = $options->{does};
}
else {
- $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_type_constraint(
- $options->{does} => {
- parent => Moose::Util::TypeConstraints::find_type_constraint('Role'),
- constraint => sub {
- Moose::Util::does_role($_[0], $options->{does})
- }
- }
- );
+ $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_does_type_constraint($options->{does});
}
}
$class->get_method($method_name)->body != $role->get_method($method_name)->body) {
next;
}
- else {
-
+ else {
# add it, although it could be overriden
$class->alias_method(
$method_name,
my @coercions;
while (@coercion_map) {
my ($constraint_name, $action) = splice(@coercion_map, 0, 2);
- my $type_constraint = Moose::Util::TypeConstraints::find_or_create_type_constraint($constraint_name);
+ my $type_constraint = Moose::Util::TypeConstraints::find_or_parse_type_constraint($constraint_name);
(defined $type_constraint)
|| confess "Could not find the type constraint ($constraint_name) to coerce from";
push @coercions => [
sub new {
my ( $class, %args ) = @_;
- $args{class} = $args{name} unless exists $args{class};
$args{parent} = Moose::Util::TypeConstraints::find_type_constraint('Object');
my $self = $class->meta->new_object(%args);
# regardless of their name
Moose::Util::TypeConstraints::find_type_constraint($_)
||
- __PACKAGE__->new( name => $_ )
+ __PACKAGE__->new( class => $_, name => "__ANON__" )
} $self->class->meta->superclasses,
);
}
--- /dev/null
+package Moose::Meta::TypeConstraint::Role;
+
+use strict;
+use warnings;
+use metaclass;
+
+use Scalar::Util 'blessed';
+use Moose::Util::TypeConstraints ();
+
+our $VERSION = '0.02';
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Moose::Meta::TypeConstraint';
+
+__PACKAGE__->meta->add_attribute('role' => (
+ reader => 'role',
+));
+
+sub new {
+ my ( $class, %args ) = @_;
+
+ $args{parent} = Moose::Util::TypeConstraints::find_type_constraint('Object');
+ my $self = $class->meta->new_object(%args);
+
+ $self->_create_hand_optimized_type_constraint;
+ $self->compile_type_constraint();
+
+ return $self;
+}
+
+sub _create_hand_optimized_type_constraint {
+ my $self = shift;
+ my $role = $self->role;
+ $self->hand_optimized_type_constraint(
+ sub { Moose::Util::does_role($_[0], $role) }
+ );
+}
+
+sub parents {
+ my $self = shift;
+ return (
+ $self->parent,
+ map {
+ # FIXME find_type_constraint might find a TC named after the role but that isn't really it
+ # I did this anyway since it's a convention that preceded TypeConstraint::Role, and it should DWIM
+ # if anybody thinks this problematic please discuss on IRC.
+ # a possible fix is to add by attr indexing to the type registry to find types of a certain property
+ # regardless of their name
+ Moose::Util::TypeConstraints::find_type_constraint($_)
+ ||
+ __PACKAGE__->new( role => $_, name => "__ANON__" )
+ } @{ $self->role->meta->get_roles },
+ );
+}
+
+sub equals {
+ my ( $self, $type_or_name ) = @_;
+
+ my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
+
+ return unless $other->isa(__PACKAGE__);
+
+ return $self->role eq $other->role;
+}
+
+sub is_a_type_of {
+ my ($self, $type_or_name) = @_;
+
+ my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
+
+ ($self->equals($type) || $self->is_subtype_of($type_or_name));
+}
+
+sub is_subtype_of {
+ my ($self, $type_or_name_or_role ) = @_;
+
+ if ( not ref $type_or_name_or_role ) {
+ # it might be a role
+ return 1 if $self->role->does_role( $type_or_name_or_role );
+ }
+
+ my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name_or_role);
+
+ if ( $type->isa(__PACKAGE__) ) {
+ # if $type_or_name_or_role isn't a role, it might be the TC name of another ::Role type
+ # or it could also just be a type object in this branch
+ return $self->role->does_role( $type->role );
+ } else {
+ # the only other thing we are a subtype of is Object
+ $self->SUPER::is_subtype_of($type);
+ }
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Moose::Meta::TypeConstraint::Role - Role/TypeConstraint parallel hierarchy
+
+=head1 METHODS
+
+=over 4
+
+=item B<new>
+
+=item B<class>
+
+=item B<hand_optimized_type_constraint>
+
+=item B<has_hand_optimized_type_constraint>
+
+=item B<equals>
+
+=item B<is_a_type_of>
+
+=item B<is_subtype_of>
+
+=item B<parents>
+
+Return all the parent types, corresponding to the parent classes.
+
+=item B<meta>
+
+=back
+
+=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
+
+Yuval Kogman E<lt>nothingmuch@cpan.orgE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006-2008 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.
+
+=cut
sub find_type_constraint ($);
sub register_type_constraint ($);
sub find_or_create_type_constraint ($;$);
+sub find_or_parse_type_constraint ($);
+sub find_or_create_isa_type_constraint ($);
+sub find_or_create_does_type_constraint ($);
sub create_type_constraint_union (@);
sub create_parameterized_type_constraint ($);
sub create_class_type_constraint ($;$);
+sub create_role_type_constraint ($;$);
sub create_enum_type_constraint ($$);
-#sub create_class_type_constraint ($);
# dah sugah!
sub type ($$;$$);
use Moose::Meta::TypeConstraint::Union;
use Moose::Meta::TypeConstraint::Parameterized;
use Moose::Meta::TypeConstraint::Parameterizable;
+use Moose::Meta::TypeConstraint::Class;
+use Moose::Meta::TypeConstraint::Role;
use Moose::Meta::TypeConstraint::Enum;
use Moose::Meta::TypeCoercion;
use Moose::Meta::TypeCoercion::Union;
use Moose::Util::TypeConstraints::OptimizedConstraints;
my @exports = qw/
- type subtype class_type as where message optimize_as
+ type subtype class_type role_type as where message optimize_as
coerce from via
enum
find_type_constraint
return Moose::Meta::TypeConstraint::Parameterized->new(
name => $type_constraint_name,
parent => $REGISTRY->get_type_constraint($base_type),
- type_parameter => find_or_create_type_constraint(
- $type_parameter => {
- parent => $REGISTRY->get_type_constraint('Object'),
- constraint => sub { $_[0]->isa($type_parameter) }
- }
- ),
+ type_parameter => find_or_create_isa_type_constraint($type_parameter),
);
}
#should we also support optimized checks?
sub create_class_type_constraint ($;$) {
- my $class = shift;
+ my ( $class, $options ) = @_;
+
# too early for this check
#find_type_constraint("ClassName")->check($class)
# || confess "Can't create a class type constraint because '$class' is not a class name";
- my $message;
- if( $_[0] ){
- $message = $_[0]->{message} if exists $_[0]->{message};
- }
- # FIXME allow a different name too, and potentially handle anon
- Moose::Meta::TypeConstraint::Class->new(
- name => $class,
- ($message ? (message => $message) : ())
+ my %options = (
+ class => $class,
+ name => $class,
+ %{ $options || {} },
);
+
+ $options{name} ||= "__ANON__";
+
+ Moose::Meta::TypeConstraint::Class->new( %options );
}
-sub find_or_create_type_constraint ($;$) {
- my ($type_constraint_name, $options_for_anon_type) = @_;
+sub create_role_type_constraint ($;$) {
+ my ( $role, $options ) = @_;
- return $REGISTRY->get_type_constraint($type_constraint_name)
- if $REGISTRY->has_type_constraint($type_constraint_name);
+ # too early for this check
+ #find_type_constraint("ClassName")->check($class)
+ # || confess "Can't create a class type constraint because '$class' is not a class name";
- my $constraint;
+ my %options = (
+ role => $role,
+ name => $role,
+ %{ $options || {} },
+ );
- if (_detect_type_constraint_union($type_constraint_name)) {
- $constraint = create_type_constraint_union($type_constraint_name);
- }
- elsif (_detect_parameterized_type_constraint($type_constraint_name)) {
- $constraint = create_parameterized_type_constraint($type_constraint_name);
+ $options{name} ||= "__ANON__";
+
+ Moose::Meta::TypeConstraint::Role->new( %options );
+}
+
+
+sub find_or_create_type_constraint ($;$) {
+ my ( $type_constraint_name, $options_for_anon_type ) = @_;
+
+ if ( my $constraint = find_or_parse_type_constraint($type_constraint_name) ) {
+ return $constraint;
}
- else {
+ elsif ( defined $options_for_anon_type ) {
# NOTE:
# if there is no $options_for_anon_type
# specified, then we assume they don't
# want to create one, and return nothing.
- return unless defined $options_for_anon_type;
- # NOTE:
# otherwise assume that we should create
# an ANON type with the $options_for_anon_type
# options which can be passed in. It should
);
}
+ return;
+}
+
+sub find_or_create_isa_type_constraint ($) {
+ my $type_constraint_name = shift;
+ find_or_parse_type_constraint($type_constraint_name) || create_class_type_constraint($type_constraint_name, { name => undef })
+}
+
+sub find_or_create_does_type_constraint ($) {
+ my $type_constraint_name = shift;
+ find_or_parse_type_constraint($type_constraint_name) || create_role_type_constraint($type_constraint_name, { name => undef })
+}
+
+sub find_or_parse_type_constraint ($) {
+ my $type_constraint_name = shift;
+
+ return $REGISTRY->get_type_constraint($type_constraint_name)
+ if $REGISTRY->has_type_constraint($type_constraint_name);
+
+ my $constraint;
+
+ if (_detect_type_constraint_union($type_constraint_name)) {
+ $constraint = create_type_constraint_union($type_constraint_name);
+ }
+ elsif (_detect_parameterized_type_constraint($type_constraint_name)) {
+ $constraint = create_parameterized_type_constraint($type_constraint_name);
+ } else {
+ return;
+ }
+
$REGISTRY->add_type_constraint($constraint);
return $constraint;
}
);
}
+sub role_type ($;$) {
+ register_type_constraint(
+ create_role_type_constraint(
+ $_[0],
+ ( defined($_[1]) ? $_[1] : () ),
+ )
+ );
+}
+
sub coerce ($@) {
my ($type_name, @coercion_map) = @_;
_install_type_coercions($type_name, \@coercion_map);
if defined $type;
}
- $parent = find_or_create_type_constraint($parent) if defined $parent;
+ $parent = find_or_parse_type_constraint($parent) if defined $parent;
my $constraint = Moose::Meta::TypeConstraint->new(
name => $name || '__ANON__',
constraint meta-object, which will be an instance of
L<Moose::Meta::TypeConstraint>.
-=item B<class_type ($class, ?$message)>
+=item B<class_type ($class, ?$options)>
Creates a type constraint with the name C<$class> and the metaclass
L<Moose::Meta::TypeConstraint::Class>.
+=item B<role_type ($role, ?$options)>
+
+Creates a type constraint with the name C<$role> and the metaclass
+L<Moose::Meta::TypeConstraint::Role>.
+
=item B<enum ($name, @values)>
This will create a basic subtype for a given set of strings.
this will extract the base type and container type and build an instance of
L<Moose::Meta::TypeConstraint::Parameterized> for it.
-=item B<create_class_type_constraint ($class, ?$message)>
+=item B<create_class_type_constraint ($class, ?$options)>
Given a class name it will create a new L<Moose::Meta::TypeConstraint::Class>
object for that class name.
+=item B<create_role_type_constraint ($role, ?$options)>
+
+Given a role name it will create a new L<Moose::Meta::TypeConstraint::Role>
+object for that role name.
+
=item B<create_enum_type_constraint ($name, $values)>
-=item B<find_or_create_type_constraint ($type_name, ?$options_for_anon_type)>
+=item B<find_or_parse_type_constraint ($type_name)>
This will attempt to find or create a type constraint given the a C<$type_name>.
If it cannot find it in the registry, it will see if it should be a union or
-container type an create one if appropriate, and lastly if nothing can be
-found or created that way, it will create an anon-type using the
-C<$options_for_anon_type> HASH ref to populate it. If the C<$options_for_anon_type>
-is not specified (it is C<undef>), then it will not create anything and simply
-return.
+container type an create one if appropriate
+
+=item B<find_or_create_type_constraint ($type_name, ?$options_for_anon_type)>
+
+This function will first call C<find_or_parse_type_constraint> with the type name.
+
+If no type is found or created, but C<$options_for_anon_type> are provided, it
+will create the corresponding type.
+
+This was used by the C<does> and C<isa> parameters to L<Moose::Meta::Attribute>
+and are now superseded by C<find_or_create_isa_type_constraint> and
+C<find_or_create_does_type_constraint>.
+
+=item B<find_or_create_isa_type_constraint ($type_name)>
+
+=item B<find_or_create_does_type_constraint ($type_name)>
+
+Attempts to parse the type name using L<find_or_parse_type_constraint> and if
+no appropriate constraint is found will create a new anonymous one.
+
+The C<isa> variant will use C<create_class_type_constraint> and the C<does>
+variant will use C<create_role_type_constraint>.
=item B<find_type_constraint ($type_name)>
ok( !$t->equals($t->parent), "not equal to parent" );
}
-my $hoi = Moose::Util::TypeConstraints::find_or_create_type_constraint('AlphaKeyHash[Int]');
+my $hoi = Moose::Util::TypeConstraints::find_or_parse_type_constraint('AlphaKeyHash[Int]');
ok($hoi->check({ one => 1, two => 2 }), '... validated it correctly');
ok(!$hoi->check({ one1 => 1, two2 => 2 }), '... validated it correctly');
ok( $hoi->equals( Moose::Meta::TypeConstraint::Parameterized->new( name => "Blah", parent => find_type_constraint("AlphaKeyHash"), type_parameter => find_type_constraint("Int") ) ), "equal to clone" );
ok( !$hoi->equals( Moose::Meta::TypeConstraint::Parameterized->new( name => "Oink", parent => find_type_constraint("AlphaKeyHash"), type_parameter => find_type_constraint("Str") ) ), "not equal to different parameter" );
-my $th = Moose::Util::TypeConstraints::find_or_create_type_constraint('Trihash[Bool]');
+my $th = Moose::Util::TypeConstraints::find_or_parse_type_constraint('Trihash[Bool]');
ok(!$th->check({ one => 1, two => 1 }), '... validated it correctly');
ok($th->check({ one => 1, two => 0, three => 1 }), '... validated it correctly');
=> via { [ $_->items ] }
} '... created the coercion okay';
-my $mylist = Moose::Util::TypeConstraints::find_or_create_type_constraint('MyList[Int]');
+my $mylist = Moose::Util::TypeConstraints::find_or_parse_type_constraint('MyList[Int]');
ok($mylist->check(MyList->new(10, 20, 30)), '... validated it correctly (pass)');
ok(!$mylist->check(MyList->new(10, "two")), '... validated it correctly (fail)');
=> via { [ $_->items ] }
} '... created the coercion okay';
-my $evenlist = Moose::Util::TypeConstraints::find_or_create_type_constraint('EvenList[Int]');
+my $evenlist = Moose::Util::TypeConstraints::find_or_parse_type_constraint('EvenList[Int]');
ok(!$evenlist->check(MyList->new(10, 20, 30)), '... validated it correctly (fail)');
ok($evenlist->check(MyList->new(10, 20, 30, 40)), '... validated it correctly (pass)');
use_ok('Moose::Util::TypeConstraints');
}
-my $type = Moose::Util::TypeConstraints::find_or_create_type_constraint('Maybe[Int]');
+my $type = Moose::Util::TypeConstraints::find_or_parse_type_constraint('Maybe[Int]');
isa_ok($type, 'Moose::Meta::TypeConstraint');
isa_ok($type, 'Moose::Meta::TypeConstraint::Parameterized');
ok( $type->parent->equals(find_type_constraint("Maybe")), "parent is Maybe" );
ok( $type->equals( Moose::Meta::TypeConstraint::Parameterized->new( name => "__ANON__", parent => find_type_constraint("Maybe"), type_parameter => find_type_constraint("Int") ) ), "equal to clone" );
ok( !$type->equals( Moose::Meta::TypeConstraint::Parameterized->new( name => "__ANON__", parent => find_type_constraint("Maybe"), type_parameter => find_type_constraint("Str") ) ), "not equal to clone with diff param" );
-ok( !$type->equals( Moose::Util::TypeConstraints::find_or_create_type_constraint('Maybe[Str]') ), "not equal to declarative version of diff param" );
+ok( !$type->equals( Moose::Util::TypeConstraints::find_or_parse_type_constraint('Maybe[Str]') ), "not equal to declarative version of diff param" );
ok($type->check(10), '... checked type correctly (pass)');
ok($type->check(undef), '... checked type correctly (pass)');
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 18;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Moose::Util::TypeConstraints');
+}
+
+{
+ package Gorch;
+ use Moose::Role;
+
+ package Bar;
+ use Moose::Role;
+
+ package Foo;
+ use Moose::Role;
+
+ with qw(Bar Gorch);
+
+}
+
+lives_ok { role_type 'Beep' } 'role_type keywork works';
+lives_ok { role_type('Boop', message { "${_} is not a Boop" }) }
+ 'role_type keywork works with message';
+
+my $type = find_type_constraint("Foo");
+
+is( $type->role, "Foo", "role attribute" );
+
+ok( $type->is_subtype_of("Gorch"), "subtype of gorch" );
+
+ok( $type->is_subtype_of("Bar"), "subtype of bar" );
+
+ok( $type->is_subtype_of("Object"), "subtype of Object" );
+
+ok( find_type_constraint("Bar")->check(Foo->new), "Foo passes Bar" );
+ok( find_type_constraint("Bar")->check(Bar->new), "Bar passes Bar" );
+ok( !find_type_constraint("Gorch")->check(Bar->new), "but Bar doesn't pass Gorch");
+
+ok( find_type_constraint("Beep")->check( bless {} => 'Beep' ), "Beep passes Beep" );
+my $boop = find_type_constraint("Boop");
+ok( $boop->has_message, 'Boop has a message');
+my $error = $boop->get_message(Foo->new);
+like( $error, qr/is not a Boop/, 'boop gives correct error message');
+
+
+ok( $type->equals($type), "equals self" );
+ok( $type->equals(Moose::Meta::TypeConstraint::Role->new( name => "__ANON__", role => "Foo" )), "equals anon constraint of same value" );
+ok( $type->equals(Moose::Meta::TypeConstraint::Role->new( name => "Oink", role => "Foo" )), "equals differently named constraint of same value" );
+ok( !$type->equals(Moose::Meta::TypeConstraint::Role->new( name => "__ANON__", role => "Bar" )), "doesn't equal other anon constraint" );
+ok( $type->is_subtype_of(Moose::Meta::TypeConstraint::Role->new( name => "__ANON__", role => "Bar" )), "subtype of other anon constraint" );
+
projects / gitmo/Moose.git / commitdiff