Commit | Line | Data |
9ec169fe |
1 | |
2 | package # hide the package from PAUSE |
3 | InsideOutClass; |
4 | |
5 | use strict; |
6 | use warnings; |
7 | |
a977cf65 |
8 | our $VERSION = '0.04'; |
9ec169fe |
9 | |
10 | use Scalar::Util 'refaddr'; |
11 | |
12 | use base 'Class::MOP::Class'; |
13 | |
14 | sub construct_instance { |
15 | my ($class, %params) = @_; |
16 | # create a scalar ref to use as |
17 | # the inside-out instance |
18 | my $instance = \(my $var); |
c9e77dbb |
19 | foreach my $attr ($class->compute_all_applicable_attributes()) { |
9ec169fe |
20 | # if the attr has an init_arg, use that, otherwise, |
21 | # use the attributes name itself as the init_arg |
651955fb |
22 | my $init_arg = $attr->init_arg(); |
9ec169fe |
23 | # try to fetch the init arg from the %params ... |
24 | my $val; |
25 | $val = $params{$init_arg} if exists $params{$init_arg}; |
26 | # if nothing was in the %params, we can use the |
27 | # attribute's default value (if it has one) |
a977cf65 |
28 | if (!defined $val && $attr->has_default) { |
29 | $val = $attr->default($instance); |
30 | } |
9ec169fe |
31 | # now add this to the instance structure |
32 | $class->get_package_variable('%' . $attr->name)->{ refaddr($instance) } = $val; |
33 | } |
34 | return $instance; |
35 | } |
36 | |
37 | package # hide the package from PAUSE |
38 | InsideOutClass::Attribute; |
39 | |
40 | use strict; |
41 | use warnings; |
42 | |
99e5b7e8 |
43 | our $VERSION = '0.04'; |
9ec169fe |
44 | |
b9dfbf78 |
45 | use Carp 'confess'; |
9ec169fe |
46 | use Scalar::Util 'refaddr'; |
47 | |
48 | use base 'Class::MOP::Attribute'; |
49 | |
50 | sub generate_accessor_method { |
51 | my ($self, $attr_name) = @_; |
52 | $attr_name = ($self->associated_class->name . '::' . $attr_name); |
53 | eval 'sub { |
54 | $' . $attr_name . '{ refaddr($_[0]) } = $_[1] if scalar(@_) == 2; |
55 | $' . $attr_name . '{ refaddr($_[0]) }; |
56 | }'; |
57 | } |
58 | |
59 | sub generate_reader_method { |
60 | my ($self, $attr_name) = @_; |
61 | eval 'sub { |
b9dfbf78 |
62 | confess "Cannot assign a value to a read-only accessor" if @_ > 1; |
9ec169fe |
63 | $' . ($self->associated_class->name . '::' . $attr_name) . '{ refaddr($_[0]) }; |
64 | }'; |
65 | } |
66 | |
67 | sub generate_writer_method { |
68 | my ($self, $attr_name) = @_; |
69 | eval 'sub { |
70 | $' . ($self->associated_class->name . '::' . $attr_name) . '{ refaddr($_[0]) } = $_[1]; |
71 | }'; |
72 | } |
73 | |
74 | sub generate_predicate_method { |
75 | my ($self, $attr_name) = @_; |
76 | eval 'sub { |
77 | defined($' . ($self->associated_class->name . '::' . $attr_name) . '{ refaddr($_[0]) }) ? 1 : 0; |
78 | }'; |
79 | } |
80 | |
81 | ## &remove_attribute is left as an exercise for the reader :) |
82 | |
83 | 1; |
84 | |
85 | __END__ |
86 | |
87 | =pod |
88 | |
89 | =head1 NAME |
90 | |
91 | InsideOutClass - A set of example metaclasses which implement the Inside-Out technique |
92 | |
93 | =head1 SYNOPSIS |
94 | |
95 | package Foo; |
96 | |
677eb158 |
97 | use metaclass 'InsideOutClass' => ( |
98 | # tell our metaclass to use the |
99 | # InsideOut attribute metclass |
100 | # to construct all it's attributes |
101 | ':attribute_metaclass' => 'InsideOutClass::Attribute' |
102 | ); |
9ec169fe |
103 | |
2e41896e |
104 | __PACKAGE__->meta->add_attribute('foo' => ( |
105 | reader => 'get_foo', |
106 | writer => 'set_foo' |
107 | )); |
9ec169fe |
108 | |
109 | sub new { |
110 | my $class = shift; |
5659d76e |
111 | $class->meta->new_object(@_); |
112 | } |
9ec169fe |
113 | |
114 | # now you can just use the class as normal |
115 | |
116 | =head1 DESCRIPTION |
117 | |
118 | This is a set of example metaclasses which implement the Inside-Out |
119 | class technique. What follows is a brief explaination of the code |
120 | found in this module. |
121 | |
122 | First step is to subclass B<Class::MOP::Class> and override the |
123 | C<construct_instance> method. The default C<construct_instance> |
124 | will create a HASH reference using the parameters and attribute |
125 | default values. Since inside-out objects don't use HASH refs, and |
126 | use package variables instead, we need to write code to handle |
127 | this difference. |
128 | |
129 | The next step is to create the subclass of B<Class::MOP::Attribute> |
130 | and override the method generation code. This requires overloading |
131 | C<generate_accessor_method>, C<generate_reader_method>, |
132 | C<generate_writer_method> and C<generate_predicate_method>. All |
133 | other aspects are taken care of with the existing B<Class::MOP::Attribute> |
134 | infastructure. |
135 | |
136 | And that is pretty much all. Of course I am ignoring need for |
137 | inside-out objects to be C<DESTROY>-ed, and some other details as |
138 | well, but this is an example. A real implementation is left as an |
139 | exercise to the reader. |
140 | |
141 | =head1 AUTHOR |
142 | |
143 | Stevan Little E<lt>stevan@iinteractive.comE<gt> |
144 | |
145 | =head1 COPYRIGHT AND LICENSE |
146 | |
147 | Copyright 2006 by Infinity Interactive, Inc. |
148 | |
149 | L<http://www.iinteractive.com> |
150 | |
151 | This library is free software; you can redistribute it and/or modify |
152 | it under the same terms as Perl itself. |
153 | |
154 | =cut |