Merge branch 'master' of gitmo@git.moose.perl.org:Class-MOP
[gitmo/Class-MOP.git] / lib / Class / MOP / Instance.pm
1
2 package Class::MOP::Instance;
3
4 use strict;
5 use warnings;
6
7 use Scalar::Util 'weaken', 'blessed';
8
9 our $VERSION   = '0.89';
10 $VERSION = eval $VERSION;
11 our $AUTHORITY = 'cpan:STEVAN';
12
13 use base 'Class::MOP::Object';
14
15 sub BUILDARGS {
16     my ($class, @args) = @_;
17
18     if ( @args == 1 ) {
19         unshift @args, "associated_metaclass";
20     } elsif ( @args >= 2 && blessed($args[0]) && $args[0]->isa("Class::MOP::Class") ) {
21         # compat mode
22         my ( $meta, @attrs ) = @args;
23         @args = ( associated_metaclass => $meta, attributes => \@attrs );
24     }
25
26     my %options = @args;
27     # FIXME lazy_build
28     $options{slots} ||= [ map { $_->slots } @{ $options{attributes} || [] } ];
29     $options{slot_hash} = { map { $_ => undef } @{ $options{slots} } }; # FIXME lazy_build
30
31     return \%options;
32 }
33
34 sub new {
35     my $class = shift;
36     my $options = $class->BUILDARGS(@_);
37
38     # FIXME replace with a proper constructor
39     my $instance = $class->_new(%$options);
40
41     # FIXME weak_ref => 1,
42     weaken($instance->{'associated_metaclass'});
43
44     return $instance;
45 }
46
47 sub _new {
48     my ( $class, %options ) = @_;
49     bless {
50         # NOTE:
51         # I am not sure that it makes
52         # sense to pass in the meta
53         # The ideal would be to just
54         # pass in the class name, but
55         # that is placing too much of
56         # an assumption on bless(),
57         # which is *probably* a safe
58         # assumption,.. but you can
59         # never tell <:)
60         'associated_metaclass' => $options{associated_metaclass},
61         'attributes'           => $options{attributes},
62         'slots'                => $options{slots},
63         'slot_hash'            => $options{slot_hash},
64     } => $class;
65 }
66
67 sub _class_name { $_[0]->{_class_name} ||= $_[0]->associated_metaclass->name }
68
69 sub associated_metaclass { $_[0]{'associated_metaclass'} }
70
71 sub create_instance {
72     my $self = shift;
73     bless {}, $self->_class_name;
74 }
75
76 # for compatibility
77 sub bless_instance_structure {
78     Carp::cluck('The bless_instance_structure method is deprecated.'
79         . " It will be removed in a future release.\n");
80
81     my ($self, $instance_structure) = @_;
82     bless $instance_structure, $self->_class_name;
83 }
84
85 sub clone_instance {
86     my ($self, $instance) = @_;
87     bless { %$instance }, $self->_class_name;
88 }
89
90 # operations on meta instance
91
92 sub get_all_slots {
93     my $self = shift;
94     return @{$self->{'slots'}};
95 }
96
97 sub get_all_attributes {
98     my $self = shift;
99     return @{$self->{attributes}};
100 }
101
102 sub is_valid_slot {
103     my ($self, $slot_name) = @_;
104     exists $self->{'slot_hash'}->{$slot_name};
105 }
106
107 # operations on created instances
108
109 sub get_slot_value {
110     my ($self, $instance, $slot_name) = @_;
111     $instance->{$slot_name};
112 }
113
114 sub set_slot_value {
115     my ($self, $instance, $slot_name, $value) = @_;
116     $instance->{$slot_name} = $value;
117 }
118
119 sub initialize_slot {
120     my ($self, $instance, $slot_name) = @_;
121     return;
122 }
123
124 sub deinitialize_slot {
125     my ( $self, $instance, $slot_name ) = @_;
126     delete $instance->{$slot_name};
127 }
128
129 sub initialize_all_slots {
130     my ($self, $instance) = @_;
131     foreach my $slot_name ($self->get_all_slots) {
132         $self->initialize_slot($instance, $slot_name);
133     }
134 }
135
136 sub deinitialize_all_slots {
137     my ($self, $instance) = @_;
138     foreach my $slot_name ($self->get_all_slots) {
139         $self->deinitialize_slot($instance, $slot_name);
140     }
141 }
142
143 sub is_slot_initialized {
144     my ($self, $instance, $slot_name, $value) = @_;
145     exists $instance->{$slot_name};
146 }
147
148 sub weaken_slot_value {
149     my ($self, $instance, $slot_name) = @_;
150     weaken $instance->{$slot_name};
151 }
152
153 sub strengthen_slot_value {
154     my ($self, $instance, $slot_name) = @_;
155     $self->set_slot_value($instance, $slot_name, $self->get_slot_value($instance, $slot_name));
156 }
157
158 sub rebless_instance_structure {
159     my ($self, $instance, $metaclass) = @_;
160
161     # we use $_[1] here because of t/306_rebless_overload.t regressions on 5.8.8
162     bless $_[1], $metaclass->name;
163 }
164
165 sub is_dependent_on_superclasses {
166     return; # for meta instances that require updates on inherited slot changes
167 }
168
169 # inlinable operation snippets
170
171 sub is_inlinable { 1 }
172
173 sub inline_create_instance {
174     my ($self, $class_variable) = @_;
175     'bless {} => ' . $class_variable;
176 }
177
178 sub inline_slot_access {
179     my ($self, $instance, $slot_name) = @_;
180     sprintf q[%s->{'%s'}], $instance, quotemeta($slot_name);
181 }
182
183 sub inline_get_slot_value {
184     my ($self, $instance, $slot_name) = @_;
185     $self->inline_slot_access($instance, $slot_name);
186 }
187
188 sub inline_set_slot_value {
189     my ($self, $instance, $slot_name, $value) = @_;
190     $self->inline_slot_access($instance, $slot_name) . " = $value",
191 }
192
193 sub inline_initialize_slot {
194     my ($self, $instance, $slot_name) = @_;
195     return '';
196 }
197
198 sub inline_deinitialize_slot {
199     my ($self, $instance, $slot_name) = @_;
200     "delete " . $self->inline_slot_access($instance, $slot_name);
201 }
202 sub inline_is_slot_initialized {
203     my ($self, $instance, $slot_name) = @_;
204     "exists " . $self->inline_slot_access($instance, $slot_name);
205 }
206
207 sub inline_weaken_slot_value {
208     my ($self, $instance, $slot_name) = @_;
209     sprintf "Scalar::Util::weaken( %s )", $self->inline_slot_access($instance, $slot_name);
210 }
211
212 sub inline_strengthen_slot_value {
213     my ($self, $instance, $slot_name) = @_;
214     $self->inline_set_slot_value($instance, $slot_name, $self->inline_slot_access($instance, $slot_name));
215 }
216
217 sub inline_rebless_instance_structure {
218     my ($self, $instance, $class_variable) = @_;
219     "bless $instance => $class_variable";
220 }
221
222 1;
223
224 __END__
225
226 =pod
227
228 =head1 NAME
229
230 Class::MOP::Instance - Instance Meta Object
231
232 =head1 DESCRIPTION
233
234 The Instance Protocol controls the creation of object instances, and
235 the storage of attribute values in those instances.
236
237 Using this API directly in your own code violates encapsulation, and
238 we recommend that you use the appropriate APIs in L<Class::MOP::Class>
239 and L<Class::MOP::Attribute> instead. Those APIs in turn call the
240 methods in this class as appropriate.
241
242 This class also participates in generating inlined code by providing
243 snippets of code to access an object instance.
244
245 =head1 METHODS
246
247 =head2 Object construction
248
249 =over 4
250
251 =item B<< Class::MOP::Instance->new(%options) >>
252
253 This method creates a new meta-instance object.
254
255 It accepts the following keys in C<%options>:
256
257 =over 8
258
259 =item * associated_metaclass
260
261 The L<Class::MOP::Class> object for which instances will be created.
262
263 =item * attributes
264
265 An array reference of L<Class::MOP::Attribute> objects. These are the
266 attributes which can be stored in each instance.
267
268 =back
269
270 =back
271
272 =head2 Creating and altering instances
273
274 =over 4
275
276 =item B<< $metainstance->create_instance >>
277
278 This method returns a reference blessed into the associated
279 metaclass's class.
280
281 The default is to use a hash reference. Subclasses can override this.
282
283 =item B<< $metainstance->clone_instance($instance) >>
284
285 Given an instance, this method creates a new object by making
286 I<shallow> clone of the original.
287
288 =back
289
290 =head2 Introspection
291
292 =over 4
293
294 =item B<< $metainstance->associated_metaclass >>
295
296 This returns the L<Class::MOP::Class> object associated with the
297 meta-instance object.
298
299 =item B<< $metainstance->get_all_slots >>
300
301 This returns a list of slot names stored in object instances. In
302 almost all cases, slot names correspond directly attribute names.
303
304 =item B<< $metainstance->is_valid_slot($slot_name) >>
305
306 This will return true if C<$slot_name> is a valid slot name.
307
308 =item B<< $metainstance->get_all_attributes >>
309
310 This returns a list of attributes corresponding to the attributes
311 passed to the constructor.
312
313 =back
314
315 =head2 Operations on Instance Structures
316
317 It's important to understand that the meta-instance object is a
318 different entity from the actual instances it creates. For this
319 reason, any operations on the C<$instance_structure> always require
320 that the object instance be passed to the method.
321
322 =over 4
323
324 =item B<< $metainstance->get_slot_value($instance_structure, $slot_name) >>
325
326 =item B<< $metainstance->set_slot_value($instance_structure, $slot_name, $value) >>
327
328 =item B<< $metainstance->initialize_slot($instance_structure, $slot_name) >>
329
330 =item B<< $metainstance->deinitialize_slot($instance_structure, $slot_name) >>
331
332 =item B<< $metainstance->initialize_all_slots($instance_structure) >>
333
334 =item B<< $metainstance->deinitialize_all_slots($instance_structure) >>
335
336 =item B<< $metainstance->is_slot_initialized($instance_structure, $slot_name) >>
337
338 =item B<< $metainstance->weaken_slot_value($instance_structure, $slot_name) >>
339
340 =item B<< $metainstance->strengthen_slot_value($instance_structure, $slot_name) >>
341
342 =item B<< $metainstance->rebless_instance_structure($instance_structure, $new_metaclass) >>
343
344 The exact details of what each method does should be fairly obvious
345 from the method name.
346
347 =back
348
349 =head2 Inlinable Instance Operations
350
351 =over 4
352
353 =item B<< $metainstance->is_inlinable >>
354
355 This is a boolean that indicates whether or not slot access operations
356 can be inlined. By default it is true, but subclasses can override
357 this.
358
359 =item B<< $metainstance->inline_create_instance($class_variable) >>
360
361 This method expects a string that, I<when inlined>, will become a
362 class name. This would literally be something like C<'$class'>, not an
363 actual class name.
364
365 It returns a snippet of code that creates a new object for the
366 class. This is something like C< bless {}, $class_name >.
367
368 =item B<< $metainstance->inline_slot_access($instance_variable, $slot_name) >>
369
370 =item B<< $metainstance->inline_get_slot_value($instance_variable, $slot_name) >>
371
372 =item B<< $metainstance->inline_set_slot_value($instance_variable, $slot_name, $value) >>
373
374 =item B<< $metainstance->inline_initialize_slot($instance_variable, $slot_name) >>
375
376 =item B<< $metainstance->inline_deinitialize_slot($instance_variable, $slot_name) >>
377
378 =item B<< $metainstance->inline_is_slot_initialized($instance_variable, $slot_name) >>
379
380 =item B<< $metainstance->inline_weaken_slot_value($instance_variable, $slot_name) >>
381
382 =item B<< $metainstance->inline_strengthen_slot_value($instance_variable, $slot_name) >>
383
384 These methods all expect two arguments. The first is the name of a
385 variable, than when inlined, will represent the object
386 instance. Typically this will be a literal string like C<'$_[0]'>.
387
388 The second argument is a slot name.
389
390 The method returns a snippet of code that, when inlined, performs some
391 operation on the instance.
392
393 =item B<< $metainstance->inline_rebless_instance_structure($instance_variable, $class_variable) >>
394
395 This takes the name of a variable that will, when inlined, represent the object
396 instance, and the name of a variable that will represent the class to rebless
397 into, and returns code to rebless an instance into a class.
398
399 =back
400
401 =head2 Introspection
402
403 =over 4
404
405 =item B<< Class::MOP::Instance->meta >>
406
407 This will return a L<Class::MOP::Class> instance for this class.
408
409 It should also be noted that L<Class::MOP> will actually bootstrap
410 this module by installing a number of attribute meta-objects into its
411 metaclass.
412
413 =back
414
415 =head1 AUTHORS
416
417 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
418
419 Stevan Little E<lt>stevan@iinteractive.comE<gt>
420
421 =head1 COPYRIGHT AND LICENSE
422
423 Copyright 2006-2009 by Infinity Interactive, Inc.
424
425 L<http://www.iinteractive.com>
426
427 This library is free software; you can redistribute it and/or modify
428 it under the same terms as Perl itself.
429
430 =cut
431