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