lib/Class/MOP/Instance.pm

   1
   2 package Class::MOP::Instance;
   3
   4 use strict;
   5 use warnings;
   6
   7 use Carp         'confess';
   8 use Scalar::Util 'blessed', 'reftype', 'weaken';
   9
  10 our $VERSION = '0.01';
  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 ) = @_;
  19     bless {
  20         meta            => $meta,
  21         instance_layout => {}
  22     } => $class;
  23 }
  24
  25 sub create_instance {
  26     my ( $self, $class ) = @_;
  27
  28     # rely on autovivification
  29     $self->bless_instance_structure( {}, $class );
  30 }
  31
  32 sub bless_instance_structure {
  33     my ( $self, $instance_structure, $class ) = @_;
  34     $class ||= $self->{meta}->name;
  35     bless $instance_structure, $class;
  36 }
  37
  38 sub get_all_parents {
  39     my $self = shift;
  40     my @parents = $self->{meta}->class_precedence_list;
  41     shift @parents; # shift off ourselves
  42     return map { $_->get_meta_instance } map { $_->meta || () } @parents;
  43 }
  44
  45 # operations on meta instance
  46
  47 sub add_slot {
  48     my ($self, $slot_name ) = @_;
  49     confess "The slot '$slot_name' already exists"
  50         if 0 && $self->has_slot_recursively( $slot_name ); # FIXME
  51     $self->{instance_layout}->{$slot_name} = undef;
  52 }
  53
  54 sub get_all_slots {
  55     my $self = shift;
  56     keys %{ $self->{instance_layout} };
  57 }
  58
  59 sub get_all_slots_recursively {
  60     my $self = shift;
  61     return (
  62         $self->get_all_slots,
  63         map { $_->get_all_slots } $self->get_all_parents,
  64     ),
  65 }
  66
  67 sub has_slot {
  68     my ($self, $slot_name) = @_;
  69     exists $self->{instance_layout}->{$slot_name} ? 1 : 0;
  70 }
  71
  72 sub has_slot_recursively {
  73     my ( $self, $slot_name ) = @_;
  74     return 1 if $self->has_slot($slot_name);
  75     $_->has_slot_recursively($slot_name) && return 1 for $self->get_all_parents;
  76     return 0;
  77 }
  78
  79 sub remove_slot {
  80     my ( $self, $slot_name ) = @_;
  81     # NOTE:
  82     # this does not search recursively cause
  83     # that is not the domain of this meta-instance
  84     # it is specific to this class ...
  85     confess "The slot '$slot_name' does not exist (maybe it's inherited?)"
  86         if 0 && $self->has_slot( $slot_name ); # FIXME
  87     delete $self->{instance_layout}->{$slot_name};
  88 }
  89
  90
  91 # operations on created instances
  92
  93 sub get_slot_value {
  94     my ($self, $instance, $slot_name) = @_;
  95     return $instance->{$slot_name};
  96 }
  97
  98 # can be called only after initialize_slot_value
  99 sub set_slot_value {
 100     my ($self, $instance, $slot_name, $value) = @_;
 101     $instance->{$slot_name} = $value;
 102 }
 103
 104 sub set_weak_slot_value {
 105         my ( $self, $instance, $slot_name, $value) = @_;
 106         $self->set_slot_value( $instance, $slot_name, $value );
 107         $self->weeaken_slot_value( $instance, $slot_name );
 108 }
 109
 110 sub weaken_slot_value {
 111         my ( $self, $instance, $slot_name ) = @_;
 112         weaken( $instance->{$slot_name} );
 113 }
 114
 115 # convenience method
 116 # non autovivifying stores will have this as { initialize_slot unless slot_initlized; set_slot_value }
 117 sub set_slot_value_with_init {
 118     my ( $self, $instance, $slot_name, $value ) = @_;
 119     $self->set_slot_value( $instance, $slot_name, $value );
 120 }
 121
 122 sub initialize_slot {
 123     my ( $self, $instance, $slot_name ) = @_;
 124 }
 125
 126 sub slot_initialized {
 127     my ($self, $instance, $slot_name) = @_;
 128     exists $instance->{$slot_name} ? 1 : 0;
 129 }
 130
 131
 132 # inlinable operation snippets
 133
 134 sub inline_get_slot_value {
 135     my ($self, $instance, $slot_name) = @_;
 136     sprintf "%s->{%s}", $instance, $slot_name;
 137 }
 138
 139 sub inline_set_slot_value {
 140     my ($self, $instance, $slot_name, $value) = @_;
 141     $self->_inline_slot_lvalue( $instance, $slot_name ) . " = $value",
 142 }
 143
 144 sub inline_set_weak_slot_value {
 145         my ( $self, $instance, $slot_name, $value ) = @_;
 146         return ""
 147                 . $self->inline_set_slot_value( $instance, $slot_name, $value )
 148                 . "; "
 149                 . $self->inline_weaken_slot_value( $instance, $slot_name );
 150 }
 151
 152 sub inline_weaken_slot_value {
 153         my ( $self, $instance, $slot_name ) = @_;
 154         return 'Scalar::Util::weaken( ' . $self->_inline_slot_lvalue( $instance, $slot_name ) . ')';
 155 }
 156
 157 sub inline_set_slot_value_with_init {
 158     my ( $self, $instance, $slot_name, $value) = @_;
 159     $self->inline_set_slot_value( $instance, $slot_name, $value ) . ";";
 160 }
 161
 162 sub inline_initialize_slot {
 163     return "";
 164 }
 165
 166 sub inline_slot_initialized {
 167     my ($self, $instance, $slot_name) = @_;
 168     "exists " . $self->inline_get_slot_value;
 169 }
 170
 171 sub _inline_slot_lvalue {
 172     my ($self, $instance, $slot_name) = @_;
 173     $self->inline_get_slot_value( $instance, $slot_name );
 174 }
 175
 176 1;
 177
 178 __END__
 179
 180 =pod
 181
 182 =head1 NAME
 183
 184 Class::MOP::Instance - Instance Meta Object
 185
 186 =head1 SYNOPSIS
 187
 188 =head1 DESCRIPTION
 189
 190 =head1 METHODS
 191
 192 =over 4
 193
 194 =item B<new>
 195
 196 =item B<add_slot>
 197
 198 =item B<bless_instance_structure>
 199
 200 =item B<create_instance>
 201
 202 =item B<get_all_parents>
 203
 204 =item B<get_slot_value>
 205
 206 =item B<has_slot>
 207
 208 =item B<has_slot_recursively>
 209
 210 =item B<initialize_slot>
 211
 212 =item B<inline_get_slot_value>
 213
 214 =item B<inline_initialize_slot>
 215
 216 =item B<inline_set_slot_value>
 217
 218 =item B<inline_set_slot_value_with_init>
 219
 220 =item B<inline_slot_initialized>
 221
 222 =item B<remove_slot>
 223
 224 =item B<set_slot_value>
 225
 226 =item B<set_slot_value_with_init>
 227
 228 =item B<slot_initialized>
 229
 230 =item B<get_all_slots>
 231
 232 =item B<get_all_slots_recursively>
 233
 234 =back
 235
 236 =head2 Introspection
 237
 238 =over 4
 239
 240 =item B<meta>
 241
 242 This will return a B<Class::MOP::Class> instance which is related
 243 to this class.
 244
 245 =back
 246
 247 =head1 AUTHOR
 248
 249 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 250
 251 =head1 COPYRIGHT AND LICENSE
 252
 253 Copyright 2006 by Infinity Interactive, Inc.
 254
 255 L<http://www.iinteractive.com>
 256
 257 This library is free software; you can redistribute it and/or modify
 258 it under the same terms as Perl itself.
 259
 260 =cut