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