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