Commit | Line | Data |
24869f62 |
1 | |
2 | package Class::MOP::Instance; |
3 | |
4 | use strict; |
5 | use warnings; |
6 | |
7 | use Carp 'confess'; |
8 | use Scalar::Util 'blessed', 'reftype', 'weaken'; |
9 | |
10 | our $VERSION = '0.01'; |
11 | |
12 | sub meta { |
13 | require Class::MOP::Class; |
14 | Class::MOP::Class->initialize(blessed($_[0]) || $_[0]); |
15 | } |
16 | |
17 | sub new { |
2d711cc8 |
18 | my ( $class, $meta ) = @_; |
24869f62 |
19 | bless { |
2d711cc8 |
20 | meta => $meta, |
21 | instance_layout => {} |
24869f62 |
22 | } => $class; |
23 | } |
24 | |
2d711cc8 |
25 | sub create_instance { |
26 | my ( $self, $class ) = @_; |
27 | |
28 | # rely on autovivification |
29 | $self->bless_instance_structure( {}, $class ); |
30 | } |
31 | |
32 | sub bless_instance_structure { |
33 | my ( $self, $instance_structure, $class ) = @_; |
34 | $class ||= $self->{meta}->name; |
35 | bless $instance_structure, $class; |
36 | } |
37 | |
38 | sub get_all_parents { |
39 | my $self = shift; |
40 | my @parents = $self->{meta}->class_precedence_list; |
41 | shift @parents; # shift off ourselves |
42 | return map { $_->get_meta_instance } map { $_->meta || () } @parents; |
43 | } |
44 | |
45 | # operations on meta instance |
46 | |
24869f62 |
47 | sub add_slot { |
2d711cc8 |
48 | my ($self, $slot_name ) = @_; |
49 | confess "The slot '$slot_name' already exists" |
eb49acde |
50 | if 0 && $self->has_slot_recursively( $slot_name ); # FIXME |
2d711cc8 |
51 | $self->{instance_layout}->{$slot_name} = undef; |
24869f62 |
52 | } |
53 | |
eb49acde |
54 | sub get_all_slots { |
55 | my $self = shift; |
56 | keys %{ $self->{instance_layout} }; |
57 | } |
58 | |
59 | sub get_all_slots_recursively { |
60 | my $self = shift; |
61 | return ( |
62 | $self->get_all_slots, |
63 | map { $_->get_all_slots } $self->get_all_parents, |
64 | ), |
65 | } |
66 | |
839ea973 |
67 | sub has_slot { |
68 | my ($self, $slot_name) = @_; |
2d711cc8 |
69 | exists $self->{instance_layout}->{$slot_name} ? 1 : 0; |
70 | } |
71 | |
72 | sub has_slot_recursively { |
73 | my ( $self, $slot_name ) = @_; |
74 | return 1 if $self->has_slot($slot_name); |
75 | $_->has_slot_recursively($slot_name) && return 1 for $self->get_all_parents; |
76 | return 0; |
839ea973 |
77 | } |
78 | |
2d711cc8 |
79 | sub remove_slot { |
80 | my ( $self, $slot_name ) = @_; |
81 | # NOTE: |
82 | # this does not search recursively cause |
83 | # that is not the domain of this meta-instance |
84 | # it is specific to this class ... |
85 | confess "The slot '$slot_name' does not exist (maybe it's inherited?)" |
eb49acde |
86 | if 0 && $self->has_slot( $slot_name ); # FIXME |
2d711cc8 |
87 | delete $self->{instance_layout}->{$slot_name}; |
88 | } |
89 | |
90 | |
91 | # operations on created instances |
92 | |
839ea973 |
93 | sub get_slot_value { |
2bab2be6 |
94 | my ($self, $instance, $slot_name) = @_; |
95 | return $instance->{$slot_name}; |
839ea973 |
96 | } |
97 | |
2d711cc8 |
98 | # can be called only after initialize_slot_value |
2bab2be6 |
99 | sub set_slot_value { |
100 | my ($self, $instance, $slot_name, $value) = @_; |
101 | $instance->{$slot_name} = $value; |
102 | } |
103 | |
2d711cc8 |
104 | # convenience method |
105 | # non autovivifying stores will have this as { initialize_slot unless slot_initlized; set_slot_value } |
106 | sub set_slot_value_with_init { |
107 | my ( $self, $instance, $slot_name, $value ) = @_; |
108 | $self->set_slot_value( $instance, $slot_name, $value ); |
109 | } |
110 | |
111 | sub initialize_slot { |
112 | my ( $self, $instance, $slot_name ) = @_; |
113 | } |
114 | |
115 | sub slot_initialized { |
2bab2be6 |
116 | my ($self, $instance, $slot_name) = @_; |
2d711cc8 |
117 | exists $instance->{$slot_name} ? 1 : 0; |
2bab2be6 |
118 | } |
839ea973 |
119 | |
2d711cc8 |
120 | |
121 | # inlinable operation snippets |
122 | |
123 | sub inline_get_slot_value { |
124 | my ($self, $instance, $slot_name) = @_; |
125 | sprintf "%s->{%s}", $instance, $slot_name; |
126 | } |
127 | |
128 | sub inline_set_slot_value { |
129 | my ($self, $instance, $slot_name, $value) = @_; |
130 | $self->_inline_slot_lvalue . " = $value", |
131 | } |
132 | |
133 | sub inline_set_slot_value_with_init { |
134 | my ( $self, $instance, $slot_name, $value) = @_; |
135 | $self->inline_set_slot_value( $instance, $slot_name, $value ) . ";"; |
136 | } |
137 | |
138 | sub inline_initialize_slot { |
139 | return ""; |
140 | } |
141 | |
142 | sub inline_slot_initialized { |
143 | my ($self, $instance, $slot_name) = @_; |
144 | "exists " . $self->inline_get_slot_value; |
145 | } |
146 | |
147 | sub _inline_slot_lvalue { |
148 | my ($self, $instance, $slot_name) = @_; |
149 | $self->inline_slot_value; |
150 | } |
24869f62 |
151 | |
152 | 1; |
153 | |
154 | __END__ |
155 | |
156 | =pod |
157 | |
158 | =head1 NAME |
159 | |
160 | Class::MOP::Instance - Instance Meta Object |
161 | |
162 | =head1 SYNOPSIS |
163 | |
164 | =head1 DESCRIPTION |
165 | |
166 | =head1 METHODS |
167 | |
168 | =over 4 |
169 | |
170 | =item B<new> |
171 | |
172 | =item B<add_slot> |
173 | |
58287a97 |
174 | =item B<bless_instance_structure> |
175 | |
176 | =item B<create_instance> |
177 | |
178 | =item B<get_all_parents> |
839ea973 |
179 | |
180 | =item B<get_slot_value> |
181 | |
58287a97 |
182 | =item B<has_slot> |
183 | |
184 | =item B<has_slot_recursively> |
185 | |
186 | =item B<initialize_slot> |
187 | |
188 | =item B<inline_get_slot_value> |
189 | |
190 | =item B<inline_initialize_slot> |
191 | |
192 | =item B<inline_set_slot_value> |
193 | |
194 | =item B<inline_set_slot_value_with_init> |
195 | |
196 | =item B<inline_slot_initialized> |
197 | |
198 | =item B<remove_slot> |
199 | |
839ea973 |
200 | =item B<set_slot_value> |
201 | |
58287a97 |
202 | =item B<set_slot_value_with_init> |
203 | |
204 | =item B<slot_initialized> |
2bab2be6 |
205 | |
24869f62 |
206 | =back |
207 | |
208 | =head2 Introspection |
209 | |
210 | =over 4 |
211 | |
212 | =item B<meta> |
213 | |
214 | This will return a B<Class::MOP::Class> instance which is related |
215 | to this class. |
216 | |
217 | =back |
218 | |
219 | =head1 AUTHOR |
220 | |
221 | Stevan Little E<lt>stevan@iinteractive.comE<gt> |
222 | |
223 | =head1 COPYRIGHT AND LICENSE |
224 | |
225 | Copyright 2006 by Infinity Interactive, Inc. |
226 | |
227 | L<http://www.iinteractive.com> |
228 | |
229 | This library is free software; you can redistribute it and/or modify |
230 | it under the same terms as Perl itself. |
231 | |
232 | =cut |