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