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