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 _set_initial_slot_value {
  82   my ($self, $instance, $slot_name, $value, $initializer) = @_;
  83
  84   return $self->set_slot_value($instance, $slot_name, $value)
  85       unless $initializer;
  86
  87   my $callback = sub {
  88     $self->set_slot_value($instance, $slot_name, $_[0]);
  89   };
  90
  91   # most things will just want to set a value, so make it first arg
  92   $instance->$initializer($value, $callback, $self);
  93 }
  94
  95 sub initialize_slot {
  96     my ($self, $instance, $slot_name) = @_;
  97     #$self->set_slot_value($instance, $slot_name, undef);
  98 }
  99
 100 sub deinitialize_slot {
 101     my ( $self, $instance, $slot_name ) = @_;
 102     delete $instance->{$slot_name};
 103 }
 104
 105 sub initialize_all_slots {
 106     my ($self, $instance) = @_;
 107     foreach my $slot_name ($self->get_all_slots) {
 108         $self->initialize_slot($instance, $slot_name);
 109     }
 110 }
 111
 112 sub deinitialize_all_slots {
 113     my ($self, $instance) = @_;
 114     foreach my $slot_name ($self->get_all_slots) {
 115         $self->deinitialize_slot($instance, $slot_name);
 116     }
 117 }
 118
 119 sub is_slot_initialized {
 120     my ($self, $instance, $slot_name, $value) = @_;
 121     exists $instance->{$slot_name};
 122 }
 123
 124 sub weaken_slot_value {
 125     my ($self, $instance, $slot_name) = @_;
 126     weaken $instance->{$slot_name};
 127 }
 128
 129 sub strengthen_slot_value {
 130     my ($self, $instance, $slot_name) = @_;
 131     $self->set_slot_value($instance, $slot_name, $self->get_slot_value($instance, $slot_name));
 132 }
 133
 134 sub rebless_instance_structure {
 135     my ($self, $instance, $metaclass) = @_;
 136     bless $instance, $metaclass->name;
 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     $self->inline_slot_access($instance, $slot_name);
 156 }
 157
 158 sub inline_set_slot_value {
 159     my ($self, $instance, $slot_name, $value) = @_;
 160     $self->inline_slot_access($instance, $slot_name) . " = $value",
 161 }
 162
 163 sub inline_initialize_slot {
 164     my ($self, $instance, $slot_name) = @_;
 165     $self->inline_set_slot_value($instance, $slot_name, 'undef'),
 166 }
 167
 168 sub inline_deinitialize_slot {
 169     my ($self, $instance, $slot_name) = @_;
 170     "delete " . $self->inline_slot_access($instance, $slot_name);
 171 }
 172 sub inline_is_slot_initialized {
 173     my ($self, $instance, $slot_name) = @_;
 174     "exists " . $self->inline_slot_access($instance, $slot_name);
 175 }
 176
 177 sub inline_weaken_slot_value {
 178     my ($self, $instance, $slot_name) = @_;
 179     sprintf "Scalar::Util::weaken( %s )", $self->inline_slot_access($instance, $slot_name);
 180 }
 181
 182 sub inline_strengthen_slot_value {
 183     my ($self, $instance, $slot_name) = @_;
 184     $self->inline_set_slot_value($instance, $slot_name, $self->inline_slot_access($instance, $slot_name));
 185 }
 186
 187 1;
 188
 189 __END__
 190
 191 =pod
 192
 193 =head1 NAME
 194
 195 Class::MOP::Instance - Instance Meta Object
 196
 197 =head1 SYNOPSIS
 198
 199     # This API is largely internal
 200     # you shouldn't need it unless you are writing meta attributes or meta
 201     # instances
 202
 203 =head1 DESCRIPTION
 204
 205 The meta instance is used by attributes for low level storage.
 206
 207 Using this API generally violates attribute encapsulation and is not
 208 reccomended, instead look at L<Class::MOP::Attribute/get_value>,
 209 L<Class::MOP::Attribute/set_value> for the reccomended way to fiddle with
 210 attribute values in a generic way, independant of how/whether accessors have
 211 been defined. Accessors can be found using L<Class::MOP::Class/get_attribute>.
 212
 213 This may seem like over-abstraction, but by abstracting
 214 this process into a sub-protocol we make it possible to
 215 easily switch the details of how an object's instance is
 216 stored with minimal impact. In most cases just subclassing
 217 this class will be all you need to do (see the examples;
 218 F<examples/ArrayBasedStorage.pod> and
 219 F<examples/InsideOutClass.pod> for details).
 220
 221 =head1 METHODS
 222
 223 =over 4
 224
 225 =item B<new ($meta, @attrs)>
 226
 227 Creates a new instance meta-object and gathers all the slots from
 228 the list of C<@attrs> given.
 229
 230 =item B<meta>
 231
 232 This will return a B<Class::MOP::Class> instance which is related
 233 to this class.
 234
 235 =back
 236
 237 =head2 Creation of Instances
 238
 239 =over 4
 240
 241 =item B<create_instance>
 242
 243 This creates the appropriate structure needed for the instance and
 244 then calls C<bless_instance_structure> to bless it into the class.
 245
 246 =item B<bless_instance_structure ($instance_structure)>
 247
 248 This does just exactly what it says it does.
 249
 250 =item B<clone_instance ($instance_structure)>
 251
 252 =back
 253
 254 =head2 Instrospection
 255
 256 NOTE: There might be more methods added to this part of the API,
 257 we will add then when we need them basically.
 258
 259 =over 4
 260
 261 =item B<associated_metaclass>
 262
 263 =item B<get_all_slots>
 264
 265 This will return the current list of slots based on what was
 266 given to this object in C<new>.
 267
 268 =item B<is_valid_slot ($slot_name)>
 269
 270 =back
 271
 272 =head2 Operations on Instance Structures
 273
 274 An important distinction of this sub-protocol is that the
 275 instance meta-object is a different entity from the actual
 276 instance it creates. For this reason, any actions on slots
 277 require that the C<$instance_structure> is passed into them.
 278
 279 =over 4
 280
 281 =item B<get_slot_value ($instance_structure, $slot_name)>
 282
 283 =item B<set_slot_value ($instance_structure, $slot_name, $value)>
 284
 285 =item B<initialize_slot ($instance_structure, $slot_name)>
 286
 287 =item B<deinitialize_slot ($instance_structure, $slot_name)>
 288
 289 =item B<initialize_all_slots ($instance_structure)>
 290
 291 =item B<deinitialize_all_slots ($instance_structure)>
 292
 293 =item B<is_slot_initialized ($instance_structure, $slot_name)>
 294
 295 =item B<weaken_slot_value ($instance_structure, $slot_name)>
 296
 297 =item B<strengthen_slot_value ($instance_structure, $slot_name)>
 298
 299 =item B<rebless_instance_structure ($instance_structure, $new_metaclass)>
 300
 301 =back
 302
 303 =head2 Inlineable Instance Operations
 304
 305 This part of the API is currently un-used. It is there for use
 306 in future experiments in class finailization mostly. Best to
 307 ignore this for now.
 308
 309 =over 4
 310
 311 =item B<is_inlinable>
 312
 313 Each meta-instance should override this method to tell Class::MOP if it's
 314 possible to inline the slot access.
 315
 316 This is currently only used by Class::MOP::Class::Immutable when performing
 317 optimizations.
 318
 319 =item B<inline_create_instance>
 320
 321 =item B<inline_slot_access ($instance_structure, $slot_name)>
 322
 323 =item B<inline_get_slot_value ($instance_structure, $slot_name)>
 324
 325 =item B<inline_set_slot_value ($instance_structure, $slot_name, $value)>
 326
 327 =item B<inline_initialize_slot ($instance_structure, $slot_name)>
 328
 329 =item B<inline_deinitialize_slot ($instance_structure, $slot_name)>
 330
 331 =item B<inline_is_slot_initialized ($instance_structure, $slot_name)>
 332
 333 =item B<inline_weaken_slot_value ($instance_structure, $slot_name)>
 334
 335 =item B<inline_strengthen_slot_value ($instance_structure, $slot_name)>
 336
 337 =back
 338
 339 =head1 AUTHORS
 340
 341 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 342
 343 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 344
 345 =head1 COPYRIGHT AND LICENSE
 346
 347 Copyright 2006-2008 by Infinity Interactive, Inc.
 348
 349 L<http://www.iinteractive.com>
 350
 351 This library is free software; you can redistribute it and/or modify
 352 it under the same terms as Perl itself.
 353
 354 =cut
 355