Commit | Line | Data |
24869f62 |
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 { |
2d711cc8 |
18 | my ( $class, $meta ) = @_; |
24869f62 |
19 | bless { |
2d711cc8 |
20 | meta => $meta, |
21 | instance_layout => {} |
24869f62 |
22 | } => $class; |
23 | } |
24 | |
2d711cc8 |
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 | |
24869f62 |
47 | sub add_slot { |
2d711cc8 |
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; |
24869f62 |
52 | } |
53 | |
839ea973 |
54 | sub has_slot { |
55 | my ($self, $slot_name) = @_; |
2d711cc8 |
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; |
839ea973 |
64 | } |
65 | |
2d711cc8 |
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 | |
839ea973 |
80 | sub get_slot_value { |
2bab2be6 |
81 | my ($self, $instance, $slot_name) = @_; |
82 | return $instance->{$slot_name}; |
839ea973 |
83 | } |
84 | |
2d711cc8 |
85 | # can be called only after initialize_slot_value |
2bab2be6 |
86 | sub set_slot_value { |
87 | my ($self, $instance, $slot_name, $value) = @_; |
2d711cc8 |
88 | $slot_name or confess "must provide slot name"; |
2bab2be6 |
89 | $instance->{$slot_name} = $value; |
90 | } |
91 | |
2d711cc8 |
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 { |
2bab2be6 |
104 | my ($self, $instance, $slot_name) = @_; |
2d711cc8 |
105 | exists $instance->{$slot_name} ? 1 : 0; |
2bab2be6 |
106 | } |
839ea973 |
107 | |
2d711cc8 |
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 | } |
24869f62 |
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 | |
839ea973 |
162 | =item B<has_slot> |
163 | |
164 | =item B<get_slot_value> |
165 | |
166 | =item B<set_slot_value> |
167 | |
2bab2be6 |
168 | =item B<has_slot_value> |
169 | |
24869f62 |
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 |