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 | |
84ef30d1 |
104 | sub set_weak_slot_value { |
105 | my ( $self, $instance, $slot_name, $value) = @_; |
106 | $self->set_slot_value( $instance, $slot_name, $value ); |
107 | $self->weeaken_slot_value( $instance, $slot_name ); |
108 | } |
109 | |
110 | sub weaken_slot_value { |
111 | my ( $self, $instance, $slot_name ) = @_; |
112 | weaken( $instance->{$slot_name} ); |
113 | } |
114 | |
2d711cc8 |
115 | # convenience method |
116 | # non autovivifying stores will have this as { initialize_slot unless slot_initlized; set_slot_value } |
117 | sub set_slot_value_with_init { |
118 | my ( $self, $instance, $slot_name, $value ) = @_; |
119 | $self->set_slot_value( $instance, $slot_name, $value ); |
120 | } |
121 | |
122 | sub initialize_slot { |
123 | my ( $self, $instance, $slot_name ) = @_; |
124 | } |
125 | |
126 | sub slot_initialized { |
2bab2be6 |
127 | my ($self, $instance, $slot_name) = @_; |
2d711cc8 |
128 | exists $instance->{$slot_name} ? 1 : 0; |
2bab2be6 |
129 | } |
839ea973 |
130 | |
2d711cc8 |
131 | |
132 | # inlinable operation snippets |
133 | |
134 | sub inline_get_slot_value { |
135 | my ($self, $instance, $slot_name) = @_; |
136 | sprintf "%s->{%s}", $instance, $slot_name; |
137 | } |
138 | |
139 | sub inline_set_slot_value { |
140 | my ($self, $instance, $slot_name, $value) = @_; |
84ef30d1 |
141 | $self->_inline_slot_lvalue( $instance, $slot_name ) . " = $value", |
142 | } |
143 | |
144 | sub inline_set_weak_slot_value { |
145 | my ( $self, $instance, $slot_name, $value ) = @_; |
146 | return "" |
147 | . $self->inline_set_slot_value( $instance, $slot_name, $value ) |
148 | . "; " |
149 | . $self->inline_weaken_slot_value( $instance, $slot_name ); |
150 | } |
151 | |
152 | sub inline_weaken_slot_value { |
153 | my ( $self, $instance, $slot_name ) = @_; |
154 | return 'Scalar::Util::weaken( ' . $self->_inline_slot_lvalue( $instance, $slot_name ) . ')'; |
2d711cc8 |
155 | } |
156 | |
157 | sub inline_set_slot_value_with_init { |
158 | my ( $self, $instance, $slot_name, $value) = @_; |
159 | $self->inline_set_slot_value( $instance, $slot_name, $value ) . ";"; |
160 | } |
161 | |
162 | sub inline_initialize_slot { |
163 | return ""; |
164 | } |
165 | |
166 | sub inline_slot_initialized { |
167 | my ($self, $instance, $slot_name) = @_; |
168 | "exists " . $self->inline_get_slot_value; |
169 | } |
170 | |
171 | sub _inline_slot_lvalue { |
172 | my ($self, $instance, $slot_name) = @_; |
84ef30d1 |
173 | $self->inline_get_slot_value( $instance, $slot_name ); |
2d711cc8 |
174 | } |
24869f62 |
175 | |
176 | 1; |
177 | |
178 | __END__ |
179 | |
180 | =pod |
181 | |
182 | =head1 NAME |
183 | |
184 | Class::MOP::Instance - Instance Meta Object |
185 | |
186 | =head1 SYNOPSIS |
187 | |
188 | =head1 DESCRIPTION |
189 | |
190 | =head1 METHODS |
191 | |
192 | =over 4 |
193 | |
194 | =item B<new> |
195 | |
196 | =item B<add_slot> |
197 | |
58287a97 |
198 | =item B<bless_instance_structure> |
199 | |
200 | =item B<create_instance> |
201 | |
202 | =item B<get_all_parents> |
839ea973 |
203 | |
204 | =item B<get_slot_value> |
205 | |
58287a97 |
206 | =item B<has_slot> |
207 | |
208 | =item B<has_slot_recursively> |
209 | |
210 | =item B<initialize_slot> |
211 | |
212 | =item B<inline_get_slot_value> |
213 | |
214 | =item B<inline_initialize_slot> |
215 | |
216 | =item B<inline_set_slot_value> |
217 | |
218 | =item B<inline_set_slot_value_with_init> |
219 | |
220 | =item B<inline_slot_initialized> |
221 | |
222 | =item B<remove_slot> |
223 | |
839ea973 |
224 | =item B<set_slot_value> |
225 | |
58287a97 |
226 | =item B<set_slot_value_with_init> |
227 | |
228 | =item B<slot_initialized> |
2bab2be6 |
229 | |
76985bf2 |
230 | =item B<get_all_slots> |
231 | |
232 | =item B<get_all_slots_recursively> |
233 | |
24869f62 |
234 | =back |
235 | |
236 | =head2 Introspection |
237 | |
238 | =over 4 |
239 | |
240 | =item B<meta> |
241 | |
242 | This will return a B<Class::MOP::Class> instance which is related |
243 | to this class. |
244 | |
245 | =back |
246 | |
247 | =head1 AUTHOR |
248 | |
249 | Stevan Little E<lt>stevan@iinteractive.comE<gt> |
250 | |
251 | =head1 COPYRIGHT AND LICENSE |
252 | |
253 | Copyright 2006 by Infinity Interactive, Inc. |
254 | |
255 | L<http://www.iinteractive.com> |
256 | |
257 | This library is free software; you can redistribute it and/or modify |
258 | it under the same terms as Perl itself. |
259 | |
84ef30d1 |
260 | =cut |