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