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.65';
  10 our $AUTHORITY = 'cpan:STEVAN';
  11
  12 use base 'Class::MOP::Object';
  13
  14 sub BUILDARGS {
  15     my ($class, @args) = @_;
  16
  17     if ( @args == 1 ) {
  18         unshift @args, "associated_metaclass";
  19     } elsif ( @args >= 2 && blessed($args[0]) && $args[0]->isa("Class::MOP::Class") ) {
  20         # compat mode
  21         my ( $meta, @attrs ) = @args;
  22         @args = ( associated_metaclass => $meta, attributes => \@attrs );
  23     }
  24
  25     my %options = @args;
  26     # FIXME lazy_build
  27     $options{slots} ||= [ map { $_->slots } @{ $options{attributes} || [] } ];
  28     $options{slot_hash} = { map { $_ => undef } @{ $options{slots} } }; # FIXME lazy_build
  29
  30     return \%options;
  31 }
  32
  33 sub new {
  34     my $class = shift;
  35     my $options = $class->BUILDARGS(@_);
  36
  37     # FIXME replace with a proper constructor
  38     my $instance = bless {
  39         # NOTE:
  40         # I am not sure that it makes
  41         # sense to pass in the meta
  42         # The ideal would be to just
  43         # pass in the class name, but
  44         # that is placing too much of
  45         # an assumption on bless(),
  46         # which is *probably* a safe
  47         # assumption,.. but you can
  48         # never tell <:)
  49         'associated_metaclass' => $options->{associated_metaclass},
  50         'attributes'           => $options->{attributes},
  51         'slots'                => $options->{slots},
  52         'slot_hash'            => $options->{slot_hash},
  53     } => $class;
  54
  55     # FIXME weak_ref => 1,
  56     weaken($instance->{'associated_metaclass'});
  57
  58     return $instance;
  59 }
  60
  61 sub _class_name { $_[0]->{_class_name} ||= $_[0]->associated_metaclass->name }
  62
  63 sub associated_metaclass { $_[0]{'associated_metaclass'} }
  64
  65 sub create_instance {
  66     my $self = shift;
  67     bless {}, $self->_class_name;
  68 }
  69
  70 # for compatibility
  71 sub bless_instance_structure {
  72     my ($self, $instance_structure) = @_;
  73     bless $instance_structure, $self->_class_name;
  74 }
  75
  76 sub clone_instance {
  77     my ($self, $instance) = @_;
  78     bless { %$instance }, $self->_class_name;
  79 }
  80
  81 # operations on meta instance
  82
  83 sub get_all_slots {
  84     my $self = shift;
  85     return @{$self->{'slots'}};
  86 }
  87
  88 sub is_valid_slot {
  89     my ($self, $slot_name) = @_;
  90     exists $self->{'slot_hash'}->{$slot_name};
  91 }
  92
  93 # operations on created instances
  94
  95 sub get_slot_value {
  96     my ($self, $instance, $slot_name) = @_;
  97     $instance->{$slot_name};
  98 }
  99
 100 sub set_slot_value {
 101     my ($self, $instance, $slot_name, $value) = @_;
 102     $instance->{$slot_name} = $value;
 103 }
 104
 105 sub initialize_slot {
 106     my ($self, $instance, $slot_name) = @_;
 107     return;
 108 }
 109
 110 sub deinitialize_slot {
 111     my ( $self, $instance, $slot_name ) = @_;
 112     delete $instance->{$slot_name};
 113 }
 114
 115 sub initialize_all_slots {
 116     my ($self, $instance) = @_;
 117     foreach my $slot_name ($self->get_all_slots) {
 118         $self->initialize_slot($instance, $slot_name);
 119     }
 120 }
 121
 122 sub deinitialize_all_slots {
 123     my ($self, $instance) = @_;
 124     foreach my $slot_name ($self->get_all_slots) {
 125         $self->deinitialize_slot($instance, $slot_name);
 126     }
 127 }
 128
 129 sub is_slot_initialized {
 130     my ($self, $instance, $slot_name, $value) = @_;
 131     exists $instance->{$slot_name};
 132 }
 133
 134 sub weaken_slot_value {
 135     my ($self, $instance, $slot_name) = @_;
 136     weaken $instance->{$slot_name};
 137 }
 138
 139 sub strengthen_slot_value {
 140     my ($self, $instance, $slot_name) = @_;
 141     $self->set_slot_value($instance, $slot_name, $self->get_slot_value($instance, $slot_name));
 142 }
 143
 144 sub rebless_instance_structure {
 145     my ($self, $instance, $metaclass) = @_;
 146     bless $instance, $metaclass->name;
 147 }
 148
 149 sub is_dependent_on_superclasses {
 150     return; # for meta instances that require updates on inherited slot changes
 151 }
 152
 153 # inlinable operation snippets
 154
 155 sub is_inlinable { 1 }
 156
 157 sub inline_create_instance {
 158     my ($self, $class_variable) = @_;
 159     'bless {} => ' . $class_variable;
 160 }
 161
 162 sub inline_slot_access {
 163     my ($self, $instance, $slot_name) = @_;
 164     sprintf "%s->{%s}", $instance, $slot_name;
 165 }
 166
 167 sub inline_get_slot_value {
 168     my ($self, $instance, $slot_name) = @_;
 169     $self->inline_slot_access($instance, $slot_name);
 170 }
 171
 172 sub inline_set_slot_value {
 173     my ($self, $instance, $slot_name, $value) = @_;
 174     $self->inline_slot_access($instance, $slot_name) . " = $value",
 175 }
 176
 177 sub inline_initialize_slot {
 178     my ($self, $instance, $slot_name) = @_;
 179     return '';
 180 }
 181
 182 sub inline_deinitialize_slot {
 183     my ($self, $instance, $slot_name) = @_;
 184     "delete " . $self->inline_slot_access($instance, $slot_name);
 185 }
 186 sub inline_is_slot_initialized {
 187     my ($self, $instance, $slot_name) = @_;
 188     "exists " . $self->inline_slot_access($instance, $slot_name);
 189 }
 190
 191 sub inline_weaken_slot_value {
 192     my ($self, $instance, $slot_name) = @_;
 193     sprintf "Scalar::Util::weaken( %s )", $self->inline_slot_access($instance, $slot_name);
 194 }
 195
 196 sub inline_strengthen_slot_value {
 197     my ($self, $instance, $slot_name) = @_;
 198     $self->inline_set_slot_value($instance, $slot_name, $self->inline_slot_access($instance, $slot_name));
 199 }
 200
 201 1;
 202
 203 __END__
 204
 205 =pod
 206
 207 =head1 NAME
 208
 209 Class::MOP::Instance - Instance Meta Object
 210
 211 =head1 DESCRIPTION
 212
 213 The meta instance is used by attributes for low level storage.
 214
 215 Using this API generally violates attribute encapsulation and is not
 216 recommended, instead look at L<Class::MOP::Attribute/get_value>,
 217 L<Class::MOP::Attribute/set_value> for the recommended way to fiddle with
 218 attribute values in a generic way, independent of how/whether accessors have
 219 been defined. Accessors can be found using L<Class::MOP::Class/get_attribute>.
 220
 221 This may seem like over-abstraction, but by abstracting
 222 this process into a sub-protocol we make it possible to
 223 easily switch the details of how an object's instance is
 224 stored with minimal impact. In most cases just subclassing
 225 this class will be all you need to do (see the examples;
 226 F<examples/ArrayBasedStorage.pod> and
 227 F<examples/InsideOutClass.pod> for details).
 228
 229 =head1 METHODS
 230
 231 =over 4
 232
 233 =item B<new %args>
 234
 235 Creates a new instance meta-object and gathers all the slots from
 236 the list of C<@attrs> given.
 237
 238 =item B<BUILDARGS>
 239
 240 Processes arguments for compatibility.
 241
 242 =item B<meta>
 243
 244 Returns the metaclass of L<Class::MOP::Instance>.
 245
 246 =back
 247
 248 =head2 Creation of Instances
 249
 250 =over 4
 251
 252 =item B<create_instance>
 253
 254 This creates the appropriate structure needed for the instance and blesses it.
 255
 256 =item B<bless_instance_structure ($instance_structure)>
 257
 258 This does just exactly what it says it does.
 259
 260 This method has been deprecated but remains for compatibility reasons. None of
 261 the subclasses of L<Class::MOP::Instance> ever bothered to actually make use of
 262 it, so it was deemed unnecessary fluff.
 263
 264 =item B<clone_instance ($instance_structure)>
 265
 266 Creates a shallow clone of $instance_structure.
 267
 268 =back
 269
 270 =head2 Introspection
 271
 272 NOTE: There might be more methods added to this part of the API,
 273 we will add then when we need them basically.
 274
 275 =over 4
 276
 277 =item B<associated_metaclass>
 278
 279 This returns the metaclass associated with this instance.
 280
 281 =item B<get_all_slots>
 282
 283 This will return the current list of slots based on what was
 284 given to this object in C<new>.
 285
 286 =item B<is_valid_slot ($slot_name)>
 287
 288 This will return true if C<$slot_name> is a valid slot name.
 289
 290 =item B<is_dependent_on_superclasses>
 291
 292 This method returns true when the meta instance must be recreated on any
 293 superclass changes.
 294
 295 Defaults to false.
 296
 297 =back
 298
 299 =head2 Operations on Instance Structures
 300
 301 An important distinction of this sub-protocol is that the
 302 instance meta-object is a different entity from the actual
 303 instance it creates. For this reason, any actions on slots
 304 require that the C<$instance_structure> is passed into them.
 305
 306 The names of these methods pretty much explain exactly
 307 what they do, if that is not enough then I suggest reading
 308 the source, it is very straightfoward.
 309
 310 =over 4
 311
 312 =item B<get_slot_value ($instance_structure, $slot_name)>
 313
 314 =item B<set_slot_value ($instance_structure, $slot_name, $value)>
 315
 316 =item B<initialize_slot ($instance_structure, $slot_name)>
 317
 318 =item B<deinitialize_slot ($instance_structure, $slot_name)>
 319
 320 =item B<initialize_all_slots ($instance_structure)>
 321
 322 =item B<deinitialize_all_slots ($instance_structure)>
 323
 324 =item B<is_slot_initialized ($instance_structure, $slot_name)>
 325
 326 =item B<weaken_slot_value ($instance_structure, $slot_name)>
 327
 328 =item B<strengthen_slot_value ($instance_structure, $slot_name)>
 329
 330 =item B<rebless_instance_structure ($instance_structure, $new_metaclass)>
 331
 332 =back
 333
 334 =head2 Inlineable Instance Operations
 335
 336 =over 4
 337
 338 =item B<is_inlinable>
 339
 340 Each meta-instance should override this method to tell Class::MOP if it's
 341 possible to inline the slot access. This is currently only used by
 342 L<Class::MOP::Immutable> when performing optimizations.
 343
 344 =item B<inline_create_instance>
 345
 346 =item B<inline_slot_access ($instance_structure, $slot_name)>
 347
 348 =item B<inline_get_slot_value ($instance_structure, $slot_name)>
 349
 350 =item B<inline_set_slot_value ($instance_structure, $slot_name, $value)>
 351
 352 =item B<inline_initialize_slot ($instance_structure, $slot_name)>
 353
 354 =item B<inline_deinitialize_slot ($instance_structure, $slot_name)>
 355
 356 =item B<inline_is_slot_initialized ($instance_structure, $slot_name)>
 357
 358 =item B<inline_weaken_slot_value ($instance_structure, $slot_name)>
 359
 360 =item B<inline_strengthen_slot_value ($instance_structure, $slot_name)>
 361
 362 =back
 363
 364 =head1 AUTHORS
 365
 366 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 367
 368 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 369
 370 =head1 COPYRIGHT AND LICENSE
 371
 372 Copyright 2006-2008 by Infinity Interactive, Inc.
 373
 374 L<http://www.iinteractive.com>
 375
 376 This library is free software; you can redistribute it and/or modify
 377 it under the same terms as Perl itself.
 378
 379 =cut
 380