From: Stevan Little Date: Mon, 30 Jan 2006 19:12:07 +0000 (+0000) Subject: Class::MOP - getting there X-Git-Tag: 0_02~16 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=2eb717d56ee2a062202c58c415f4e56bcb90b40a;p=gitmo%2FClass-MOP.git Class::MOP - getting there --- diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index ce1b6e6..2e04e05 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -6,13 +6,21 @@ use warnings; use Scalar::Util 'blessed'; +use Class::MOP::Class; +use Class::MOP::Attribute; +use Class::MOP::Method; + our $VERSION = '0.01'; -# my %METAS; -# sub UNIVERSAL::meta { -# my $class = blessed($_[0]) || $_[0]; -# $METAS{$class} ||= Class::MOP::Class->initialize($class) -# } +sub import { + shift; + return unless @_; + if ($_[0] eq ':universal') { + *UNIVERSAL::meta = sub { + Class::MOP::Class->initialize(blessed($_[0]) || $_[0]) + }; + } +} 1; @@ -26,7 +34,11 @@ Class::MOP - A Meta Object Protocol for Perl 5 =head1 SYNOPSIS - # ... coming soon + use Class::MOP ':universal'; + + package Foo; + + Foo->meta->add_method('foo' => sub { ... }); =head1 DESCRIPTON @@ -77,16 +89,18 @@ of method dispatch. =head2 What changes do I have to make to use this module? -This module was designed to be as unintrusive as possible. So many of +This module was designed to be as unintrusive as possible. Many of it's features are accessible without B change to your existsing code at all. It is meant to be a compliment to your existing code and -not an intrusion on your code base. +not an intrusion on your code base. Unlike many other B +modules, this module does require you subclass it, or even that you +C it in within your module's package. -The only feature which requires additions to your code are the -attribute handling and instance construction features. The only reason -for this is because Perl 5's object system does not actually have -these features built in. More information about this feature can be -found below. +The only features which requires additions to your code are the +attribute handling and instance construction features, and these are +both optional features as well. The only reason for this is because +Perl 5's object system does not actually have these features built +in. More information about this feature can be found below. =head2 A Note about Performance? @@ -101,9 +115,9 @@ designed into the language and runtime (the CLR). In contrast, CLOS and so performance is tuned for it. This library in particular does it's absolute best to avoid putting -B drain at all upon your code's performance, while still trying -to make sure it is fast as well (although only as a secondary -concern). +B drain at all upon your code's performance. In fact, by itself +it does nothing to affect your existing code. So you only pay for +what you actually use. =head1 PROTOCOLS diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm index 3ed1f23..6cfeff7 100644 --- a/lib/Class/MOP/Attribute.pm +++ b/lib/Class/MOP/Attribute.pm @@ -4,10 +4,16 @@ package Class::MOP::Attribute; use strict; use warnings; -use Carp 'confess'; +use Carp 'confess'; +use Scalar::Util 'blessed'; + +use Class::MOP::Class; +use Class::MOP::Method; our $VERSION = '0.01'; +sub meta { Class::MOP::Class->initialize($_[0]) } + sub new { my $class = shift; my $name = shift; @@ -15,7 +21,10 @@ sub new { (defined $name && $name ne '') || confess "You must provide a name for the attribute"; - + (!exists $options{reader} && !exists $options{writer}) + || confess "You cannot declare an accessor and reader and/or writer functions" + if exists $options{accessor}; + bless { name => $name, accessor => $options{accessor}, @@ -43,11 +52,65 @@ sub init_arg { (shift)->{init_arg} } sub has_default { (shift)->{default} ? 1 : 0 } sub default { (shift)->{default} } -sub generate_accessor { - my $self = shift; - # ... +sub install_accessors { + my ($self, $class) = @_; + (blessed($class) && $class->isa('Class::MOP::Class')) + || confess "You must pass a Class::MOP::Class instance (or a subclass)"; + + if ($self->has_accessor()) { + $class->add_method($self->accessor() => Class::MOP::Attribute::Accessor->wrap(sub { + $_[0]->{$self->name} = $_[1] if scalar(@_) == 2; + $_[0]->{$self->name}; + })); + } + else { + if ($self->has_reader()) { + $class->add_method($self->reader() => Class::MOP::Attribute::Accessor->wrap(sub { + $_[0]->{$self->name}; + })); + } + if ($self->has_writer()) { + $class->add_method($self->writer() => Class::MOP::Attribute::Accessor->wrap(sub { + $_[0]->{$self->name} = $_[1]; + return; + })); + } + } +} + +sub remove_accessors { + my ($self, $class) = @_; + (blessed($class) && $class->isa('Class::MOP::Class')) + || confess "You must pass a Class::MOP::Class instance (or a subclass)"; + + if ($self->has_accessor()) { + my $method = $class->get_method($self->accessor); + $class->remove_method($self->accessor) + if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor')); + } + else { + if ($self->has_reader()) { + my $method = $class->get_method($self->reader); + $class->remove_method($self->reader) + if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor')); + } + if ($self->has_writer()) { + my $method = $class->get_method($self->writer); + $class->remove_method($self->writer) + if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor')); + } + } } +package Class::MOP::Attribute::Accessor; + +use strict; +use warnings; + +our $VERSION = '0.01'; + +our @ISA = ('Class::MOP::Method'); + 1; __END__ @@ -144,11 +207,23 @@ otherwise. =over 4 -=item B +=item B + +This allows the attribute to generate and install code for it's own +accessor methods. This is called by C. + +=item B + +This allows the attribute to remove the method for it's own +accessor. This is called by C. + +=back + +=head2 Introspection + +=over 4 -This allows the attribute to generate code for it's own accessor -methods. This is mostly part of an internal protocol between the class -and it's own attributes, see the C method above. +=item B =back diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 107734d..cf0d160 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -11,6 +11,10 @@ use B 'svref_2object'; our $VERSION = '0.01'; +# Self-introspection + +sub meta { $_[0]->initialize($_[0]) } + # Creation { @@ -42,11 +46,21 @@ sub create { my $meta = $class->initialize($package_name); $meta->superclasses(@{$options{superclasses}}) if exists $options{superclasses}; + # NOTE: + # process attributes first, so that they can + # install accessors, but locally defined methods + # can then overwrite them. It is maybe a little odd, but + # I think this should be the order of things. + if (exists $options{attributes}) { + foreach my $attr_name (keys %{$options{attributes}}) { + $meta->add_attribute($attr_name, $options{attributes}->{$attr_name}); + } + } if (exists $options{methods}) { foreach my $method_name (keys %{$options{methods}}) { $meta->add_method($method_name, $options{methods}->{$method_name}); } - } + } return $meta; } @@ -115,8 +129,8 @@ sub add_method { { ## private utility functions for has_method - my $_find_subroutine_package_name = sub { eval { svref_2object($_[0])->GV->STASH->NAME } }; - my $_find_subroutine_name = sub { eval { svref_2object($_[0])->GV->NAME } }; + my $_find_subroutine_package_name = sub { eval { svref_2object($_[0])->GV->STASH->NAME } || '' }; + my $_find_subroutine_name = sub { eval { svref_2object($_[0])->GV->NAME } || '' }; sub has_method { my ($self, $method_name) = @_; @@ -219,12 +233,11 @@ sub find_all_methods_by_name { ## Attributes sub add_attribute { - my ($self, $attribute_name, $attribute) = @_; - (defined $attribute_name && $attribute_name) - || confess "You must define an attribute name"; + my ($self,$attribute) = @_; (blessed($attribute) && $attribute->isa('Class::MOP::Attribute')) || confess "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)"; - $self->{'%:attrs'}->{$attribute_name} = $attribute; + $attribute->install_accessors($self); + $self->{'%:attrs'}->{$attribute->name} = $attribute; } sub has_attribute { @@ -249,6 +262,7 @@ sub remove_attribute { my $removed_attribute = $self->{'%:attrs'}->{$attribute_name}; delete $self->{'%:attrs'}->{$attribute_name} if defined $removed_attribute; + $removed_attribute->remove_accessors($self); return $removed_attribute; } @@ -282,10 +296,7 @@ sub compute_all_applicable_attributes { } return @attrs; } - -sub create_all_accessors { - -} + 1; @@ -303,6 +314,16 @@ Class::MOP::Class - Class Meta Object =head1 METHODS +=head2 Self Introspection + +=over 4 + +=item B + +This allows Class::MOP::Class to actually introspect itself. + +=back + =head2 Class construction These methods handle creating Class objects, which can be used to @@ -507,13 +528,7 @@ This will traverse the inheritance heirachy and return a list of HASH references for all the applicable attributes for this class. The HASH references will contain the following information; the attribute name, the class which the attribute is associated with and the actual -attribute meta-object - -=item B - -This will communicate with all of the classes attributes to create -and install the appropriate accessors. (see L -below for more details). +attribute meta-object. =back diff --git a/lib/Class/MOP/Method.pm b/lib/Class/MOP/Method.pm index 56772f7..874159a 100644 --- a/lib/Class/MOP/Method.pm +++ b/lib/Class/MOP/Method.pm @@ -4,7 +4,24 @@ package Class::MOP::Method; use strict; use warnings; +use Carp 'confess'; +use Scalar::Util 'reftype'; + +use Class::MOP::Class; + our $VERSION = '0.01'; + +sub meta { Class::MOP::Class->initialize($_[0]) } + +sub wrap { + my $class = shift; + my $code = shift; + + (reftype($code) && reftype($code) eq 'CODE') + || confess "You must supply a CODE reference to wrap"; + + bless $code => $class; +} 1; @@ -25,6 +42,16 @@ subroutines within the particular package. Basically all we do is to bless the subroutine and provide some very simple introspection methods for it. +=head1 METHODS + +=over 4 + +=item B + +=item B + +=back + =head1 AUTHOR Stevan Little Estevan@iinteractive.comE diff --git a/t/005_attributes.t b/t/005_attributes.t new file mode 100644 index 0000000..cb93fae --- /dev/null +++ b/t/005_attributes.t @@ -0,0 +1,92 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More no_plan => 1; +use Test::Exception; + +BEGIN { + use_ok('Class::MOP', ':universal'); +} + +my $FOO_ATTR = Class::MOP::Attribute->new('$foo'); +my $BAR_ATTR = Class::MOP::Attribute->new('$bar' => ( + accessor => 'bar' +)); +my $BAZ_ATTR = Class::MOP::Attribute->new('$baz' => ( + reader => 'get_baz', + writer => 'set_baz', +)); + +{ + package Foo; + + my $meta = __PACKAGE__->meta; + ::lives_ok { + $meta->add_attribute($FOO_ATTR); + } '... we added an attribute to Foo successfully'; + ::ok($meta->has_attribute('$foo'), '... Foo has $foo attribute'); + ::is($meta->get_attribute('$foo'), $FOO_ATTR, '... got the right attribute back for Foo'); + + ::ok(!$meta->has_method('foo'), '... no accessor created'); +} +{ + package Bar; + our @ISA = ('Foo'); + + my $meta = __PACKAGE__->meta; + ::lives_ok { + $meta->add_attribute($BAR_ATTR); + } '... we added an attribute to Bar successfully'; + ::ok($meta->has_attribute('$bar'), '... Bar has $bar attribute'); + ::is($meta->get_attribute('$bar'), $BAR_ATTR, '... got the right attribute back for Bar'); + + ::ok($meta->has_method('bar'), '... an accessor has been created'); + ::isa_ok($meta->get_method('bar'), 'Class::MOP::Attribute::Accessor'); +} +{ + package Baz; + our @ISA = ('Bar'); + + my $meta = __PACKAGE__->meta; + ::lives_ok { + $meta->add_attribute($BAZ_ATTR); + } '... we added an attribute to Baz successfully'; + ::ok($meta->has_attribute('$baz'), '... Baz has $baz attribute'); + ::is($meta->get_attribute('$baz'), $BAZ_ATTR, '... got the right attribute back for Baz'); + + ::ok($meta->has_method('get_baz'), '... a reader has been created'); + ::ok($meta->has_method('set_baz'), '... a writer has been created'); + + ::isa_ok($meta->get_method('get_baz'), 'Class::MOP::Attribute::Accessor'); + ::isa_ok($meta->get_method('set_baz'), 'Class::MOP::Attribute::Accessor'); +} + +{ + my $meta = Baz->meta; + isa_ok($meta, 'Class::MOP::Class'); + + is_deeply( + [ sort { $a->{name} cmp $b->{name} } $meta->compute_all_applicable_attributes() ], + [ + { + name => '$bar', + class => 'Bar', + attribute => $BAR_ATTR + }, + { + name => '$baz', + class => 'Baz', + attribute => $BAZ_ATTR + }, + { + name => '$foo', + class => 'Foo', + attribute => $FOO_ATTR + }, + ], + '... got the right list of applicable attributes for Baz'); +} + + diff --git a/t/010_self_introspection.t b/t/010_self_introspection.t index f73e89d..314afe3 100644 --- a/t/010_self_introspection.t +++ b/t/010_self_introspection.t @@ -10,10 +10,12 @@ BEGIN { use_ok('Class::MOP::Class'); } -my $meta = Class::MOP::Class->initialize('Class::MOP::Class'); +my $meta = Class::MOP::Class->meta(); isa_ok($meta, 'Class::MOP::Class'); foreach my $method_name (qw( + meta + initialize create name version @@ -24,7 +26,7 @@ foreach my $method_name (qw( get_method_list compute_all_applicable_methods find_all_methods_by_name has_attribute get_attribute add_attribute remove_attribute - get_attribute_list compute_all_applicable_attributes create_all_accessors + get_attribute_list compute_all_applicable_attributes )) { ok($meta->has_method($method_name), '... Class::MOP::Class->has_method(' . $method_name . ')'); { @@ -35,6 +37,15 @@ foreach my $method_name (qw( } } +foreach my $non_method_name (qw( + confess + blessed reftype + subname + svref_2object + )) { + ok(!$meta->has_method($non_method_name), '... NOT Class::MOP::Class->has_method(' . $non_method_name . ')'); +} + is($meta->name, 'Class::MOP::Class', '... Class::MOP::Class->name'); is($meta->version, $Class::MOP::Class::VERSION, '... Class::MOP::Class->version'); diff --git a/t/020_attribute.t b/t/020_attribute.t new file mode 100644 index 0000000..57b1917 --- /dev/null +++ b/t/020_attribute.t @@ -0,0 +1,133 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More no_plan => 1; +use Test::Exception; + +BEGIN { + use_ok('Class::MOP::Attribute'); +} + +{ + my $attr = Class::MOP::Attribute->new('$foo'); + isa_ok($attr, 'Class::MOP::Attribute'); + + is($attr->name, '$foo', '... $attr->name == $foo'); + + ok(!$attr->has_accessor, '... $attr does not have an accessor'); + ok(!$attr->has_reader, '... $attr does not have an reader'); + ok(!$attr->has_writer, '... $attr does not have an writer'); + ok(!$attr->has_init_arg, '... $attr does not have an init_arg'); + ok(!$attr->has_default, '... $attr does not have an default'); +} + +{ + my $attr = Class::MOP::Attribute->new('$foo', ( + init_arg => '-foo', + default => 'BAR' + )); + isa_ok($attr, 'Class::MOP::Attribute'); + + is($attr->name, '$foo', '... $attr->name == $foo'); + + ok($attr->has_init_arg, '... $attr does have an init_arg'); + is($attr->init_arg, '-foo', '... $attr->init_arg == -foo'); + ok($attr->has_default, '... $attr does have an default'); + is($attr->default, 'BAR', '... $attr->default == BAR'); + + ok(!$attr->has_accessor, '... $attr does not have an accessor'); + ok(!$attr->has_reader, '... $attr does not have an reader'); + ok(!$attr->has_writer, '... $attr does not have an writer'); +} + +{ + my $attr = Class::MOP::Attribute->new('$foo', ( + accessor => 'foo', + init_arg => '-foo', + default => 'BAR' + )); + isa_ok($attr, 'Class::MOP::Attribute'); + + is($attr->name, '$foo', '... $attr->name == $foo'); + + ok($attr->has_init_arg, '... $attr does have an init_arg'); + is($attr->init_arg, '-foo', '... $attr->init_arg == -foo'); + ok($attr->has_default, '... $attr does have an default'); + is($attr->default, 'BAR', '... $attr->default == BAR'); + + ok($attr->has_accessor, '... $attr does have an accessor'); + is($attr->accessor, 'foo', '... $attr->accessor == foo'); + + ok(!$attr->has_reader, '... $attr does not have an reader'); + ok(!$attr->has_writer, '... $attr does not have an writer'); +} + +{ + my $attr = Class::MOP::Attribute->new('$foo', ( + reader => 'get_foo', + writer => 'set_foo', + init_arg => '-foo', + default => 'BAR' + )); + isa_ok($attr, 'Class::MOP::Attribute'); + + is($attr->name, '$foo', '... $attr->name == $foo'); + + ok($attr->has_init_arg, '... $attr does have an init_arg'); + is($attr->init_arg, '-foo', '... $attr->init_arg == -foo'); + ok($attr->has_default, '... $attr does have an default'); + is($attr->default, 'BAR', '... $attr->default == BAR'); + + ok($attr->has_reader, '... $attr does have an reader'); + is($attr->reader, 'get_foo', '... $attr->reader == get_foo'); + ok($attr->has_writer, '... $attr does have an writer'); + is($attr->writer, 'set_foo', '... $attr->writer == set_foo'); + + ok(!$attr->has_accessor, '... $attr does not have an accessor'); +} + +dies_ok { + my $attr = Class::MOP::Attribute->new('$foo', ( + accessor => 'foo', + reader => 'get_foo', + )); +} '... cannot create accessors with reader/writers'; + +dies_ok { + my $attr = Class::MOP::Attribute->new('$foo', ( + accessor => 'foo', + writer => 'set_foo', + )); +} '... cannot create accessors with reader/writers'; + +dies_ok { + my $attr = Class::MOP::Attribute->new('$foo', ( + accessor => 'foo', + reader => 'get_foo', + writer => 'set_foo', + )); +} '... cannot create accessors with reader/writers'; + + +{ + my $meta = Class::MOP::Attribute->meta(); + isa_ok($meta, 'Class::MOP::Class'); + + foreach my $method_name (qw( + meta + new + has_accessor accessor + has_writer writer + has_reader reader + has_init_arg init_arg + has_default default + install_accessors + remove_accessors + )) { + ok($meta->has_method($method_name), '... Class::MOP::Attribute->has_method(' . $method_name . ')'); + } + + +}