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