From: Stevan Little Date: Mon, 20 Mar 2006 20:22:16 +0000 (+0000) Subject: up X-Git-Tag: 0_05~82 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=b841b2a3b00fe1aeac7b7973dd92db37686890f3;p=gitmo%2FMoose.git up --- diff --git a/Changes b/Changes index 7a3f770..fc8b0ca 100644 --- a/Changes +++ b/Changes @@ -2,16 +2,49 @@ Revision history for Perl extension Moose 0.02 * Moose - - many more tests, fixing some bugs/edge - and cases, general development work - - &extends now loads the base module with - UNIVERSAL::require - - added UNIVERSAL::require to the - dependencies list + - many more tests, fixing some bugs and + edge cases + + - &extends now loads the base module with + UNIVERSAL::require + - added UNIVERSAL::require to the + dependencies list + + # API CHANGES # + + - each new Moose class will also create + and register a subtype of Object which + correspond to the new Moose class. + + - the 'isa' option in &has now only + accepts strings, and will DWIM in + almost all cases + + * Moose::Util::TypeConstraints + - added type coercion features + - added tests for this + - added support for this in attributes + and instance construction + + # API CHANGES # + + - type construction no longer creates a + function, it registers the type instead. + - added several functions to get the + registered types + + * Moose::Meta::Attribute + - adding support for coercion in the + autogenerated accessors + + * Moose::Meta::Class + - adding support for coercion in the + instance construction * Moose::Object - - BUILDALL and DEMOLISHALL were broken - because of a mis-named hash key, Whoops :) + + - BUILDALL and DEMOLISHALL were broken + because of a mis-named hash key, Whoops :) 0.01 Wed. March 15, 2006 - Moooooooooooooooooose!!! \ No newline at end of file diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm index bd16e11..332af9e 100644 --- a/lib/Moose/Meta/Attribute.pm +++ b/lib/Moose/Meta/Attribute.pm @@ -122,12 +122,23 @@ sub generate_writer_method { }; } else { - return sub { - (defined $self->type_constraint->($_[1])) - || confess "Attribute ($attr_name) does not pass the type contraint with '$_[1]'" - if defined $_[1]; - $_[0]->{$attr_name} = $_[1]; - }; + if ($self->has_coercion) { + return sub { + 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; + }; + } + else { + return sub { + (defined $self->type_constraint->($_[1])) + || confess "Attribute ($attr_name) does not pass the type contraint with '$_[1]'" + if defined $_[1]; + $_[0]->{$attr_name} = $_[1]; + }; + } } } else { diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm index 362ad54..395a8dc 100644 --- a/lib/Moose/Util/TypeConstraints.pm +++ b/lib/Moose/Util/TypeConstraints.pm @@ -112,6 +112,7 @@ sub coerce ($@) { foreach my $coercion (@coercions) { my ($constraint, $converter) = @$coercion; if (defined $constraint->($thing)) { + local $_ = $thing; return $converter->($thing); } } diff --git a/t/004_basic.t b/t/004_basic.t index e5a9665..e9ac66d 100644 --- a/t/004_basic.t +++ b/t/004_basic.t @@ -12,7 +12,6 @@ BEGIN { } use Test::Exception; - use Scalar::Util 'isweak'; BEGIN { diff --git a/t/006_basic.t b/t/006_basic.t new file mode 100644 index 0000000..769fc52 --- /dev/null +++ b/t/006_basic.t @@ -0,0 +1,106 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; + +BEGIN { + eval "use HTTP::Headers; use Params::Coerce; use URI;"; + plan skip_all => "HTTP::Headers & Params::Coerce & URI required for this test" if $@; + plan no_plan => 1; +} + +use Test::Exception; + +BEGIN { + use_ok('Moose'); +} + +{ + package Request; + use strict; + use warnings; + use Moose; + + use HTTP::Headers (); + use Params::Coerce (); + use URI (); + + subtype Header + => as Object + => where { $_->isa('HTTP::Headers') }; + + coerce Header + => from ArrayRef + => via { HTTP::Headers->new( @{ $_ } ) } + => from HashRef + => via { HTTP::Headers->new( %{ $_ } ) }; + + subtype Uri + => as Object + => where { $_->isa('URI') }; + + coerce Uri + => from Object + => via { $_->isa('URI') ? $_ : Params::Coerce::coerce( 'URI', $_ ) } + => from Str + => via { URI->new( $_, 'http' ) }; + + subtype Protocol + => as Str + => where { /^HTTP\/[0-9]\.[0-9]$/ }; + + + has 'base' => (is => 'rw', isa => 'Uri', coerce => 1); + has 'url' => (is => 'rw', isa => 'Uri', coerce => 1); + has 'method' => (is => 'rw', isa => 'Str'); + has 'protocol' => (is => 'rw', isa => 'Protocol'); + has 'headers' => ( + is => 'rw', + isa => 'Header', + coerce => 1, + default => sub { HTTP::Headers->new } + ); +} + +my $r = Request->new; +isa_ok($r, 'Request'); + +{ + my $header = $r->headers; + isa_ok($header, 'HTTP::Headers'); + + is($r->headers->content_type, '', '... got no content type in the header'); + + $r->headers( { content_type => 'text/plain' } ); + + my $header2 = $r->headers; + isa_ok($header2, 'HTTP::Headers'); + isnt($header, $header2, '... created a new HTTP::Header object'); + + is($header2->content_type, 'text/plain', '... got the right content type in the header'); + + $r->headers( [ content_type => 'text/html' ] ); + + my $header3 = $r->headers; + isa_ok($header3, 'HTTP::Headers'); + isnt($header2, $header3, '... created a new HTTP::Header object'); + + is($header3->content_type, 'text/html', '... got the right content type in the header'); + + $r->headers( HTTP::Headers->new(content_type => 'application/pdf') ); + + my $header4 = $r->headers; + isa_ok($header4, 'HTTP::Headers'); + isnt($header3, $header4, '... created a new HTTP::Header object'); + + is($header4->content_type, 'application/pdf', '... got the right content type in the header'); + + dies_ok { + $r->headers('Foo') + } '... dies when it gets bad params'; +} + + +