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, @attrs) = @_;
  19     my @slots = map { $_->slots } @attrs;
  20     bless {
  21         # NOTE:
  22         # I am not sure that it makes
  23         # sense to pass in the meta
  24         # The ideal would be to just
  25         # pass in the class name, but
  26         # that is placing too much of
  27         # an assumption on bless(),
  28         # which is *probably* a safe
  29         # assumption,.. but you can
  30         # never tell <:)
  31         meta  => $meta,
  32         slots => \@slots,
  33     } => $class;
  34 }
  35
  36 sub create_instance {
  37     my $self = shift;
  38     $self->bless_instance_structure({});
  39 }
  40
  41 sub bless_instance_structure {
  42     my ($self, $instance_structure) = @_;
  43     bless $instance_structure, $self->{meta}->name;
  44 }
  45
  46 # operations on meta instance
  47
  48 sub get_all_slots {
  49     my $self = shift;
  50     return @{$self->{slots}};
  51 }
  52
  53 # operations on created instances
  54
  55 sub initialize_all_slots {
  56     my ($self, $instance) = @_;
  57     foreach my $slot_name ($self->get_all_slots) {
  58         $self->initialize_slot($instance, $slot_name);
  59     }
  60 }
  61
  62 sub get_slot_value {
  63     my ($self, $instance, $slot_name) = @_;
  64     return $instance->{$slot_name};
  65 }
  66
  67 sub set_slot_value {
  68     my ($self, $instance, $slot_name, $value) = @_;
  69     $instance->{$slot_name} = $value;
  70 }
  71
  72 sub initialize_slot {
  73     my ($self, $instance, $slot_name) = @_;
  74     $instance->{$slot_name} = undef;
  75 }
  76
  77 sub is_slot_initialized {
  78     my ($self, $instance, $slot_name, $value) = @_;
  79     exists $instance->{$slot_name} ? 1 : 0;
  80 }
  81
  82 # inlinable operation snippets
  83
  84 sub inline_get_slot_value {
  85     my ($self, $instance_var_name, $slot_name) = @_;
  86     return ($instance_var_name . '->{\'' . $slot_name . '\'}');
  87 }
  88
  89 sub inline_set_slot_value {
  90     my ($self, $instance_var_name, $slot_name, $value_name) = @_;
  91     return ($self->inline_get_slot_value($instance_var_name, $slot_name) . ' = ' . $value_name);
  92 }
  93
  94 sub inline_initialize_slot {
  95     my ($self, $instance_var_name, $slot_name) = @_;
  96     $self->inline_set_slot_value($instance_var_name, $slot_name, 'undef');
  97 }
  98
  99 sub inline_is_slot_initialized {
 100     my ($self, $instance_var_name, $slot_name) = @_;
 101     return ('exists ' . $self->inline_get_slot_value($instance_var_name, $slot_name) . ' ? 1 : 0');
 102 }
 103
 104 1;
 105
 106 __END__
 107
 108 =pod
 109
 110 =head1 NAME
 111
 112 Class::MOP::Instance - Instance Meta Object
 113
 114 =head1 SYNOPSIS
 115
 116 =head1 DESCRIPTION
 117
 118 =head1 METHODS
 119
 120 =over 4
 121
 122 =item B<new>
 123
 124 =item B<create_instance>
 125
 126 =item B<bless_instance_structure>
 127
 128 =item B<get_all_slots>
 129
 130 =item B<initialize_all_slots>
 131
 132 =item B<get_slot_value>
 133
 134 =item B<set_slot_value>
 135
 136 =item B<initialize_slot>
 137
 138 =item B<is_slot_initialized>
 139
 140 =item B<inline_get_slot_value>
 141
 142 =item B<inline_set_slot_value>
 143
 144 =item B<inline_initialize_slot>
 145
 146 =item B<inline_is_slot_initialized>
 147
 148 =back
 149
 150 =head2 Introspection
 151
 152 =over 4
 153
 154 =item B<meta>
 155
 156 This will return a B<Class::MOP::Class> instance which is related
 157 to this class.
 158
 159 =back
 160
 161 =head1 AUTHOR
 162
 163 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 164
 165 =head1 COPYRIGHT AND LICENSE
 166
 167 Copyright 2006 by Infinity Interactive, Inc.
 168
 169 L<http://www.iinteractive.com>
 170
 171 This library is free software; you can redistribute it and/or modify
 172 it under the same terms as Perl itself.
 173
 174 =cut