Commit | Line | Data |
38bf2a25 |
1 | |
2 | package # hide the package from PAUSE |
3 | ArrayBasedStorage::Instance; |
4 | |
5 | use strict; |
6 | use warnings; |
7 | use Scalar::Util qw/refaddr/; |
8 | |
9 | use Carp 'confess'; |
10 | |
11 | our $VERSION = '0.01'; |
12 | my $unbound = \'empty-slot-value'; |
13 | |
14 | use base 'Class::MOP::Instance'; |
15 | |
16 | sub new { |
17 | my ($class, $meta, @attrs) = @_; |
18 | my $self = $class->SUPER::new($meta, @attrs); |
19 | my $index = 0; |
20 | $self->{'slot_index_map'} = { map { $_ => $index++ } $self->get_all_slots }; |
21 | return $self; |
22 | } |
23 | |
24 | sub create_instance { |
25 | my $self = shift; |
26 | my $instance = bless [], $self->_class_name; |
27 | $self->initialize_all_slots($instance); |
28 | return $instance; |
29 | } |
30 | |
31 | sub clone_instance { |
32 | my ($self, $instance) = shift; |
33 | $self->bless_instance_structure([ @$instance ]); |
34 | } |
35 | |
36 | # operations on meta instance |
37 | |
38 | sub get_slot_index_map { (shift)->{'slot_index_map'} } |
39 | |
40 | sub initialize_slot { |
41 | my ($self, $instance, $slot_name) = @_; |
42 | $self->set_slot_value($instance, $slot_name, $unbound); |
43 | } |
44 | |
45 | sub deinitialize_slot { |
46 | my ( $self, $instance, $slot_name ) = @_; |
47 | $self->set_slot_value($instance, $slot_name, $unbound); |
48 | } |
49 | |
50 | sub get_all_slots { |
51 | my $self = shift; |
52 | return sort $self->SUPER::get_all_slots; |
53 | } |
54 | |
55 | sub get_slot_value { |
56 | my ($self, $instance, $slot_name) = @_; |
57 | my $value = $instance->[ $self->{'slot_index_map'}->{$slot_name} ]; |
58 | return $value unless ref $value; |
59 | refaddr $value eq refaddr $unbound ? undef : $value; |
60 | } |
61 | |
62 | sub set_slot_value { |
63 | my ($self, $instance, $slot_name, $value) = @_; |
64 | $instance->[ $self->{'slot_index_map'}->{$slot_name} ] = $value; |
65 | } |
66 | |
67 | sub is_slot_initialized { |
68 | my ($self, $instance, $slot_name) = @_; |
69 | # NOTE: maybe use CLOS's *special-unbound-value* for this? |
70 | my $value = $instance->[ $self->{'slot_index_map'}->{$slot_name} ]; |
71 | return 1 unless ref $value; |
72 | refaddr $value eq refaddr $unbound ? 0 : 1; |
73 | } |
74 | |
75 | sub is_dependent_on_superclasses { 1 } |
76 | |
77 | 1; |
78 | |
79 | __END__ |
80 | |
81 | =pod |
82 | |
83 | =head1 NAME |
84 | |
85 | ArrayBasedStorage - An example of an Array based instance storage |
86 | |
87 | =head1 SYNOPSIS |
88 | |
89 | package Foo; |
90 | |
91 | use metaclass ( |
92 | ':instance_metaclass' => 'ArrayBasedStorage::Instance' |
93 | ); |
94 | |
95 | __PACKAGE__->meta->add_attribute('foo' => ( |
96 | reader => 'get_foo', |
97 | writer => 'set_foo' |
98 | )); |
99 | |
100 | sub new { |
101 | my $class = shift; |
102 | $class->meta->new_object(@_); |
103 | } |
104 | |
105 | # now you can just use the class as normal |
106 | |
107 | =head1 DESCRIPTION |
108 | |
109 | This is a proof of concept using the Instance sub-protocol |
110 | which uses ARRAY refs to store the instance data. |
111 | |
112 | This is very similar now to the InsideOutClass example, and |
113 | in fact, they both share the exact same test suite, with |
114 | the only difference being the Instance metaclass they use. |
115 | |
116 | =head1 AUTHORS |
117 | |
118 | Stevan Little E<lt>stevan@iinteractive.comE<gt> |
119 | |
120 | Yuval Kogman E<lt>nothingmuch@woobling.comE<gt> |
121 | |
122 | =head1 SEE ALSO |
123 | |
124 | =head1 COPYRIGHT AND LICENSE |
125 | |
126 | Copyright 2006-2008 by Infinity Interactive, Inc. |
127 | |
128 | L<http://www.iinteractive.com> |
129 | |
130 | This library is free software; you can redistribute it and/or modify |
131 | it under the same terms as Perl itself. |
132 | |
133 | =cut |