Commit | Line | Data |
9ec169fe |
1 | |
9ec169fe |
2 | package # hide the package from PAUSE |
43715282 |
3 | InsideOutClass::Attribute; |
4 | |
5 | use strict; |
6 | use warnings; |
7 | |
ba38bf08 |
8 | our $VERSION = '0.02'; |
43715282 |
9 | |
10 | use Carp 'confess'; |
11 | use Scalar::Util 'refaddr'; |
12 | |
13 | use base 'Class::MOP::Attribute'; |
14 | |
15 | sub initialize_instance_slot { |
16 | my ($self, $meta_instance, $instance, $params) = @_; |
c23184fc |
17 | my $init_arg = $self->init_arg; |
43715282 |
18 | # try to fetch the init arg from the %params ... |
19 | my $val; |
20 | $val = $params->{$init_arg} if exists $params->{$init_arg}; |
21 | # if nothing was in the %params, we can use the |
22 | # attribute's default value (if it has one) |
c23184fc |
23 | if (!defined $val && defined $self->default) { |
43715282 |
24 | $val = $self->default($instance); |
25 | } |
6d5355c3 |
26 | my $_meta_instance = $self->associated_class->get_meta_instance; |
27 | $_meta_instance->initialize_slot($instance, $self->name); |
28 | $_meta_instance->set_slot_value($instance, $self->name, $val); |
43715282 |
29 | } |
30 | |
ba38bf08 |
31 | sub accessor_metaclass { 'InsideOutClass::Method::Accessor' } |
32 | |
33 | package # hide the package from PAUSE |
34 | InsideOutClass::Method::Accessor; |
35 | |
36 | use strict; |
37 | use warnings; |
38 | |
39 | our $VERSION = '0.01'; |
40 | |
41 | use Carp 'confess'; |
42 | use Scalar::Util 'refaddr'; |
43 | |
44 | use base 'Class::MOP::Method::Accessor'; |
45 | |
640e0757 |
46 | sub is_inline{ 0 } |
47 | |
43715282 |
48 | ## Method generation helpers |
49 | |
afc92ac6 |
50 | sub _generate_accessor_method { |
ba38bf08 |
51 | my $attr = (shift)->associated_attribute; |
52 | my $meta_class = $attr->associated_class; |
53 | my $attr_name = $attr->name; |
43715282 |
54 | return sub { |
55 | my $meta_instance = $meta_class->get_meta_instance; |
56 | $meta_instance->set_slot_value($_[0], $attr_name, $_[1]) if scalar(@_) == 2; |
57 | $meta_instance->get_slot_value($_[0], $attr_name); |
58 | }; |
59 | } |
60 | |
afc92ac6 |
61 | sub _generate_reader_method { |
ba38bf08 |
62 | my $attr = (shift)->associated_attribute; |
63 | my $meta_class = $attr->associated_class; |
64 | my $attr_name = $attr->name; |
43715282 |
65 | return sub { |
66 | confess "Cannot assign a value to a read-only accessor" if @_ > 1; |
67 | $meta_class->get_meta_instance |
68 | ->get_slot_value($_[0], $attr_name); |
69 | }; |
70 | } |
71 | |
afc92ac6 |
72 | sub _generate_writer_method { |
ba38bf08 |
73 | my $attr = (shift)->associated_attribute; |
74 | my $meta_class = $attr->associated_class; |
75 | my $attr_name = $attr->name; |
43715282 |
76 | return sub { |
77 | $meta_class->get_meta_instance |
78 | ->set_slot_value($_[0], $attr_name, $_[1]); |
79 | }; |
80 | } |
81 | |
afc92ac6 |
82 | sub _generate_predicate_method { |
ba38bf08 |
83 | my $attr = (shift)->associated_attribute; |
84 | my $meta_class = $attr->associated_class; |
85 | my $attr_name = $attr->name; |
43715282 |
86 | return sub { |
87 | defined $meta_class->get_meta_instance |
88 | ->get_slot_value($_[0], $attr_name) ? 1 : 0; |
89 | }; |
90 | } |
91 | |
92 | package # hide the package from PAUSE |
2d711cc8 |
93 | InsideOutClass::Instance; |
9ec169fe |
94 | |
95 | use strict; |
96 | use warnings; |
97 | |
b880e0de |
98 | our $VERSION = '0.01'; |
9ec169fe |
99 | |
b9dfbf78 |
100 | use Carp 'confess'; |
9ec169fe |
101 | use Scalar::Util 'refaddr'; |
102 | |
2d711cc8 |
103 | use base 'Class::MOP::Instance'; |
104 | |
105 | sub create_instance { |
49c93440 |
106 | my ($self, $class) = @_; |
cf11901e |
107 | bless \(my $instance), $self->_class_name; |
9ec169fe |
108 | } |
109 | |
2d711cc8 |
110 | sub get_slot_value { |
49c93440 |
111 | my ($self, $instance, $slot_name) = @_; |
c23184fc |
112 | $self->associated_metaclass->get_package_symbol('%' . $slot_name)->{refaddr $instance}; |
9ec169fe |
113 | } |
114 | |
2d711cc8 |
115 | sub set_slot_value { |
49c93440 |
116 | my ($self, $instance, $slot_name, $value) = @_; |
c23184fc |
117 | $self->associated_metaclass->get_package_symbol('%' . $slot_name)->{refaddr $instance} = $value; |
9ec169fe |
118 | } |
119 | |
49c93440 |
120 | sub initialize_slot { |
121 | my ($self, $instance, $slot_name) = @_; |
c23184fc |
122 | $self->associated_metaclass->add_package_symbol(('%' . $slot_name) => {}) |
123 | unless $self->associated_metaclass->has_package_symbol('%' . $slot_name); |
124 | $self->associated_metaclass->get_package_symbol('%' . $slot_name)->{refaddr $instance} = undef; |
49c93440 |
125 | } |
2d711cc8 |
126 | |
49c93440 |
127 | sub is_slot_initialized { |
128 | my ($self, $instance, $slot_name) = @_; |
c23184fc |
129 | return 0 unless $self->associated_metaclass->has_package_symbol('%' . $slot_name); |
130 | return exists $self->associated_metaclass->get_package_symbol('%' . $slot_name)->{refaddr $instance} ? 1 : 0; |
9ec169fe |
131 | } |
132 | |
9ec169fe |
133 | 1; |
134 | |
135 | __END__ |
136 | |
137 | =pod |
138 | |
139 | =head1 NAME |
140 | |
141 | InsideOutClass - A set of example metaclasses which implement the Inside-Out technique |
142 | |
143 | =head1 SYNOPSIS |
144 | |
145 | package Foo; |
146 | |
1becdfcc |
147 | use metaclass ( |
43715282 |
148 | ':attribute_metaclass' => 'InsideOutClass::Attribute', |
149 | ':instance_metaclass' => 'InsideOutClass::Instance' |
677eb158 |
150 | ); |
9ec169fe |
151 | |
2e41896e |
152 | __PACKAGE__->meta->add_attribute('foo' => ( |
153 | reader => 'get_foo', |
154 | writer => 'set_foo' |
155 | )); |
9ec169fe |
156 | |
157 | sub new { |
158 | my $class = shift; |
5659d76e |
159 | $class->meta->new_object(@_); |
160 | } |
9ec169fe |
161 | |
162 | # now you can just use the class as normal |
163 | |
164 | =head1 DESCRIPTION |
165 | |
166 | This is a set of example metaclasses which implement the Inside-Out |
167 | class technique. What follows is a brief explaination of the code |
168 | found in this module. |
169 | |
2d711cc8 |
170 | We must create a subclass of B<Class::MOP::Instance> and override |
171 | the slot operations. This requires |
172 | overloading C<get_slot_value>, C<set_slot_value>, C<slot_initialized>, and |
173 | C<initialize_slot>, as well as their inline counterparts. Additionally we |
174 | overload C<add_slot> in order to initialize the global hash containing the |
175 | actual slot values. |
9ec169fe |
176 | |
177 | And that is pretty much all. Of course I am ignoring need for |
178 | inside-out objects to be C<DESTROY>-ed, and some other details as |
2d711cc8 |
179 | well (threading, etc), but this is an example. A real implementation is left as |
180 | an exercise to the reader. |
9ec169fe |
181 | |
1a09d9cc |
182 | =head1 AUTHORS |
9ec169fe |
183 | |
184 | Stevan Little E<lt>stevan@iinteractive.comE<gt> |
185 | |
005adf8f |
186 | Yuval Kogman E<lt>nothingmuch@woobling.comE<gt> |
2d711cc8 |
187 | |
9ec169fe |
188 | =head1 COPYRIGHT AND LICENSE |
189 | |
69e3ab0a |
190 | Copyright 2006-2008 by Infinity Interactive, Inc. |
9ec169fe |
191 | |
192 | L<http://www.iinteractive.com> |
193 | |
194 | This library is free software; you can redistribute it and/or modify |
195 | it under the same terms as Perl itself. |
196 | |
197 | =cut |