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;
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') ) {
--- /dev/null
+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
# 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 ($);
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({
);
}
+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) = @_;
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 ($$;$$) {
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);
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)>
+
+Given a class name it will create a new L<Moose::Meta::TypeConstraint::Class>
+object for that class name.
+
=item B<find_or_create_type_constraint ($type_name, ?$options_for_anon_type)>
This will attempt to find or create a type constraint given the a C<$type_name>.
meta-object, of the class L<Moose::Meta::TypeConstraint> or a
derivative. What you do with it from there is up to you :)
+=item B<register_type_constraint ($type_object)>
+
+This function will register a named type constraint with the type registry.
+
=item B<get_type_constraint_registry>
Fetch the L<Moose::Meta::TypeConstraint::Registry> object which
constraint meta-object, which will be an instance of
L<Moose::Meta::TypeConstraint>.
+=item B<class_type ($class)>
+
+Creates a type constraint with the name C<$class> and the metaclass
+L<Moose::Meta::TypeConstraint::Class>.
+
=item B<enum ($name, @values)>
This will create a basic subtype for a given set of strings.
--- /dev/null
+#!/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");
+
projects / gitmo/Moose.git / commitdiff