From: Yuval Kogman Date: Sat, 27 Jun 2009 02:35:01 +0000 (-0400) Subject: fix insideout test X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5dcaf2cb2657d51cb87ec6b509a8efa499aa7b94;p=gitmo%2FClass-MOP.git fix insideout test --- diff --git a/examples/InsideOutClass.pod b/examples/InsideOutClass.pod index 07da94f..96ec8f4 100644 --- a/examples/InsideOutClass.pod +++ b/examples/InsideOutClass.pod @@ -1,14 +1,9 @@ -package # hide the package from PAUSE - InsideOutClass::Attribute; - use strict; use warnings; -our $VERSION = '0.02'; - -use Carp 'confess'; -use Scalar::Util 'refaddr'; +package # hide the package from PAUSE + InsideOutClass::Attribute; use base 'Class::MOP::Attribute'; @@ -16,38 +11,38 @@ sub initialize_instance_slot { my ($self, $meta_instance, $instance, $params) = @_; my $init_arg = $self->init_arg; # try to fetch the init arg from the %params ... - my $val; - $val = $params->{$init_arg} if exists $params->{$init_arg}; - # if nothing was in the %params, we can use the - # attribute's default value (if it has one) - if (!defined $val && defined $self->default) { - $val = $self->default($instance); + + my $class_meta_instance = $self->associated_class->get_meta_instance; + + if ( exists $params->{$init_arg} ) { + $meta_instance->set_slot_value($instance, $self->name, $params->{$init_arg}); + } elsif ( $self->default ) { + $meta_instance->set_slot_value($instance, $self->name, $self->default($instance)); } - my $_meta_instance = $self->associated_class->get_meta_instance; - $_meta_instance->initialize_slot($instance, $self->name); - $_meta_instance->set_slot_value($instance, $self->name, $val); } -sub accessor_metaclass { 'InsideOutClass::Method::Accessor' } +sub method_metaclass { + # this should really be overriding the default values of the attribute + return { + accessor => 'InsideOutClass::Method::Accessor', + reader => 'InsideOutClass::Method::Reader', + writer => 'InsideOutClass::Method::Writer', + predicate => 'InsideOutClass::Method::Predicate', + } +} package # hide the package from PAUSE InsideOutClass::Method::Accessor; - -use strict; -use warnings; - -our $VERSION = '0.01'; - -use Carp 'confess'; -use Scalar::Util 'refaddr'; use base 'Class::MOP::Method::Accessor'; ## Method generation helpers -sub _generate_accessor_method { +sub is_inline { 0 } + +sub _generate_method { my $attr = (shift)->associated_attribute; - my $meta_class = $attr->associated_class; + my $meta_class = $attr->associated_class; my $attr_name = $attr->name; return sub { my $meta_instance = $meta_class->get_meta_instance; @@ -56,53 +51,84 @@ sub _generate_accessor_method { }; } -sub _generate_reader_method { +package # hide the package from PAUSE + InsideOutClass::Method::Reader; + +use Carp 'confess'; + +use base 'Class::MOP::Method::Reader'; + +sub is_inline { 0 } + +sub _generate_method { my $attr = (shift)->associated_attribute; - my $meta_class = $attr->associated_class; + my $meta_class = $attr->associated_class; my $attr_name = $attr->name; - return sub { + return sub { confess "Cannot assign a value to a read-only accessor" if @_ > 1; $meta_class->get_meta_instance - ->get_slot_value($_[0], $attr_name); - }; + ->get_slot_value($_[0], $attr_name); + }; } -sub _generate_writer_method { +package # hide the package from PAUSE + InsideOutClass::Method::Writer; + +use base 'Class::MOP::Method::Writer'; + +sub is_inline { 0 } + +sub _generate_method { my $attr = (shift)->associated_attribute; - my $meta_class = $attr->associated_class; + my $meta_class = $attr->associated_class; my $attr_name = $attr->name; - return sub { + return sub { $meta_class->get_meta_instance ->set_slot_value($_[0], $attr_name, $_[1]); }; } -sub _generate_predicate_method { +package # hide the package from PAUSE + InsideOutClass::Method::Predicate; + +use base 'Class::MOP::Method::Predicate'; + +sub is_inline { 0 } + +sub _generate_method { my $attr = (shift)->associated_attribute; - my $meta_class = $attr->associated_class; + my $meta_class = $attr->associated_class; my $attr_name = $attr->name; - return sub { - defined $meta_class->get_meta_instance - ->get_slot_value($_[0], $attr_name) ? 1 : 0; - }; + return sub { + $meta_class->get_meta_instance + ->is_slot_initialized($_[0], $attr_name); + }; } package # hide the package from PAUSE InsideOutClass::Instance; -use strict; -use warnings; - -our $VERSION = '0.01'; - -use Carp 'confess'; use Scalar::Util 'refaddr'; use base 'Class::MOP::Instance'; +sub new { + my ( $class, @args ) = @_; + + my $self = $class->SUPER::new(@args); + + foreach my $slot_name ( $self->get_all_slots ) { + $self->associated_metaclass->add_package_symbol(('%' . $slot_name) => {}) + unless $self->associated_metaclass->has_package_symbol('%' . $slot_name); + } + + return $self; +} + sub create_instance { my ($self, $class) = @_; - bless \(my $instance), $self->_class_name; + + bless \(my $instance), $self->_class_name; } sub get_slot_value { @@ -117,15 +143,12 @@ sub set_slot_value { sub initialize_slot { my ($self, $instance, $slot_name) = @_; - $self->associated_metaclass->add_package_symbol(('%' . $slot_name) => {}) - unless $self->associated_metaclass->has_package_symbol('%' . $slot_name); $self->associated_metaclass->get_package_symbol('%' . $slot_name)->{refaddr $instance} = undef; } sub is_slot_initialized { my ($self, $instance, $slot_name) = @_; - return 0 unless $self->associated_metaclass->has_package_symbol('%' . $slot_name); - return exists $self->associated_metaclass->get_package_symbol('%' . $slot_name)->{refaddr $instance} ? 1 : 0; + exists $self->associated_metaclass->get_package_symbol('%' . $slot_name)->{refaddr $instance}; } 1; @@ -141,39 +164,39 @@ InsideOutClass - A set of example metaclasses which implement the Inside-Out tec =head1 SYNOPSIS package Foo; - + use metaclass ( ':attribute_metaclass' => 'InsideOutClass::Attribute', ':instance_metaclass' => 'InsideOutClass::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 set of example metaclasses which implement the Inside-Out -class technique. What follows is a brief explaination of the code +This is a set of example metaclasses which implement the Inside-Out +class technique. What follows is a brief explaination of the code found in this module. -We must create a subclass of B and override -the slot operations. This requires +We must create a subclass of B and override +the slot operations. This requires overloading C, C, C, and C, as well as their inline counterparts. Additionally we overload C in order to initialize the global hash containing the actual slot values. -And that is pretty much all. Of course I am ignoring need for -inside-out objects to be C-ed, and some other details as +And that is pretty much all. Of course I am ignoring need for +inside-out objects to be C-ed, and some other details as well (threading, etc), but this is an example. A real implementation is left as an exercise to the reader. @@ -190,6 +213,6 @@ Copyright 2006-2008 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. +it under the same terms as Perl itself. =cut diff --git a/t/102_InsideOutClass_test.t b/t/102_InsideOutClass_test.t index 242d161..43426ac 100644 --- a/t/102_InsideOutClass_test.t +++ b/t/102_InsideOutClass_test.t @@ -5,77 +5,77 @@ use Test::More tests => 88; use File::Spec; use Scalar::Util 'reftype'; -BEGIN {use Class::MOP; +BEGIN {use Class::MOP; require_ok(File::Spec->catfile('examples', 'InsideOutClass.pod')); } { package Foo; - + use strict; - use warnings; - + use warnings; + use metaclass ( 'attribute_metaclass' => 'InsideOutClass::Attribute', 'instance_metaclass' => 'InsideOutClass::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' + default => 'FOO is BAR' )); - + sub new { my $class = shift; $class->meta->new_object(@_); } - + package Bar; use metaclass ( 'attribute_metaclass' => 'InsideOutClass::Attribute', 'instance_metaclass' => 'InsideOutClass::Instance' ); - + 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 ( + use metaclass ( 'attribute_metaclass' => 'InsideOutClass::Attribute', 'instance_metaclass' => 'InsideOutClass::Instance' ); - + Baz->meta->add_attribute('bling' => ( accessor => 'bling', default => 'Baz::bling' - )); - + )); + package Bar::Baz; use metaclass ( 'attribute_metaclass' => 'InsideOutClass::Attribute', 'instance_metaclass' => 'InsideOutClass::Instance' ); - + use strict; use warnings; - - use base 'Bar', 'Baz'; + + use base 'Bar', 'Baz'; } my $foo = Foo->new(); @@ -191,32 +191,32 @@ is($baz->bling(), 'Baz::bling', '... Bar::Baz::bling has been initialized'); { no strict 'refs'; - + ok(*{'Foo::foo'}{HASH}, '... there is a foo package variable in Foo'); ok(*{'Foo::bar'}{HASH}, '... there is a bar package variable in Foo'); - is(scalar(keys(%{'Foo::foo'})), 4, '... got the right number of entries for Foo::foo'); - is(scalar(keys(%{'Foo::bar'})), 4, '... got the right number of entries for Foo::bar'); + is(scalar(keys(%{'Foo::foo'})), 1, '... got the right number of entries for Foo::foo'); + is(scalar(keys(%{'Foo::bar'})), 2, '... got the right number of entries for Foo::bar'); - ok(!*{'Bar::foo'}{HASH}, '... no foo package variable in Bar'); - ok(!*{'Bar::bar'}{HASH}, '... no bar package variable in Bar'); + ok(*{'Bar::foo'}{HASH}, '... no foo package variable in Bar'); + ok(*{'Bar::bar'}{HASH}, '... no bar package variable in Bar'); ok(*{'Bar::baz'}{HASH}, '... there is a baz package variable in Bar'); - is(scalar(keys(%{'Bar::foo'})), 0, '... got the right number of entries for Bar::foo'); - is(scalar(keys(%{'Bar::bar'})), 0, '... got the right number of entries for Bar::bar'); - is(scalar(keys(%{'Bar::baz'})), 2, '... got the right number of entries for Bar::baz'); - + is(scalar(keys(%{'Bar::foo'})), 1, '... got the right number of entries for Bar::foo'); + is(scalar(keys(%{'Bar::bar'})), 1, '... got the right number of entries for Bar::bar'); + is(scalar(keys(%{'Bar::baz'})), 1, '... got the right number of entries for Bar::baz'); + ok(*{'Baz::bling'}{HASH}, '... there is a bar package variable in Baz'); - is(scalar(keys(%{'Baz::bling'})), 1, '... got the right number of entries for Baz::bling'); - - ok(!*{'Bar::Baz::foo'}{HASH}, '... no foo package variable in Bar::Baz'); - ok(!*{'Bar::Baz::bar'}{HASH}, '... no bar package variable in Bar::Baz'); - ok(!*{'Bar::Baz::baz'}{HASH}, '... no baz package variable in Bar::Baz'); - ok(!*{'Bar::Baz::bling'}{HASH}, '... no bar package variable in Baz::Baz'); - - is(scalar(keys(%{'Bar::Baz::foo'})), 0, '... got the right number of entries for Bar::Baz::foo'); - is(scalar(keys(%{'Bar::Baz::bar'})), 0, '... got the right number of entries for Bar::Baz::bar'); - is(scalar(keys(%{'Bar::Baz::baz'})), 0, '... got the right number of entries for Bar::Baz::baz'); - is(scalar(keys(%{'Bar::Baz::bling'})), 0, '... got the right number of entries for Bar::Baz::bling'); + is(scalar(keys(%{'Baz::bling'})), 0, '... got the right number of entries for Baz::bling'); + + ok(*{'Bar::Baz::foo'}{HASH}, '... no foo package variable in Bar::Baz'); + ok(*{'Bar::Baz::bar'}{HASH}, '... no bar package variable in Bar::Baz'); + ok(*{'Bar::Baz::baz'}{HASH}, '... no baz package variable in Bar::Baz'); + ok(*{'Bar::Baz::bling'}{HASH}, '... no bar package variable in Baz::Baz'); + + is(scalar(keys(%{'Bar::Baz::foo'})), 1, '... got the right number of entries for Bar::Baz::foo'); + is(scalar(keys(%{'Bar::Baz::bar'})), 1, '... got the right number of entries for Bar::Baz::bar'); + is(scalar(keys(%{'Bar::Baz::baz'})), 1, '... got the right number of entries for Bar::Baz::baz'); + is(scalar(keys(%{'Bar::Baz::bling'})), 1, '... got the right number of entries for Bar::Baz::bling'); }