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