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