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