From: Stevan Little Date: Tue, 21 Mar 2006 01:51:18 +0000 (+0000) Subject: it-works X-Git-Tag: 0_05~76 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=66811d632060009cb379ccc57d1a1372f5ef4623;p=gitmo%2FMoose.git it-works --- diff --git a/lib/Moose.pm b/lib/Moose.pm index 6f972bc..a8a9a56 100644 --- a/lib/Moose.pm +++ b/lib/Moose.pm @@ -76,11 +76,8 @@ sub import { } if (exists $options{isa}) { # allow for anon-subtypes here ... - if (reftype($options{isa}) && reftype($options{isa}) eq 'CODE') { - $options{type_constraint} = Moose::Meta::TypeConstraint->new( - name => '__ANON__', - constraint_code => $options{isa} - ); + if (blessed($options{isa}) && $options{isa}->isa('Moose::Meta::TypeConstraint')) { + $options{type_constraint} = $options{isa}; } else { # otherwise assume it is a constraint @@ -89,10 +86,7 @@ sub import { unless (defined $constraint) { # assume it is a foreign class, and make # an anon constraint for it - $constraint = Moose::Meta::TypeConstraint->new( - name => '__ANON__', - constraint_code => subtype Object => where { $_->isa($constraint) } - ); + $constraint = subtype Object => where { $_->isa($options{isa}) }; } $options{type_constraint} = $constraint; } diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm index 014dc7b..fcd4e7d 100644 --- a/lib/Moose/Meta/Class.pm +++ b/lib/Moose/Meta/Class.pm @@ -27,7 +27,7 @@ sub construct_instance { $val = $attr->type_constraint->coercion_code->($val); } (defined($attr->type_constraint->constraint_code->($val))) - || confess "Attribute (" . $attr->name . ") does not pass the type contraint with"; + || confess "Attribute (" . $attr->name . ") does not pass the type contraint with '$val'"; } } $instance->{$attr->name} = $val; diff --git a/lib/Moose/Meta/TypeConstraint.pm b/lib/Moose/Meta/TypeConstraint.pm index 651b1bf..b18e498 100644 --- a/lib/Moose/Meta/TypeConstraint.pm +++ b/lib/Moose/Meta/TypeConstraint.pm @@ -5,27 +5,60 @@ use strict; use warnings; use metaclass; -Moose::Meta::TypeConstraint->meta->add_attribute( - Class::MOP::Attribute->new('name' => ( - reader => 'name' - )) -); - -Moose::Meta::TypeConstraint->meta->add_attribute( - Class::MOP::Attribute->new('constraint_code' => ( - reader => 'constraint_code' - )) -); - -Moose::Meta::TypeConstraint->meta->add_attribute( - Class::MOP::Attribute->new('coercion_code' => ( - reader => 'coercion_code', - writer => 'set_coercion_code', - predicate => 'has_coercion' - )) -); - -sub new { return (shift)->meta->new_object(@_) } +use Sub::Name 'subname'; +use Carp 'confess'; + +our $VERSION = '0.01'; + +my %TYPE_CONSTRAINT_REGISTRY; + +__PACKAGE__->meta->add_attribute('name' => (reader => 'name' )); +__PACKAGE__->meta->add_attribute('parent' => (reader => 'parent' )); +__PACKAGE__->meta->add_attribute('constraint' => (reader => 'constraint')); + +# private accessor +__PACKAGE__->meta->add_attribute('compiled_type_constraint' => ( + accessor => '_compiled_type_constraint' +)); + +__PACKAGE__->meta->add_attribute('coercion_code' => ( + reader => 'coercion_code', + writer => 'set_coercion_code', + predicate => 'has_coercion' +)); + +sub new { + my $class = shift; + my $self = $class->meta->new_object(@_); + $self->compile_type_constraint(); + return $self; +} + +sub compile_type_constraint () { + my $self = shift; + my $check = $self->constraint; + (defined $check) + || confess "Could not compile type constraint '" . $self->name . "' because no constraint check"; + my $parent = $self->parent; + if (defined $parent) { + $parent = $parent->_compiled_type_constraint; + $self->_compiled_type_constraint(subname $self->name => sub { + local $_ = $_[0]; + return undef unless defined $parent->($_[0]) && $check->($_[0]); + $_[0]; + }); + } + else { + $self->_compiled_type_constraint(subname $self->name => sub { + local $_ = $_[0]; + return undef unless $check->($_[0]); + $_[0]; + }); + } +} + +# backwards for now +sub constraint_code { (shift)->_compiled_type_constraint } 1; @@ -51,8 +84,12 @@ Moose::Meta::TypeConstraint - The Moose Type Constraint metaobject =item B +=item B + =item B +=item B + =item B =item B @@ -63,6 +100,8 @@ Moose::Meta::TypeConstraint - The Moose Type Constraint metaobject =item B +=item B + =back =head1 BUGS diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm index e32da46..cf99b1d 100644 --- a/lib/Moose/Util/TypeConstraints.pm +++ b/lib/Moose/Util/TypeConstraints.pm @@ -30,22 +30,16 @@ sub import { } sub register_type_constraint { - my ($type_name, $type_constraint) = @_; - (not exists $TYPES{$type_name}) - || confess "The type constraint '$type_name' has already been registered"; - $TYPES{$type_name} = Moose::Meta::TypeConstraint->new( - name => $type_name, - constraint_code => $type_constraint + my ($name, $parent, $constraint) = @_; + (not exists $TYPES{$name}) + || confess "The type constraint '$name' has already been registered"; + $parent = find_type_constraint($parent) if defined $parent; + $TYPES{$name} = Moose::Meta::TypeConstraint->new( + name => $name, + parent => $parent, + constraint => $constraint, ); } - - sub export_type_contstraints_as_functions { - my $pkg = caller(); - no strict 'refs'; - foreach my $constraint (keys %TYPES) { - *{"${pkg}::${constraint}"} = $TYPES{$constraint}->constraint_code; - } - } sub find_type_coercion { my $type_name = shift; @@ -59,47 +53,40 @@ sub import { || confess "The type coercion for '$type_name' has already been registered"; $type->set_coercion_code($type_coercion); } + + sub export_type_contstraints_as_functions { + my $pkg = caller(); + no strict 'refs'; + foreach my $constraint (keys %TYPES) { + *{"${pkg}::${constraint}"} = $TYPES{$constraint}->constraint_code; + } + } } sub type ($$) { my ($name, $check) = @_; - my $full_name = caller() . "::${name}"; - register_type_constraint($name => subname $full_name => sub { - local $_ = $_[0]; - return undef unless $check->($_[0]); - $_[0]; - }); + register_type_constraint($name, undef, $check); } sub subtype ($$;$) { - my ($name, $parent, $check) = @_; - if (defined $check) { - my $full_name = caller() . "::${name}"; - $parent = find_type_constraint($parent)->constraint_code - unless $parent && ref($parent) eq 'CODE'; - register_type_constraint($name => subname $full_name => sub { - local $_ = $_[0]; - return undef unless defined $parent->($_[0]) && $check->($_[0]); - $_[0]; - }); + if (scalar @_ == 3) { + my ($name, $parent, $check) = @_; + register_type_constraint($name, $parent, $check); } else { - ($parent, $check) = ($name, $parent); - $parent = find_type_constraint($parent)->constraint_code - unless $parent && ref($parent) eq 'CODE'; - return subname '__anon_subtype__' => sub { - local $_ = $_[0]; - return undef unless defined $parent->($_[0]) && $check->($_[0]); - $_[0]; - }; + my ($parent, $check) = @_; + $parent = find_type_constraint($parent); + return Moose::Meta::TypeConstraint->new( + name => '__ANON__', + parent => $parent, + constraint => $check, + ); } } sub coerce ($@) { - my ($type_name, @coercion_map) = @_; - #use Data::Dumper; - #warn Dumper \@coercion_map; + my ($type_name, @coercion_map) = @_; my @coercions; while (@coercion_map) { my ($constraint_name, $action) = splice(@coercion_map, 0, 2); diff --git a/t/050_util_type_constraints.t b/t/050_util_type_constraints.t index 5f41558..e0ce780 100644 --- a/t/050_util_type_constraints.t +++ b/t/050_util_type_constraints.t @@ -44,8 +44,8 @@ is(NaturalLessThanTen('Foo'), undef, '... this is not a NaturalLessThanTen'); my $negative = subtype Num => where { $_ < 0 }; ok(defined $negative, '... got a value back from negative'); -is(ref($negative), 'CODE', '... got a type constraint back from negative'); +isa_ok($negative, 'Moose::Meta::TypeConstraint'); -is($negative->(-5), -5, '... this is a negative number'); -ok(!defined($negative->(5)), '... this is not a negative number'); -is($negative->('Foo'), undef, '... this is not a negative number'); +is($negative->_compiled_type_constraint->(-5), -5, '... this is a negative number'); +ok(!defined($negative->_compiled_type_constraint->(5)), '... this is not a negative number'); +is($negative->_compiled_type_constraint->('Foo'), undef, '... this is not a negative number');