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