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.64_02';
  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     bless $instance, $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 "%s->{%s}", $instance, $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 1;
 213
 214 __END__
 215
 216 =pod
 217
 218 =head1 NAME
 219
 220 Class::MOP::Instance - Instance Meta Object
 221
 222 =head1 DESCRIPTION
 223
 224 The meta instance is used by attributes for low level storage.
 225
 226 Using this API generally violates attribute encapsulation and is not
 227 recommended, instead look at L<Class::MOP::Attribute/get_value>,
 228 L<Class::MOP::Attribute/set_value> for the recommended way to fiddle with
 229 attribute values in a generic way, independent of how/whether accessors have
 230 been defined. Accessors can be found using L<Class::MOP::Class/get_attribute>.
 231
 232 This may seem like over-abstraction, but by abstracting
 233 this process into a sub-protocol we make it possible to
 234 easily switch the details of how an object's instance is
 235 stored with minimal impact. In most cases just subclassing
 236 this class will be all you need to do (see the examples;
 237 F<examples/ArrayBasedStorage.pod> and
 238 F<examples/InsideOutClass.pod> for details).
 239
 240 =head1 METHODS
 241
 242 =over 4
 243
 244 =item B<new %args>
 245
 246 Creates a new instance meta-object and gathers all the slots from
 247 the list of C<@attrs> given.
 248
 249 =item B<BUILDARGS>
 250
 251 Processes arguments for compatibility.
 252
 253 =item B<meta>
 254
 255 Returns the metaclass of L<Class::MOP::Instance>.
 256
 257 =back
 258
 259 =head2 Creation of Instances
 260
 261 =over 4
 262
 263 =item B<create_instance>
 264
 265 This creates the appropriate structure needed for the instance and blesses it.
 266
 267 =item B<bless_instance_structure ($instance_structure)>
 268
 269 This does just exactly what it says it does.
 270
 271 This method has been deprecated but remains for compatibility reasons. None of
 272 the subclasses of L<Class::MOP::Instance> ever bothered to actually make use of
 273 it, so it was deemed unnecessary fluff.
 274
 275 =item B<clone_instance ($instance_structure)>
 276
 277 Creates a shallow clone of $instance_structure.
 278
 279 =back
 280
 281 =head2 Introspection
 282
 283 NOTE: There might be more methods added to this part of the API,
 284 we will add then when we need them basically.
 285
 286 =over 4
 287
 288 =item B<associated_metaclass>
 289
 290 This returns the metaclass associated with this instance.
 291
 292 =item B<get_all_slots>
 293
 294 This will return the current list of slots based on what was
 295 given to this object in C<new>.
 296
 297 =item B<is_valid_slot ($slot_name)>
 298
 299 This will return true if C<$slot_name> is a valid slot name.
 300
 301 =item B<is_dependent_on_superclasses>
 302
 303 This method returns true when the meta instance must be recreated on any
 304 superclass changes.
 305
 306 Defaults to false.
 307
 308 =item B<get_all_attributes>
 309
 310 This will return the current list of attributes (as
 311 Class::MOP::Attribute objects) based on what was given to this object
 312 in C<new>.
 313
 314 =back
 315
 316 =head2 Operations on Instance Structures
 317
 318 An important distinction of this sub-protocol is that the
 319 instance meta-object is a different entity from the actual
 320 instance it creates. For this reason, any actions on slots
 321 require that the C<$instance_structure> is passed into them.
 322
 323 The names of these methods pretty much explain exactly
 324 what they do, if that is not enough then I suggest reading
 325 the source, it is very straightfoward.
 326
 327 =over 4
 328
 329 =item B<get_slot_value ($instance_structure, $slot_name)>
 330
 331 =item B<set_slot_value ($instance_structure, $slot_name, $value)>
 332
 333 =item B<initialize_slot ($instance_structure, $slot_name)>
 334
 335 =item B<deinitialize_slot ($instance_structure, $slot_name)>
 336
 337 =item B<initialize_all_slots ($instance_structure)>
 338
 339 =item B<deinitialize_all_slots ($instance_structure)>
 340
 341 =item B<is_slot_initialized ($instance_structure, $slot_name)>
 342
 343 =item B<weaken_slot_value ($instance_structure, $slot_name)>
 344
 345 =item B<strengthen_slot_value ($instance_structure, $slot_name)>
 346
 347 =item B<rebless_instance_structure ($instance_structure, $new_metaclass)>
 348
 349 =back
 350
 351 =head2 Inlineable Instance Operations
 352
 353 =over 4
 354
 355 =item B<is_inlinable>
 356
 357 Each meta-instance should override this method to tell Class::MOP if it's
 358 possible to inline the slot access. This is currently only used by
 359 L<Class::MOP::Immutable> when performing optimizations.
 360
 361 =item B<inline_create_instance>
 362
 363 =item B<inline_slot_access ($instance_structure, $slot_name)>
 364
 365 =item B<inline_get_slot_value ($instance_structure, $slot_name)>
 366
 367 =item B<inline_set_slot_value ($instance_structure, $slot_name, $value)>
 368
 369 =item B<inline_initialize_slot ($instance_structure, $slot_name)>
 370
 371 =item B<inline_deinitialize_slot ($instance_structure, $slot_name)>
 372
 373 =item B<inline_is_slot_initialized ($instance_structure, $slot_name)>
 374
 375 =item B<inline_weaken_slot_value ($instance_structure, $slot_name)>
 376
 377 =item B<inline_strengthen_slot_value ($instance_structure, $slot_name)>
 378
 379 =back
 380
 381 =head1 AUTHORS
 382
 383 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 384
 385 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 386
 387 =head1 COPYRIGHT AND LICENSE
 388
 389 Copyright 2006-2008 by Infinity Interactive, Inc.
 390
 391 L<http://www.iinteractive.com>
 392
 393 This library is free software; you can redistribute it and/or modify
 394 it under the same terms as Perl itself.
 395
 396 =cut
 397