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