| Subject: | accessor installation overwrites pre-existing subs |
Here's a rough patch that fixes this issue and a test that illustrates
it. Unfortunately the patch causes some other tests to fail.
<patch>
--- lib/Class/MOP/Attribute.pm (revision 6867)
+++ lib/Class/MOP/Attribute.pm (working copy)
@@ -367,23 +367,23 @@
$class->add_method(
$self->process_accessors('accessor' => $self->accessor(), $inline)
- ) if $self->has_accessor();
+ ) if $self->has_accessor() && ! $class->has_method( $self->accessor );
$class->add_method(
$self->process_accessors('reader' => $self->reader(), $inline)
- ) if $self->has_reader();
+ ) if $self->has_reader() && ! $class->has_method( $self->reader );
$class->add_method(
$self->process_accessors('writer' => $self->writer(), $inline)
- ) if $self->has_writer();
+ ) if $self->has_writer() && ! $class->has_method( $self->writer );
$class->add_method(
$self->process_accessors('predicate' => $self->predicate(),
$inline)
- ) if $self->has_predicate();
+ ) if $self->has_predicate() && ! $class->has_method(
$self->predicate );
$class->add_method(
$self->process_accessors('clearer' => $self->clearer(), $inline)
- ) if $self->has_clearer();
+ ) if $self->has_clearer() && ! $class->has_method( $self->clearer );
return;
}
</patch>
<test>
#!/usr/bin/perl
use Class::MOP;
use strict;
use Test::More tests => 5;
use warnings;
{
package Foo;
use strict;
use warnings;
use metaclass;
__PACKAGE__->meta->add_attribute(
'foo' => (
accessor => 'foo_accessor',
reader => 'foo_reader',
writer => 'foo_writer',
predicate => 'foo_predicate',
clearer => 'foo_clearer',
)
);
sub foo_accessor { "Don't tread on me! (a)" }
sub foo_reader { "Don't tread on me! (r)" }
sub foo_writer { "Don't tread on me! (w)" }
sub foo_predicate { "Don't tread on me! (p)" }
sub foo_clearer { "Don't tread on me! (c)" }
}
{
Foo->meta->make_immutable(
inline_constructor => 1,
inline_accessors => 1,
);
my $foo = Foo->new;
is(
$foo->foo_accessor, "Don't tread on me! (a)",
'pre-existing foo_accessor sub persists'
);
is(
$foo->foo_reader, "Don't tread on me! (r)",
'pre-existing foo_reader sub persists'
);
is(
$foo->foo_writer, "Don't tread on me! (w)",
'pre-existing foo_writer sub persists'
);
is(
$foo->foo_predicate, "Don't tread on me! (p)",
'pre-existing foo_predicate sub persists'
);
is(
$foo->foo_clearer, "Don't tread on me! (c)",
'pre-existing foo_clearer sub persists'
);
}
</test>