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