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