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