From: Stevan Little Date: Tue, 21 Mar 2006 15:52:55 +0000 (+0000) Subject: type-coercion-meta-object X-Git-Tag: 0_05~72 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a27aa6009414ead1a0c1a00df0ce41c2cf9b632d;p=gitmo%2FMoose.git type-coercion-meta-object --- diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm index f0978e6..a2e9672 100644 --- a/lib/Moose/Meta/Attribute.pm +++ b/lib/Moose/Meta/Attribute.pm @@ -37,7 +37,7 @@ sub generate_accessor_method { if ($self->has_weak_ref) { return sub { if (scalar(@_) == 2) { - (defined $self->type_constraint->constraint_code->($_[1])) + (defined $self->type_constraint->check($_[1])) || confess "Attribute ($attr_name) does not pass the type contraint with '$_[1]'" if defined $_[1]; $_[0]->{$attr_name} = $_[1]; @@ -50,8 +50,8 @@ sub generate_accessor_method { if ($self->has_coercion) { return sub { if (scalar(@_) == 2) { - my $val = $self->type_constraint->coercion_code->($_[1]); - (defined $self->type_constraint->constraint_code->($val)) + my $val = $self->type_constraint->coercion->coerce($_[1]); + (defined $self->type_constraint->check($val)) || confess "Attribute ($attr_name) does not pass the type contraint with '$val'" if defined $val; $_[0]->{$attr_name} = $val; @@ -62,7 +62,7 @@ sub generate_accessor_method { else { return sub { if (scalar(@_) == 2) { - (defined $self->type_constraint->constraint_code->($_[1])) + (defined $self->type_constraint->check($_[1])) || confess "Attribute ($attr_name) does not pass the type contraint with '$_[1]'" if defined $_[1]; $_[0]->{$attr_name} = $_[1]; @@ -96,7 +96,7 @@ sub generate_writer_method { if ($self->has_type_constraint) { if ($self->has_weak_ref) { return sub { - (defined $self->type_constraint->constraint_code->($_[1])) + (defined $self->type_constraint->check($_[1])) || confess "Attribute ($attr_name) does not pass the type contraint with '$_[1]'" if defined $_[1]; $_[0]->{$attr_name} = $_[1]; @@ -106,8 +106,8 @@ sub generate_writer_method { else { if ($self->has_coercion) { return sub { - my $val = $self->type_constraint->coercion_code->($_[1]); - (defined $self->type_constraint->constraint_code->($val)) + my $val = $self->type_constraint->coercion->coerce($_[1]); + (defined $self->type_constraint->check($val)) || confess "Attribute ($attr_name) does not pass the type contraint with '$val'" if defined $val; $_[0]->{$attr_name} = $val; @@ -115,7 +115,7 @@ sub generate_writer_method { } else { return sub { - (defined $self->type_constraint->constraint_code->($_[1])) + (defined $self->type_constraint->check($_[1])) || confess "Attribute ($attr_name) does not pass the type contraint with '$_[1]'" if defined $_[1]; $_[0]->{$attr_name} = $_[1]; diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm index fcd4e7d..4daa68b 100644 --- a/lib/Moose/Meta/Class.pm +++ b/lib/Moose/Meta/Class.pm @@ -24,9 +24,9 @@ sub construct_instance { if (defined $val) { if ($attr->has_type_constraint) { if ($attr->has_coercion && $attr->type_constraint->has_coercion) { - $val = $attr->type_constraint->coercion_code->($val); + $val = $attr->type_constraint->coercion->coerce($val); } - (defined($attr->type_constraint->constraint_code->($val))) + (defined($attr->type_constraint->check($val))) || confess "Attribute (" . $attr->name . ") does not pass the type contraint with '$val'"; } } diff --git a/lib/Moose/Meta/TypeCoercion.pm b/lib/Moose/Meta/TypeCoercion.pm index 4decb47..1e9f470 100644 --- a/lib/Moose/Meta/TypeCoercion.pm +++ b/lib/Moose/Meta/TypeCoercion.pm @@ -7,8 +7,61 @@ use metaclass; use Carp 'confess'; +use Moose::Meta::Attribute; +use Moose::Util::TypeConstraints; + our $VERSION = '0.01'; +__PACKAGE__->meta->add_attribute('type_coercion_map' => ( + reader => 'type_coercion_map', + default => sub { [] } +)); +__PACKAGE__->meta->add_attribute( + Moose::Meta::Attribute->new('type_constraint' => ( + reader => 'type_constraint', + weak_ref => 1 + )) +); + +# private accessor +__PACKAGE__->meta->add_attribute('compiled_type_coercion' => ( + accessor => '_compiled_type_coercion' +)); + +sub new { + my $class = shift; + my $self = $class->meta->new_object(@_); + $self->compile_type_coercion(); + return $self; +} + +sub compile_type_coercion { + my $self = shift; + my @coercion_map = @{$self->type_coercion_map}; + my @coercions; + while (@coercion_map) { + my ($constraint_name, $action) = splice(@coercion_map, 0, 2); + my $constraint = Moose::Util::TypeConstraints::find_type_constraint($constraint_name)->_compiled_type_constraint; + (defined $constraint) + || confess "Could not find the type constraint ($constraint_name)"; + push @coercions => [ $constraint, $action ]; + } + $self->_compiled_type_coercion(sub { + my $thing = shift; + foreach my $coercion (@coercions) { + my ($constraint, $converter) = @$coercion; + if (defined $constraint->($thing)) { + local $_ = $thing; + return $converter->($thing); + } + } + return $thing; + }); +} + +sub coerce { $_[0]->_compiled_type_coercion->($_[1]) } + + 1; __END__ @@ -29,6 +82,16 @@ Moose::Meta::TypeCoercion - The Moose Type Coercion metaobject =item B +=item B + +=item B + +=item B + +=item B + +=item B + =back =head1 BUGS diff --git a/lib/Moose/Meta/TypeConstraint.pm b/lib/Moose/Meta/TypeConstraint.pm index bb16b01..4c1205c 100644 --- a/lib/Moose/Meta/TypeConstraint.pm +++ b/lib/Moose/Meta/TypeConstraint.pm @@ -13,32 +13,31 @@ our $VERSION = '0.01'; __PACKAGE__->meta->add_attribute('name' => (reader => 'name' )); __PACKAGE__->meta->add_attribute('parent' => (reader => 'parent' )); __PACKAGE__->meta->add_attribute('constraint' => (reader => 'constraint')); +__PACKAGE__->meta->add_attribute('coercion' => ( + accessor => 'coercion', + predicate => 'has_coercion' +)); # 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(@_); + 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; + 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) { + # we have a subtype ... $parent = $parent->_compiled_type_constraint; $self->_compiled_type_constraint(subname $self->name => sub { local $_ = $_[0]; @@ -47,6 +46,7 @@ sub compile_type_constraint () { }); } else { + # we have a type .... $self->_compiled_type_constraint(subname $self->name => sub { local $_ = $_[0]; return undef unless $check->($_[0]); @@ -55,8 +55,7 @@ sub compile_type_constraint () { } } -# backwards for now -sub constraint_code { (shift)->_compiled_type_constraint } +sub check { $_[0]->_compiled_type_constraint->($_[1]) } 1; @@ -88,16 +87,10 @@ Moose::Meta::TypeConstraint - The Moose Type Constraint metaobject =item B -=item B - -=item B - -=item B - -=item B - =item B +=item B + =item B =back diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm index 06390c3..8963ad2 100644 --- a/lib/Moose/Util/TypeConstraints.pm +++ b/lib/Moose/Util/TypeConstraints.pm @@ -28,35 +28,37 @@ sub import { sub find_type_constraint { $TYPES{$_[0]} } sub create_type_constraint { - my ($name, $parent, $constraint) = @_; - (not exists $TYPES{$name}) - || confess "The type constraint '$name' has already been created"; + my ($name, $parent, $check) = @_; + (!exists $TYPES{$name}) + || confess "The type constraint '$name' has already been created" + if defined $name; $parent = find_type_constraint($parent) if defined $parent; - $TYPES{$name} = Moose::Meta::TypeConstraint->new( - name => $name, + my $constraint = Moose::Meta::TypeConstraint->new( + name => $name || '__ANON__', parent => $parent, - constraint => $constraint, + constraint => $check, ); + $TYPES{$name} = $constraint if defined $name; + return $constraint; } - sub find_type_coercion { - my $type_name = shift; - $TYPES{$type_name}->coercion_code; - } - - sub register_type_coercion { - my ($type_name, $type_coercion) = @_; - my $type = $TYPES{$type_name}; + sub install_type_coercions { + my ($type_name, $coercion_map) = @_; + my $type = find_type_constraint($type_name); (!$type->has_coercion) || confess "The type coercion for '$type_name' has already been registered"; - $type->set_coercion_code($type_coercion); + my $type_coercion = Moose::Meta::TypeCoercion->new( + type_coercion_map => $coercion_map, + type_constraint => $type + ); + $type->coercion($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; + *{"${pkg}::${constraint}"} = $TYPES{$constraint}->_compiled_type_constraint; } } } @@ -68,42 +70,13 @@ sub type ($$) { } sub subtype ($$;$) { - if (scalar @_ == 3) { - my ($name, $parent, $check) = @_; - create_type_constraint($name, $parent, $check); - } - else { - my ($parent, $check) = @_; - $parent = find_type_constraint($parent); - return Moose::Meta::TypeConstraint->new( - name => '__ANON__', - parent => $parent, - constraint => $check, - ); - } + unshift @_ => undef if scalar @_ == 2; + create_type_constraint(@_); } sub coerce ($@) { my ($type_name, @coercion_map) = @_; - my @coercions; - while (@coercion_map) { - my ($constraint_name, $action) = splice(@coercion_map, 0, 2); - my $constraint = find_type_constraint($constraint_name)->constraint_code; - (defined $constraint) - || confess "Could not find the type constraint ($constraint_name)"; - push @coercions => [ $constraint, $action ]; - } - register_type_coercion($type_name, sub { - my $thing = shift; - foreach my $coercion (@coercions) { - my ($constraint, $converter) = @$coercion; - if (defined $constraint->($thing)) { - local $_ = $thing; - return $converter->($thing); - } - } - return $thing; - }); + install_type_coercions($type_name, \@coercion_map); } sub as ($) { $_[0] } @@ -194,14 +167,10 @@ Suggestions for improvement are welcome. =item B -=item B - -=item B +=item B =item B -=item B - =back =head2 Type Constraint Constructors diff --git a/t/050_util_type_constraints.t b/t/050_util_type_constraints.t index e0ce780..67c28f7 100644 --- a/t/050_util_type_constraints.t +++ b/t/050_util_type_constraints.t @@ -46,6 +46,9 @@ my $negative = subtype Num => where { $_ < 0 }; ok(defined $negative, '... got a value back from negative'); isa_ok($negative, 'Moose::Meta::TypeConstraint'); -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'); +is($negative->check(-5), -5, '... this is a negative number'); +ok(!defined($negative->check(5)), '... this is not a negative number'); +is($negative->check('Foo'), undef, '... this is not a negative number'); + + + diff --git a/t/054_util_type_coercion.t b/t/054_util_type_coercion.t index 83bd546..7ac47be 100644 --- a/t/054_util_type_coercion.t +++ b/t/054_util_type_coercion.t @@ -39,11 +39,11 @@ ok(Header($header), '... this passed the type test'); ok(!Header([]), '... this did not pass the type test'); ok(!Header({}), '... this did not pass the type test'); -my $coercion = Moose::Util::TypeConstraints::find_type_coercion('Header'); -is(ref($coercion), 'CODE', '... got the right type of coercion'); +my $coercion = Moose::Util::TypeConstraints::find_type_constraint('Header')->coercion; +isa_ok($coercion, 'Moose::Meta::TypeCoercion'); { - my $coerced = $coercion->([ 1, 2, 3 ]); + my $coerced = $coercion->coerce([ 1, 2, 3 ]); isa_ok($coerced, 'HTTPHeader'); is_deeply( @@ -54,7 +54,7 @@ is(ref($coercion), 'CODE', '... got the right type of coercion'); } { - my $coerced = $coercion->({ one => 1, two => 2, three => 3 }); + my $coerced = $coercion->coerce({ one => 1, two => 2, three => 3 }); isa_ok($coerced, 'HTTPHeader'); is_deeply( @@ -66,12 +66,12 @@ is(ref($coercion), 'CODE', '... got the right type of coercion'); { my $scalar_ref = \(my $var); - my $coerced = $coercion->($scalar_ref); + my $coerced = $coercion->coerce($scalar_ref); is($coerced, $scalar_ref, '... got back what we put in'); } { - my $coerced = $coercion->("Foo"); + my $coerced = $coercion->coerce("Foo"); is($coerced, "Foo", '... got back what we put in'); }