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 # convenience method
 105 # non autovivifying stores will have this as { initialize_slot unless slot_initlized; set_slot_value }
 106 sub set_slot_value_with_init {
 107     my ( $self, $instance, $slot_name, $value ) = @_;
 108     $self->set_slot_value( $instance, $slot_name, $value );
 109 }
 110
 111 sub initialize_slot {
 112     my ( $self, $instance, $slot_name ) = @_;
 113 }
 114
 115 sub slot_initialized {
 116     my ($self, $instance, $slot_name) = @_;
 117     exists $instance->{$slot_name} ? 1 : 0;
 118 }
 119
 120
 121 # inlinable operation snippets
 122
 123 sub inline_get_slot_value {
 124     my ($self, $instance, $slot_name) = @_;
 125     sprintf "%s->{%s}", $instance, $slot_name;
 126 }
 127
 128 sub inline_set_slot_value {
 129     my ($self, $instance, $slot_name, $value) = @_;
 130     $self->_inline_slot_lvalue . " = $value",
 131 }
 132
 133 sub inline_set_slot_value_with_init {
 134     my ( $self, $instance, $slot_name, $value) = @_;
 135     $self->inline_set_slot_value( $instance, $slot_name, $value ) . ";";
 136 }
 137
 138 sub inline_initialize_slot {
 139     return "";
 140 }
 141
 142 sub inline_slot_initialized {
 143     my ($self, $instance, $slot_name) = @_;
 144     "exists " . $self->inline_get_slot_value;
 145 }
 146
 147 sub _inline_slot_lvalue {
 148     my ($self, $instance, $slot_name) = @_;
 149     $self->inline_slot_value;
 150 }
 151
 152 1;
 153
 154 __END__
 155
 156 =pod
 157
 158 =head1 NAME
 159
 160 Class::MOP::Instance - Instance Meta Object
 161
 162 =head1 SYNOPSIS
 163
 164 =head1 DESCRIPTION
 165
 166 =head1 METHODS
 167
 168 =over 4
 169
 170 =item B<new>
 171
 172 =item B<add_slot>
 173
 174 =item B<bless_instance_structure>
 175
 176 =item B<create_instance>
 177
 178 =item B<get_all_parents>
 179
 180 =item B<get_slot_value>
 181
 182 =item B<has_slot>
 183
 184 =item B<has_slot_recursively>
 185
 186 =item B<initialize_slot>
 187
 188 =item B<inline_get_slot_value>
 189
 190 =item B<inline_initialize_slot>
 191
 192 =item B<inline_set_slot_value>
 193
 194 =item B<inline_set_slot_value_with_init>
 195
 196 =item B<inline_slot_initialized>
 197
 198 =item B<remove_slot>
 199
 200 =item B<set_slot_value>
 201
 202 =item B<set_slot_value_with_init>
 203
 204 =item B<slot_initialized>
 205
 206 =back
 207
 208 =head2 Introspection
 209
 210 =over 4
 211
 212 =item B<meta>
 213
 214 This will return a B<Class::MOP::Class> instance which is related
 215 to this class.
 216
 217 =back
 218
 219 =head1 AUTHOR
 220
 221 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 222
 223 =head1 COPYRIGHT AND LICENSE
 224
 225 Copyright 2006 by Infinity Interactive, Inc.
 226
 227 L<http://www.iinteractive.com>
 228
 229 This library is free software; you can redistribute it and/or modify
 230 it under the same terms as Perl itself.
 231
 232 =cut