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 DESCRIPTION
 184
 185 The meta instance is used by attributes for low level storage.
 186
 187 Using this API generally violates attribute encapsulation and is not
 188 reccomended, instead look at L<Class::MOP::Attribute/get_value>,
 189 L<Class::MOP::Attribute/set_value> for the reccomended way to fiddle with
 190 attribute values in a generic way, independant of how/whether accessors have
 191 been defined. Accessors can be found using L<Class::MOP::Class/get_attribute>.
 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 This too does just exactly what it says it does.
 233
 234 =back
 235
 236 =head2 Instrospection
 237
 238 NOTE: There might be more methods added to this part of the API,
 239 we will add then when we need them basically.
 240
 241 =over 4
 242
 243 =item B<associated_metaclass>
 244
 245 This returns the metaclass associated with this instance.
 246
 247 =item B<get_all_slots>
 248
 249 This will return the current list of slots based on what was
 250 given to this object in C<new>.
 251
 252 =item B<is_valid_slot ($slot_name)>
 253
 254 This will return true if C<$slot_name> is a valid slot name.
 255
 256 =back
 257
 258 =head2 Operations on Instance Structures
 259
 260 An important distinction of this sub-protocol is that the
 261 instance meta-object is a different entity from the actual
 262 instance it creates. For this reason, any actions on slots
 263 require that the C<$instance_structure> is passed into them.
 264
 265 The names of these methods pretty much explain exactly
 266 what they do, if that is not enough then I suggest reading
 267 the source, it is very straightfoward.
 268
 269 =over 4
 270
 271 =item B<get_slot_value ($instance_structure, $slot_name)>
 272
 273 =item B<set_slot_value ($instance_structure, $slot_name, $value)>
 274
 275 =item B<initialize_slot ($instance_structure, $slot_name)>
 276
 277 =item B<deinitialize_slot ($instance_structure, $slot_name)>
 278
 279 =item B<initialize_all_slots ($instance_structure)>
 280
 281 =item B<deinitialize_all_slots ($instance_structure)>
 282
 283 =item B<is_slot_initialized ($instance_structure, $slot_name)>
 284
 285 =item B<weaken_slot_value ($instance_structure, $slot_name)>
 286
 287 =item B<strengthen_slot_value ($instance_structure, $slot_name)>
 288
 289 =item B<rebless_instance_structure ($instance_structure, $new_metaclass)>
 290
 291 =back
 292
 293 =head2 Inlineable Instance Operations
 294
 295 =over 4
 296
 297 =item B<is_inlinable>
 298
 299 Each meta-instance should override this method to tell Class::MOP if it's
 300 possible to inline the slot access. This is currently only used by
 301 L<Class::MOP::Immutable> when performing optimizations.
 302
 303 =item B<inline_create_instance>
 304
 305 =item B<inline_slot_access ($instance_structure, $slot_name)>
 306
 307 =item B<inline_get_slot_value ($instance_structure, $slot_name)>
 308
 309 =item B<inline_set_slot_value ($instance_structure, $slot_name, $value)>
 310
 311 =item B<inline_initialize_slot ($instance_structure, $slot_name)>
 312
 313 =item B<inline_deinitialize_slot ($instance_structure, $slot_name)>
 314
 315 =item B<inline_is_slot_initialized ($instance_structure, $slot_name)>
 316
 317 =item B<inline_weaken_slot_value ($instance_structure, $slot_name)>
 318
 319 =item B<inline_strengthen_slot_value ($instance_structure, $slot_name)>
 320
 321 =back
 322
 323 =head1 AUTHORS
 324
 325 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 326
 327 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 328
 329 =head1 COPYRIGHT AND LICENSE
 330
 331 Copyright 2006-2008 by Infinity Interactive, Inc.
 332
 333 L<http://www.iinteractive.com>
 334
 335 This library is free software; you can redistribute it and/or modify
 336 it under the same terms as Perl itself.
 337
 338 =cut
 339