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