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 get_slot_value {
  56     my ($self, $instance, $slot_name) = @_;
  57     return $instance->{$slot_name};
  58 }
  59
  60 sub set_slot_value {
  61     my ($self, $instance, $slot_name, $value) = @_;
  62     $instance->{$slot_name} = $value;
  63 }
  64
  65 sub initialize_slot {
  66     my ($self, $instance, $slot_name) = @_;
  67     $instance->{$slot_name} = undef;
  68 }
  69
  70 sub is_slot_initialized {
  71     my ($self, $instance, $slot_name, $value) = @_;
  72     exists $instance->{$slot_name} ? 1 : 0;
  73 }
  74
  75 # inlinable operation snippets
  76
  77 sub inline_get_slot_value {
  78     my ($self, $instance_var_name, $slot_name) = @_;
  79     return ($instance_var_name . '->{\'' . $slot_name . '\'}');
  80 }
  81
  82 sub inline_set_slot_value {
  83     my ($self, $instance_var_name, $slot_name, $value_name) = @_;
  84     return ($self->inline_get_slot_value($instance_var_name, $slot_name) . ' = ' . $value_name);
  85 }
  86
  87 sub inline_initialize_slot {
  88     my ($self, $instance_var_name, $slot_name) = @_;
  89     $self->inline_set_slot_value($instance_var_name, $slot_name, 'undef');
  90 }
  91
  92 sub inline_is_slot_initialized {
  93     my ($self, $instance_var_name, $slot_name) = @_;
  94     return ('exists ' . $self->inline_get_slot_value($instance_var_name, $slot_name) . ' ? 1 : 0');
  95 }
  96
  97 1;
  98
  99 __END__
 100
 101 =pod
 102
 103 =head1 NAME
 104
 105 Class::MOP::Instance - Instance Meta Object
 106
 107 =head1 SYNOPSIS
 108
 109 =head1 DESCRIPTION
 110
 111 =head1 METHODS
 112
 113 =over 4
 114
 115 =item B<new>
 116
 117 =item B<bless_instance_structure>
 118
 119 =item B<compute_layout_from_class>
 120
 121 =item B<create_instance>
 122
 123 =item B<get_all_slots>
 124
 125 =item B<get_slot_value>
 126
 127 =item B<set_slot_value>
 128
 129 =item B<initialize_slot>
 130
 131 =item B<is_slot_initialized>
 132
 133 =item B<inline_get_slot_value>
 134
 135 =item B<inline_set_slot_value>
 136
 137 =item B<inline_initialize_slot>
 138
 139 =item B<inline_is_slot_initialized>
 140
 141 =back
 142
 143 =head2 Introspection
 144
 145 =over 4
 146
 147 =item B<meta>
 148
 149 This will return a B<Class::MOP::Class> instance which is related
 150 to this class.
 151
 152 =back
 153
 154 =head1 AUTHOR
 155
 156 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 157
 158 =head1 COPYRIGHT AND LICENSE
 159
 160 Copyright 2006 by Infinity Interactive, Inc.
 161
 162 L<http://www.iinteractive.com>
 163
 164 This library is free software; you can redistribute it and/or modify
 165 it under the same terms as Perl itself.
 166
 167 =cut