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 );
  51     $self->{instance_layout}->{$slot_name} = undef;
  52 }
  53
  54 sub has_slot {
  55     my ($self, $slot_name) = @_;
  56     exists $self->{instance_layout}->{$slot_name} ? 1 : 0;
  57 }
  58
  59 sub has_slot_recursively {
  60     my ( $self, $slot_name ) = @_;
  61     return 1 if $self->has_slot($slot_name);
  62     $_->has_slot_recursively($slot_name) && return 1 for $self->get_all_parents;
  63     return 0;
  64 }
  65
  66 sub remove_slot {
  67     my ( $self, $slot_name ) = @_;
  68     # NOTE:
  69     # this does not search recursively cause
  70     # that is not the domain of this meta-instance
  71     # it is specific to this class ...
  72     confess "The slot '$slot_name' does not exist (maybe it's inherited?)"
  73         if 0 && $self->has_slot( $slot_name );
  74     delete $self->{instance_layout}->{$slot_name};
  75 }
  76
  77
  78 # operations on created instances
  79
  80 sub get_slot_value {
  81     my ($self, $instance, $slot_name) = @_;
  82     return $instance->{$slot_name};
  83 }
  84
  85 # can be called only after initialize_slot_value
  86 sub set_slot_value {
  87     my ($self, $instance, $slot_name, $value) = @_;
  88     $slot_name or confess "must provide slot name";
  89     $instance->{$slot_name} = $value;
  90 }
  91
  92 # convenience method
  93 # non autovivifying stores will have this as { initialize_slot unless slot_initlized; set_slot_value }
  94 sub set_slot_value_with_init {
  95     my ( $self, $instance, $slot_name, $value ) = @_;
  96     $self->set_slot_value( $instance, $slot_name, $value );
  97 }
  98
  99 sub initialize_slot {
 100     my ( $self, $instance, $slot_name ) = @_;
 101 }
 102
 103 sub slot_initialized {
 104     my ($self, $instance, $slot_name) = @_;
 105     exists $instance->{$slot_name} ? 1 : 0;
 106 }
 107
 108
 109 # inlinable operation snippets
 110
 111 sub inline_get_slot_value {
 112     my ($self, $instance, $slot_name) = @_;
 113     sprintf "%s->{%s}", $instance, $slot_name;
 114 }
 115
 116 sub inline_set_slot_value {
 117     my ($self, $instance, $slot_name, $value) = @_;
 118     $self->_inline_slot_lvalue . " = $value",
 119 }
 120
 121 sub inline_set_slot_value_with_init {
 122     my ( $self, $instance, $slot_name, $value) = @_;
 123     $self->inline_set_slot_value( $instance, $slot_name, $value ) . ";";
 124 }
 125
 126 sub inline_initialize_slot {
 127     return "";
 128 }
 129
 130 sub inline_slot_initialized {
 131     my ($self, $instance, $slot_name) = @_;
 132     "exists " . $self->inline_get_slot_value;
 133 }
 134
 135 sub _inline_slot_lvalue {
 136     my ($self, $instance, $slot_name) = @_;
 137     $self->inline_slot_value;
 138 }
 139
 140 1;
 141
 142 __END__
 143
 144 =pod
 145
 146 =head1 NAME
 147
 148 Class::MOP::Instance - Instance Meta Object
 149
 150 =head1 SYNOPSIS
 151
 152 =head1 DESCRIPTION
 153
 154 =head1 METHODS
 155
 156 =over 4
 157
 158 =item B<new>
 159
 160 =item B<add_slot>
 161
 162 =item B<has_slot>
 163
 164 =item B<get_slot_value>
 165
 166 =item B<set_slot_value>
 167
 168 =item B<has_slot_value>
 169
 170 =back
 171
 172 =head2 Introspection
 173
 174 =over 4
 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 =head1 AUTHOR
 184
 185 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 186
 187 =head1 COPYRIGHT AND LICENSE
 188
 189 Copyright 2006 by Infinity Interactive, Inc.
 190
 191 L<http://www.iinteractive.com>
 192
 193 This library is free software; you can redistribute it and/or modify
 194 it under the same terms as Perl itself.
 195
 196 =cut