diff --git a/lib/Moose/Exception/BothAttributeAndClearAttributeAreNotAllowed.pm b/lib/Moose/Exception/BothAttributeAndClearAttributeAreNotAllowed.pm new file mode 100644 index 000000000..7b52a63d4 --- /dev/null +++ b/lib/Moose/Exception/BothAttributeAndClearAttributeAreNotAllowed.pm @@ -0,0 +1,21 @@ +package Moose::Exception::BothAttributeAndClearAttributeAreNotAllowed; +our $VERSION = '2.2013'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::ParamsHash'; + +has 'attribute_name' => ( + is => 'ro', + isa => 'Str', + required => 1 +); + +sub _build_message { + my $self = shift; + return "You said both to clear_" . $self->attribute_name + . " and also to set a value for " . $self->attribute_name; +} + +__PACKAGE__->meta->make_immutable; +1; diff --git a/lib/Moose/Exception/InvalidClearedAttribute.pm b/lib/Moose/Exception/InvalidClearedAttribute.pm new file mode 100644 index 000000000..44f778827 --- /dev/null +++ b/lib/Moose/Exception/InvalidClearedAttribute.pm @@ -0,0 +1,21 @@ +package Moose::Exception::InvalidClearedAttribute; +our $VERSION = '2.2013'; + +use Moose; +extends 'Moose::Exception'; +with 'Moose::Exception::Role::ParamsHash'; + +has 'attribute_name' => ( + is => 'ro', + isa => 'Str', + required => 1, +); + +sub _build_message { + my $self = shift; + "You said clear_" . $self->attribute_name . " but " . $self->attribute_name + . " is not the name of an existing attribute"; +} + +__PACKAGE__->meta->make_immutable; +1; diff --git a/lib/Moose/Manual/Attributes.pod b/lib/Moose/Manual/Attributes.pod index e4c1a3bad..e3b9342a1 100644 --- a/lib/Moose/Manual/Attributes.pod +++ b/lib/Moose/Manual/Attributes.pod @@ -575,6 +575,35 @@ As a consequence, any method modifiers defined on the attribute's accessors in an ancestor class will effectively be ignored, because the new accessors live in the child class and do not see the modifiers from the parent class. +=head2 Clearing Aspects + +Sometimes, you may decide that you don't want to override an aspect of the +original attribute with a new value; rather, you want there to be I. +(For instance, the default would normally have been a value that is no longer +valid; but undef or the empty string aren't valid either.) In situations like +this, prepend the attribute name with C: e.g. + + person Person::Archaic; + + use Moose; + + has 'gender' => ( + is => 'ro', + isa => 'Gender', + default => 'Male', + ); + + package Person::Modern; + + use Moose; + extends 'Person::Archaic'; + + has '+gender' => ( + is => 'rw', + clear_default => 1, + required => 1, + ); + =head1 MULTIPLE ATTRIBUTE SHORTCUTS If you have a number of attributes that differ only by name, you can declare diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm index d6106aaec..a4c7d635e 100644 --- a/lib/Moose/Meta/Attribute.pm +++ b/lib/Moose/Meta/Attribute.pm @@ -238,13 +238,37 @@ sub clone { my $class = delete $params{metaclass} || ref $self; - my ( @init, @non_init ); - - foreach my $attr ( grep { $_->has_value($self) } Class::MOP::class_of($self)->get_all_attributes ) { - push @{ $attr->has_init_arg ? \@init : \@non_init }, $attr; + my ( %new_params, @non_init ); + + my @possible_attrs = Class::MOP::class_of($self)->get_all_attributes; + my %attr_by_name = map { $_->name => $_ } @possible_attrs; + foreach my $attr ( grep { $_->has_value($self) } @possible_attrs ) { + if ($attr->has_init_arg) { + $new_params{$attr->init_arg} = $attr->get_value($self); + } else { + push @non_init, $attr; + } } - my %new_params = ( ( map { $_->init_arg => $_->get_value($self) } @init ), %params ); + for my $param_name (keys %params) { + if ($param_name =~ /^ clear_ (.+) /x) { + my $cleared_attr_name = $1; + if ($attr_by_name{$cleared_attr_name}) { + if (exists $params{$cleared_attr_name}) { + throw_exception( BothAttributeAndClearAttributeAreNotAllowed => attribute_name => $cleared_attr_name, + params => \%params + ); + } + delete $new_params{$cleared_attr_name}; + } else { + throw_exception( InvalidClearedAttribute => attribute_name => $cleared_attr_name, + params => \%params + ); + } + } else { + $new_params{$param_name} = $params{$param_name}; + } + } my $name = delete $new_params{name}; diff --git a/t/attributes/attribute_inherited_slot_specs.t b/t/attributes/attribute_inherited_slot_specs.t index 2556e9a3e..ec882a716 100644 --- a/t/attributes/attribute_inherited_slot_specs.t +++ b/t/attributes/attribute_inherited_slot_specs.t @@ -114,6 +114,32 @@ use Test::Fatal; ::like( ::exception { has '+does_not_exist' => (isa => 'Str'); }, qr/in Bar/, '... cannot extend a non-existing attribute' ); + + ::is( ::exception { + has '+baz' => (clear_default => 1), + }, undef, 'Can trivially clear an already-cleared attribute'); + + package Foo::VagueBar; + use Moose; + + extends 'Foo'; + + ::like( ::exception { + has '+bar' => (clear_brush => 'I live in Texas, I just do this'); + }, qr/You said clear_brush but/, 'Cannot clear a non-existent attribute'); + my $re_make_up_your_mind + = qr/You said both to clear_default and also to set a value for default/; + ::like( ::exception { + has '+bar' => (clear_default => 1, default => 'Something reasonable'); + }, $re_make_up_your_mind, + 'Must be consistent: default value or no default value?'); + ::like( ::exception { + has '+bar' => (clear_default => 1, default => 0); + }, $re_make_up_your_mind, + '...including when the new default value is false'); + ::is( ::exception { + has '+bar' => (clear_default => 1); + }, undef, 'Can clear a previous default'); } my $foo = Foo->new; @@ -191,6 +217,12 @@ is($bar->baz, undef, '... got the right undef default value'); isnt( exception { $bar->baz($code_ref) }, undef, '... Bar::baz does not accept a code ref' ); } +my $foo_vaguebar = Foo::VagueBar->new; +isa_ok($foo_vaguebar, 'Foo::VagueBar'); +isa_ok($foo_vaguebar, 'Foo'); +ok(!$foo_vaguebar->meta->find_attribute_by_name('bar')->has_value($foo_vaguebar), + 'An attribute whose definition gets rid of a default value does not have a value'); + # check some meta-stuff ok(Bar->meta->has_attribute('foo'), '... Bar has a foo attr');