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     $slot_name =~ s/(['\\])/\\$1/g; # In '', only "'" and "\\" are meta characters.
 185     sprintf q[%s->{'%s'}], $instance, $slot_name;
 186 }
 187
 188 sub inline_get_slot_value {
 189     my ($self, $instance, $slot_name) = @_;
 190     $self->inline_slot_access($instance, $slot_name);
 191 }
 192
 193 sub inline_set_slot_value {
 194     my ($self, $instance, $slot_name, $value) = @_;
 195     $self->inline_slot_access($instance, $slot_name) . " = $value",
 196 }
 197
 198 sub inline_initialize_slot {
 199     my ($self, $instance, $slot_name) = @_;
 200     return '';
 201 }
 202
 203 sub inline_deinitialize_slot {
 204     my ($self, $instance, $slot_name) = @_;
 205     "delete " . $self->inline_slot_access($instance, $slot_name);
 206 }
 207 sub inline_is_slot_initialized {
 208     my ($self, $instance, $slot_name) = @_;
 209     "exists " . $self->inline_slot_access($instance, $slot_name);
 210 }
 211
 212 sub inline_weaken_slot_value {
 213     my ($self, $instance, $slot_name) = @_;
 214     sprintf "Scalar::Util::weaken( %s )", $self->inline_slot_access($instance, $slot_name);
 215 }
 216
 217 sub inline_strengthen_slot_value {
 218     my ($self, $instance, $slot_name) = @_;
 219     $self->inline_set_slot_value($instance, $slot_name, $self->inline_slot_access($instance, $slot_name));
 220 }
 221
 222 sub inline_rebless_instance_structure {
 223     my ($self, $instance, $class_variable) = @_;
 224     "bless $instance => $class_variable";
 225 }
 226
 227 1;
 228
 229 __END__
 230
 231 =pod
 232
 233 =head1 NAME
 234
 235 Class::MOP::Instance - Instance Meta Object
 236
 237 =head1 DESCRIPTION
 238
 239 The Instance Protocol controls the creation of object instances, and
 240 the storage of attribute values in those instances.
 241
 242 Using this API directly in your own code violates encapsulation, and
 243 we recommend that you use the appropriate APIs in L<Class::MOP::Class>
 244 and L<Class::MOP::Attribute> instead. Those APIs in turn call the
 245 methods in this class as appropriate.
 246
 247 This class also participates in generating inlined code by providing
 248 snippets of code to access an object instance.
 249
 250 =head1 METHODS
 251
 252 =head2 Object construction
 253
 254 =over 4
 255
 256 =item B<< Class::MOP::Instance->new(%options) >>
 257
 258 This method creates a new meta-instance object.
 259
 260 It accepts the following keys in C<%options>:
 261
 262 =over 8
 263
 264 =item * associated_metaclass
 265
 266 The L<Class::MOP::Class> object for which instances will be created.
 267
 268 =item * attributes
 269
 270 An array reference of L<Class::MOP::Attribute> objects. These are the
 271 attributes which can be stored in each instance.
 272
 273 =back
 274
 275 =back
 276
 277 =head2 Creating and altering instances
 278
 279 =over 4
 280
 281 =item B<< $metainstance->create_instance >>
 282
 283 This method returns a reference blessed into the associated
 284 metaclass's class.
 285
 286 The default is to use a hash reference. Subclasses can override this.
 287
 288 =item B<< $metainstance->clone_instance($instance) >>
 289
 290 Given an instance, this method creates a new object by making
 291 I<shallow> clone of the original.
 292
 293 =back
 294
 295 =head2 Introspection
 296
 297 =over 4
 298
 299 =item B<< $metainstance->associated_metaclass >>
 300
 301 This returns the L<Class::MOP::Class> object associated with the
 302 meta-instance object.
 303
 304 =item B<< $metainstance->get_all_slots >>
 305
 306 This returns a list of slot names stored in object instances. In
 307 almost all cases, slot names correspond directly attribute names.
 308
 309 =item B<< $metainstance->is_valid_slot($slot_name) >>
 310
 311 This will return true if C<$slot_name> is a valid slot name.
 312
 313 =item B<< $metainstance->get_all_attributes >>
 314
 315 This returns a list of attributes corresponding to the attributes
 316 passed to the constructor.
 317
 318 =back
 319
 320 =head2 Operations on Instance Structures
 321
 322 It's important to understand that the meta-instance object is a
 323 different entity from the actual instances it creates. For this
 324 reason, any operations on the C<$instance_structure> always require
 325 that the object instance be passed to the method.
 326
 327 =over 4
 328
 329 =item B<< $metainstance->get_slot_value($instance_structure, $slot_name) >>
 330
 331 =item B<< $metainstance->set_slot_value($instance_structure, $slot_name, $value) >>
 332
 333 =item B<< $metainstance->initialize_slot($instance_structure, $slot_name) >>
 334
 335 =item B<< $metainstance->deinitialize_slot($instance_structure, $slot_name) >>
 336
 337 =item B<< $metainstance->initialize_all_slots($instance_structure) >>
 338
 339 =item B<< $metainstance->deinitialize_all_slots($instance_structure) >>
 340
 341 =item B<< $metainstance->is_slot_initialized($instance_structure, $slot_name) >>
 342
 343 =item B<< $metainstance->weaken_slot_value($instance_structure, $slot_name) >>
 344
 345 =item B<< $metainstance->strengthen_slot_value($instance_structure, $slot_name) >>
 346
 347 =item B<< $metainstance->rebless_instance_structure($instance_structure, $new_metaclass) >>
 348
 349 The exact details of what each method does should be fairly obvious
 350 from the method name.
 351
 352 =back
 353
 354 =head2 Inlinable Instance Operations
 355
 356 =over 4
 357
 358 =item B<< $metainstance->is_inlinable >>
 359
 360 This is a boolean that indicates whether or not slot access operations
 361 can be inlined. By default it is true, but subclasses can override
 362 this.
 363
 364 =item B<< $metainstance->inline_create_instance($class_variable) >>
 365
 366 This method expects a string that, I<when inlined>, will become a
 367 class name. This would literally be something like C<'$class'>, not an
 368 actual class name.
 369
 370 It returns a snippet of code that creates a new object for the
 371 class. This is something like C< bless {}, $class_name >.
 372
 373 =item B<< $metainstance->inline_slot_access($instance_variable, $slot_name) >>
 374
 375 =item B<< $metainstance->inline_get_slot_value($instance_variable, $slot_name) >>
 376
 377 =item B<< $metainstance->inline_set_slot_value($instance_variable, $slot_name, $value) >>
 378
 379 =item B<< $metainstance->inline_initialize_slot($instance_variable, $slot_name) >>
 380
 381 =item B<< $metainstance->inline_deinitialize_slot($instance_variable, $slot_name) >>
 382
 383 =item B<< $metainstance->inline_is_slot_initialized($instance_variable, $slot_name) >>
 384
 385 =item B<< $metainstance->inline_weaken_slot_value($instance_variable, $slot_name) >>
 386
 387 =item B<< $metainstance->inline_strengthen_slot_value($instance_variable, $slot_name) >>
 388
 389 These methods all expect two arguments. The first is the name of a
 390 variable, than when inlined, will represent the object
 391 instance. Typically this will be a literal string like C<'$_[0]'>.
 392
 393 The second argument is a slot name.
 394
 395 The method returns a snippet of code that, when inlined, performs some
 396 operation on the instance.
 397
 398 =item B<< $metainstance->inline_rebless_instance_structure($instance_variable, $class_variable) >>
 399
 400 This takes the name of a variable that will, when inlined, represent the object
 401 instance, and the name of a variable that will represent the class to rebless
 402 into, and returns code to rebless an instance into a class.
 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