Commit | Line | Data |
0e76a376 |
1 | |
2 | package # hide the package from PAUSE |
62189f84 |
3 | ArrayBasedStorage::Attribute; |
4 | |
5 | use strict; |
6 | use warnings; |
7 | |
8 | use Carp 'confess'; |
9 | |
10 | our $VERSION = '0.01'; |
11 | |
12 | use base 'Class::MOP::Attribute'; |
13 | |
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 ... |
18 | my $val; |
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); |
24 | } |
25 | $meta_instance->set_slot_value($instance, $self->name, $val); |
26 | } |
27 | |
28 | sub generate_accessor_method { |
29 | my $self = shift; |
30 | my $meta_class = $self->associated_class; |
31 | my $attr_name = $self->name; |
32 | return sub { |
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); |
36 | }; |
37 | } |
38 | |
39 | sub generate_reader_method { |
40 | my $self = shift; |
41 | my $meta_class = $self->associated_class; |
42 | my $attr_name = $self->name; |
43 | return sub { |
44 | confess "Cannot assign a value to a read-only accessor" if @_ > 1; |
45 | $meta_class->initialize(Scalar::Util::blessed($_[0])) |
46 | ->get_meta_instance |
47 | ->get_slot_value($_[0], $attr_name); |
48 | }; |
49 | } |
50 | |
51 | sub generate_writer_method { |
52 | my $self = shift; |
53 | my $meta_class = $self->associated_class; |
54 | my $attr_name = $self->name; |
55 | return sub { |
56 | $meta_class->initialize(Scalar::Util::blessed($_[0])) |
57 | ->get_meta_instance |
58 | ->set_slot_value($_[0], $attr_name, $_[1]); |
59 | }; |
60 | } |
61 | |
62 | sub generate_predicate_method { |
63 | my $self = shift; |
64 | my $meta_class = $self->associated_class; |
65 | my $attr_name = $self->name; |
66 | return sub { |
67 | defined $meta_class->initialize(Scalar::Util::blessed($_[0])) |
68 | ->get_meta_instance |
69 | ->get_slot_value($_[0], $attr_name) ? 1 : 0; |
70 | }; |
71 | } |
72 | |
73 | package # hide the package from PAUSE |
f892c0f0 |
74 | ArrayBasedStorage::Instance; |
0e76a376 |
75 | |
76 | use strict; |
77 | use warnings; |
78 | |
79 | use Carp 'confess'; |
80 | |
81 | our $VERSION = '0.01'; |
82 | |
83 | use base 'Class::MOP::Instance'; |
84 | |
85 | sub new { |
86 | my ($class, $meta, @attrs) = @_; |
87 | my $self = $class->SUPER::new($meta, @attrs); |
88 | my $index = 0; |
89 | $self->{slot_index_map} = { map { $_ => $index++ } $self->get_all_slots }; |
90 | return $self; |
91 | } |
92 | |
93 | sub create_instance { |
94 | my $self = shift; |
95 | $self->bless_instance_structure([]); |
96 | } |
97 | |
98 | # operations on meta instance |
99 | |
62189f84 |
100 | sub get_slot_index_map { (shift)->{slot_index_map} } |
101 | |
0e76a376 |
102 | sub get_all_slots { |
103 | my $self = shift; |
104 | return sort @{$self->{slots}}; |
105 | } |
106 | |
107 | sub get_slot_value { |
108 | my ($self, $instance, $slot_name) = @_; |
109 | return $instance->[ $self->{slot_index_map}->{$slot_name} ]; |
110 | } |
111 | |
112 | sub set_slot_value { |
113 | my ($self, $instance, $slot_name, $value) = @_; |
114 | $instance->[ $self->{slot_index_map}->{$slot_name} ] = $value; |
115 | } |
116 | |
117 | sub initialize_slot { |
118 | my ($self, $instance, $slot_name) = @_; |
119 | $instance->[ $self->{slot_index_map}->{$slot_name} ] = undef; |
120 | } |
121 | |
122 | sub is_slot_initialized { |
123 | # NOTE: |
124 | # maybe use CLOS's *special-unbound-value* |
125 | # for this ? |
126 | confess "Cannot really tell this for sure"; |
127 | } |
128 | |
129 | 1; |
130 | |
131 | __END__ |
132 | |
133 | =pod |
134 | |
135 | =head1 NAME |
136 | |
f892c0f0 |
137 | ArrayBasedStorage - An example of an Array based instance storage |
0e76a376 |
138 | |
139 | =head1 SYNOPSIS |
140 | |
f892c0f0 |
141 | package Foo; |
142 | |
1becdfcc |
143 | use metaclass ( |
f892c0f0 |
144 | ':instance_metaclass' => 'ArrayBasedStorage::Instance' |
145 | ); |
146 | |
147 | __PACKAGE__->meta->add_attribute('foo' => ( |
148 | reader => 'get_foo', |
149 | writer => 'set_foo' |
150 | )); |
151 | |
152 | sub new { |
153 | my $class = shift; |
154 | $class->meta->new_object(@_); |
155 | } |
156 | |
157 | # now you can just use the class as normal |
158 | |
0e76a376 |
159 | =head1 DESCRIPTION |
160 | |
f892c0f0 |
161 | This is a proof of concept using the Instance sub-protocol |
162 | which uses ARRAY refs to store the instance data. |
163 | |
1becdfcc |
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. |
167 | |
0e76a376 |
168 | =head1 AUTHOR |
169 | |
170 | Stevan Little E<lt>stevan@iinteractive.comE<gt> |
171 | |
172 | =head1 SEE ALSO |
173 | |
174 | =head1 COPYRIGHT AND LICENSE |
175 | |
176 | Copyright 2006 by Infinity Interactive, Inc. |
177 | |
178 | L<http://www.iinteractive.com> |
179 | |
180 | This library is free software; you can redistribute it and/or modify |
181 | it under the same terms as Perl itself. |
182 | |
183 | =cut |