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