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.65';
  10 our $AUTHORITY = 'cpan:STEVAN';
  11
  12 use base 'Class::MOP::Object';
  13
  14 sub BUILDARGS {
  15     my ($class, @args) = @_;
  16
  17     if ( @args == 1 ) {
  18         unshift @args, "associated_metaclass";
  19     } elsif ( @args >= 2 && blessed($args[0]) && $args[0]->isa("Class::MOP::Class") ) {
  20         # compat mode
  21         my ( $meta, @attrs ) = @args;
  22         @args = ( associated_metaclass => $meta, attributes => \@attrs );
  23     }
  24
  25     my %options = @args;
  26     # FIXME lazy_build
  27     $options{slots} ||= [ map { $_->slots } @{ $options{attributes} || [] } ];
  28     $options{slot_hash} = { map { $_ => undef } @{ $options{slots} } }; # FIXME lazy_build
  29
  30     return \%options;
  31 }
  32
  33 sub new {
  34     my $class = shift;
  35     my $options = $class->BUILDARGS(@_);
  36
  37     # FIXME replace with a proper constructor
  38     my $instance = bless {
  39         # NOTE:
  40         # I am not sure that it makes
  41         # sense to pass in the meta
  42         # The ideal would be to just
  43         # pass in the class name, but
  44         # that is placing too much of
  45         # an assumption on bless(),
  46         # which is *probably* a safe
  47         # assumption,.. but you can
  48         # never tell <:)
  49         'associated_metaclass' => $options->{associated_metaclass},
  50         'slots'     => $options->{slots},
  51         'slot_hash' => $options->{slot_hash},
  52     } => $class;
  53
  54     # FIXME weak_ref => 1,
  55     weaken($instance->{'associated_metaclass'});
  56
  57     return $instance;
  58 }
  59
  60 sub associated_metaclass { (shift)->{'associated_metaclass'} }
  61
  62 sub create_instance {
  63     my $self = shift;
  64     $self->bless_instance_structure({});
  65 }
  66
  67 sub bless_instance_structure {
  68     my ($self, $instance_structure) = @_;
  69     bless $instance_structure, $self->associated_metaclass->name;
  70 }
  71
  72 sub clone_instance {
  73     my ($self, $instance) = @_;
  74     $self->bless_instance_structure({ %$instance });
  75 }
  76
  77 # operations on meta instance
  78
  79 sub get_all_slots {
  80     my $self = shift;
  81     return @{$self->{'slots'}};
  82 }
  83
  84 sub is_valid_slot {
  85     my ($self, $slot_name) = @_;
  86     exists $self->{'slot_hash'}->{$slot_name};
  87 }
  88
  89 # operations on created instances
  90
  91 sub get_slot_value {
  92     my ($self, $instance, $slot_name) = @_;
  93     $instance->{$slot_name};
  94 }
  95
  96 sub set_slot_value {
  97     my ($self, $instance, $slot_name, $value) = @_;
  98     $instance->{$slot_name} = $value;
  99 }
 100
 101 sub initialize_slot {
 102     my ($self, $instance, $slot_name) = @_;
 103     return;
 104 }
 105
 106 sub deinitialize_slot {
 107     my ( $self, $instance, $slot_name ) = @_;
 108     delete $instance->{$slot_name};
 109 }
 110
 111 sub initialize_all_slots {
 112     my ($self, $instance) = @_;
 113     foreach my $slot_name ($self->get_all_slots) {
 114         $self->initialize_slot($instance, $slot_name);
 115     }
 116 }
 117
 118 sub deinitialize_all_slots {
 119     my ($self, $instance) = @_;
 120     foreach my $slot_name ($self->get_all_slots) {
 121         $self->deinitialize_slot($instance, $slot_name);
 122     }
 123 }
 124
 125 sub is_slot_initialized {
 126     my ($self, $instance, $slot_name, $value) = @_;
 127     exists $instance->{$slot_name};
 128 }
 129
 130 sub weaken_slot_value {
 131     my ($self, $instance, $slot_name) = @_;
 132     weaken $instance->{$slot_name};
 133 }
 134
 135 sub strengthen_slot_value {
 136     my ($self, $instance, $slot_name) = @_;
 137     $self->set_slot_value($instance, $slot_name, $self->get_slot_value($instance, $slot_name));
 138 }
 139
 140 sub rebless_instance_structure {
 141     my ($self, $instance, $metaclass) = @_;
 142     bless $instance, $metaclass->name;
 143 }
 144
 145 # inlinable operation snippets
 146
 147 sub is_inlinable { 1 }
 148
 149 sub inline_create_instance {
 150     my ($self, $class_variable) = @_;
 151     'bless {} => ' . $class_variable;
 152 }
 153
 154 sub inline_slot_access {
 155     my ($self, $instance, $slot_name) = @_;
 156     sprintf "%s->{%s}", $instance, $slot_name;
 157 }
 158
 159 sub inline_get_slot_value {
 160     my ($self, $instance, $slot_name) = @_;
 161     $self->inline_slot_access($instance, $slot_name);
 162 }
 163
 164 sub inline_set_slot_value {
 165     my ($self, $instance, $slot_name, $value) = @_;
 166     $self->inline_slot_access($instance, $slot_name) . " = $value",
 167 }
 168
 169 sub inline_initialize_slot {
 170     my ($self, $instance, $slot_name) = @_;
 171     return '';
 172 }
 173
 174 sub inline_deinitialize_slot {
 175     my ($self, $instance, $slot_name) = @_;
 176     "delete " . $self->inline_slot_access($instance, $slot_name);
 177 }
 178 sub inline_is_slot_initialized {
 179     my ($self, $instance, $slot_name) = @_;
 180     "exists " . $self->inline_slot_access($instance, $slot_name);
 181 }
 182
 183 sub inline_weaken_slot_value {
 184     my ($self, $instance, $slot_name) = @_;
 185     sprintf "Scalar::Util::weaken( %s )", $self->inline_slot_access($instance, $slot_name);
 186 }
 187
 188 sub inline_strengthen_slot_value {
 189     my ($self, $instance, $slot_name) = @_;
 190     $self->inline_set_slot_value($instance, $slot_name, $self->inline_slot_access($instance, $slot_name));
 191 }
 192
 193 1;
 194
 195 __END__
 196
 197 =pod
 198
 199 =head1 NAME
 200
 201 Class::MOP::Instance - Instance Meta Object
 202
 203 =head1 DESCRIPTION
 204
 205 The meta instance is used by attributes for low level storage.
 206
 207 Using this API generally violates attribute encapsulation and is not
 208 recommended, instead look at L<Class::MOP::Attribute/get_value>,
 209 L<Class::MOP::Attribute/set_value> for the recommended way to fiddle with
 210 attribute values in a generic way, independent of how/whether accessors have
 211 been defined. Accessors can be found using L<Class::MOP::Class/get_attribute>.
 212
 213 This may seem like over-abstraction, but by abstracting
 214 this process into a sub-protocol we make it possible to
 215 easily switch the details of how an object's instance is
 216 stored with minimal impact. In most cases just subclassing
 217 this class will be all you need to do (see the examples;
 218 F<examples/ArrayBasedStorage.pod> and
 219 F<examples/InsideOutClass.pod> for details).
 220
 221 =head1 METHODS
 222
 223 =over 4
 224
 225 =item B<new %args>
 226
 227 Creates a new instance meta-object and gathers all the slots from
 228 the list of C<@attrs> given.
 229
 230 =item B<BUILDARGS>
 231
 232 Processes arguments for compatibility.
 233
 234 =item B<meta>
 235
 236 Returns the metaclass of L<Class::MOP::Instance>.
 237
 238 =back
 239
 240 =head2 Creation of Instances
 241
 242 =over 4
 243
 244 =item B<create_instance>
 245
 246 This creates the appropriate structure needed for the instance and
 247 then calls C<bless_instance_structure> to bless it into the class.
 248
 249 =item B<bless_instance_structure ($instance_structure)>
 250
 251 This does just exactly what it says it does.
 252
 253 =item B<clone_instance ($instance_structure)>
 254
 255 This too does just exactly what it says it does.
 256
 257 =back
 258
 259 =head2 Introspection
 260
 261 NOTE: There might be more methods added to this part of the API,
 262 we will add then when we need them basically.
 263
 264 =over 4
 265
 266 =item B<associated_metaclass>
 267
 268 This returns the metaclass associated with this instance.
 269
 270 =item B<get_all_slots>
 271
 272 This will return the current list of slots based on what was
 273 given to this object in C<new>.
 274
 275 =item B<is_valid_slot ($slot_name)>
 276
 277 This will return true if C<$slot_name> is a valid slot name.
 278
 279 =back
 280
 281 =head2 Operations on Instance Structures
 282
 283 An important distinction of this sub-protocol is that the
 284 instance meta-object is a different entity from the actual
 285 instance it creates. For this reason, any actions on slots
 286 require that the C<$instance_structure> is passed into them.
 287
 288 The names of these methods pretty much explain exactly
 289 what they do, if that is not enough then I suggest reading
 290 the source, it is very straightfoward.
 291
 292 =over 4
 293
 294 =item B<get_slot_value ($instance_structure, $slot_name)>
 295
 296 =item B<set_slot_value ($instance_structure, $slot_name, $value)>
 297
 298 =item B<initialize_slot ($instance_structure, $slot_name)>
 299
 300 =item B<deinitialize_slot ($instance_structure, $slot_name)>
 301
 302 =item B<initialize_all_slots ($instance_structure)>
 303
 304 =item B<deinitialize_all_slots ($instance_structure)>
 305
 306 =item B<is_slot_initialized ($instance_structure, $slot_name)>
 307
 308 =item B<weaken_slot_value ($instance_structure, $slot_name)>
 309
 310 =item B<strengthen_slot_value ($instance_structure, $slot_name)>
 311
 312 =item B<rebless_instance_structure ($instance_structure, $new_metaclass)>
 313
 314 =back
 315
 316 =head2 Inlineable Instance Operations
 317
 318 =over 4
 319
 320 =item B<is_inlinable>
 321
 322 Each meta-instance should override this method to tell Class::MOP if it's
 323 possible to inline the slot access. This is currently only used by
 324 L<Class::MOP::Immutable> when performing optimizations.
 325
 326 =item B<inline_create_instance>
 327
 328 =item B<inline_slot_access ($instance_structure, $slot_name)>
 329
 330 =item B<inline_get_slot_value ($instance_structure, $slot_name)>
 331
 332 =item B<inline_set_slot_value ($instance_structure, $slot_name, $value)>
 333
 334 =item B<inline_initialize_slot ($instance_structure, $slot_name)>
 335
 336 =item B<inline_deinitialize_slot ($instance_structure, $slot_name)>
 337
 338 =item B<inline_is_slot_initialized ($instance_structure, $slot_name)>
 339
 340 =item B<inline_weaken_slot_value ($instance_structure, $slot_name)>
 341
 342 =item B<inline_strengthen_slot_value ($instance_structure, $slot_name)>
 343
 344 =back
 345
 346 =head1 AUTHORS
 347
 348 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 349
 350 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 351
 352 =head1 COPYRIGHT AND LICENSE
 353
 354 Copyright 2006-2008 by Infinity Interactive, Inc.
 355
 356 L<http://www.iinteractive.com>
 357
 358 This library is free software; you can redistribute it and/or modify
 359 it under the same terms as Perl itself.
 360
 361 =cut
 362