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