From: Yuval Kogman Date: Sun, 13 Apr 2008 16:22:10 +0000 (+0000) Subject: Introduce TypeConstraint::Role, and add find_or_create_{isa,does}_type_constraint... X-Git-Tag: 0_55~226 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=620db0454d31341c981eb9061132d4f3a08a7310;p=gitmo%2FMoose.git Introduce TypeConstraint::Role, and add find_or_create_{isa,does}_type_constraint to Moose::Util::TypeConstraints, utilizing these helpers in Moose::Meta::Attribute --- diff --git a/lib/Moose.pm b/lib/Moose.pm index c172f29..f1a3708 100644 --- a/lib/Moose.pm +++ b/lib/Moose.pm @@ -17,7 +17,6 @@ use Class::MOP; 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; diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm index ad1822a..be577f8 100644 --- a/lib/Moose/Meta/Attribute.pm +++ b/lib/Moose/Meta/Attribute.pm @@ -78,9 +78,9 @@ sub clone_and_inherit_options { $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} . "'"; } @@ -95,9 +95,9 @@ sub clone_and_inherit_options { $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} . "'"; } @@ -147,12 +147,7 @@ sub _process_options { $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}) { @@ -161,14 +156,7 @@ sub _process_options { $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}); } } diff --git a/lib/Moose/Meta/Role/Application/ToClass.pm b/lib/Moose/Meta/Role/Application/ToClass.pm index bf09f5c..1ecc060 100644 --- a/lib/Moose/Meta/Role/Application/ToClass.pm +++ b/lib/Moose/Meta/Role/Application/ToClass.pm @@ -110,8 +110,7 @@ sub apply_methods { $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, diff --git a/lib/Moose/Meta/TypeCoercion.pm b/lib/Moose/Meta/TypeCoercion.pm index aaae013..1412ae7 100644 --- a/lib/Moose/Meta/TypeCoercion.pm +++ b/lib/Moose/Meta/TypeCoercion.pm @@ -43,7 +43,7 @@ sub compile_type_coercion { 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 => [ diff --git a/lib/Moose/Meta/TypeConstraint/Class.pm b/lib/Moose/Meta/TypeConstraint/Class.pm index 0a763a1..50a627c 100644 --- a/lib/Moose/Meta/TypeConstraint/Class.pm +++ b/lib/Moose/Meta/TypeConstraint/Class.pm @@ -19,7 +19,6 @@ __PACKAGE__->meta->add_attribute('class' => ( 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); @@ -51,7 +50,7 @@ sub parents { # regardless of their name Moose::Util::TypeConstraints::find_type_constraint($_) || - __PACKAGE__->new( name => $_ ) + __PACKAGE__->new( class => $_, name => "__ANON__" ) } $self->class->meta->superclasses, ); } diff --git a/lib/Moose/Meta/TypeConstraint/Role.pm b/lib/Moose/Meta/TypeConstraint/Role.pm new file mode 100644 index 0000000..c2bf664 --- /dev/null +++ b/lib/Moose/Meta/TypeConstraint/Role.pm @@ -0,0 +1,149 @@ +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 + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +Return all the parent types, corresponding to the parent classes. + +=item B + +=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 Enothingmuch@cpan.orgE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006-2008 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. + +=cut diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm index 39ce45d..72d68fe 100644 --- a/lib/Moose/Util/TypeConstraints.pm +++ b/lib/Moose/Util/TypeConstraints.pm @@ -22,11 +22,14 @@ our $AUTHORITY = 'cpan:STEVAN'; 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 ($$;$$); @@ -51,6 +54,8 @@ use Moose::Meta::TypeConstraint; 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; @@ -58,7 +63,7 @@ use Moose::Meta::TypeConstraint::Registry; 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 @@ -147,55 +152,60 @@ sub create_parameterized_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 @@ -208,6 +218,36 @@ sub find_or_create_type_constraint ($;$) { ); } + 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; } @@ -263,6 +303,15 @@ sub class_type ($;$) { ); } +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); @@ -334,7 +383,7 @@ sub _create_type_constraint ($$$;$$) { 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__', @@ -797,11 +846,16 @@ This creates an unnamed subtype and will return the type constraint meta-object, which will be an instance of L. -=item B +=item B Creates a type constraint with the name C<$class> and the metaclass L. +=item B + +Creates a type constraint with the name C<$role> and the metaclass +L. + =item B This will create a basic subtype for a given set of strings. @@ -889,22 +943,44 @@ Given a C<$type_name> in the form of: this will extract the base type and container type and build an instance of L for it. -=item B +=item B Given a class name it will create a new L object for that class name. +=item B + +Given a role name it will create a new L +object for that role name. + =item B -=item B +=item B 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), then it will not create anything and simply -return. +container type an create one if appropriate + +=item B + +This function will first call C 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 and C parameters to L +and are now superseded by C and +C. + +=item B + +=item B + +Attempts to parse the type name using L and if +no appropriate constraint is found will create a new anonymous one. + +The C variant will use C and the C +variant will use C. =item B diff --git a/t/040_type_constraints/018_custom_parameterized_types.t b/t/040_type_constraints/018_custom_parameterized_types.t index 54de87d..2de911b 100644 --- a/t/040_type_constraints/018_custom_parameterized_types.t +++ b/t/040_type_constraints/018_custom_parameterized_types.t @@ -48,7 +48,7 @@ lives_ok { 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'); @@ -61,7 +61,7 @@ ok( !$hoi->equals(find_type_constraint('AlphaKeyHash')), "not equal to unparamet 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'); diff --git a/t/040_type_constraints/019_coerced_parameterized_types.t b/t/040_type_constraints/019_coerced_parameterized_types.t index 9010448..724b1c0 100644 --- a/t/040_type_constraints/019_coerced_parameterized_types.t +++ b/t/040_type_constraints/019_coerced_parameterized_types.t @@ -32,7 +32,7 @@ lives_ok { => 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)'); @@ -49,7 +49,7 @@ lives_ok { => 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)'); diff --git a/t/040_type_constraints/021_maybe_type_constraint.t b/t/040_type_constraints/021_maybe_type_constraint.t index 515610c..c4f62d7 100644 --- a/t/040_type_constraints/021_maybe_type_constraint.t +++ b/t/040_type_constraints/021_maybe_type_constraint.t @@ -11,7 +11,7 @@ BEGIN { 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'); @@ -21,7 +21,7 @@ ok( !$type->equals(find_type_constraint("Maybe")), "not equal to Maybe" ); 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)'); diff --git a/t/040_type_constraints/024_role_type_constraint.t b/t/040_type_constraints/024_role_type_constraint.t new file mode 100644 index 0000000..ee13ebe --- /dev/null +++ b/t/040_type_constraints/024_role_type_constraint.t @@ -0,0 +1,57 @@ +#!/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" ); +