From: Tuomas Jormola <tj@solitudo.net>
Date: Tue, 3 Nov 2009 08:33:42 +0000 (+0200)
Subject: Implement inversed logic when defining which attribute options can be changed
X-Git-Tag: 1.09~47^2~2
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7782e1dab182a154ca18d79b580a23d29992ad25;p=gitmo%2FMoose.git

Implement inversed logic when defining which attribute options can be changed
---

diff --git a/lib/Moose/Manual/Delta.pod b/lib/Moose/Manual/Delta.pod
index c1b8f57..3950b13 100644
--- a/lib/Moose/Manual/Delta.pod
+++ b/lib/Moose/Manual/Delta.pod
@@ -34,6 +34,29 @@ This change was made in 1.05, and has now been reverted. We don't know if the
 user has explicitly loaded strict or warnings outside on their own, and
 unimporting them is just broken in that case.
 
+=item Inversed logic when defining which options can be changed
+
+L<Moose::Meta::Attribute> now uses inversed logic when defining which
+options can be changed. By default all options are allowed to be
+changed. The previous behaviour required each option to be whitelisted
+for changing using C<legal_options_for_inheritance> method. This
+method has been removed. New method C<illegal_options_for_inheritance>
+can now be used to prevent certain options from being changeable.
+
+  package Bar::Meta::Attribute;
+  use Moose;
+
+  extends 'Moose::Meta::Attribute';
+
+  has 'my_illegal_option' => (
+    isa => 'CodeRef',
+    is => 'rw',
+  );
+
+  around illegal_options_for_inheritance => sub {
+    return (shift->(@_), qw/my_illegal_option/);
+  };
+
 =back
 
 =head1 1.05
diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm
index dfdfbbe..818efd1 100644
--- a/lib/Moose/Meta/Attribute.pm
+++ b/lib/Moose/Meta/Attribute.pm
@@ -131,15 +131,7 @@ sub interpolate_class {
 
 # ...
 
-my @legal_options_for_inheritance = qw(
-    default coerce required
-    documentation lazy handles
-    builder type_constraint
-    definition_context
-    lazy_build weak_ref
-);
-
-sub legal_options_for_inheritance { @legal_options_for_inheritance }
+sub illegal_options_for_inheritance { }
 
 # NOTE/TODO
 # This method *must* be able to handle
@@ -160,8 +152,6 @@ sub clone_and_inherit_options {
 
     my %copy = %options;
 
-    my %actual_options;
-
     # NOTE:
     # we may want to extends a Class::MOP::Attribute
     # in which case we need to be able to use the
@@ -169,16 +159,13 @@ sub clone_and_inherit_options {
     # been here. But we allows Moose::Meta::Attribute
     # instances to changes them.
     # - SL
-    my @legal_options = $self->can('legal_options_for_inheritance')
-        ? $self->legal_options_for_inheritance
-        : @legal_options_for_inheritance;
-
-    foreach my $legal_option (@legal_options) {
-        if (exists $options{$legal_option}) {
-            $actual_options{$legal_option} = $options{$legal_option};
-            delete $options{$legal_option};
-        }
-    }
+    my @illegal_options = $self->can('illegal_options_for_inheritance')
+        ? $self->illegal_options_for_inheritance
+        : ();
+
+    my @found_illegal_options = grep { exists $options{$_} ? $_ : undef } @illegal_options;
+    (scalar @found_illegal_options == 0)
+        || $self->throw_error("Illegal inherited options => (" . (join ', ' => @found_illegal_options) . ")", data => \%options);
 
     if ($options{isa}) {
         my $type_constraint;
@@ -191,8 +178,7 @@ sub clone_and_inherit_options {
                 || $self->throw_error("Could not find the type constraint '" . $options{isa} . "'", data => $options{isa});
         }
 
-        $actual_options{type_constraint} = $type_constraint;
-        delete $options{isa};
+        $options{type_constraint} = $type_constraint;
     }
 
     if ($options{does}) {
@@ -206,8 +192,7 @@ sub clone_and_inherit_options {
                 || $self->throw_error("Could not find the type constraint '" . $options{does} . "'", data => $options{does});
         }
 
-        $actual_options{type_constraint} = $type_constraint;
-        delete $options{does};
+        $options{type_constraint} = $type_constraint;
     }
 
     # NOTE:
@@ -215,20 +200,14 @@ sub clone_and_inherit_options {
     # so we can ignore it for them.
     # - SL
     if ($self->can('interpolate_class')) {
-        ( $actual_options{metaclass}, my @traits ) = $self->interpolate_class(\%options);
+        ( $options{metaclass}, my @traits ) = $self->interpolate_class(\%options);
 
         my %seen;
         my @all_traits = grep { $seen{$_}++ } @{ $self->applied_traits || [] }, @traits;
-        $actual_options{traits} = \@all_traits if @all_traits;
-
-        delete @options{qw(metaclass traits)};
+        $options{traits} = \@all_traits if @all_traits;
     }
 
-    (scalar keys %options == 0)
-        || $self->throw_error("Illegal inherited options => (" . (join ', ' => keys %options) . ")", data => \%options);
-
-
-    $self->clone(%actual_options);
+    $self->clone(%options);
 }
 
 sub clone {
@@ -1027,16 +1006,16 @@ of processing on the supplied C<%options> before ultimately calling
 the C<clone> method.
 
 One of its main tasks is to make sure that the C<%options> provided
-only includes the options returned by the
-C<legal_options_for_inheritance> method.
+does not include the options returned by the
+C<illegal_options_for_inheritance> method.
 
-=item B<< $attr->legal_options_for_inheritance >>
+=item B<< $attr->illegal_options_for_inheritance >>
 
-This returns a whitelist of options that can be overridden in a
+This returns a blacklist of options that can not be overridden in a
 subclass's attribute definition.
 
 This exists to allow a custom metaclass to change or add to the list
-of options which can be changed.
+of options which can not be changed.
 
 =item B<< $attr->type_constraint >>
 
diff --git a/t/020_attributes/009_attribute_inherited_slot_specs.t b/t/020_attributes/009_attribute_inherited_slot_specs.t
index 593c9d4..1a61073 100644
--- a/t/020_attributes/009_attribute_inherited_slot_specs.t
+++ b/t/020_attributes/009_attribute_inherited_slot_specs.t
@@ -8,6 +8,14 @@ use Test::Exception;
 
 
 {
+    package Thing::Meta::Attribute;
+    use Moose;
+
+    extends 'Moose::Meta::Attribute';
+    around illegal_options_for_inheritance => sub {
+        return (shift->(@_), qw/trigger/);
+    };
+
     package Thing;
     use Moose;
 
@@ -43,7 +51,7 @@ use Test::Exception;
 
     # this one will work here ....
     has 'fail' => (isa => 'CodeRef', is => 'bare');
-    has 'other_fail' => (is => 'bare');
+    has 'other_fail' => (metaclass => 'Thing::Meta::Attribute', is => 'bare');
 
     package Bar;
     use Moose;
diff --git a/t/020_attributes/022_illegal_options_for_inheritance.t b/t/020_attributes/022_illegal_options_for_inheritance.t
new file mode 100644
index 0000000..49c16e9
--- /dev/null
+++ b/t/020_attributes/022_illegal_options_for_inheritance.t
@@ -0,0 +1,41 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use Test::More;
+
+
+
+{
+    package Bar::Meta::Attribute;
+    use Moose;
+
+    extends 'Moose::Meta::Attribute';
+
+    has 'my_illegal_option' => (
+      isa => 'CodeRef',
+      is => 'rw',
+    );
+
+    around illegal_options_for_inheritance => sub {
+      return (shift->(@_), qw/my_illegal_option/);
+    };
+
+    package Bar;
+    use Moose;
+
+    has 'bar' => (
+      metaclass       => 'Bar::Meta::Attribute',
+      my_illegal_option => sub { 'Bar' },
+      is => 'bare',
+    );
+}
+
+my $bar_attr = Bar->meta->get_attribute('bar');
+my ($illegal_option) = grep {
+  $_ eq 'my_illegal_option'
+} $bar_attr->illegal_options_for_inheritance;
+is($illegal_option, 'my_illegal_option',
+  '... added my_illegal_option as illegal option for inheritance' );
+
+done_testing;
diff --git a/t/020_attributes/022_legal_options_for_inheritance.t b/t/020_attributes/022_legal_options_for_inheritance.t
deleted file mode 100644
index ca21b6f..0000000
--- a/t/020_attributes/022_legal_options_for_inheritance.t
+++ /dev/null
@@ -1,50 +0,0 @@
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-use Test::More;
-
-
-{
-    package Bar::Meta::Attribute;
-    use Moose;
-
-    extends 'Moose::Meta::Attribute';
-
-    has 'my_legal_option' => (
-      isa => 'CodeRef',
-      is => 'rw',
-    );
-
-    around legal_options_for_inheritance => sub {
-      return (shift->(@_), qw/my_legal_option/);
-    };
-
-    package Bar;
-    use Moose;
-
-    has 'bar' => (
-      metaclass       => 'Bar::Meta::Attribute',
-      my_legal_option => sub { 'Bar' },
-      is => 'bare',
-    );
-
-    package Bar::B;
-    use Moose;
-
-    extends 'Bar';
-
-    has '+bar' => (
-      my_legal_option => sub { 'Bar::B' }
-    );
-}
-
-my $bar_attr = Bar::B->meta->get_attribute('bar');
-my ($legal_option) = grep {
-  $_ eq 'my_legal_option'
-} $bar_attr->legal_options_for_inheritance;
-is($legal_option, 'my_legal_option',
-  '... added my_legal_option as legal option for inheritance' );
-is($bar_attr->my_legal_option->(), 'Bar::B', '... overloaded my_legal_option');
-
-done_testing;