From: Stevan Little Date: Fri, 3 Feb 2006 22:22:10 +0000 (+0000) Subject: start of the new user-level API X-Git-Tag: 0_06~17 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=2e41896ef928bb97cd490b03cd77f0280d802384;p=gitmo%2FClass-MOP.git start of the new user-level API --- diff --git a/Changes b/Changes index fbcc008..1a4f6c7 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,15 @@ Revision history for Perl extension Class-MOP. +0.05 + * Class::MOP::Class + - added the &attribute_metaclass and &method_metaclass + functions which return a metaclass name to use for + attributes/methods respectively + + * examples/ + - adjusted the example code and tests to use the new + &attribute_metaclass feature of Class::MOP::Class + 0.04 Fri Feb. 3, 2006 * Class::MOP::Class - some documentation suggestions from #perl6 diff --git a/examples/ClassEncapsulatedAttributes.pod b/examples/ClassEncapsulatedAttributes.pod index 7c19e7a..d6380e3 100644 --- a/examples/ClassEncapsulatedAttributes.pod +++ b/examples/ClassEncapsulatedAttributes.pod @@ -38,6 +38,8 @@ sub construct_instance { return $instance; } +sub attribute_metaclass { 'ClassEncapsulatedAttributes::Attribute' } + package # hide the package from PAUSE ClassEncapsulatedAttributes::Attribute; @@ -101,12 +103,10 @@ ClassEncapsulatedAttributes - A set of example metaclasses with class encapsulat sub meta { ClassEncapsulatedAttributes->initialize($_[0]) } - Foo->meta->add_attribute( - ClassEncapsulatedAttributes::Attribute->new('foo' => ( - accessor => 'Foo_foo', - default => 'init in FOO' - )) - ); + Foo->meta->add_attribute('foo' => ( + accessor => 'Foo_foo', + default => 'init in FOO' + )); sub new { my $class = shift; @@ -117,12 +117,10 @@ ClassEncapsulatedAttributes - A set of example metaclasses with class encapsulat our @ISA = ('Foo'); # duplicate the attribute name here - Bar->meta->add_attribute( - ClassEncapsulatedAttributes::Attribute->new('foo' => ( - accessor => 'Bar_foo', - default => 'init in BAR' - )) - ); + Bar->meta->add_attribute('foo' => ( + accessor => 'Bar_foo', + default => 'init in BAR' + )); # ... later in other code ... diff --git a/examples/InsideOutClass.pod b/examples/InsideOutClass.pod index dfb38d2..b371c15 100644 --- a/examples/InsideOutClass.pod +++ b/examples/InsideOutClass.pod @@ -34,6 +34,8 @@ sub construct_instance { return $instance; } +sub attribute_metaclass { 'InsideOutClass::Attribute' } + package # hide the package from PAUSE InsideOutClass::Attribute; @@ -96,12 +98,10 @@ InsideOutClass - A set of example metaclasses which implement the Inside-Out tec sub meta { InsideOutClass->initialize($_[0]) } - __PACKAGE__->meta->add_attribute( - InsideOutClass::Attribute->new('foo' => ( - reader => 'get_foo', - writer => 'set_foo' - )) - ); + __PACKAGE__->meta->add_attribute('foo' => ( + reader => 'get_foo', + writer => 'set_foo' + )); sub new { my $class = shift; diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index 303137f..74d76b4 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -11,7 +11,7 @@ use Class::MOP::Class; use Class::MOP::Attribute; use Class::MOP::Method; -our $VERSION = '0.04'; +our $VERSION = '0.05'; sub import { shift; diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index ecf8f5d..6ebd6d1 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -9,7 +9,7 @@ use Scalar::Util 'blessed', 'reftype'; use Sub::Name 'subname'; use B 'svref_2object'; -our $VERSION = '0.01'; +our $VERSION = '0.02'; # Self-introspection @@ -146,6 +146,9 @@ sub class_precedence_list { ## Methods +# un-used right now ... +sub method_metaclass { 'Class::MOP::Method' } + sub add_method { my ($self, $method_name, $method) = @_; (defined $method_name && $method_name) @@ -266,10 +269,16 @@ sub find_all_methods_by_name { ## Attributes +sub attribute_metaclass { 'Class::MOP::Attribute' } + sub add_attribute { - my ($self,$attribute) = @_; - (blessed($attribute) && $attribute->isa('Class::MOP::Attribute')) - || confess "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)"; + my $self = shift; + # either we have an attribute object already + # or we need to create one from the args provided + my $attribute = blessed($_[0]) ? $_[0] : $self->attribute_metaclass->new(@_); + # 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)"; $attribute->attach_to_class($self); $attribute->install_accessors(); $self->{'%:attrs'}->{$attribute->name} = $attribute; @@ -558,6 +567,8 @@ what B does, but we don't remove duplicate names. =over 4 +=item B + =item B This will take a C<$method_name> and CODE reference to that @@ -644,6 +655,8 @@ their own. See L for more details. =over 4 +=item B + =item B This stores a C<$attribute_meta_object> in the B diff --git a/t/013_add_attribute_alternate.t b/t/013_add_attribute_alternate.t new file mode 100644 index 0000000..8b168c6 --- /dev/null +++ b/t/013_add_attribute_alternate.t @@ -0,0 +1,108 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 27; +use Test::Exception; + +BEGIN { + use_ok('Class::MOP', ':universal'); +} + +{ + package Point; + + Point->meta->add_attribute('$.x' => ( + reader => 'x', + init_arg => 'x' + )); + + Point->meta->add_attribute('$.y' => ( + accessor => 'y', + init_arg => 'y' + )); + + sub new { + my $class = shift; + bless $class->meta->construct_instance(@_) => $class; + } + + sub clear { + my $self = shift; + $self->{'$.x'} = 0; + $self->{'$.y'} = 0; + } + + package Point3D; + our @ISA = ('Point'); + + Point3D->meta->add_attribute('$:z' => ( + default => 123 + )); + + sub clear { + my $self = shift; + $self->{'$:z'} = 0; + $self->SUPER::clear(); + } +} + +isa_ok(Point->meta, 'Class::MOP::Class'); +isa_ok(Point3D->meta, 'Class::MOP::Class'); + +# ... test the classes themselves + +my $point = Point->new('x' => 2, 'y' => 3); +isa_ok($point, 'Point'); + +can_ok($point, 'x'); +can_ok($point, 'y'); +can_ok($point, 'clear'); + +{ + my $meta = $point->meta; + is($meta, Point->meta(), '... got the meta from the instance too'); +} + +is($point->y, 3, '... the $.y attribute was initialized correctly through the metaobject'); + +$point->y(42); +is($point->y, 42, '... the $.y attribute was set properly with the accessor'); + +is($point->x, 2, '... the $.x attribute was initialized correctly through the metaobject'); + +$point->x(42); +is($point->x, 2, '... the $.x attribute was not altered'); + +$point->clear(); + +is($point->y, 0, '... the $.y attribute was cleared correctly'); +is($point->x, 0, '... the $.x attribute was cleared correctly'); + +my $point3d = Point3D->new('x' => 1, 'y' => 2, '$:z' => 3); +isa_ok($point3d, 'Point3D'); +isa_ok($point3d, 'Point'); + +{ + my $meta = $point3d->meta; + is($meta, Point3D->meta(), '... got the meta from the instance too'); +} + +can_ok($point3d, 'x'); +can_ok($point3d, 'y'); +can_ok($point3d, 'clear'); + +is($point3d->x, 1, '... the $.x attribute was initialized correctly through the metaobject'); +is($point3d->y, 2, '... the $.y attribute was initialized correctly through the metaobject'); +is($point3d->{'$:z'}, 3, '... the $:z attribute was initialized correctly through the metaobject'); + +{ + my $point3d = Point3D->new(); + isa_ok($point3d, 'Point3D'); + + is($point3d->x, undef, '... the $.x attribute was not initialized'); + is($point3d->y, undef, '... the $.y attribute was not initialized'); + is($point3d->{'$:z'}, 123, '... the $:z attribute was initialized correctly through the metaobject'); + +} diff --git a/t/102_InsideOutClass_test.t b/t/102_InsideOutClass_test.t index 6510ca7..fb7581e 100644 --- a/t/102_InsideOutClass_test.t +++ b/t/102_InsideOutClass_test.t @@ -16,20 +16,16 @@ BEGIN { sub meta { InsideOutClass->initialize($_[0]) } - Foo->meta->add_attribute( - InsideOutClass::Attribute->new('foo' => ( - accessor => 'foo', - predicate => 'has_foo', - )) - ); + Foo->meta->add_attribute('foo' => ( + accessor => 'foo', + predicate => 'has_foo', + )); - Foo->meta->add_attribute( - InsideOutClass::Attribute->new('bar' => ( - reader => 'get_bar', - writer => 'set_bar', - default => 'FOO is BAR' - )) - ); + Foo->meta->add_attribute('bar' => ( + reader => 'get_bar', + writer => 'set_bar', + default => 'FOO is BAR' + )); sub new { my $class = shift; diff --git a/t/105_ClassEncapsulatedAttributes_test.t b/t/105_ClassEncapsulatedAttributes_test.t index 199b4c2..47952e6 100644 --- a/t/105_ClassEncapsulatedAttributes_test.t +++ b/t/105_ClassEncapsulatedAttributes_test.t @@ -16,21 +16,17 @@ BEGIN { sub meta { ClassEncapsulatedAttributes->initialize($_[0]) } - Foo->meta->add_attribute( - ClassEncapsulatedAttributes::Attribute->new('foo' => ( - accessor => 'foo', - predicate => 'has_foo', - default => 'init in FOO' - )) - ); + Foo->meta->add_attribute('foo' => ( + accessor => 'foo', + predicate => 'has_foo', + default => 'init in FOO' + )); - Foo->meta->add_attribute( - ClassEncapsulatedAttributes::Attribute->new('bar' => ( - reader => 'get_bar', - writer => 'set_bar', - default => 'init in FOO' - )) - ); + Foo->meta->add_attribute('bar' => ( + reader => 'get_bar', + writer => 'set_bar', + default => 'init in FOO' + )); sub new { my $class = shift; @@ -40,21 +36,17 @@ BEGIN { package Bar; our @ISA = ('Foo'); - Bar->meta->add_attribute( - ClassEncapsulatedAttributes::Attribute->new('foo' => ( - accessor => 'foo', - predicate => 'has_foo', - default => 'init in BAR' - )) - ); + Bar->meta->add_attribute('foo' => ( + accessor => 'foo', + predicate => 'has_foo', + default => 'init in BAR' + )); - Bar->meta->add_attribute( - ClassEncapsulatedAttributes::Attribute->new('bar' => ( - reader => 'get_bar', - writer => 'set_bar', - default => 'init in BAR' - )) - ); + Bar->meta->add_attribute('bar' => ( + reader => 'get_bar', + writer => 'set_bar', + default => 'init in BAR' + )); sub SUPER_foo { (shift)->SUPER::foo(@_) } sub SUPER_has_foo { (shift)->SUPER::foo(@_) }