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