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