Commit | Line | Data |
08e2f1fe |
1 | |
2 | =pod |
3 | |
4 | =begin testing-SETUP |
5 | |
6 | { |
7 | package My::Meta::Instance; |
8 | use Moose; |
9 | |
10 | # This needs to be in a BEGIN block so to avoid a metaclass |
11 | # incompatibility error from Moose. In normal usage, |
12 | # My::Meta::Instance would be in a separate file from MyApp::User, |
13 | # and this would be a non-issue. |
14 | BEGIN { extends 'Moose::Meta::Instance' } |
15 | } |
16 | |
17 | =end testing-SETUP |
18 | |
19 | =head1 NAME |
20 | |
81ee0ebc |
21 | Moose::Cookbook::Meta::Recipe7 - Creating a glob reference meta-instance class |
08e2f1fe |
22 | |
23 | =head1 SYNOPSIS |
24 | |
25 | package My::Meta::Instance; |
26 | |
81ee0ebc |
27 | use Scalar::Util qw( weaken ); |
28 | use Symbol qw( gensym ); |
08e2f1fe |
29 | |
30 | use Moose; |
31 | extends 'Moose::Meta::Instance'; |
32 | |
33 | sub create_instance { |
34 | my $self = shift; |
81ee0ebc |
35 | my $sym = gensym(); |
36 | bless $sym, $self->_class_name; |
08e2f1fe |
37 | } |
38 | |
39 | sub clone_instance { |
40 | my ( $self, $instance ) = @_; |
81ee0ebc |
41 | |
42 | my $new_sym = gensym(); |
43 | %{*$new_sym} = %{*$instance}; |
44 | |
45 | bless $new_sym, $self->_class_name; |
08e2f1fe |
46 | } |
47 | |
48 | sub get_slot_value { |
49 | my ( $self, $instance, $slot_name ) = @_; |
81ee0ebc |
50 | return *$instance->{$slot_name}; |
08e2f1fe |
51 | } |
52 | |
53 | sub set_slot_value { |
54 | my ( $self, $instance, $slot_name, $value ) = @_; |
81ee0ebc |
55 | *$instance->{$slot_name} = $value; |
08e2f1fe |
56 | } |
57 | |
58 | sub deinitialize_slot { |
59 | my ( $self, $instance, $slot_name ) = @_; |
81ee0ebc |
60 | delete *$instance->{$slot_name};; |
08e2f1fe |
61 | } |
62 | |
63 | sub is_slot_initialized { |
64 | my ( $self, $instance, $slot_name, $value ) = @_; |
81ee0ebc |
65 | exists *$instance->{$slot_name};; |
08e2f1fe |
66 | } |
67 | |
68 | sub weaken_slot_value { |
69 | my ( $self, $instance, $slot_name ) = @_; |
81ee0ebc |
70 | weaken *$instance->{$slot_name};; |
08e2f1fe |
71 | } |
72 | |
73 | sub inline_create_instance { |
74 | my ( $self, $class_variable ) = @_; |
81ee0ebc |
75 | return 'do { my $sym = Symbol::gensym(); bless $sym, ' . $class_variable . ' }'; |
08e2f1fe |
76 | } |
77 | |
78 | sub inline_slot_access { |
79 | my ( $self, $instance, $slot_name ) = @_; |
81ee0ebc |
80 | return '*{' . $instance . '}->{' . $slot_name . '}'; |
08e2f1fe |
81 | } |
82 | |
83 | package MyApp::User; |
84 | |
85 | use metaclass 'Moose::Meta::Class' => |
86 | ( instance_metaclass => 'My::Meta::Instance' ); |
87 | |
88 | use Moose; |
89 | |
90 | has 'name' => ( |
91 | is => 'rw', |
92 | isa => 'Str', |
93 | ); |
94 | |
95 | has 'email' => ( |
96 | is => 'rw', |
97 | isa => 'Str', |
98 | ); |
99 | |
100 | =head1 DESCRIPTION |
101 | |
102 | This recipe shows how to build your own meta-instance. The meta |
103 | instance is the metaclass that creates object instances and helps |
104 | manages access to attribute slots. |
105 | |
81ee0ebc |
106 | In this example, we're creating a meta-instance that is based on a |
107 | glob reference rather than a hash reference. This example is largely |
108 | based on the Piotr Roszatycki's L<MooseX::GlobRef> module. |
08e2f1fe |
109 | |
110 | Our class is a subclass of L<Moose::Meta::Instance>, which creates |
111 | hash reference based objects. We need to override all the methods |
112 | which make assumptions about the object's data structure. |
113 | |
114 | The first method we override is C<create_instance>: |
115 | |
81ee0ebc |
116 | |
08e2f1fe |
117 | sub create_instance { |
118 | my $self = shift; |
81ee0ebc |
119 | my $sym = gensym(); |
120 | bless $sym, $self->_class_name; |
08e2f1fe |
121 | } |
122 | |
81ee0ebc |
123 | This returns an glob reference which has been blessed into our |
08e2f1fe |
124 | meta-instance's associated class. |
125 | |
126 | We also override C<clone_instance> to create a new array reference: |
127 | |
128 | sub clone_instance { |
129 | my ( $self, $instance ) = @_; |
81ee0ebc |
130 | |
131 | my $new_sym = gensym(); |
132 | %{*$new_sym} = %{*$instance}; |
133 | |
134 | bless $new_sym, $self->_class_name; |
08e2f1fe |
135 | } |
136 | |
137 | After that, we have a series of methods which mediate access to the |
138 | object's slots (attributes are stored in "slots"). In the default |
81ee0ebc |
139 | instance class, these expect the object to be a hash reference, but we |
140 | need to change this to expect a glob reference instead. |
08e2f1fe |
141 | |
142 | sub get_slot_value { |
143 | my ( $self, $instance, $slot_name ) = @_; |
81ee0ebc |
144 | *$instance->{$slot_name};; |
08e2f1fe |
145 | } |
146 | |
147 | This level of indirection probably makes our instance class I<slower> |
148 | than the default. However, when attribute access is inlined, this |
149 | lookup will be cached: |
150 | |
81ee0ebc |
151 | sub inline_create_instance { |
152 | my ( $self, $class_variable ) = @_; |
153 | return 'do { my $sym = Symbol::gensym(); bless $sym, ' . $class_variable . ' }'; |
08e2f1fe |
154 | } |
155 | |
156 | The code snippet that the C<inline_slot_access> method returns will |
157 | get C<eval>'d once per attribute. |
158 | |
159 | Finally, we use this meta-instance in our C<MyApp::User> class: |
160 | |
161 | use metaclass 'Moose::Meta::Class' => |
162 | ( instance_metaclass => 'My::Meta::Instance' ); |
163 | |
164 | We actually don't recommend the use of L<metaclass> in most |
165 | cases. However, the other ways of using alternate metaclasses are more |
166 | complex, and would complicate our example code unnecessarily. |
167 | |
168 | =head1 CONCLUSION |
169 | |
170 | This recipe shows how to create your own meta-instance class. It's |
171 | unlikely that you'll need to do this yourself, but it's interesting to |
172 | take a peek at how Moose works under the hood. |
173 | |
174 | =head1 SEE ALSO |
175 | |
176 | There are a few meta-instance class extensions on CPAN: |
177 | |
178 | =over 4 |
179 | |
180 | =item * L<MooseX::Singleton> |
181 | |
182 | This module extends the instance class in order to ensure that the |
183 | object is a singleton. The instance it uses is still a blessed hash |
184 | reference. |
185 | |
186 | =item * L<MooseX::GlobRef> |
187 | |
188 | This module makes the instance a blessed glob reference. This lets you |
189 | use a handle as an object instance. |
190 | |
191 | =back |
192 | |
193 | =head1 AUTHOR |
194 | |
195 | Dave Rolsky E<lt>autarch@urth.orgE<gt> |
196 | |
197 | =head1 COPYRIGHT AND LICENSE |
198 | |
199 | Copyright 2006-2009 by Infinity Interactive, Inc. |
200 | |
201 | L<http://www.iinteractive.com> |
202 | |
203 | This library is free software; you can redistribute it and/or modify |
204 | it under the same terms as Perl itself. |
205 | |
206 | =begin testing |
207 | |
08e2f1fe |
208 | { |
81ee0ebc |
209 | package MyApp::Employee; |
210 | |
211 | use Moose; |
212 | extends 'MyApp::User'; |
213 | |
214 | has 'employee_number' => ( is => 'rw' ); |
215 | } |
216 | |
217 | for my $x ( 0 .. 1 ) { |
08e2f1fe |
218 | MyApp::User->meta->make_immutable if $x; |
219 | |
81ee0ebc |
220 | my $user = MyApp::User->new( |
221 | name => 'Faye', |
222 | email => 'faye@example.com', |
223 | ); |
08e2f1fe |
224 | |
81ee0ebc |
225 | ok( eval { *{$user} }, 'user object is an glob ref with some values' ); |
08e2f1fe |
226 | |
81ee0ebc |
227 | is( $user->name, 'Faye', 'check name' ); |
08e2f1fe |
228 | is( $user->email, 'faye@example.com', 'check email' ); |
229 | |
230 | $user->name('Ralph'); |
231 | is( $user->name, 'Ralph', 'check name after changing it' ); |
232 | |
233 | $user->email('ralph@example.com'); |
234 | is( $user->email, 'ralph@example.com', 'check email after changing it' ); |
235 | } |
236 | |
81ee0ebc |
237 | for my $x ( 0 .. 1 ) { |
238 | MyApp::Employee->meta->make_immutable if $x; |
08e2f1fe |
239 | |
81ee0ebc |
240 | my $emp = MyApp::Employee->new( |
241 | name => 'Faye', |
242 | email => 'faye@example.com', |
243 | employee_number => $x, |
244 | ); |
245 | |
246 | ok( eval { *{$emp} }, 'employee object is an glob ref with some values' ); |
247 | |
248 | is( $emp->name, 'Faye', 'check name' ); |
249 | is( $emp->email, 'faye@example.com', 'check email' ); |
250 | is( $emp->employee_number, $x, 'check employee_number' ); |
251 | |
252 | $emp->name('Ralph'); |
253 | is( $emp->name, 'Ralph', 'check name after changing it' ); |
254 | |
255 | $emp->email('ralph@example.com'); |
256 | is( $emp->email, 'ralph@example.com', 'check email after changing it' ); |
257 | |
258 | $emp->employee_number(42); |
259 | is( $emp->employee_number, 42, 'check employee_number after changing it' ); |
260 | } |
08e2f1fe |
261 | |
262 | =end testing |
263 | |
264 | =pod |