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 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 sub _inline_get_mop_slot {
 238     my ($self, $instance) = @_;
 239     $self->inline_get_slot_value($instance, $RESERVED_MOP_SLOT);
 240 }
 241
 242 sub _inline_set_mop_slot {
 243     my ($self, $instance, $value) = @_;
 244     $self->inline_set_slot_value($instance, $RESERVED_MOP_SLOT, $value);
 245 }
 246
 247 sub _inline_clear_mop_slot {
 248     my ($self, $instance) = @_;
 249     $self->inline_deinitialize_slot($instance, $RESERVED_MOP_SLOT);
 250 }
 251
 252 1;
 253
 254 __END__
 255
 256 =pod
 257
 258 =head1 NAME
 259
 260 Class::MOP::Instance - Instance Meta Object
 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 =head1 AUTHORS
 451
 452 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 453
 454 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 455
 456 =head1 COPYRIGHT AND LICENSE
 457
 458 Copyright 2006-2010 by Infinity Interactive, Inc.
 459
 460 L<http://www.iinteractive.com>
 461
 462 This library is free software; you can redistribute it and/or modify
 463 it under the same terms as Perl itself.
 464
 465 =cut
 466