From: Stevan Little Date: Wed, 30 Aug 2006 18:06:41 +0000 (+0000) Subject: add_attribute fix, and version fixes, changes, etc X-Git-Tag: 0_35~12 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=b1897d4d804dc11f86868052ecb6997a04821df3;p=gitmo%2FClass-MOP.git add_attribute fix, and version fixes, changes, etc --- diff --git a/Changes b/Changes index 0562797..018d631 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,41 @@ Revision history for Perl extension Class-MOP. +0.35 + + * Class::MOP + - non-generated accessors are no longer + copied, but instead are aliased from + the originals + - added Class::MOP::Method (and its subclasses) + to the bootstrap + - adjusted tests for this + + * Class::MOP::Method + *** API CHANGE *** + - methods are no longer blessed CODE refs + but are actual objects which can be CODE-ified + - adjusted tests to compensate + + * Class::MOP::Class + - changed how methods are dealt with to + encapsulate most of the work into the + &get_method_map method + - made several adjustments for the change + in Class::MOP::Method + - &add_attribute now checks if you are adding + a duplicate name, and properly removes the + old one before installing the new one + - added tests for this + + * Class::MOP::Class::Immutable + - added caching of &get_method_map + - fixed issue with &get_package_symbol + - cleaned up the methods that die (patch by David Wheeler) + + * Class::MOP::Package + - added filtering capabilities to + &list_all_package_symbols + 0.34 Sat. Aug. 26, 2006 * Class::MOP::Class - added the %:methods attribute, which like diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index dbc4136..9b713f3 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -13,7 +13,7 @@ use Class::MOP::Method; use Class::MOP::Class::Immutable; -our $VERSION = '0.34'; +our $VERSION = '0.35'; our $AUTHORITY = 'cpan:STEVAN'; { diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm index a0f0a0b..8a51a5c 100644 --- a/lib/Class/MOP/Attribute.pm +++ b/lib/Class/MOP/Attribute.pm @@ -10,6 +10,8 @@ use Scalar::Util 'blessed', 'reftype', 'weaken'; our $VERSION = '0.12'; our $AUTHORITY = 'cpan:STEVAN'; +use base 'Class::MOP::Object'; + sub meta { require Class::MOP::Class; Class::MOP::Class->initialize(blessed($_[0]) || $_[0]); diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 2501688..ea560ba 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -9,7 +9,7 @@ use Scalar::Util 'blessed', 'reftype', 'weaken'; use Sub::Name 'subname'; use B 'svref_2object'; -our $VERSION = '0.19'; +our $VERSION = '0.20'; our $AUTHORITY = 'cpan:STEVAN'; use base 'Class::MOP::Module'; @@ -609,7 +609,20 @@ sub add_attribute { # make sure it is derived from the correct type though ($attribute->isa('Class::MOP::Attribute')) || confess "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)"; + + # first we attach our new attribute + # because it might need certain information + # about the class which it is attached to $attribute->attach_to_class($self); + + # then we remove attributes of a conflicting + # name here so that we can properly detach + # the old attr object, and remove any + # accessors it would have generated + $self->remove_attribute($attribute->name) + if $self->has_attribute($attribute->name); + + # then onto installing the new accessors $attribute->install_accessors(); $self->get_attribute_map->{$attribute->name} = $attribute; } @@ -626,8 +639,10 @@ sub get_attribute { (defined $attribute_name && $attribute_name) || confess "You must define an attribute name"; return $self->get_attribute_map->{$attribute_name} - if $self->has_attribute($attribute_name); - return; + # NOTE: + # this will return undef anyway, so no need ... + # if $self->has_attribute($attribute_name); + #return; } sub remove_attribute { diff --git a/lib/Class/MOP/Class/Immutable.pm b/lib/Class/MOP/Class/Immutable.pm index e40198f..802a3ba 100644 --- a/lib/Class/MOP/Class/Immutable.pm +++ b/lib/Class/MOP/Class/Immutable.pm @@ -7,22 +7,26 @@ use warnings; use Carp 'confess'; use Scalar::Util 'blessed', 'looks_like_number'; -our $VERSION = '0.02'; +our $VERSION = '0.03'; our $AUTHORITY = 'cpan:STEVAN'; use base 'Class::MOP::Class'; # methods which can *not* be called - -sub add_method { confess 'Cannot call method "add_method" on an immutable instance' } -sub alias_method { confess 'Cannot call method "alias_method" on an immutable instance' } -sub remove_method { confess 'Cannot call method "remove_method" on an immutable instance' } - -sub add_attribute { confess 'Cannot call method "add_attribute" on an immutable instance' } -sub remove_attribute { confess 'Cannot call method "remove_attribute" on an immutable instance' } - -sub add_package_symbol { confess 'Cannot call method "add_package_symbol" on an immutable instance' } -sub remove_package_symbol { confess 'Cannot call method "remove_package_symbol" on an immutable instance' } +for my $meth (qw( + add_method + alias_method + remove_method + add_attribute + remove_attribute + add_package_symbol + remove_package_symbol +)) { + no strict 'refs'; + *{$meth} = sub { + confess "Cannot call method '$meth' on an immutable instance"; + }; +} sub get_package_symbol { my ($self, $variable) = @_; diff --git a/lib/Class/MOP/Method.pm b/lib/Class/MOP/Method.pm index dbb7773..04f1312 100644 --- a/lib/Class/MOP/Method.pm +++ b/lib/Class/MOP/Method.pm @@ -8,9 +8,11 @@ use Carp 'confess'; use Scalar::Util 'reftype', 'blessed'; use B 'svref_2object'; -our $VERSION = '0.03'; +our $VERSION = '0.04'; our $AUTHORITY = 'cpan:STEVAN'; +use base 'Class::MOP::Object'; + # NOTE: # if poked in the right way, # they should act like CODE refs. @@ -39,6 +41,8 @@ sub wrap { sub body { (shift)->{body} } +# TODO - add associated_class + # informational # NOTE: diff --git a/lib/Class/MOP/Package.pm b/lib/Class/MOP/Package.pm index 86114d4..2e507fe 100644 --- a/lib/Class/MOP/Package.pm +++ b/lib/Class/MOP/Package.pm @@ -7,7 +7,7 @@ use warnings; use Scalar::Util 'blessed'; use Carp 'confess'; -our $VERSION = '0.04'; +our $VERSION = '0.05'; our $AUTHORITY = 'cpan:STEVAN'; use base 'Class::MOP::Object'; diff --git a/t/000_load.t b/t/000_load.t index 57bfebf..b9edef2 100644 --- a/t/000_load.t +++ b/t/000_load.t @@ -63,4 +63,21 @@ is_deeply( Class::MOP::Object Class::MOP::Package / ], - \ No newline at end of file + '... got all the metaclass names'); + +is_deeply( + [ map { $_->meta->identifier } sort { $a cmp $b } Class::MOP::get_all_metaclass_names() ], + [ + "Class::MOP::Attribute-" . $Class::MOP::Attribute::VERSION . "-cpan:STEVAN", + "Class::MOP::Attribute::Accessor-" . $Class::MOP::Attribute::Accessor::VERSION . "-cpan:STEVAN", + "Class::MOP::Class-" . $Class::MOP::Class::VERSION . "-cpan:STEVAN", + "Class::MOP::Instance-" . $Class::MOP::Instance::VERSION . "-cpan:STEVAN", + "Class::MOP::Method-" . $Class::MOP::Method::VERSION . "-cpan:STEVAN", + "Class::MOP::Method::Wrapped-" . $Class::MOP::Method::Wrapped::VERSION . "-cpan:STEVAN", + "Class::MOP::Module-" . $Class::MOP::Module::VERSION . "-cpan:STEVAN", + "Class::MOP::Object-" . $Class::MOP::Object::VERSION . "-cpan:STEVAN", + "Class::MOP::Package-" . $Class::MOP::Package::VERSION . "-cpan:STEVAN", + ], + '... got all the metaclass identifiers'); + + diff --git a/t/022_attribute_duplication.t b/t/022_attribute_duplication.t new file mode 100644 index 0000000..f23d4a1 --- /dev/null +++ b/t/022_attribute_duplication.t @@ -0,0 +1,59 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 17; + +BEGIN { + use_ok('Class::MOP'); +} + +=pod + +This tests that when an attribute of the same name +is added to a class, that it will remove the old +one first. + +=cut + +{ + package Foo; + use metaclass; + + Foo->meta->add_attribute('bar' => + reader => 'get_bar', + writer => 'set_bar', + ); + + ::can_ok('Foo', 'get_bar'); + ::can_ok('Foo', 'set_bar'); + ::ok(Foo->meta->has_attribute('bar'), '... Foo has the attribute bar'); + + my $bar_attr = Foo->meta->get_attribute('bar'); + + ::is($bar_attr->reader, 'get_bar', '... the bar attribute has the reader get_bar'); + ::is($bar_attr->writer, 'set_bar', '... the bar attribute has the writer set_bar'); + ::is($bar_attr->associated_class, Foo->meta, '... and the bar attribute is associated with Foo->meta'); + + Foo->meta->add_attribute('bar' => + reader => 'assign_bar' + ); + + ::ok(!Foo->can('get_bar'), '... Foo no longer has the get_bar method'); + ::ok(!Foo->can('set_bar'), '... Foo no longer has the set_bar method'); + ::can_ok('Foo', 'assign_bar'); + ::ok(Foo->meta->has_attribute('bar'), '... Foo still has the attribute bar'); + + my $bar_attr2 = Foo->meta->get_attribute('bar'); + + ::isnt($bar_attr, $bar_attr2, '... this is a new bar attribute'); + ::isnt($bar_attr->associated_class, Foo->meta, '... and the old bar attribute is no longer associated with Foo->meta'); + + ::is($bar_attr2->associated_class, Foo->meta, '... and the new bar attribute *is* associated with Foo->meta'); + + ::isnt($bar_attr2->reader, 'get_bar', '... the bar attribute no longer has the reader get_bar'); + ::isnt($bar_attr2->reader, 'set_bar', '... the bar attribute no longer has the reader set_bar'); + ::is($bar_attr2->reader, 'assign_bar', '... the bar attribute now has the reader assign_bar'); +} +