package # hide the package from PAUSE
- ArrayBasedInstance::Attribute;
+ ArrayBasedStorage::Attribute;
use strict;
use warnings;
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);
};
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);
};
}
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;
=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 E<lt>stevan@iinteractive.comE<gt>
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);
}
}
# 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();
}
# 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 {
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;
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__
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
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);
}
}
}
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;
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:
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;
}
use strict;
use warnings;
-use Test::More tests => 19;
+use Test::More tests => 65;
use File::Spec;
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' => (
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();
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');
+
+++ /dev/null
-#!/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');
--- /dev/null
+#!/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');
+
+
projects / gitmo/Class-MOP.git / commitdiff