From: Yuval Kogman Date: Sun, 13 Jan 2008 15:16:01 +0000 (+0000) Subject: Moose::Meta::TypeConstraint::Class X-Git-Tag: 0_35~22^2 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=3fef8ce8cbb223d6edec5f444a51a5af6c82ab69;p=gitmo%2FMoose.git Moose::Meta::TypeConstraint::Class --- diff --git a/lib/Moose.pm b/lib/Moose.pm index bc9c0fb..8b6f610 100644 --- a/lib/Moose.pm +++ b/lib/Moose.pm @@ -17,6 +17,7 @@ use Class::MOP 0.49; 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; @@ -39,9 +40,8 @@ use Moose::Util::TypeConstraints; unless $metaclass->isa('Moose::Meta::Class'); # make a subtype for each Moose class - subtype $class => as 'Object' => where { $_->isa($class) } => - optimize_as { blessed( $_[0] ) && $_[0]->isa($class) } - unless find_type_constraint($class); + class_type($class) + unless find_type_constraint($class); my $meta; if ( $class->can('meta') ) { diff --git a/lib/Moose/Meta/TypeConstraint/Class.pm b/lib/Moose/Meta/TypeConstraint/Class.pm new file mode 100644 index 0000000..5569cc5 --- /dev/null +++ b/lib/Moose/Meta/TypeConstraint/Class.pm @@ -0,0 +1,79 @@ +package Moose::Meta::TypeConstraint::Class; + +use strict; +use warnings; +use metaclass; + +use Scalar::Util qw(blessed); + +use base 'Moose::Meta::TypeConstraint'; + +use Moose::Util::TypeConstraints (); + +sub new { + my $class = shift; + my $self = $class->meta->new_object(@_, parent => Moose::Util::TypeConstraints::find_type_constraint('Object') ); + $self->compile_type_constraint() + unless $self->_has_compiled_type_constraint; + return $self; +} + +sub parents { + my $self = shift; + return ( + $self->parent, + map { Moose::Util::TypeConstraints::find_type_constraint($_) } $self->name->meta->superclasses, + ); +} + +sub hand_optimized_type_constraint { + my $self = shift; + my $class = $self->name; + sub { blessed( $_[0] ) && $_[0]->isa($class) } +} + +sub has_hand_optimized_type_constraint { 1 } + +sub is_a_type_of { + my ($self, $type_name) = @_; + + return $self->name eq $type_name || $self->is_subtype_of($type_name); +} + +sub is_subtype_of { + my ($self, $type_name) = @_; + + return 1 if $type_name eq 'Object'; + return $self->name->isa( $type_name ); +} + +1; + +__END__ +=pod + +=head1 NAME + +Moose::Meta::TypeConstraint::Class - Class/TypeConstraint parallel hierarchy + +=head1 METHODS + +=over 4 + +=item new + +=item hand_optimized_type_constraint + +=item has_hand_optimized_type_constraint + +=item is_a_type_of + +=item is_subtype_of + +=item parents + +Return all the parent types, corresponding to the parent classes. + +=back + +=cut diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm index a040755..5af8dc5 100644 --- a/lib/Moose/Util/TypeConstraints.pm +++ b/lib/Moose/Util/TypeConstraints.pm @@ -20,13 +20,16 @@ our $AUTHORITY = 'cpan:STEVAN'; # creation and location sub find_type_constraint ($); +sub register_type_constraint ($); sub find_or_create_type_constraint ($;$); sub create_type_constraint_union (@); sub create_parameterized_type_constraint ($); +sub create_class_type_constraint ($); # dah sugah! sub type ($$;$$); sub subtype ($$;$$$); +sub class_type ($); sub coerce ($@); sub as ($); sub from ($); @@ -51,10 +54,11 @@ use Moose::Meta::TypeConstraint::Registry; use Moose::Util::TypeConstraints::OptimizedConstraints; my @exports = qw/ - type subtype as where message optimize_as + type subtype class_type as where message optimize_as coerce from via enum find_type_constraint + register_type_constraint /; Sub::Exporter::setup_exporter({ @@ -148,6 +152,16 @@ sub create_parameterized_type_constraint ($) { ); } +sub create_class_type_constraint ($) { + my $class = shift; + + # 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"; + + Moose::Meta::TypeConstraint::Class->new( name => $class ); +} + sub find_or_create_type_constraint ($;$) { my ($type_constraint_name, $options_for_anon_type) = @_; @@ -192,6 +206,12 @@ sub find_or_create_type_constraint ($;$) { sub find_type_constraint ($) { $REGISTRY->get_type_constraint(@_) } +sub register_type_constraint ($) { + my $constraint = shift; + confess "can't register an unnamed type constraint" unless defined $constraint->name; + $REGISTRY->add_type_constraint($constraint); +} + # type constructors sub type ($$;$$) { @@ -213,6 +233,10 @@ sub subtype ($$;$$$) { goto &_create_type_constraint; } +sub class_type ($) { + register_type_constraint( create_class_type_constraint(shift) ); +} + sub coerce ($@) { my ($type_name, @coercion_map) = @_; _install_type_coercions($type_name, \@coercion_map); @@ -638,6 +662,11 @@ 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 + +Given a class name it will create a new L +object for that class name. + =item B This will attempt to find or create a type constraint given the a C<$type_name>. @@ -654,6 +683,10 @@ This function can be used to locate a specific type constraint meta-object, of the class L or a derivative. What you do with it from there is up to you :) +=item B + +This function will register a named type constraint with the type registry. + =item B Fetch the L object which @@ -703,6 +736,11 @@ This creates an unnamed subtype and will return the type constraint meta-object, which will be an instance of L. +=item B + +Creates a type constraint with the name C<$class> and the metaclass +L. + =item B This will create a basic subtype for a given set of strings. diff --git a/t/040_type_constraints/020_class_type_constraint.t b/t/040_type_constraints/020_class_type_constraint.t new file mode 100644 index 0000000..f565e23 --- /dev/null +++ b/t/040_type_constraints/020_class_type_constraint.t @@ -0,0 +1,36 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More 'no_plan'; + +BEGIN { + use_ok('Moose::Util::TypeConstraints'); +} + +{ + package Gorch; + use Moose; + + package Bar; + use Moose; + + package Foo; + use Moose; + + extends qw(Bar Gorch); +} + +my $type = find_type_constraint("Foo"); + +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"); +