From: Stevan Little Date: Fri, 21 Apr 2006 20:53:29 +0000 (+0000) Subject: uploadin X-Git-Tag: 0_05~10 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c07af9d225d67b36f962c2dc3aa7ac66b823541a;p=gitmo%2FMoose.git uploadin --- diff --git a/Changes b/Changes index 278eadc..f953c4e 100644 --- a/Changes +++ b/Changes @@ -7,18 +7,15 @@ Revision history for Perl extension Moose - has keyword now takes a 'metaclass' option to support custom attribute meta-classes on a per-attribute basis - - Moose now enforces that your attribute - metaclasses are always derived from - Moose::Meta::Attribute - added tests for this * Moose::Role - keywords are now exported with Sub::Exporter * Moose::Utils::TypeConstraints - - added Bool type and CollectionRef type - then made ArrayRef and HashRef into subtypes - of the CollectionRef + - added several more types and restructured + the hierarchy somewhat + - added tests for this - keywords are now exported with Sub::Exporter thanks chansen for this commit @@ -29,6 +26,10 @@ Revision history for Perl extension Moose * Moose::Meta::Attribute - due to changes in Class::MOP, we had to add the initialize_instance_slot method (it's a good thing) + + * Moose::Meta::TypeConstraints + - added type constraint unions + - added tests for this 0.04 Sun. April 16th, 2006 * Moose::Role diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm index 7f1d925..fec33d7 100644 --- a/lib/Moose/Meta/Attribute.pm +++ b/lib/Moose/Meta/Attribute.pm @@ -60,18 +60,27 @@ sub new { $options{type_constraint} = $options{isa}; } else { - # otherwise assume it is a constraint - my $constraint = Moose::Util::TypeConstraints::find_type_constraint($options{isa}); - # if the constraing it not found .... - unless (defined $constraint) { - # assume it is a foreign class, and make - # an anon constraint for it - $constraint = Moose::Util::TypeConstraints::subtype( - 'Object', - Moose::Util::TypeConstraints::where { $_->isa($options{isa}) } + + if ($options{isa} =~ /\|/) { + my @type_constraints = split /\s*\|\s*/ => $options{isa}; + $options{type_constraint} = Moose::Util::TypeConstraints::create_type_constraint_union( + @type_constraints ); - } - $options{type_constraint} = $constraint; + } + else { + # otherwise assume it is a constraint + my $constraint = Moose::Util::TypeConstraints::find_type_constraint($options{isa}); + # if the constraing it not found .... + unless (defined $constraint) { + # assume it is a foreign class, and make + # an anon constraint for it + $constraint = Moose::Util::TypeConstraints::subtype( + 'Object', + Moose::Util::TypeConstraints::where { $_->isa($options{isa}) } + ); + } + $options{type_constraint} = $constraint; + } } } elsif (exists $options{does}) { @@ -98,6 +107,8 @@ sub new { if (exists $options{coerce} && $options{coerce}) { (exists $options{type_constraint}) || confess "You cannot have coercion without specifying a type constraint"; + (!$options{type_constraint}->isa('Moose::Meta::TypeConstraint::Union')) + || confess "You cannot have coercion with a type constraint union"; confess "You cannot have a weak reference to a coerced value" if $options{weak_ref}; } @@ -132,11 +143,16 @@ sub initialize_instance_slot { } if (defined $val) { if ($self->has_type_constraint) { - if ($self->should_coerce && $self->type_constraint->has_coercion) { - $val = $self->type_constraint->coercion->coerce($val); + my $type_constraint = $self->type_constraint; + if ($self->should_coerce && $type_constraint->has_coercion) { + $val = $type_constraint->coercion->coerce($val); } - (defined($self->type_constraint->check($val))) - || confess "Attribute (" . $self->name . ") does not pass the type contraint with '$val'"; + (defined($type_constraint->check($val))) + || confess "Attribute (" . + $self->name . + ") does not pass the type contraint (" . + $type_constraint->name . + ") with '$val'"; } } $instance->{$self->name} = $val; @@ -158,7 +174,7 @@ sub generate_accessor_method { : '') . ($self->has_type_constraint ? ('(defined $self->type_constraint->check(' . $value_name . '))' - . '|| confess "Attribute ($attr_name) does not pass the type contraint with \'' . $value_name . '\'"' + . '|| confess "Attribute ($attr_name) does not pass the type contraint (" . $self->type_constraint->name . ") with \'' . $value_name . '\'"' . 'if defined ' . $value_name . ';') : '') . '$_[0]->{$attr_name} = ' . $value_name . ';' @@ -192,7 +208,7 @@ sub generate_writer_method { : '') . ($self->has_type_constraint ? ('(defined $self->type_constraint->check(' . $value_name . '))' - . '|| confess "Attribute ($attr_name) does not pass the type contraint with \'' . $value_name . '\'"' + . '|| confess "Attribute ($attr_name) does not pass the type contraint (" . $self->type_constraint->name . ") with \'' . $value_name . '\'"' . 'if defined ' . $value_name . ';') : '') . '$_[0]->{$attr_name} = ' . $value_name . ';' diff --git a/lib/Moose/Meta/TypeConstraint.pm b/lib/Moose/Meta/TypeConstraint.pm index 8d3d1c0..19aa9cb 100644 --- a/lib/Moose/Meta/TypeConstraint.pm +++ b/lib/Moose/Meta/TypeConstraint.pm @@ -5,8 +5,9 @@ use strict; use warnings; use metaclass; -use Sub::Name 'subname'; -use Carp 'confess'; +use Sub::Name 'subname'; +use Carp 'confess'; +use Scalar::Util 'blessed'; our $VERSION = '0.03'; @@ -79,6 +80,11 @@ sub validate { sub union { my ($class, @type_constraints) = @_; + (scalar @type_constraints >= 2) + || confess "You must pass in at least 2 Moose::Meta::TypeConstraint instances to make a union"; + (blessed($_) && $_->isa('Moose::Meta::TypeConstraint')) + || confess "You must pass in only Moose::Meta::TypeConstraint instances to make unions" + foreach @type_constraints; return Moose::Meta::TypeConstraint::Union->new( type_constraints => \@type_constraints ); @@ -105,6 +111,21 @@ sub new { sub name { join ' | ' => map { $_->name } @{$_[0]->type_constraints} } +# NOTE: +# this should probably never be used +# but we include it here for completeness +sub constraint { + my $self = shift; + sub { $self->check($_[0]) }; +} + +# conform to the TypeConstraint API +sub parent { undef } +sub coercion { undef } +sub has_coercion { 0 } +sub message { undef } +sub has_message { 0 } + sub check { my $self = shift; my $value = shift; diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm index 3d6d7ba..f715727 100644 --- a/lib/Moose/Util/TypeConstraints.pm +++ b/lib/Moose/Util/TypeConstraints.pm @@ -69,6 +69,15 @@ use Moose::Meta::TypeCoercion; $type->coercion($type_coercion); } + sub create_type_constraint_union { + my (@type_constraint_names) = @_; + return Moose::Meta::TypeConstraint->union( + map { + find_type_constraint($_) + } @type_constraint_names + ); + } + sub export_type_contstraints_as_functions { my $pkg = caller(); no strict 'refs'; @@ -211,6 +220,11 @@ Suggestions for improvement are welcome. This function can be used to locate a specific type constraint meta-object. What you do with it from there is up to you :) +=item B + +Given a list of C<@type_constraint_names>, this will return a +B instance. + =item B This will export all the current type constraints as functions diff --git a/t/037_attribute_type_unions.t b/t/037_attribute_type_unions.t new file mode 100644 index 0000000..b81f64b --- /dev/null +++ b/t/037_attribute_type_unions.t @@ -0,0 +1,59 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 10; +use Test::Exception; + +BEGIN { + use_ok('Moose'); +} + +{ + package Foo; + use strict; + use warnings; + use Moose; + + has 'bar' => (is => 'rw', isa => 'ArrayRef | HashRef'); +} + +my $foo = Foo->new; +isa_ok($foo, 'Foo'); + +lives_ok { + $foo->bar([]) +} '... set bar successfully with an ARRAY ref'; + +lives_ok { + $foo->bar({}) +} '... set bar successfully with a HASH ref'; + +dies_ok { + $foo->bar(100) +} '... couldnt set bar successfully with a number'; + +dies_ok { + $foo->bar(sub {}) +} '... couldnt set bar successfully with a CODE ref'; + +# check the constructor + +lives_ok { + Foo->new(bar => []) +} '... created new Foo with bar successfully set with an ARRAY ref'; + +lives_ok { + Foo->new(bar => {}) +} '... created new Foo with bar successfully set with a HASH ref'; + +dies_ok { + Foo->new(bar => 50) +} '... didnt create a new Foo with bar as a number'; + +dies_ok { + Foo->new(bar => sub {}) +} '... didnt create a new Foo with bar as a number'; + +