From: Stevan Little Date: Sun, 19 Mar 2006 18:23:17 +0000 (+0000) Subject: type-coercion X-Git-Tag: 0_05~88 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4b598ea31ff4d1ec8f76f2f27cac8d56cbccc39f;p=gitmo%2FMoose.git type-coercion --- diff --git a/lib/Moose.pm b/lib/Moose.pm index b692b10..0d1068d 100644 --- a/lib/Moose.pm +++ b/lib/Moose.pm @@ -95,6 +95,12 @@ sub import { $options{type_constraint} = $constraint; } } + if (exists $options{coerce} && $options{coerce} && $options{isa}) { + my $coercion = Moose::Util::TypeConstraints::find_type_coercion($options{isa}); + (defined $coercion) + || confess "Cannot find coercion for type " . $options{isa}; + $options{coerce} = $coercion; + } $meta->add_attribute($name, %options) }); diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm index 5c4af2f..bd16e11 100644 --- a/lib/Moose/Meta/Attribute.pm +++ b/lib/Moose/Meta/Attribute.pm @@ -14,6 +14,13 @@ our $VERSION = '0.02'; use base 'Class::MOP::Attribute'; Moose::Meta::Attribute->meta->add_attribute( + Class::MOP::Attribute->new('coerce' => ( + reader => 'coerce', + predicate => 'has_coercion' + )) +); + +Moose::Meta::Attribute->meta->add_attribute( Class::MOP::Attribute->new('weak_ref' => ( reader => 'weak_ref', predicate => { @@ -31,6 +38,12 @@ Moose::Meta::Attribute->meta->add_attribute( Moose::Meta::Attribute->meta->add_before_method_modifier('new' => sub { my (undef, undef, %options) = @_; + if (exists $options{coerce} && $options{coerce}) { + (exists $options{type_constraint}) + || confess "You cannot have coercion without specifying a type constraint"; + confess "You cannot have a weak reference to a coerced value" + if $options{weak_ref}; + } (reftype($options{type_constraint}) && reftype($options{type_constraint}) eq 'CODE') || confess "Type cosntraint parameter must be a code-ref, not " . $options{type_constraint} if exists $options{type_constraint}; @@ -52,15 +65,29 @@ sub generate_accessor_method { }; } else { - return sub { - if (scalar(@_) == 2) { - (defined $self->type_constraint->($_[1])) - || confess "Attribute ($attr_name) does not pass the type contraint with '$_[1]'" - if defined $_[1]; - $_[0]->{$attr_name} = $_[1]; - } - $_[0]->{$attr_name}; - }; + if ($self->has_coercion) { + return sub { + if (scalar(@_) == 2) { + my $val = $self->coerce->($_[1]); + (defined $self->type_constraint->($val)) + || confess "Attribute ($attr_name) does not pass the type contraint with '$val'" + if defined $val; + $_[0]->{$attr_name} = $val; + } + $_[0]->{$attr_name}; + }; + } + else { + return sub { + if (scalar(@_) == 2) { + (defined $self->type_constraint->($_[1])) + || confess "Attribute ($attr_name) does not pass the type contraint with '$_[1]'" + if defined $_[1]; + $_[0]->{$attr_name} = $_[1]; + } + $_[0]->{$attr_name}; + }; + } } } else { @@ -155,6 +182,10 @@ extensions. =item B +=item B + +=item B + =back =head1 BUGS diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm index f21e348..f9fa401 100644 --- a/lib/Moose/Util/TypeConstraints.pm +++ b/lib/Moose/Util/TypeConstraints.pm @@ -15,7 +15,7 @@ sub import { my $pkg = shift || caller(); return if $pkg eq ':no_export'; no strict 'refs'; - foreach my $export (qw(type subtype coerce as where to)) { + foreach my $export (qw(type subtype as where to coerce)) { *{"${pkg}::${export}"} = \&{"${export}"}; } } @@ -32,6 +32,12 @@ sub import { $TYPES{$type_name} = $type_constraint; } + sub dump_type_constraints { + require Data::Dumper; + $Data::Dumper::Deparse = 1; + Data::Dumper::Dumper(\%TYPES); + } + sub export_type_contstraints_as_functions { my $pkg = caller(); no strict 'refs'; @@ -91,8 +97,10 @@ sub subtype ($$;$) { } } -sub coerce { +sub coerce ($@) { my ($type_name, @coercion_map) = @_; + #use Data::Dumper; + #warn Dumper \@coercion_map; my @coercions; while (@coercion_map) { my ($constraint_name, $action) = splice(@coercion_map, 0, 2); @@ -206,6 +214,8 @@ Suggestions for improvement are welcome. =item B +=item B + =back =head2 Type Constraint Constructors diff --git a/t/005_basic.t b/t/005_basic.t new file mode 100644 index 0000000..3695fac --- /dev/null +++ b/t/005_basic.t @@ -0,0 +1,73 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 10; +use Test::Exception; + +use Scalar::Util 'isweak'; + +BEGIN { + use_ok('Moose'); +} + +{ + package HTTPHeader; + use strict; + use warnings; + use Moose; + + has 'array' => (is => 'ro'); + has 'hash' => (is => 'ro'); + + package Engine; + use strict; + use warnings; + use Moose; + + coerce 'HTTPHeader' + => as ArrayRef + => to { HTTPHeader->new(array => $_[0]) } + => as HashRef + => to { HTTPHeader->new(hash => $_[0]) }; + + has 'header' => (is => 'rw', isa => 'HTTPHeader', coerce => 1); +} + +my $engine = Engine->new(); +isa_ok($engine, 'Engine'); + +# try with arrays + +$engine->header([ 1, 2, 3 ]); +isa_ok($engine->header, 'HTTPHeader'); + +is_deeply( + $engine->header->array, + [ 1, 2, 3 ], + '... got the right array value of the header'); +ok(!defined($engine->header->hash), '... no hash value set'); + +# try with hash + +$engine->header({ one => 1, two => 2, three => 3 }); +isa_ok($engine->header, 'HTTPHeader'); + +is_deeply( + $engine->header->hash, + { one => 1, two => 2, three => 3 }, + '... got the right hash value of the header'); +ok(!defined($engine->header->array), '... no array value set'); + +dies_ok { + $engine->header("Foo"); +} '... dies with the wrong type, even after coercion'; + +lives_ok { + $engine->header(HTTPHeader->new); +} '... lives with the right type, even after coercion'; + + + + diff --git a/t/053_util_find_type_constraint.t b/t/053_util_find_type_constraint.t index 242abf9..b3dc1e0 100644 --- a/t/053_util_find_type_constraint.t +++ b/t/053_util_find_type_constraint.t @@ -10,3 +10,4 @@ BEGIN { use_ok('Moose::Util::TypeConstraints', (':no_export')); } +#diag Moose::Util::TypeConstraints::dump_type_constraints(); \ No newline at end of file