lib/Class/MOP/Instance.pm

   1
   2 package Class::MOP::Instance;
   3
   4 use strict;
   5 use warnings;
   6
   7 use Scalar::Util 'isweak', 'weaken', 'blessed';
   8
   9 use base 'Class::MOP::Object';
  10
  11 # make this not a valid method name, to avoid (most) attribute conflicts
  12 my $RESERVED_MOP_SLOT = '<<MOP>>';
  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 = shift;
  48     return Class::MOP::Class->initialize($class)->new_object(@_)
  49       if $class ne __PACKAGE__;
  50
  51     my $params = @_ == 1 ? $_[0] : {@_};
  52     return bless {
  53         # NOTE:
  54         # I am not sure that it makes
  55         # sense to pass in the meta
  56         # The ideal would be to just
  57         # pass in the class name, but
  58         # that is placing too much of
  59         # an assumption on bless(),
  60         # which is *probably* a safe
  61         # assumption,.. but you can
  62         # never tell <:)
  63         'associated_metaclass' => $params->{associated_metaclass},
  64         'attributes'           => $params->{attributes},
  65         'slots'                => $params->{slots},
  66         'slot_hash'            => $params->{slot_hash},
  67     } => $class;
  68 }
  69
  70 sub _class_name { $_[0]->{_class_name} ||= $_[0]->associated_metaclass->name }
  71
  72 sub create_instance {
  73     my $self = shift;
  74     bless {}, $self->_class_name;
  75 }
  76
  77 sub clone_instance {
  78     my ($self, $instance) = @_;
  79
  80     my $clone = $self->create_instance;
  81     for my $attr ($self->get_all_attributes) {
  82         next unless $attr->has_value($instance);
  83         for my $slot ($attr->slots) {
  84             my $val = $self->get_slot_value($instance, $slot);
  85             $self->set_slot_value($clone, $slot, $val);
  86             $self->weaken_slot_value($clone, $slot)
  87                 if $self->slot_value_is_weak($instance, $slot);
  88         }
  89     }
  90
  91     $self->_set_mop_slot($clone, $self->_get_mop_slot($instance))
  92         if $self->_has_mop_slot($instance);
  93
  94     return $clone;
  95 }
  96
  97 # operations on meta instance
  98
  99 sub get_all_slots {
 100     my $self = shift;
 101     return @{$self->{'slots'}};
 102 }
 103
 104 sub get_all_attributes {
 105     my $self = shift;
 106     return @{$self->{attributes}};
 107 }
 108
 109 sub is_valid_slot {
 110     my ($self, $slot_name) = @_;
 111     exists $self->{'slot_hash'}->{$slot_name};
 112 }
 113
 114 # operations on created instances
 115
 116 sub get_slot_value {
 117     my ($self, $instance, $slot_name) = @_;
 118     $instance->{$slot_name};
 119 }
 120
 121 sub set_slot_value {
 122     my ($self, $instance, $slot_name, $value) = @_;
 123     $instance->{$slot_name} = $value;
 124 }
 125
 126 sub initialize_slot {
 127     my ($self, $instance, $slot_name) = @_;
 128     return;
 129 }
 130
 131 sub deinitialize_slot {
 132     my ( $self, $instance, $slot_name ) = @_;
 133     delete $instance->{$slot_name};
 134 }
 135
 136 sub initialize_all_slots {
 137     my ($self, $instance) = @_;
 138     foreach my $slot_name ($self->get_all_slots) {
 139         $self->initialize_slot($instance, $slot_name);
 140     }
 141 }
 142
 143 sub deinitialize_all_slots {
 144     my ($self, $instance) = @_;
 145     foreach my $slot_name ($self->get_all_slots) {
 146         $self->deinitialize_slot($instance, $slot_name);
 147     }
 148 }
 149
 150 sub is_slot_initialized {
 151     my ($self, $instance, $slot_name, $value) = @_;
 152     exists $instance->{$slot_name};
 153 }
 154
 155 sub weaken_slot_value {
 156     my ($self, $instance, $slot_name) = @_;
 157     weaken $instance->{$slot_name};
 158 }
 159
 160 sub slot_value_is_weak {
 161     my ($self, $instance, $slot_name) = @_;
 162     isweak $instance->{$slot_name};
 163 }
 164
 165 sub strengthen_slot_value {
 166     my ($self, $instance, $slot_name) = @_;
 167     $self->set_slot_value($instance, $slot_name, $self->get_slot_value($instance, $slot_name));
 168 }
 169
 170 sub rebless_instance_structure {
 171     my ($self, $instance, $metaclass) = @_;
 172
 173     # we use $_[1] here because of t/cmop/rebless_overload.t regressions
 174     # on 5.8.8
 175     bless $_[1], $metaclass->name;
 176 }
 177
 178 sub is_dependent_on_superclasses {
 179     return; # for meta instances that require updates on inherited slot changes
 180 }
 181
 182 sub _get_mop_slot {
 183     my ($self, $instance) = @_;
 184     $self->get_slot_value($instance, $RESERVED_MOP_SLOT);
 185 }
 186
 187 sub _has_mop_slot {
 188     my ($self, $instance) = @_;
 189     $self->is_slot_initialized($instance, $RESERVED_MOP_SLOT);
 190 }
 191
 192 sub _set_mop_slot {
 193     my ($self, $instance, $value) = @_;
 194     $self->set_slot_value($instance, $RESERVED_MOP_SLOT, $value);
 195 }
 196
 197 sub _clear_mop_slot {
 198     my ($self, $instance) = @_;
 199     $self->deinitialize_slot($instance, $RESERVED_MOP_SLOT);
 200 }
 201
 202 # inlinable operation snippets
 203
 204 sub is_inlinable { 1 }
 205
 206 sub inline_create_instance {
 207     my ($self, $class_variable) = @_;
 208     'bless {} => ' . $class_variable;
 209 }
 210
 211 sub inline_slot_access {
 212     my ($self, $instance, $slot_name) = @_;
 213     sprintf q[%s->{"%s"}], $instance, quotemeta($slot_name);
 214 }
 215
 216 sub inline_get_is_lvalue { 1 }
 217
 218 sub inline_get_slot_value {
 219     my ($self, $instance, $slot_name) = @_;
 220     $self->inline_slot_access($instance, $slot_name);
 221 }
 222
 223 sub inline_set_slot_value {
 224     my ($self, $instance, $slot_name, $value) = @_;
 225     $self->inline_slot_access($instance, $slot_name) . " = $value",
 226 }
 227
 228 sub inline_initialize_slot {
 229     my ($self, $instance, $slot_name) = @_;
 230     return '';
 231 }
 232
 233 sub inline_deinitialize_slot {
 234     my ($self, $instance, $slot_name) = @_;
 235     "delete " . $self->inline_slot_access($instance, $slot_name);
 236 }
 237 sub inline_is_slot_initialized {
 238     my ($self, $instance, $slot_name) = @_;
 239     "exists " . $self->inline_slot_access($instance, $slot_name);
 240 }
 241
 242 sub inline_weaken_slot_value {
 243     my ($self, $instance, $slot_name) = @_;
 244     sprintf "Scalar::Util::weaken( %s )", $self->inline_slot_access($instance, $slot_name);
 245 }
 246
 247 sub inline_strengthen_slot_value {
 248     my ($self, $instance, $slot_name) = @_;
 249     $self->inline_set_slot_value($instance, $slot_name, $self->inline_slot_access($instance, $slot_name));
 250 }
 251
 252 sub inline_rebless_instance_structure {
 253     my ($self, $instance, $class_variable) = @_;
 254     "bless $instance => $class_variable";
 255 }
 256
 257 sub _inline_get_mop_slot {
 258     my ($self, $instance) = @_;
 259     $self->inline_get_slot_value($instance, $RESERVED_MOP_SLOT);
 260 }
 261
 262 sub _inline_set_mop_slot {
 263     my ($self, $instance, $value) = @_;
 264     $self->inline_set_slot_value($instance, $RESERVED_MOP_SLOT, $value);
 265 }
 266
 267 sub _inline_clear_mop_slot {
 268     my ($self, $instance) = @_;
 269     $self->inline_deinitialize_slot($instance, $RESERVED_MOP_SLOT);
 270 }
 271
 272 1;
 273
 274 # ABSTRACT: Instance Meta Object
 275
 276 __END__
 277
 278 =pod
 279
 280 =head1 DESCRIPTION
 281
 282 The Instance Protocol controls the creation of object instances, and
 283 the storage of attribute values in those instances.
 284
 285 Using this API directly in your own code violates encapsulation, and
 286 we recommend that you use the appropriate APIs in L<Class::MOP::Class>
 287 and L<Class::MOP::Attribute> instead. Those APIs in turn call the
 288 methods in this class as appropriate.
 289
 290 This class also participates in generating inlined code by providing
 291 snippets of code to access an object instance.
 292
 293 =head1 METHODS
 294
 295 =head2 Object construction
 296
 297 =over 4
 298
 299 =item B<< Class::MOP::Instance->new(%options) >>
 300
 301 This method creates a new meta-instance object.
 302
 303 It accepts the following keys in C<%options>:
 304
 305 =over 8
 306
 307 =item * associated_metaclass
 308
 309 The L<Class::MOP::Class> object for which instances will be created.
 310
 311 =item * attributes
 312
 313 An array reference of L<Class::MOP::Attribute> objects. These are the
 314 attributes which can be stored in each instance.
 315
 316 =back
 317
 318 =back
 319
 320 =head2 Creating and altering instances
 321
 322 =over 4
 323
 324 =item B<< $metainstance->create_instance >>
 325
 326 This method returns a reference blessed into the associated
 327 metaclass's class.
 328
 329 The default is to use a hash reference. Subclasses can override this.
 330
 331 =item B<< $metainstance->clone_instance($instance) >>
 332
 333 Given an instance, this method creates a new object by making
 334 I<shallow> clone of the original.
 335
 336 =back
 337
 338 =head2 Introspection
 339
 340 =over 4
 341
 342 =item B<< $metainstance->associated_metaclass >>
 343
 344 This returns the L<Class::MOP::Class> object associated with the
 345 meta-instance object.
 346
 347 =item B<< $metainstance->get_all_slots >>
 348
 349 This returns a list of slot names stored in object instances. In
 350 almost all cases, slot names correspond directly attribute names.
 351
 352 =item B<< $metainstance->is_valid_slot($slot_name) >>
 353
 354 This will return true if C<$slot_name> is a valid slot name.
 355
 356 =item B<< $metainstance->get_all_attributes >>
 357
 358 This returns a list of attributes corresponding to the attributes
 359 passed to the constructor.
 360
 361 =back
 362
 363 =head2 Operations on Instance Structures
 364
 365 It's important to understand that the meta-instance object is a
 366 different entity from the actual instances it creates. For this
 367 reason, any operations on the C<$instance_structure> always require
 368 that the object instance be passed to the method.
 369
 370 =over 4
 371
 372 =item B<< $metainstance->get_slot_value($instance_structure, $slot_name) >>
 373
 374 =item B<< $metainstance->set_slot_value($instance_structure, $slot_name, $value) >>
 375
 376 =item B<< $metainstance->initialize_slot($instance_structure, $slot_name) >>
 377
 378 =item B<< $metainstance->deinitialize_slot($instance_structure, $slot_name) >>
 379
 380 =item B<< $metainstance->initialize_all_slots($instance_structure) >>
 381
 382 =item B<< $metainstance->deinitialize_all_slots($instance_structure) >>
 383
 384 =item B<< $metainstance->is_slot_initialized($instance_structure, $slot_name) >>
 385
 386 =item B<< $metainstance->weaken_slot_value($instance_structure, $slot_name) >>
 387
 388 =item B<< $metainstance->strengthen_slot_value($instance_structure, $slot_name) >>
 389
 390 =item B<< $metainstance->rebless_instance_structure($instance_structure, $new_metaclass) >>
 391
 392 The exact details of what each method does should be fairly obvious
 393 from the method name.
 394
 395 =back
 396
 397 =head2 Inlinable Instance Operations
 398
 399 =over 4
 400
 401 =item B<< $metainstance->is_inlinable >>
 402
 403 This is a boolean that indicates whether or not slot access operations
 404 can be inlined. By default it is true, but subclasses can override
 405 this.
 406
 407 =item B<< $metainstance->inline_create_instance($class_variable) >>
 408
 409 This method expects a string that, I<when inlined>, will become a
 410 class name. This would literally be something like C<'$class'>, not an
 411 actual class name.
 412
 413 It returns a snippet of code that creates a new object for the
 414 class. This is something like C< bless {}, $class_name >.
 415
 416 =item B<< $metainstance->inline_get_is_lvalue >>
 417
 418 Returns whether or not C<inline_get_slot_value> is a valid lvalue. This can be
 419 used to do extra optimizations when generating inlined methods.
 420
 421 =item B<< $metainstance->inline_slot_access($instance_variable, $slot_name) >>
 422
 423 =item B<< $metainstance->inline_get_slot_value($instance_variable, $slot_name) >>
 424
 425 =item B<< $metainstance->inline_set_slot_value($instance_variable, $slot_name, $value) >>
 426
 427 =item B<< $metainstance->inline_initialize_slot($instance_variable, $slot_name) >>
 428
 429 =item B<< $metainstance->inline_deinitialize_slot($instance_variable, $slot_name) >>
 430
 431 =item B<< $metainstance->inline_is_slot_initialized($instance_variable, $slot_name) >>
 432
 433 =item B<< $metainstance->inline_weaken_slot_value($instance_variable, $slot_name) >>
 434
 435 =item B<< $metainstance->inline_strengthen_slot_value($instance_variable, $slot_name) >>
 436
 437 These methods all expect two arguments. The first is the name of a
 438 variable, than when inlined, will represent the object
 439 instance. Typically this will be a literal string like C<'$_[0]'>.
 440
 441 The second argument is a slot name.
 442
 443 The method returns a snippet of code that, when inlined, performs some
 444 operation on the instance.
 445
 446 =item B<< $metainstance->inline_rebless_instance_structure($instance_variable, $class_variable) >>
 447
 448 This takes the name of a variable that will, when inlined, represent the object
 449 instance, and the name of a variable that will represent the class to rebless
 450 into, and returns code to rebless an instance into a class.
 451
 452 =back
 453
 454 =head2 Introspection
 455
 456 =over 4
 457
 458 =item B<< Class::MOP::Instance->meta >>
 459
 460 This will return a L<Class::MOP::Class> instance for this class.
 461
 462 It should also be noted that L<Class::MOP> will actually bootstrap
 463 this module by installing a number of attribute meta-objects into its
 464 metaclass.
 465
 466 =back
 467
 468 =cut
 469