lib/Class/MOP/Instance.pm

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