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