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 sub get_all_slot_values {
 126     my ($self, $instance) = @_;
 127
 128     return +{
 129         map { $_->name => $_->get_value($instance) }
 130             grep { $_->has_value($instance) }
 131                 $self->associated_metaclass->compute_all_applicable_attributes
 132     };
 133 }
 134
 135 # inlinable operation snippets
 136
 137 sub is_inlinable { 1 }
 138
 139 sub inline_create_instance {
 140     my ($self, $class_variable) = @_;
 141     'bless {} => ' . $class_variable;
 142 }
 143
 144 sub inline_slot_access {
 145     my ($self, $instance, $slot_name) = @_;
 146     sprintf "%s->{%s}", $instance, $slot_name;
 147 }
 148
 149 sub inline_get_slot_value {
 150     my ($self, $instance, $slot_name) = @_;
 151     'exists ' . $self->inline_slot_access($instance, $slot_name) .
 152     ' ? ' . $self->inline_slot_access($instance, $slot_name) . ' : undef'
 153 }
 154
 155 sub inline_set_slot_value {
 156     my ($self, $instance, $slot_name, $value) = @_;
 157     $self->inline_slot_access($instance, $slot_name) . " = $value",
 158 }
 159
 160 sub inline_initialize_slot {
 161     my ($self, $instance, $slot_name) = @_;
 162     $self->inline_set_slot_value($instance, $slot_name, 'undef'),
 163 }
 164
 165 sub inline_deinitialize_slot {
 166     my ($self, $instance, $slot_name) = @_;
 167     "delete " . $self->inline_slot_access($instance, $slot_name);
 168 }
 169 sub inline_is_slot_initialized {
 170     my ($self, $instance, $slot_name) = @_;
 171     "exists " . $self->inline_slot_access($instance, $slot_name) . " ? 1 : 0";
 172 }
 173
 174 sub inline_weaken_slot_value {
 175     my ($self, $instance, $slot_name) = @_;
 176     sprintf "Scalar::Util::weaken( %s )", $self->inline_slot_access($instance, $slot_name);
 177 }
 178
 179 sub inline_strengthen_slot_value {
 180     my ($self, $instance, $slot_name) = @_;
 181     $self->inline_set_slot_value($instance, $slot_name, $self->inline_slot_access($instance, $slot_name));
 182 }
 183
 184 1;
 185
 186 __END__
 187
 188 =pod
 189
 190 =head1 NAME
 191
 192 Class::MOP::Instance - Instance Meta Object
 193
 194 =head1 SYNOPSIS
 195
 196   # for the most part, this protocol is internal
 197   # and not for public usage, but this how one
 198   # might use it
 199
 200   package Foo;
 201
 202   use strict;
 203   use warnings;
 204   use metaclass (
 205       ':instance_metaclass'  => 'ArrayBasedStorage::Instance',
 206   );
 207
 208   # now Foo->new produces blessed ARRAY ref based objects
 209
 210 =head1 DESCRIPTION
 211
 212 This is a sub-protocol which governs instance creation
 213 and access to the slots of the instance structure.
 214
 215 This may seem like over-abstraction, but by abstracting
 216 this process into a sub-protocol we make it possible to
 217 easily switch the details of how an object's instance is
 218 stored with minimal impact. In most cases just subclassing
 219 this class will be all you need to do (see the examples;
 220 F<examples/ArrayBasedStorage.pod> and
 221 F<examples/InsideOutClass.pod> for details).
 222
 223 =head1 METHODS
 224
 225 =over 4
 226
 227 =item B<new ($meta, @attrs)>
 228
 229 Creates a new instance meta-object and gathers all the slots from
 230 the list of C<@attrs> given.
 231
 232 =item B<meta>
 233
 234 This will return a B<Class::MOP::Class> instance which is related
 235 to this class.
 236
 237 =back
 238
 239 =head2 Creation of Instances
 240
 241 =over 4
 242
 243 =item B<create_instance>
 244
 245 This creates the appropriate structure needed for the instance and
 246 then calls C<bless_instance_structure> to bless it into the class.
 247
 248 =item B<bless_instance_structure ($instance_structure)>
 249
 250 This does just exactly what it says it does.
 251
 252 =item B<clone_instance ($instance_structure)>
 253
 254 =back
 255
 256 =head2 Instrospection
 257
 258 NOTE: There might be more methods added to this part of the API,
 259 we will add then when we need them basically.
 260
 261 =over 4
 262
 263 =item B<associated_metaclass>
 264
 265 =item B<get_all_slots>
 266
 267 This will return the current list of slots based on what was
 268 given to this object in C<new>.
 269
 270 =item B<is_valid_slot ($slot_name)>
 271
 272 =back
 273
 274 =head2 Operations on Instance Structures
 275
 276 An important distinction of this sub-protocol is that the
 277 instance meta-object is a different entity from the actual
 278 instance it creates. For this reason, any actions on slots
 279 require that the C<$instance_structure> is passed into them.
 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<get_all_slot_values ($instance_structure)>
 288
 289 =item B<initialize_slot ($instance_structure, $slot_name)>
 290
 291 =item B<deinitialize_slot ($instance_structure, $slot_name)>
 292
 293 =item B<initialize_all_slots ($instance_structure)>
 294
 295 =item B<deinitialize_all_slots ($instance_structure)>
 296
 297 =item B<is_slot_initialized ($instance_structure, $slot_name)>
 298
 299 =item B<weaken_slot_value ($instance_structure, $slot_name)>
 300
 301 =item B<strengthen_slot_value ($instance_structure, $slot_name)>
 302
 303 =item B<rebless_instance_structure ($instance_structure, $new_metaclass)>
 304
 305 =back
 306
 307 =head2 Inlineable Instance Operations
 308
 309 This part of the API is currently un-used. It is there for use
 310 in future experiments in class finailization mostly. Best to
 311 ignore this for now.
 312
 313 =over 4
 314
 315 =item B<is_inlinable>
 316
 317 Each meta-instance should override this method to tell Class::MOP if it's
 318 possible to inline the slot access.
 319
 320 This is currently only used by Class::MOP::Class::Immutable when performing
 321 optimizations.
 322
 323 =item B<inline_create_instance>
 324
 325 =item B<inline_slot_access ($instance_structure, $slot_name)>
 326
 327 =item B<inline_get_slot_value ($instance_structure, $slot_name)>
 328
 329 =item B<inline_set_slot_value ($instance_structure, $slot_name, $value)>
 330
 331 =item B<inline_initialize_slot ($instance_structure, $slot_name)>
 332
 333 =item B<inline_deinitialize_slot ($instance_structure, $slot_name)>
 334
 335 =item B<inline_is_slot_initialized ($instance_structure, $slot_name)>
 336
 337 =item B<inline_weaken_slot_value ($instance_structure, $slot_name)>
 338
 339 =item B<inline_strengthen_slot_value ($instance_structure, $slot_name)>
 340
 341 =back
 342
 343 =head1 AUTHORS
 344
 345 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 346
 347 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 348
 349 =head1 COPYRIGHT AND LICENSE
 350
 351 Copyright 2006-2008 by Infinity Interactive, Inc.
 352
 353 L<http://www.iinteractive.com>
 354
 355 This library is free software; you can redistribute it and/or modify
 356 it under the same terms as Perl itself.
 357
 358 =cut
 359