From: Stevan Little Date: Sat, 29 Apr 2006 17:31:18 +0000 (+0000) Subject: refactoring-n-tests X-Git-Tag: 0_29_02~28 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f892c0f0fa293dff33f6b20826493c089a69218e;p=gitmo%2FClass-MOP.git refactoring-n-tests --- diff --git a/examples/ArrayBasedInstance.pod b/examples/ArrayBasedStorage.pod similarity index 67% rename from examples/ArrayBasedInstance.pod rename to examples/ArrayBasedStorage.pod index 19a4815..284e558 100644 --- a/examples/ArrayBasedInstance.pod +++ b/examples/ArrayBasedStorage.pod @@ -1,6 +1,6 @@ package # hide the package from PAUSE - ArrayBasedInstance::Attribute; + ArrayBasedStorage::Attribute; use strict; use warnings; @@ -15,7 +15,7 @@ sub generate_accessor_method { my $self = shift; my $attr_name = $self->name; return sub { - my $meta_instance = $self->associated_class->get_meta_instance; + my $meta_instance = $_[0]->meta->get_meta_instance; $meta_instance->set_slot_value($_[0], $attr_name, $_[1]) if scalar(@_) == 2; $meta_instance->get_slot_value($_[0], $attr_name); }; @@ -26,8 +26,9 @@ sub generate_reader_method { my $attr_name = $self->name; return sub { confess "Cannot assign a value to a read-only accessor" if @_ > 1; - my $meta_instance = $self->associated_class->get_meta_instance; - $meta_instance->get_slot_value($_[0], $attr_name); + $_[0]->meta + ->get_meta_instance + ->get_slot_value($_[0], $attr_name); }; } @@ -35,22 +36,24 @@ sub generate_writer_method { my $self = shift; my $attr_name = $self->name; return sub { - my $meta_instance = $self->associated_class->get_meta_instance; - $meta_instance->set_slot_value($_[0], $attr_name, $_[1]); + $_[0]->meta + ->get_meta_instance + ->set_slot_value($_[0], $attr_name, $_[1]); }; } sub generate_predicate_method { my $self = shift; my $attr_name = $self->name; - return sub { - my $meta_instance = $self->associated_class->get_meta_instance; - defined $meta_instance->get_slot_value($_[0], $attr_name) ? 1 : 0; + return sub { + defined $_[0]->meta + ->get_meta_instance + ->get_slot_value($_[0], $attr_name) ? 1 : 0; }; } package # hide the package from PAUSE - ArrayBasedInstance::Instance; + ArrayBasedStorage::Instance; use strict; use warnings; @@ -111,12 +114,34 @@ __END__ =head1 NAME -ArrayBasedInstance - An example of an Array based instance +ArrayBasedStorage - An example of an Array based instance storage =head1 SYNOPSIS + package Foo; + + use metaclass 'Class::MOP::Class' => ( + ':attribute_metaclass' => 'ArrayBasedStorage::Attribute' + ':instance_metaclass' => 'ArrayBasedStorage::Instance' + ); + + __PACKAGE__->meta->add_attribute('foo' => ( + reader => 'get_foo', + writer => 'set_foo' + )); + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } + + # now you can just use the class as normal + =head1 DESCRIPTION +This is a proof of concept using the Instance sub-protocol +which uses ARRAY refs to store the instance data. + =head1 AUTHOR Stevan Little Estevan@iinteractive.comE diff --git a/examples/ClassEncapsulatedAttributes.pod b/examples/ClassEncapsulatedAttributes.pod index 49ef294..c1b91b5 100644 --- a/examples/ClassEncapsulatedAttributes.pod +++ b/examples/ClassEncapsulatedAttributes.pod @@ -19,14 +19,15 @@ sub initialize { sub construct_instance { my ($class, %params) = @_; - my $instance = $class->get_meta_instance->create_instance(); + my $meta_instance = $class->get_meta_instance; + my $instance = $meta_instance->create_instance(); # initialize *ALL* attributes, including masked ones (as opposed to applicable) foreach my $current_class ($class->class_precedence_list()) { my $meta = $current_class->meta; foreach my $attr_name ($meta->get_attribute_list()) { my $attr = $meta->get_attribute($attr_name); - $attr->initialize_instance_slot($instance, \%params); + $attr->initialize_instance_slot($meta_instance, $instance, \%params); } } @@ -45,7 +46,7 @@ use base 'Class::MOP::Attribute'; # alter the way parameters are specified sub initialize_instance_slot { - my ($self, $instance, $params) = @_; + my ($self, $meta_instance, $instance, $params) = @_; # if the attr has an init_arg, use that, otherwise, # use the attributes name itself as the init_arg my $init_arg = $self->init_arg(); @@ -62,9 +63,7 @@ sub initialize_instance_slot { } # now add this to the instance structure - $self->associated_class - ->get_meta_instance - ->set_slot_value($instance, $self->name, $val); + $meta_instance->set_slot_value($instance, $self->name, $val); } sub name { diff --git a/examples/InsideOutClass.pod b/examples/InsideOutClass.pod index 62c1004..d78ce24 100644 --- a/examples/InsideOutClass.pod +++ b/examples/InsideOutClass.pod @@ -1,5 +1,58 @@ package # hide the package from PAUSE + InsideOutClass::Attribute; + +use strict; +use warnings; + +use Carp 'confess'; + +our $VERSION = '0.01'; + +use base 'Class::MOP::Attribute'; + +sub generate_accessor_method { + my $self = shift; + my $attr_name = $self->name; + return sub { + my $meta_instance = $_[0]->meta->get_meta_instance; + $meta_instance->set_slot_value($_[0], $attr_name, $_[1]) if scalar(@_) == 2; + $meta_instance->get_slot_value($_[0], $attr_name); + }; +} + +sub generate_reader_method { + my $self = shift; + my $attr_name = $self->name; + return sub { + confess "Cannot assign a value to a read-only accessor" if @_ > 1; + $_[0]->meta + ->get_meta_instance + ->get_slot_value($_[0], $attr_name); + }; +} + +sub generate_writer_method { + my $self = shift; + my $attr_name = $self->name; + return sub { + $_[0]->meta + ->get_meta_instance + ->set_slot_value($_[0], $attr_name, $_[1]); + }; +} + +sub generate_predicate_method { + my $self = shift; + my $attr_name = $self->name; + return sub { + defined $_[0]->meta + ->get_meta_instance + ->get_slot_value($_[0], $attr_name) ? 1 : 0; + }; +} + +package # hide the package from PAUSE InsideOutClass::Instance; use strict; @@ -40,8 +93,6 @@ sub is_slot_initialized { return exists $self->{meta}->get_package_variable('%' . $slot_name)->{refaddr $instance} ? 1 : 0; } -## &remove_slot is left as an exercise for the reader :) - 1; __END__ diff --git a/examples/LazyClass.pod b/examples/LazyClass.pod index 6d6017d..b4c308c 100644 --- a/examples/LazyClass.pod +++ b/examples/LazyClass.pod @@ -12,7 +12,7 @@ our $VERSION = '0.04'; use base 'Class::MOP::Attribute'; sub initialize_instance_slot { - my ($self, $instance, $params) = @_; + my ($self, $meta_instance, $instance, $params) = @_; # if the attr has an init_arg, use that, otherwise, # use the attributes name itself as the init_arg @@ -20,9 +20,7 @@ sub initialize_instance_slot { if ( exists $params->{$init_arg} ) { my $val = $params->{$init_arg}; - $self->associated_class - ->get_meta_instance - ->set_slot_value($instance, $self->name, $val); + $meta_instance->set_slot_value($instance, $self->name, $val); } } diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm index bb41bd7..284d2b9 100644 --- a/lib/Class/MOP/Attribute.pm +++ b/lib/Class/MOP/Attribute.pm @@ -61,7 +61,7 @@ sub clone { } sub initialize_instance_slot { - my ($self, $instance, $params) = @_; + my ($self, $meta_instance, $instance, $params) = @_; my $init_arg = $self->{init_arg}; # try to fetch the init arg from the %params ... my $val; @@ -71,9 +71,7 @@ sub initialize_instance_slot { if (!defined $val && defined $self->{default}) { $val = $self->default($instance); } - $self->associated_class - ->get_meta_instance - ->set_slot_value($instance, $self->name, $val); + $meta_instance->set_slot_value($instance, $self->name, $val); } # NOTE: diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 06246b6..a95d0b8 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -183,7 +183,7 @@ sub construct_instance { my $instance = $meta_instance->create_instance(); $meta_instance->initialize_all_slots($instance); foreach my $attr ($class->compute_all_applicable_attributes()) { - $attr->initialize_instance_slot($instance, \%params); + $attr->initialize_instance_slot($meta_instance, $instance, \%params); } return $instance; } diff --git a/t/102_InsideOutClass_test.t b/t/102_InsideOutClass_test.t index 41942c1..5a486ff 100644 --- a/t/102_InsideOutClass_test.t +++ b/t/102_InsideOutClass_test.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 19; +use Test::More tests => 65; use File::Spec; BEGIN { @@ -14,8 +14,12 @@ BEGIN { { package Foo; + use strict; + use warnings; + use metaclass 'Class::MOP::Class' => ( - ':instance_metaclass' => 'InsideOutClass::Instance' + ':attribute_metaclass' => 'InsideOutClass::Attribute', + ':instance_metaclass' => 'InsideOutClass::Instance' ); Foo->meta->add_attribute('foo' => ( @@ -33,6 +37,39 @@ BEGIN { my $class = shift; $class->meta->new_object(@_); } + + package Bar; + + use strict; + use warnings; + + use base 'Foo'; + + Bar->meta->add_attribute('baz' => ( + accessor => 'baz', + predicate => 'has_baz', + )); + + package Baz; + + use strict; + use warnings; + use metaclass 'Class::MOP::Class' => ( + ':attribute_metaclass' => 'InsideOutClass::Attribute', + ':instance_metaclass' => 'InsideOutClass::Instance' + ); + + Baz->meta->add_attribute('bling' => ( + accessor => 'bling', + default => 'Baz::bling' + )); + + package Bar::Baz; + + use strict; + use warnings; + + use base 'Bar', 'Baz'; } my $foo = Foo->new(); @@ -66,3 +103,75 @@ $foo2->set_bar('DONT PANIC'); is($foo2->get_bar(), 'DONT PANIC', '... Foo2::bar == DONT PANIC'); is($foo->get_bar(), 42, '... Foo::bar == 42'); + +# now Bar ... + +my $bar = Bar->new(); +isa_ok($bar, 'Bar'); +isa_ok($bar, 'Foo'); + +can_ok($bar, 'foo'); +can_ok($bar, 'has_foo'); +can_ok($bar, 'get_bar'); +can_ok($bar, 'set_bar'); +can_ok($bar, 'baz'); +can_ok($bar, 'has_baz'); + +ok(!$bar->has_foo, '... Bar::foo is not defined yet'); +is($bar->foo(), undef, '... Bar::foo is not defined yet'); +is($bar->get_bar(), 'FOO is BAR', '... Bar::bar has been initialized'); +ok(!$bar->has_baz, '... Bar::baz is not defined yet'); +is($bar->baz(), undef, '... Bar::baz is not defined yet'); + +$bar->foo('This is Bar::foo'); + +ok($bar->has_foo, '... Bar::foo is defined now'); +is($bar->foo(), 'This is Bar::foo', '... Bar::foo == "This is Bar"'); +is($bar->get_bar(), 'FOO is BAR', '... Bar::bar has been initialized'); + +$bar->baz('This is Bar::baz'); + +ok($bar->has_baz, '... Bar::baz is defined now'); +is($bar->baz(), 'This is Bar::baz', '... Bar::foo == "This is Bar"'); +is($bar->foo(), 'This is Bar::foo', '... Bar::foo == "This is Bar"'); +is($bar->get_bar(), 'FOO is BAR', '... Bar::bar has been initialized'); + +# now Baz ... + +my $baz = Bar::Baz->new(); +isa_ok($baz, 'Bar::Baz'); +isa_ok($baz, 'Bar'); +isa_ok($baz, 'Foo'); +isa_ok($baz, 'Baz'); + +can_ok($baz, 'foo'); +can_ok($baz, 'has_foo'); +can_ok($baz, 'get_bar'); +can_ok($baz, 'set_bar'); +can_ok($baz, 'baz'); +can_ok($baz, 'has_baz'); +can_ok($baz, 'bling'); + +is($baz->get_bar(), 'FOO is BAR', '... Bar::Baz::bar has been initialized'); +is($baz->bling(), 'Baz::bling', '... Bar::Baz::bling has been initialized'); + +ok(!$baz->has_foo, '... Bar::Baz::foo is not defined yet'); +is($baz->foo(), undef, '... Bar::Baz::foo is not defined yet'); +ok(!$baz->has_baz, '... Bar::Baz::baz is not defined yet'); +is($baz->baz(), undef, '... Bar::Baz::baz is not defined yet'); + +$baz->foo('This is Bar::Baz::foo'); + +ok($baz->has_foo, '... Bar::Baz::foo is defined now'); +is($baz->foo(), 'This is Bar::Baz::foo', '... Bar::Baz::foo == "This is Bar"'); +is($baz->get_bar(), 'FOO is BAR', '... Bar::Baz::bar has been initialized'); +is($baz->bling(), 'Baz::bling', '... Bar::Baz::bling has been initialized'); + +$baz->baz('This is Bar::Baz::baz'); + +ok($baz->has_baz, '... Bar::Baz::baz is defined now'); +is($baz->baz(), 'This is Bar::Baz::baz', '... Bar::Baz::foo == "This is Bar"'); +is($baz->foo(), 'This is Bar::Baz::foo', '... Bar::Baz::foo == "This is Bar"'); +is($baz->get_bar(), 'FOO is BAR', '... Bar::Baz::bar has been initialized'); +is($baz->bling(), 'Baz::bling', '... Bar::Baz::bling has been initialized'); + diff --git a/t/108_ArrayBasedInstance_test.t b/t/108_ArrayBasedInstance_test.t deleted file mode 100644 index 9893cbb..0000000 --- a/t/108_ArrayBasedInstance_test.t +++ /dev/null @@ -1,69 +0,0 @@ -#!/usr/bin/perl - -use strict; -use warnings; - -use Test::More tests => 19; -use File::Spec; - -BEGIN { - use_ok('Class::MOP'); - require_ok(File::Spec->catdir('examples', 'ArrayBasedInstance.pod')); -} - -{ - package Foo; - - use metaclass 'Class::MOP::Class' => ( - ':attribute_metaclass' => 'ArrayBasedInstance::Attribute', - ':instance_metaclass' => 'ArrayBasedInstance::Instance', - ); - - Foo->meta->add_attribute('foo' => ( - accessor => 'foo', - predicate => 'has_foo', - )); - - Foo->meta->add_attribute('bar' => ( - reader => 'get_bar', - writer => 'set_bar', - default => 'FOO is BAR' - )); - - sub new { - my $class = shift; - $class->meta->new_object(@_); - } -} - -my $foo = Foo->new(); -isa_ok($foo, 'Foo'); - -can_ok($foo, 'foo'); -can_ok($foo, 'has_foo'); -can_ok($foo, 'get_bar'); -can_ok($foo, 'set_bar'); - -ok(!$foo->has_foo, '... Foo::foo is not defined yet'); -is($foo->foo(), undef, '... Foo::foo is not defined yet'); -is($foo->get_bar(), 'FOO is BAR', '... Foo::bar has been initialized'); - -$foo->foo('This is Foo'); - -ok($foo->has_foo, '... Foo::foo is defined now'); -is($foo->foo(), 'This is Foo', '... Foo::foo == "This is Foo"'); - -$foo->set_bar(42); -is($foo->get_bar(), 42, '... Foo::bar == 42'); - -my $foo2 = Foo->new(); -isa_ok($foo2, 'Foo'); - -ok(!$foo2->has_foo, '... Foo2::foo is not defined yet'); -is($foo2->foo(), undef, '... Foo2::foo is not defined yet'); -is($foo2->get_bar(), 'FOO is BAR', '... Foo2::bar has been initialized'); - -$foo2->set_bar('DONT PANIC'); -is($foo2->get_bar(), 'DONT PANIC', '... Foo2::bar == DONT PANIC'); - -is($foo->get_bar(), 42, '... Foo::bar == 42'); diff --git a/t/108_ArrayBasedStorage_test.t b/t/108_ArrayBasedStorage_test.t new file mode 100644 index 0000000..689c996 --- /dev/null +++ b/t/108_ArrayBasedStorage_test.t @@ -0,0 +1,177 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 65; +use File::Spec; + +BEGIN { + use_ok('Class::MOP'); + require_ok(File::Spec->catdir('examples', 'ArrayBasedStorage.pod')); +} + +{ + package Foo; + + use strict; + use warnings; + use metaclass 'Class::MOP::Class' => ( + ':attribute_metaclass' => 'ArrayBasedStorage::Attribute', + ':instance_metaclass' => 'ArrayBasedStorage::Instance', + ); + + Foo->meta->add_attribute('foo' => ( + accessor => 'foo', + predicate => 'has_foo', + )); + + Foo->meta->add_attribute('bar' => ( + reader => 'get_bar', + writer => 'set_bar', + default => 'FOO is BAR' + )); + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } + + package Bar; + + use strict; + use warnings; + + use base 'Foo'; + + Bar->meta->add_attribute('baz' => ( + accessor => 'baz', + predicate => 'has_baz', + )); + + package Baz; + + use strict; + use warnings; + use metaclass 'Class::MOP::Class' => ( + ':attribute_metaclass' => 'ArrayBasedStorage::Attribute', + ':instance_metaclass' => 'ArrayBasedStorage::Instance', + ); + + Baz->meta->add_attribute('bling' => ( + accessor => 'bling', + default => 'Baz::bling' + )); + + package Bar::Baz; + + use strict; + use warnings; + + use base 'Bar', 'Baz'; +} + +my $foo = Foo->new(); +isa_ok($foo, 'Foo'); + +can_ok($foo, 'foo'); +can_ok($foo, 'has_foo'); +can_ok($foo, 'get_bar'); +can_ok($foo, 'set_bar'); + +ok(!$foo->has_foo, '... Foo::foo is not defined yet'); +is($foo->foo(), undef, '... Foo::foo is not defined yet'); +is($foo->get_bar(), 'FOO is BAR', '... Foo::bar has been initialized'); + +$foo->foo('This is Foo'); + +ok($foo->has_foo, '... Foo::foo is defined now'); +is($foo->foo(), 'This is Foo', '... Foo::foo == "This is Foo"'); + +$foo->set_bar(42); +is($foo->get_bar(), 42, '... Foo::bar == 42'); + +my $foo2 = Foo->new(); +isa_ok($foo2, 'Foo'); + +ok(!$foo2->has_foo, '... Foo2::foo is not defined yet'); +is($foo2->foo(), undef, '... Foo2::foo is not defined yet'); +is($foo2->get_bar(), 'FOO is BAR', '... Foo2::bar has been initialized'); + +$foo2->set_bar('DONT PANIC'); +is($foo2->get_bar(), 'DONT PANIC', '... Foo2::bar == DONT PANIC'); + +is($foo->get_bar(), 42, '... Foo::bar == 42'); + +# now Bar ... + +my $bar = Bar->new(); +isa_ok($bar, 'Bar'); +isa_ok($bar, 'Foo'); + +can_ok($bar, 'foo'); +can_ok($bar, 'has_foo'); +can_ok($bar, 'get_bar'); +can_ok($bar, 'set_bar'); +can_ok($bar, 'baz'); +can_ok($bar, 'has_baz'); + +ok(!$bar->has_foo, '... Bar::foo is not defined yet'); +is($bar->foo(), undef, '... Bar::foo is not defined yet'); +is($bar->get_bar(), 'FOO is BAR', '... Bar::bar has been initialized'); +ok(!$bar->has_baz, '... Bar::baz is not defined yet'); +is($bar->baz(), undef, '... Bar::baz is not defined yet'); + +$bar->foo('This is Bar::foo'); + +ok($bar->has_foo, '... Bar::foo is defined now'); +is($bar->foo(), 'This is Bar::foo', '... Bar::foo == "This is Bar"'); +is($bar->get_bar(), 'FOO is BAR', '... Bar::bar has been initialized'); + +$bar->baz('This is Bar::baz'); + +ok($bar->has_baz, '... Bar::baz is defined now'); +is($bar->baz(), 'This is Bar::baz', '... Bar::foo == "This is Bar"'); +is($bar->foo(), 'This is Bar::foo', '... Bar::foo == "This is Bar"'); +is($bar->get_bar(), 'FOO is BAR', '... Bar::bar has been initialized'); + +# now Baz ... + +my $baz = Bar::Baz->new(); +isa_ok($baz, 'Bar::Baz'); +isa_ok($baz, 'Bar'); +isa_ok($baz, 'Foo'); +isa_ok($baz, 'Baz'); + +can_ok($baz, 'foo'); +can_ok($baz, 'has_foo'); +can_ok($baz, 'get_bar'); +can_ok($baz, 'set_bar'); +can_ok($baz, 'baz'); +can_ok($baz, 'has_baz'); +can_ok($baz, 'bling'); + +is($baz->get_bar(), 'FOO is BAR', '... Bar::Baz::bar has been initialized'); +is($baz->bling(), 'Baz::bling', '... Bar::Baz::bling has been initialized'); + +ok(!$baz->has_foo, '... Bar::Baz::foo is not defined yet'); +is($baz->foo(), undef, '... Bar::Baz::foo is not defined yet'); +ok(!$baz->has_baz, '... Bar::Baz::baz is not defined yet'); +is($baz->baz(), undef, '... Bar::Baz::baz is not defined yet'); + +$baz->foo('This is Bar::Baz::foo'); + +ok($baz->has_foo, '... Bar::Baz::foo is defined now'); +is($baz->foo(), 'This is Bar::Baz::foo', '... Bar::Baz::foo == "This is Bar"'); +is($baz->get_bar(), 'FOO is BAR', '... Bar::Baz::bar has been initialized'); +is($baz->bling(), 'Baz::bling', '... Bar::Baz::bling has been initialized'); + +$baz->baz('This is Bar::Baz::baz'); + +ok($baz->has_baz, '... Bar::Baz::baz is defined now'); +is($baz->baz(), 'This is Bar::Baz::baz', '... Bar::Baz::foo == "This is Bar"'); +is($baz->foo(), 'This is Bar::Baz::foo', '... Bar::Baz::foo == "This is Bar"'); +is($baz->get_bar(), 'FOO is BAR', '... Bar::Baz::bar has been initialized'); +is($baz->bling(), 'Baz::bling', '... Bar::Baz::bling has been initialized'); + +