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