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.03';
  10 our $AUTHORITY = 'cpan:STEVAN';
  11
  12 sub meta {
  13     require Class::MOP::Class;
  14     Class::MOP::Class->initialize(blessed($_[0]) || $_[0]);
  15 }
  16
  17 sub new {
  18     my ($class, $meta, @attrs) = @_;
  19     my @slots = map { $_->slots } @attrs;
  20     my $instance = bless {
  21         # NOTE:
  22         # I am not sure that it makes
  23         # sense to pass in the meta
  24         # The ideal would be to just
  25         # pass in the class name, but
  26         # that is placing too much of
  27         # an assumption on bless(),
  28         # which is *probably* a safe
  29         # assumption,.. but you can
  30         # never tell <:)
  31         '$!meta'  => $meta,
  32         '@!slots' => { map { $_ => undef } @slots },
  33     } => $class;
  34
  35     weaken($instance->{'$!meta'});
  36
  37     return $instance;
  38 }
  39
  40 sub associated_metaclass { (shift)->{'$!meta'} }
  41
  42 sub create_instance {
  43     my $self = shift;
  44     $self->bless_instance_structure({});
  45 }
  46
  47 sub bless_instance_structure {
  48     my ($self, $instance_structure) = @_;
  49     bless $instance_structure, $self->associated_metaclass->name;
  50 }
  51
  52 sub clone_instance {
  53     my ($self, $instance) = @_;
  54     $self->bless_instance_structure({ %$instance });
  55 }
  56
  57 # operations on meta instance
  58
  59 sub get_all_slots {
  60     my $self = shift;
  61     return keys %{$self->{'@!slots'}};
  62 }
  63
  64 sub is_valid_slot {
  65     my ($self, $slot_name) = @_;
  66     exists $self->{'@!slots'}->{$slot_name} ? 1 : 0;
  67 }
  68
  69 # operations on created instances
  70
  71 sub get_slot_value {
  72     my ($self, $instance, $slot_name) = @_;
  73     $self->is_slot_initialized($instance, $slot_name) ? $instance->{$slot_name} : undef;
  74 }
  75
  76 sub set_slot_value {
  77     my ($self, $instance, $slot_name, $value) = @_;
  78     $instance->{$slot_name} = $value;
  79 }
  80
  81 sub initialize_slot {
  82     my ($self, $instance, $slot_name) = @_;
  83     #$self->set_slot_value($instance, $slot_name, undef);
  84 }
  85
  86 sub deinitialize_slot {
  87     my ( $self, $instance, $slot_name ) = @_;
  88     delete $instance->{$slot_name};
  89 }
  90
  91 sub initialize_all_slots {
  92     my ($self, $instance) = @_;
  93     foreach my $slot_name ($self->get_all_slots) {
  94         $self->initialize_slot($instance, $slot_name);
  95     }
  96 }
  97
  98 sub deinitialize_all_slots {
  99     my ($self, $instance) = @_;
 100     foreach my $slot_name ($self->get_all_slots) {
 101         $self->deinitialize_slot($instance, $slot_name);
 102     }
 103 }
 104
 105 sub is_slot_initialized {
 106     my ($self, $instance, $slot_name, $value) = @_;
 107     exists $instance->{$slot_name} ? 1 : 0;
 108 }
 109
 110 sub weaken_slot_value {
 111     my ($self, $instance, $slot_name) = @_;
 112     weaken $instance->{$slot_name};
 113 }
 114
 115 sub strengthen_slot_value {
 116     my ($self, $instance, $slot_name) = @_;
 117     $self->set_slot_value($instance, $slot_name, $self->get_slot_value($instance, $slot_name));
 118 }
 119
 120 sub rebless_instance_structure {
 121     my ($self, $instance, $metaclass) = @_;
 122     bless $instance, $metaclass->name;
 123 }
 124
 125 # inlinable operation snippets
 126
 127 sub is_inlinable { 1 }
 128
 129 sub inline_create_instance {
 130     my ($self, $class_variable) = @_;
 131     'bless {} => ' . $class_variable;
 132 }
 133
 134 sub inline_slot_access {
 135     my ($self, $instance, $slot_name) = @_;
 136     sprintf "%s->{%s}", $instance, $slot_name;
 137 }
 138
 139 sub inline_get_slot_value {
 140     my ($self, $instance, $slot_name) = @_;
 141     'exists ' . $self->inline_slot_access($instance, $slot_name) .
 142     ' ? ' . $self->inline_slot_access($instance, $slot_name) . ' : undef'
 143 }
 144
 145 sub inline_set_slot_value {
 146     my ($self, $instance, $slot_name, $value) = @_;
 147     $self->inline_slot_access($instance, $slot_name) . " = $value",
 148 }
 149
 150 sub inline_initialize_slot {
 151     my ($self, $instance, $slot_name) = @_;
 152     $self->inline_set_slot_value($instance, $slot_name, 'undef'),
 153 }
 154
 155 sub inline_deinitialize_slot {
 156     my ($self, $instance, $slot_name) = @_;
 157     "delete " . $self->inline_slot_access($instance, $slot_name);
 158 }
 159 sub inline_is_slot_initialized {
 160     my ($self, $instance, $slot_name) = @_;
 161     "exists " . $self->inline_slot_access($instance, $slot_name) . " ? 1 : 0";
 162 }
 163
 164 sub inline_weaken_slot_value {
 165     my ($self, $instance, $slot_name) = @_;
 166     sprintf "Scalar::Util::weaken( %s )", $self->inline_slot_access($instance, $slot_name);
 167 }
 168
 169 sub inline_strengthen_slot_value {
 170     my ($self, $instance, $slot_name) = @_;
 171     $self->inline_set_slot_value($instance, $slot_name, $self->inline_slot_access($instance, $slot_name));
 172 }
 173
 174 1;
 175
 176 __END__
 177
 178 =pod
 179
 180 =head1 NAME
 181
 182 Class::MOP::Instance - Instance Meta Object
 183
 184 =head1 SYNOPSIS
 185
 186   # for the most part, this protocol is internal
 187   # and not for public usage, but this how one
 188   # might use it
 189
 190   package Foo;
 191
 192   use strict;
 193   use warnings;
 194   use metaclass (
 195       ':instance_metaclass'  => 'ArrayBasedStorage::Instance',
 196   );
 197
 198   # now Foo->new produces blessed ARRAY ref based objects
 199
 200 =head1 DESCRIPTION
 201
 202 This is a sub-protocol which governs instance creation
 203 and access to the slots of the instance structure.
 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 =back
 245
 246 =head2 Instrospection
 247
 248 NOTE: There might be more methods added to this part of the API,
 249 we will add then when we need them basically.
 250
 251 =over 4
 252
 253 =item B<associated_metaclass>
 254
 255 =item B<get_all_slots>
 256
 257 This will return the current list of slots based on what was
 258 given to this object in C<new>.
 259
 260 =item B<is_valid_slot ($slot_name)>
 261
 262 =back
 263
 264 =head2 Operations on Instance Structures
 265
 266 An important distinction of this sub-protocol is that the
 267 instance meta-object is a different entity from the actual
 268 instance it creates. For this reason, any actions on slots
 269 require that the C<$instance_structure> is passed into them.
 270
 271 =over 4
 272
 273 =item B<get_slot_value ($instance_structure, $slot_name)>
 274
 275 =item B<set_slot_value ($instance_structure, $slot_name, $value)>
 276
 277 =item B<initialize_slot ($instance_structure, $slot_name)>
 278
 279 =item B<deinitialize_slot ($instance_structure, $slot_name)>
 280
 281 =item B<initialize_all_slots ($instance_structure)>
 282
 283 =item B<deinitialize_all_slots ($instance_structure)>
 284
 285 =item B<is_slot_initialized ($instance_structure, $slot_name)>
 286
 287 =item B<weaken_slot_value ($instance_structure, $slot_name)>
 288
 289 =item B<strengthen_slot_value ($instance_structure, $slot_name)>
 290
 291 =item B<rebless_instance_structure ($instance_structure, $new_metaclass)>
 292
 293 =back
 294
 295 =head2 Inlineable Instance Operations
 296
 297 This part of the API is currently un-used. It is there for use
 298 in future experiments in class finailization mostly. Best to
 299 ignore this for now.
 300
 301 =over 4
 302
 303 =item B<is_inlinable>
 304
 305 Each meta-instance should override this method to tell Class::MOP if it's
 306 possible to inline the slot access.
 307
 308 This is currently only used by Class::MOP::Class::Immutable when performing
 309 optimizations.
 310
 311 =item B<inline_create_instance>
 312
 313 =item B<inline_slot_access ($instance_structure, $slot_name)>
 314
 315 =item B<inline_get_slot_value ($instance_structure, $slot_name)>
 316
 317 =item B<inline_set_slot_value ($instance_structure, $slot_name, $value)>
 318
 319 =item B<inline_initialize_slot ($instance_structure, $slot_name)>
 320
 321 =item B<inline_deinitialize_slot ($instance_structure, $slot_name)>
 322
 323 =item B<inline_is_slot_initialized ($instance_structure, $slot_name)>
 324
 325 =item B<inline_weaken_slot_value ($instance_structure, $slot_name)>
 326
 327 =item B<inline_strengthen_slot_value ($instance_structure, $slot_name)>
 328
 329 =back
 330
 331 =head1 AUTHORS
 332
 333 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 334
 335 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 336
 337 =head1 COPYRIGHT AND LICENSE
 338
 339 Copyright 2006-2008 by Infinity Interactive, Inc.
 340
 341 L<http://www.iinteractive.com>
 342
 343 This library is free software; you can redistribute it and/or modify
 344 it under the same terms as Perl itself.
 345
 346 =cut
 347