--- /dev/null
+
+package # hide the package from PAUSE
+ ArrayBasedInstance::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 = $self->associated_class->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;
+ my $meta_instance = $self->associated_class->get_meta_instance;
+ $meta_instance->get_slot_value($_[0], $attr_name);
+ };
+}
+
+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]);
+ };
+}
+
+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;
+ };
+}
+
+package # hide the package from PAUSE
+ ArrayBasedInstance::Instance;
+
+use strict;
+use warnings;
+
+use Carp 'confess';
+
+our $VERSION = '0.01';
+
+use base 'Class::MOP::Instance';
+
+sub new {
+ my ($class, $meta, @attrs) = @_;
+ my $self = $class->SUPER::new($meta, @attrs);
+ my $index = 0;
+ $self->{slot_index_map} = { map { $_ => $index++ } $self->get_all_slots };
+ return $self;
+}
+
+sub create_instance {
+ my $self = shift;
+ $self->bless_instance_structure([]);
+}
+
+# operations on meta instance
+
+sub get_all_slots {
+ my $self = shift;
+ return sort @{$self->{slots}};
+}
+
+sub get_slot_value {
+ my ($self, $instance, $slot_name) = @_;
+ return $instance->[ $self->{slot_index_map}->{$slot_name} ];
+}
+
+sub set_slot_value {
+ my ($self, $instance, $slot_name, $value) = @_;
+ $instance->[ $self->{slot_index_map}->{$slot_name} ] = $value;
+}
+
+sub initialize_slot {
+ my ($self, $instance, $slot_name) = @_;
+ $instance->[ $self->{slot_index_map}->{$slot_name} ] = undef;
+}
+
+sub is_slot_initialized {
+ # NOTE:
+ # maybe use CLOS's *special-unbound-value*
+ # for this ?
+ confess "Cannot really tell this for sure";
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+ArrayBasedInstance - An example of an Array based instance
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+=head1 AUTHOR
+
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+=head1 SEE ALSO
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
-
package # hide the package from PAUSE
InsideOutClass::Instance;
sub initialize_slot {
my ($self, $instance, $slot_name) = @_;
- $self->{meta}->add_package_variable(('%' . $slot_name) => {});
+ $self->{meta}->add_package_variable(('%' . $slot_name) => {})
+ unless $self->{meta}->has_package_variable('%' . $slot_name);
$self->{meta}->get_package_variable('%' . $slot_name)->{refaddr $instance} = undef;
}
};
}
+
+
+package # hide the package from PAUSE
+ LazyClass::Instance;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+use base 'Class::MOP::Instance';
+
+sub initialize_all_slots {}
+
1;
__END__
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();
+ $meta_instance->initialize_all_slots($instance);
foreach my $attr ($class->compute_all_applicable_attributes()) {
$attr->initialize_instance_slot($instance, \%params);
}
# operations on created instances
+sub initialize_all_slots {
+ my ($self, $instance) = @_;
+ foreach my $slot_name ($self->get_all_slots) {
+ $self->initialize_slot($instance, $slot_name);
+ }
+}
+
sub get_slot_value {
my ($self, $instance, $slot_name) = @_;
return $instance->{$slot_name};
=item B<new>
-=item B<bless_instance_structure>
-
-=item B<compute_layout_from_class>
-
=item B<create_instance>
+=item B<bless_instance_structure>
+
=item B<get_all_slots>
+=item B<initialize_all_slots>
+
=item B<get_slot_value>
=item B<set_slot_value>
use metaclass 'Class::MOP::Class' => (
':attribute_metaclass' => 'LazyClass::Attribute',
+ ':instance_metaclass' => 'LazyClass::Instance',
);
BinaryTree->meta->add_attribute('$:node' => (
--- /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');
projects / gitmo/Class-MOP.git / commitdiff