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