From: Stevan Little Date: Sun, 24 Sep 2006 00:50:13 +0000 (+0000) Subject: foo X-Git-Tag: 0_14~6 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=94b8bbb863f819137b85ea47790bef144d6fc3cc;p=gitmo%2FMoose.git foo --- diff --git a/Changes b/Changes index 31a5682..916bc50 100644 --- a/Changes +++ b/Changes @@ -25,6 +25,10 @@ Revision history for Perl extension Moose * Moose::Meta::Attribute - if your attribute 'isa' ArrayRef of HashRef, and you have not explicitly set a default, then make the default DWIM. + This will also work for subtypes of ArrayRef and HashRef + as well. + - you can now auto-deref subtypes of ArrayRef or HashRef too. + - new test added for this (thanks to ashley) * Moose::Meta::Role - added basic support for runtime role composition diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm index 2c5e01c..8b49cd5 100644 --- a/lib/Moose/Meta/Attribute.pm +++ b/lib/Moose/Meta/Attribute.pm @@ -170,11 +170,14 @@ sub _process_options { if (exists $options->{auto_deref} && $options->{auto_deref}) { (exists $options->{type_constraint}) || confess "You cannot auto-dereference without specifying a type constraint"; - ($options->{type_constraint}->name =~ /^ArrayRef|HashRef$/) + ($options->{type_constraint}->is_a_type_of('ArrayRef') || + $options->{type_constraint}->is_a_type_of('HashRef')) || confess "You cannot auto-dereference anything other than a ArrayRef or HashRef"; } - if (exists $options->{type_constraint} && $options->{type_constraint}->name =~ /^ArrayRef|HashRef$/) { + if (exists $options->{type_constraint} && + ($options->{type_constraint}->is_a_type_of('ArrayRef') || + $options->{type_constraint}->is_a_type_of('HashRef') )) { unless (exists $options->{default}) { $options->{default} = sub { [] } if $options->{type_constraint}->name eq 'ArrayRef'; $options->{default} = sub { {} } if $options->{type_constraint}->name eq 'HashRef'; @@ -296,17 +299,17 @@ sub _inline_auto_deref { return $ref_value unless $self->should_auto_deref; - my $type = $self->type_constraint->name; + my $type_constraint = $self->type_constraint; my $sigil; - if ($type eq "ArrayRef") { + if ($type_constraint->is_a_type_of('ArrayRef')) { $sigil = '@'; } - elsif ($type eq 'HashRef') { + elsif ($type_constraint->is_a_type_of('HashRef')) { $sigil = '%'; } else { - confess "Can not auto de-reference the type constraint '$type'"; + confess "Can not auto de-reference the type constraint '" . $type_constraint->name . "'"; } "(wantarray() ? $sigil\{ ( $ref_value ) || return } : ( $ref_value ) )"; diff --git a/lib/Moose/Meta/TypeConstraint.pm b/lib/Moose/Meta/TypeConstraint.pm index 1ae35e2..e4dc9bb 100644 --- a/lib/Moose/Meta/TypeConstraint.pm +++ b/lib/Moose/Meta/TypeConstraint.pm @@ -163,6 +163,22 @@ sub validate { return ($message . ' in (' . $self->name . ')') ; } +sub is_a_type_of { + my ($self, $type_name) = @_; + foreach my $type (@{$self->type_constraints}) { + return 1 if $type->is_a_type_of($type_name); + } + return 0; +} + +sub is_subtype_of { + my ($self, $type_name) = @_; + foreach my $type (@{$self->type_constraints}) { + return 1 if $type->is_subtype_of($type_name); + } + return 0; +} + 1; __END__ diff --git a/t/040_meta_role.t b/t/040_meta_role.t index 181a604..c13b336 100644 --- a/t/040_meta_role.t +++ b/t/040_meta_role.t @@ -3,10 +3,11 @@ use strict; use warnings; -use Test::More tests => 28; +use Test::More tests => 29; use Test::Exception; BEGIN { + use_ok('Moose'); use_ok('Moose::Meta::Role'); } diff --git a/t/052_util_std_type_constraints.t b/t/052_util_std_type_constraints.t index acd2ab1..19e7da9 100644 --- a/t/052_util_std_type_constraints.t +++ b/t/052_util_std_type_constraints.t @@ -13,6 +13,8 @@ BEGIN { } my $SCALAR_REF = \(my $var); + +no warnings 'once'; # << I *hates* that warning ... my $GLOB_REF = \*GLOB_REF; Moose::Util::TypeConstraints->export_type_contstraints_as_functions(); diff --git a/t/058_union_types_and_coercions.t b/t/058_union_types_and_coercions.t new file mode 100644 index 0000000..2707454 --- /dev/null +++ b/t/058_union_types_and_coercions.t @@ -0,0 +1,90 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 1; +use Test::Exception; + +BEGIN { + use_ok('Moose'); +} + +__END__ + +package Email::Moose; + +use warnings; +use strict; + +use Moose; +use Moose::Util::TypeConstraints; + +use IO::String; + +=head1 NAME + +Email::Moose - Email::Simple on Moose steroids + +=head1 VERSION + +Version 0.01 + +=cut + +our $VERSION = '0.01'; + +=head1 SYNOPSIS + +=head1 METHODS + +=head2 raw_body + +=cut + +subtype q{IO::String} + => as q{Object} + => where { $_->isa(q{IO::String}) }; + +coerce q{IO::String} + => from q{Str} + => via { IO::String->new($_) }, + => from q{ScalarRef}, + => via { IO::String->new($_) }; + +type q{FileHandle} + => where { Scalar::Util::openhandle($_) }; + +subtype q{IO::File} + => as q{Object} + => where { $_->isa(q{IO::File}) }; + +coerce q{IO::File} + => from q{FileHandle} + => via { bless $_, q{IO::File} }; + +subtype q{IO::Socket} + => as q{Object} + => where { $_->isa(q{IO::Socket}) }; + +coerce q{IO::Socket} + => from q{CodeRef} # no test sample yet + => via { IO::Socket->new($_) }; +=cut + +has q{raw_body} => ( + is => q{rw}, + isa => q{IO::String | IO::File | IO::Socket}, + coerce => 1, + default => sub { IO::String->new() }, +); + +=head2 as_string + +=cut + +sub as_string { + my ($self) = @_; + my $fh = $self->raw_body(); + return do { local $/; <$fh> }; +} \ No newline at end of file diff --git a/t/071_misc_attribute_tests.t b/t/071_misc_attribute_tests.t new file mode 100644 index 0000000..eb22962 --- /dev/null +++ b/t/071_misc_attribute_tests.t @@ -0,0 +1,37 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 7; +use Test::Exception; + +BEGIN { + use_ok('Moose'); +} + +## Roles + +{ + package Test::TheDefaultFor::ArrayRef::and::HashRef; + use Moose; + + has 'array_ref' => (is => 'rw', isa => 'ArrayRef'); + has 'hash_ref' => (is => 'rw', isa => 'HashRef'); + +} + +my $test = Test::TheDefaultFor::ArrayRef::and::HashRef->new; +isa_ok($test, 'Test::TheDefaultFor::ArrayRef::and::HashRef'); + +is_deeply($test->array_ref, [], '.... got the right default value'); +is_deeply($test->hash_ref, {}, '.... got the right default value'); + +my $test2 = Test::TheDefaultFor::ArrayRef::and::HashRef->new( + array_ref => [ 1, 2, [] ], + hash_ref => { one => 1, two => 2, three => {} }, +); +isa_ok($test2, 'Test::TheDefaultFor::ArrayRef::and::HashRef'); + +is_deeply($test2->array_ref, [ 1, 2, [] ], '.... got the right default value'); +is_deeply($test2->hash_ref, { one => 1, two => 2, three => {} }, '.... got the right default value'); \ No newline at end of file diff --git a/t/072_attr_dereference_test.t b/t/072_attr_dereference_test.t new file mode 100644 index 0000000..bc11931 --- /dev/null +++ b/t/072_attr_dereference_test.t @@ -0,0 +1,58 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 9; +use Test::Exception; + +BEGIN { + use_ok('Moose'); +} + +{ + package Customer; + use Moose; + + package Firm; + use Moose; + use Moose::Util::TypeConstraints; + + ::lives_ok { + has 'customers' => ( + is => 'ro', + isa => subtype('ArrayRef' => where { + (blessed($_) && $_->isa('Customer') || return) for @$_; 1 }), + auto_deref => 1, + ); + } '... successfully created attr'; +} + +{ + my $customer = Customer->new; + isa_ok($customer, 'Customer'); + + my $firm = Firm->new(customers => [ $customer ]); + isa_ok($firm, 'Firm'); + + can_ok($firm, 'customers'); + + is_deeply( + [ $firm->customers ], + [ $customer ], + '... got the right dereferenced value' + ); +} + +{ + my $firm = Firm->new(); + isa_ok($firm, 'Firm'); + + can_ok($firm, 'customers'); + + is_deeply( + [ $firm->customers ], + [], + '... got the right dereferenced value' + ); +} \ No newline at end of file