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