2 package # hide the package from PAUSE
3 ArrayBasedStorage::Attribute;
10 our $VERSION = '0.01';
12 use base 'Class::MOP::Attribute';
14 sub initialize_instance_slot {
15 my ($self, $meta_instance, $instance, $params) = @_;
16 my $init_arg = $self->{init_arg};
17 # try to fetch the init arg from the %params ...
19 $val = $params->{$init_arg} if exists $params->{$init_arg};
20 # if nothing was in the %params, we can use the
21 # attribute's default value (if it has one)
22 if (!defined $val && defined $self->{default}) {
23 $val = $self->default($instance);
25 $meta_instance->set_slot_value($instance, $self->name, $val);
28 sub generate_accessor_method {
30 my $meta_class = $self->associated_class;
31 my $attr_name = $self->name;
33 my $meta_instance = $meta_class->initialize(Scalar::Util::blessed($_[0]))->get_meta_instance;
34 $meta_instance->set_slot_value($_[0], $attr_name, $_[1]) if scalar(@_) == 2;
35 $meta_instance->get_slot_value($_[0], $attr_name);
39 sub generate_reader_method {
41 my $meta_class = $self->associated_class;
42 my $attr_name = $self->name;
44 confess "Cannot assign a value to a read-only accessor" if @_ > 1;
45 $meta_class->initialize(Scalar::Util::blessed($_[0]))
47 ->get_slot_value($_[0], $attr_name);
51 sub generate_writer_method {
53 my $meta_class = $self->associated_class;
54 my $attr_name = $self->name;
56 $meta_class->initialize(Scalar::Util::blessed($_[0]))
58 ->set_slot_value($_[0], $attr_name, $_[1]);
62 sub generate_predicate_method {
64 my $meta_class = $self->associated_class;
65 my $attr_name = $self->name;
67 defined $meta_class->initialize(Scalar::Util::blessed($_[0]))
69 ->get_slot_value($_[0], $attr_name) ? 1 : 0;
73 package # hide the package from PAUSE
74 ArrayBasedStorage::Instance;
81 our $VERSION = '0.01';
83 use base 'Class::MOP::Instance';
86 my ($class, $meta, @attrs) = @_;
87 my $self = $class->SUPER::new($meta, @attrs);
89 $self->{slot_index_map} = { map { $_ => $index++ } $self->get_all_slots };
95 $self->bless_instance_structure([]);
98 # operations on meta instance
100 sub get_slot_index_map { (shift)->{slot_index_map} }
104 return sort @{$self->{slots}};
108 my ($self, $instance, $slot_name) = @_;
109 return $instance->[ $self->{slot_index_map}->{$slot_name} ];
113 my ($self, $instance, $slot_name, $value) = @_;
114 $instance->[ $self->{slot_index_map}->{$slot_name} ] = $value;
117 sub initialize_slot {
118 my ($self, $instance, $slot_name) = @_;
119 $instance->[ $self->{slot_index_map}->{$slot_name} ] = undef;
122 sub is_slot_initialized {
124 # maybe use CLOS's *special-unbound-value*
126 confess "Cannot really tell this for sure";
137 ArrayBasedStorage - An example of an Array based instance storage
144 ':instance_metaclass' => 'ArrayBasedStorage::Instance'
147 __PACKAGE__->meta->add_attribute('foo' => (
154 $class->meta->new_object(@_);
157 # now you can just use the class as normal
161 This is a proof of concept using the Instance sub-protocol
162 which uses ARRAY refs to store the instance data.
164 This is very similar now to the InsideOutClass example, and
165 in fact, they both share the exact same test suite, with
166 the only difference being the Instance metaclass they use.
170 Stevan Little E<lt>stevan@iinteractive.comE<gt>
174 =head1 COPYRIGHT AND LICENSE
176 Copyright 2006 by Infinity Interactive, Inc.
178 L<http://www.iinteractive.com>
180 This library is free software; you can redistribute it and/or modify
181 it under the same terms as Perl itself.