From: Stevan Little Date: Sun, 23 Apr 2006 12:58:49 +0000 (+0000) Subject: inherited-slot-specifications X-Git-Tag: 0_05~7 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=1d768fb16a397e849073f2147a1879cb78df08da;p=gitmo%2FMoose.git inherited-slot-specifications --- diff --git a/lib/Moose.pm b/lib/Moose.pm index ed64f64..2087c26 100644 --- a/lib/Moose.pm +++ b/lib/Moose.pm @@ -79,7 +79,13 @@ use Moose::Util::TypeConstraints; return subname 'Moose::has' => sub { my ($name, %options) = @_; if ($name =~ /^\+(.*)/) { - warn $1; + my $inherited_attr = $meta->find_attribute_by_name($1); + (defined $inherited_attr) + || confess "Could not find an attribute by the name of '$1' to inherit from"; + (scalar keys %options == 1 && exists $options{default}) + || confess "Inherited slot specifications can only alter the 'default' option"; + my $new_attr = $inherited_attr->clone(%options); + $meta->add_attribute($new_attr); } else { if ($options{metaclass}) { diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm index fec33d7..4cab769 100644 --- a/lib/Moose/Meta/Attribute.pm +++ b/lib/Moose/Meta/Attribute.pm @@ -28,26 +28,37 @@ __PACKAGE__->meta->add_attribute('trigger' => ( sub new { my ($class, $name, %options) = @_; - - if (exists $options{is}) { - if ($options{is} eq 'ro') { - $options{reader} = $name; - (!exists $options{trigger}) + $class->_process_options($name, \%options); + $class->SUPER::new($name, %options); +} + +sub clone { + my ($self, %options) = @_; + $self->_process_options($self->name, \%options); + $self->SUPER::clone(%options); +} + +sub _process_options { + my ($class, $name, $options) = @_; + if (exists $options->{is}) { + if ($options->{is} eq 'ro') { + $options->{reader} = $name; + (!exists $options->{trigger}) || confess "Cannot have a trigger on a read-only attribute"; } - elsif ($options{is} eq 'rw') { - $options{accessor} = $name; - ((reftype($options{trigger}) || '') eq 'CODE') + elsif ($options->{is} eq 'rw') { + $options->{accessor} = $name; + ((reftype($options->{trigger}) || '') eq 'CODE') || confess "A trigger must be a CODE reference" - if exists $options{trigger}; + if exists $options->{trigger}; } } - if (exists $options{isa}) { + if (exists $options->{isa}) { - if (exists $options{does}) { - if (eval { $options{isa}->can('does') }) { - ($options{isa}->does($options{does})) + if (exists $options->{does}) { + if (eval { $options->{isa}->can('does') }) { + ($options->{isa}->does($options->{does})) || confess "Cannot have an isa option and a does option if the isa does not do the does"; } else { @@ -56,69 +67,67 @@ sub new { } # allow for anon-subtypes here ... - if (blessed($options{isa}) && $options{isa}->isa('Moose::Meta::TypeConstraint')) { - $options{type_constraint} = $options{isa}; + if (blessed($options->{isa}) && $options->{isa}->isa('Moose::Meta::TypeConstraint')) { + $options->{type_constraint} = $options->{isa}; } else { - if ($options{isa} =~ /\|/) { - my @type_constraints = split /\s*\|\s*/ => $options{isa}; - $options{type_constraint} = Moose::Util::TypeConstraints::create_type_constraint_union( + if ($options->{isa} =~ /\|/) { + my @type_constraints = split /\s*\|\s*/ => $options->{isa}; + $options->{type_constraint} = Moose::Util::TypeConstraints::create_type_constraint_union( @type_constraints ); } else { # otherwise assume it is a constraint - my $constraint = Moose::Util::TypeConstraints::find_type_constraint($options{isa}); + 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}) } + Moose::Util::TypeConstraints::where { $_->isa($options->{isa}) } ); } - $options{type_constraint} = $constraint; + $options->{type_constraint} = $constraint; } } } - elsif (exists $options{does}) { + elsif (exists $options->{does}) { # allow for anon-subtypes here ... - if (blessed($options{does}) && $options{does}->isa('Moose::Meta::TypeConstraint')) { - $options{type_constraint} = $options{isa}; + if (blessed($options->{does}) && $options->{does}->isa('Moose::Meta::TypeConstraint')) { + $options->{type_constraint} = $options->{isa}; } else { # otherwise assume it is a constraint - my $constraint = Moose::Util::TypeConstraints::find_type_constraint($options{does}); + my $constraint = Moose::Util::TypeConstraints::find_type_constraint($options->{does}); # 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( 'Role', - Moose::Util::TypeConstraints::where { $_->does($options{does}) } + Moose::Util::TypeConstraints::where { $_->does($options->{does}) } ); } - $options{type_constraint} = $constraint; + $options->{type_constraint} = $constraint; } } - if (exists $options{coerce} && $options{coerce}) { - (exists $options{type_constraint}) + 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')) + (!$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}; + if $options->{weak_ref}; } - if (exists $options{lazy} && $options{lazy}) { - (exists $options{default}) + if (exists $options->{lazy} && $options->{lazy}) { + (exists $options->{default}) || confess "You cannot have lazy attribute without specifying a default value for it"; - } - - $class->SUPER::new($name, %options); + } } sub initialize_instance_slot { @@ -271,6 +280,8 @@ will behave just as L does. =item B +=item B + =item B =item B diff --git a/t/038_attribute_inherited_slot_specs.t b/t/038_attribute_inherited_slot_specs.t new file mode 100644 index 0000000..df735b2 --- /dev/null +++ b/t/038_attribute_inherited_slot_specs.t @@ -0,0 +1,66 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 10; +use Test::Exception; + +BEGIN { + use_ok('Moose'); +} + +=pod + +http://www.gwydiondylan.org/books/drm/Instance_Creation_and_Initialization#HEADING43-37 + +=cut + +{ + package Foo; + use strict; + use warnings; + use Moose; + + has 'bar' => (is => 'ro', isa => 'Str', default => 'Foo::bar'); + + package Bar; + use strict; + use warnings; + use Moose; + + extends 'Foo'; + + has '+bar' => (default => 'Bar::bar'); +} + +my $foo = Foo->new; +isa_ok($foo, 'Foo'); + +is($foo->bar, 'Foo::bar', '... got the right default value'); + +dies_ok { $foo->bar(10) } '... Foo::bar is a read/only attr'; + +my $bar = Bar->new; +isa_ok($bar, 'Bar'); +isa_ok($bar, 'Foo'); + +is($bar->bar, 'Bar::bar', '... got the right default value'); + +dies_ok { $bar->bar(10) } '... Bar::bar is a read/only attr'; + +# check some meta-stuff + +ok(Bar->meta->has_attribute('bar'), '... Bar has a bar attr'); +isnt(Foo->meta->get_attribute('bar'), + Bar->meta->get_attribute('bar'), + '... Foo and Bar have different copies of bar'); + + + + + + + + +