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