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