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