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