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