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