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