Add Instance->get_all_slot_values and tests
[gitmo/Class-MOP.git] / lib / Class / MOP / Instance.pm
CommitLineData
24869f62 1
2package Class::MOP::Instance;
3
4use strict;
5use warnings;
6
fa16e528 7use Scalar::Util 'weaken', 'blessed';
24869f62 8
f0480c45 9our $VERSION = '0.03';
10our $AUTHORITY = 'cpan:STEVAN';
24869f62 11
8d2d4c67 12sub meta {
24869f62 13 require Class::MOP::Class;
14 Class::MOP::Class->initialize(blessed($_[0]) || $_[0]);
15}
16
8d2d4c67 17sub new {
052c2a1a 18 my ($class, $meta, @attrs) = @_;
c57c8b10 19 my @slots = map { $_->slots } @attrs;
c23184fc 20 my $instance = bless {
fc3ddd1d 21 # NOTE:
22 # I am not sure that it makes
23 # sense to pass in the meta
8d2d4c67 24 # The ideal would be to just
25 # pass in the class name, but
26 # that is placing too much of
27 # an assumption on bless(),
fc3ddd1d 28 # which is *probably* a safe
8d2d4c67 29 # assumption,.. but you can
fc3ddd1d 30 # never tell <:)
c23184fc 31 '$!meta' => $meta,
32 '@!slots' => { map { $_ => undef } @slots },
8d2d4c67 33 } => $class;
34
c23184fc 35 weaken($instance->{'$!meta'});
8d2d4c67 36
c23184fc 37 return $instance;
24869f62 38}
39
c23184fc 40sub associated_metaclass { (shift)->{'$!meta'} }
41
49c93440 42sub create_instance {
43 my $self = shift;
44 $self->bless_instance_structure({});
2d711cc8 45}
46
49c93440 47sub bless_instance_structure {
48 my ($self, $instance_structure) = @_;
c23184fc 49 bless $instance_structure, $self->associated_metaclass->name;
2d711cc8 50}
51
f7259199 52sub clone_instance {
53 my ($self, $instance) = @_;
54 $self->bless_instance_structure({ %$instance });
55}
56
2d711cc8 57# operations on meta instance
58
eb49acde 59sub get_all_slots {
60 my $self = shift;
c23184fc 61 return keys %{$self->{'@!slots'}};
f7259199 62}
63
64sub is_valid_slot {
65 my ($self, $slot_name) = @_;
c23184fc 66 exists $self->{'@!slots'}->{$slot_name} ? 1 : 0;
839ea973 67}
68
2d711cc8 69# operations on created instances
70
839ea973 71sub get_slot_value {
2bab2be6 72 my ($self, $instance, $slot_name) = @_;
8d2d4c67 73 $self->is_slot_initialized($instance, $slot_name) ? $instance->{$slot_name} : undef;
839ea973 74}
75
2bab2be6 76sub set_slot_value {
77 my ($self, $instance, $slot_name, $value) = @_;
78 $instance->{$slot_name} = $value;
79}
80
2d711cc8 81sub initialize_slot {
49c93440 82 my ($self, $instance, $slot_name) = @_;
8d2d4c67 83 #$self->set_slot_value($instance, $slot_name, undef);
2d711cc8 84}
85
7d28758b 86sub deinitialize_slot {
87 my ( $self, $instance, $slot_name ) = @_;
88 delete $instance->{$slot_name};
89}
90
c174112e 91sub initialize_all_slots {
92 my ($self, $instance) = @_;
93 foreach my $slot_name ($self->get_all_slots) {
94 $self->initialize_slot($instance, $slot_name);
95 }
96}
97
7d28758b 98sub deinitialize_all_slots {
99 my ($self, $instance) = @_;
100 foreach my $slot_name ($self->get_all_slots) {
101 $self->deinitialize_slot($instance, $slot_name);
102 }
103}
104
49c93440 105sub is_slot_initialized {
106 my ($self, $instance, $slot_name, $value) = @_;
2d711cc8 107 exists $instance->{$slot_name} ? 1 : 0;
2bab2be6 108}
839ea973 109
5582521c 110sub weaken_slot_value {
69e3ab0a 111 my ($self, $instance, $slot_name) = @_;
112 weaken $instance->{$slot_name};
5582521c 113}
114
115sub strengthen_slot_value {
69e3ab0a 116 my ($self, $instance, $slot_name) = @_;
117 $self->set_slot_value($instance, $slot_name, $self->get_slot_value($instance, $slot_name));
5582521c 118}
119
3d9e4646 120sub rebless_instance_structure {
121 my ($self, $instance, $metaclass) = @_;
122 bless $instance, $metaclass->name;
123}
124
ad074154 125sub get_all_slot_values {
126 my ($self, $instance) = @_;
127 my $class = $self->associated_metaclass;
128 my %map;
129
130 for my $attr ($class->compute_all_applicable_attributes) {
131 my $name = $attr->name;
132 $map{$name} = $self->get_slot_value($instance, $name)
133 if $self->is_slot_initialized($instance, $name);
134 }
135
136 return \%map;
137}
138
ee7c0467 139# inlinable operation snippets
140
c0cbf4d9 141sub is_inlinable { 1 }
142
143sub inline_create_instance {
144 my ($self, $class_variable) = @_;
145 'bless {} => ' . $class_variable;
146}
147
ee7c0467 148sub inline_slot_access {
149 my ($self, $instance, $slot_name) = @_;
150 sprintf "%s->{%s}", $instance, $slot_name;
151}
152
153sub inline_get_slot_value {
154 my ($self, $instance, $slot_name) = @_;
8d2d4c67 155 'exists ' . $self->inline_slot_access($instance, $slot_name) .
156 ' ? ' . $self->inline_slot_access($instance, $slot_name) . ' : undef'
ee7c0467 157}
158
159sub inline_set_slot_value {
160 my ($self, $instance, $slot_name, $value) = @_;
8d2d4c67 161 $self->inline_slot_access($instance, $slot_name) . " = $value",
ee7c0467 162}
163
164sub inline_initialize_slot {
165 my ($self, $instance, $slot_name) = @_;
166 $self->inline_set_slot_value($instance, $slot_name, 'undef'),
167}
168
7d28758b 169sub inline_deinitialize_slot {
170 my ($self, $instance, $slot_name) = @_;
171 "delete " . $self->inline_slot_access($instance, $slot_name);
172}
ee7c0467 173sub inline_is_slot_initialized {
174 my ($self, $instance, $slot_name) = @_;
175 "exists " . $self->inline_slot_access($instance, $slot_name) . " ? 1 : 0";
176}
177
178sub inline_weaken_slot_value {
179 my ($self, $instance, $slot_name) = @_;
180 sprintf "Scalar::Util::weaken( %s )", $self->inline_slot_access($instance, $slot_name);
181}
182
183sub inline_strengthen_slot_value {
184 my ($self, $instance, $slot_name) = @_;
185 $self->inline_set_slot_value($instance, $slot_name, $self->inline_slot_access($instance, $slot_name));
186}
187
24869f62 1881;
189
190__END__
191
192=pod
193
8d2d4c67 194=head1 NAME
24869f62 195
196Class::MOP::Instance - Instance Meta Object
197
198=head1 SYNOPSIS
199
8d2d4c67 200 # for the most part, this protocol is internal
201 # and not for public usage, but this how one
9fa4d0b4 202 # might use it
8d2d4c67 203
9fa4d0b4 204 package Foo;
8d2d4c67 205
9fa4d0b4 206 use strict;
207 use warnings;
1becdfcc 208 use metaclass (
9fa4d0b4 209 ':instance_metaclass' => 'ArrayBasedStorage::Instance',
210 );
8d2d4c67 211
9fa4d0b4 212 # now Foo->new produces blessed ARRAY ref based objects
213
24869f62 214=head1 DESCRIPTION
215
8d2d4c67 216This is a sub-protocol which governs instance creation
9fa4d0b4 217and access to the slots of the instance structure.
218
8d2d4c67 219This may seem like over-abstraction, but by abstracting
220this process into a sub-protocol we make it possible to
221easily switch the details of how an object's instance is
222stored with minimal impact. In most cases just subclassing
223this class will be all you need to do (see the examples;
224F<examples/ArrayBasedStorage.pod> and
1becdfcc 225F<examples/InsideOutClass.pod> for details).
9fa4d0b4 226
24869f62 227=head1 METHODS
228
229=over 4
230
9fa4d0b4 231=item B<new ($meta, @attrs)>
232
8d2d4c67 233Creates a new instance meta-object and gathers all the slots from
9fa4d0b4 234the list of C<@attrs> given.
235
236=item B<meta>
237
8d2d4c67 238This will return a B<Class::MOP::Class> instance which is related
9fa4d0b4 239to this class.
240
241=back
242
243=head2 Creation of Instances
244
245=over 4
24869f62 246
58287a97 247=item B<create_instance>
248
8d2d4c67 249This creates the appropriate structure needed for the instance and
9fa4d0b4 250then calls C<bless_instance_structure> to bless it into the class.
0e76a376 251
9fa4d0b4 252=item B<bless_instance_structure ($instance_structure)>
839ea973 253
9fa4d0b4 254This does just exactly what it says it does.
0e76a376 255
f7259199 256=item B<clone_instance ($instance_structure)>
257
9fa4d0b4 258=back
839ea973 259
9fa4d0b4 260=head2 Instrospection
58287a97 261
8d2d4c67 262NOTE: There might be more methods added to this part of the API,
9fa4d0b4 263we will add then when we need them basically.
58287a97 264
9fa4d0b4 265=over 4
266
c23184fc 267=item B<associated_metaclass>
268
9fa4d0b4 269=item B<get_all_slots>
270
8d2d4c67 271This will return the current list of slots based on what was
9fa4d0b4 272given to this object in C<new>.
58287a97 273
f7259199 274=item B<is_valid_slot ($slot_name)>
275
24869f62 276=back
277
9fa4d0b4 278=head2 Operations on Instance Structures
279
8d2d4c67 280An important distinction of this sub-protocol is that the
281instance meta-object is a different entity from the actual
282instance it creates. For this reason, any actions on slots
9fa4d0b4 283require that the C<$instance_structure> is passed into them.
24869f62 284
285=over 4
286
9fa4d0b4 287=item B<get_slot_value ($instance_structure, $slot_name)>
24869f62 288
9fa4d0b4 289=item B<set_slot_value ($instance_structure, $slot_name, $value)>
290
ad074154 291=item B<get_all_slot_values ($instance_structure)>
292
9fa4d0b4 293=item B<initialize_slot ($instance_structure, $slot_name)>
294
7d28758b 295=item B<deinitialize_slot ($instance_structure, $slot_name)>
296
9fa4d0b4 297=item B<initialize_all_slots ($instance_structure)>
298
7d28758b 299=item B<deinitialize_all_slots ($instance_structure)>
300
9fa4d0b4 301=item B<is_slot_initialized ($instance_structure, $slot_name)>
24869f62 302
ee7c0467 303=item B<weaken_slot_value ($instance_structure, $slot_name)>
304
305=item B<strengthen_slot_value ($instance_structure, $slot_name)>
306
5fdf066d 307=item B<rebless_instance_structure ($instance_structure, $new_metaclass)>
308
ee7c0467 309=back
310
311=head2 Inlineable Instance Operations
312
8d2d4c67 313This part of the API is currently un-used. It is there for use
314in future experiments in class finailization mostly. Best to
f7259199 315ignore this for now.
316
ee7c0467 317=over 4
318
c0cbf4d9 319=item B<is_inlinable>
320
8d2d4c67 321Each meta-instance should override this method to tell Class::MOP if it's
322possible to inline the slot access.
c0cbf4d9 323
8d2d4c67 324This is currently only used by Class::MOP::Class::Immutable when performing
c0cbf4d9 325optimizations.
326
495af518 327=item B<inline_create_instance>
328
ee7c0467 329=item B<inline_slot_access ($instance_structure, $slot_name)>
330
331=item B<inline_get_slot_value ($instance_structure, $slot_name)>
332
333=item B<inline_set_slot_value ($instance_structure, $slot_name, $value)>
334
335=item B<inline_initialize_slot ($instance_structure, $slot_name)>
336
7d28758b 337=item B<inline_deinitialize_slot ($instance_structure, $slot_name)>
338
ee7c0467 339=item B<inline_is_slot_initialized ($instance_structure, $slot_name)>
5582521c 340
ee7c0467 341=item B<inline_weaken_slot_value ($instance_structure, $slot_name)>
5582521c 342
ee7c0467 343=item B<inline_strengthen_slot_value ($instance_structure, $slot_name)>
5582521c 344
24869f62 345=back
346
1a09d9cc 347=head1 AUTHORS
24869f62 348
9fa4d0b4 349Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
350
24869f62 351Stevan Little E<lt>stevan@iinteractive.comE<gt>
352
353=head1 COPYRIGHT AND LICENSE
354
69e3ab0a 355Copyright 2006-2008 by Infinity Interactive, Inc.
24869f62 356
357L<http://www.iinteractive.com>
358
359This library is free software; you can redistribute it and/or modify
8d2d4c67 360it under the same terms as Perl itself.
24869f62 361
84ef30d1 362=cut
5582521c 363