Commit | Line | Data |
4dee0fd3 |
1 | package MooseX::ClassAttribute; |
2 | |
4dee0fd3 |
3 | use strict; |
54a288bd |
4 | use warnings; |
4dee0fd3 |
5 | |
fab23ffc |
6 | our $VERSION = '0.04'; |
0f24a39d |
7 | our $AUTHORITY = 'cpan:DROLSKY'; |
8 | |
54a288bd |
9 | our @EXPORT = 'class_has'; ## no critic ProhibitAutomaticExportation |
d48c186f |
10 | use base 'Exporter'; |
0f24a39d |
11 | |
54a288bd |
12 | use B qw( svref_2object ); |
d8ac31ad |
13 | use Moose::Meta::Class; |
54a288bd |
14 | use Sub::Name; |
a124b299 |
15 | |
0f24a39d |
16 | |
54a288bd |
17 | sub class_has ## no critic RequireArgUnpacking |
0f24a39d |
18 | { |
54a288bd |
19 | my $caller = caller(); |
20 | |
8d655404 |
21 | process_class_attribute( $caller, @_ ); |
22 | |
23 | return; |
24 | } |
25 | |
26 | sub process_class_attribute ## no critic RequireArgUnpacking |
27 | { |
28 | my $caller = shift; |
29 | |
54a288bd |
30 | my $caller_meta = $caller->meta(); |
31 | |
32 | my @parents = $caller_meta->superclasses(); |
33 | |
34 | my $container_pkg = _make_container_class( $caller, @parents ); |
9cabc97e |
35 | my $container_meta = $container_pkg->meta(); |
a124b299 |
36 | |
b8f68e61 |
37 | $container_meta->add_attribute(@_); |
a124b299 |
38 | |
54a288bd |
39 | for my $meth ( grep { $_ ne 'instance' } $container_meta->get_method_list() ) |
40 | { |
41 | next if $caller_meta->has_method($meth); |
a124b299 |
42 | |
54a288bd |
43 | my $sub = sub { shift; |
44 | my $instance = $container_pkg->instance(); |
45 | return $instance->$meth(@_); }; |
46 | |
47 | $caller_meta->add_method( $meth => $sub ); |
48 | } |
a124b299 |
49 | |
0f24a39d |
50 | return; |
51 | } |
52 | |
54a288bd |
53 | { |
54 | # This should probably be an attribute of the metaclass, but that |
55 | # would require extending Moose::Meta::Class, which would conflict |
56 | # with anything else that wanted to do so as well (we need |
57 | # metaclass roles or something). |
58 | my %Name; |
59 | |
60 | sub _make_container_class ## no critic RequireArgUnpacking |
61 | { |
62 | my $caller = shift; |
63 | |
64 | return $Name{$caller} if $Name{$caller}; |
65 | |
66 | my @parents = map { container_class($_) || () } @_; |
67 | |
b4d972cd |
68 | push @parents, 'Moose::Object' |
69 | unless grep { $_->isa('Moose::Object') } @parents; |
54a288bd |
70 | |
b4d972cd |
71 | my $container_pkg = 'MooseX::ClassAttribute::Container::' . $caller; |
0f24a39d |
72 | |
b4d972cd |
73 | my $instance_meth = sub { |
74 | no strict 'refs'; ## no critic ProhibitNoStrict |
75 | return ${ $container_pkg . '::Self' } ||= shift->new(@_); |
76 | }; |
77 | |
78 | my $class = |
79 | Moose::Meta::Class->create |
80 | ( $container_pkg => |
81 | superclasses => \@parents, |
82 | methods => { instance => $instance_meth }, |
83 | ); |
0f24a39d |
84 | |
54a288bd |
85 | return $Name{$caller} = $container_pkg; |
86 | } |
87 | |
88 | sub container_class |
89 | { |
90 | my $pkg = shift || caller(); |
91 | |
92 | return $Name{$pkg}; |
93 | } |
94 | } |
95 | |
96 | # This is basically copied from Moose.pm |
8d655404 |
97 | sub unimport ## no critic RequireFinalReturn, RequireArgUnpacking |
54a288bd |
98 | { |
4c911e18 |
99 | my $caller = Moose::_get_caller(@_); |
54a288bd |
100 | |
101 | no strict 'refs'; ## no critic ProhibitNoStrict |
102 | foreach my $name (@EXPORT) |
103 | { |
104 | if ( defined &{ $caller . '::' . $name } ) |
105 | { |
106 | my $keyword = \&{ $caller . '::' . $name }; |
107 | |
108 | my $pkg_name = |
109 | eval { svref_2object($keyword)->GV()->STASH()->NAME() }; |
110 | |
111 | next if $@; |
112 | next if $pkg_name ne __PACKAGE__; |
113 | |
114 | delete ${ $caller . '::' }{$name}; |
115 | } |
116 | } |
117 | } |
4dee0fd3 |
118 | |
119 | |
120 | 1; |
121 | |
122 | __END__ |
123 | |
124 | =pod |
125 | |
126 | =head1 NAME |
127 | |
54a288bd |
128 | MooseX::ClassAttribute - Declare class attributes Moose-style |
4dee0fd3 |
129 | |
4dee0fd3 |
130 | =head1 SYNOPSIS |
131 | |
54a288bd |
132 | package My::Class; |
4dee0fd3 |
133 | |
54a288bd |
134 | use Moose; |
4dee0fd3 |
135 | use MooseX::ClassAttribute; |
136 | |
54a288bd |
137 | class_has 'Cache' => |
138 | ( is => 'rw', |
139 | isa => 'HashRef', |
140 | default => sub { {} }, |
141 | ); |
142 | |
143 | __PACKAGE__->meta()->make_immutable(); |
ac5d97b7 |
144 | MooseX::ClassAttribute::container_class()->meta()->make_immutable(); |
54a288bd |
145 | |
146 | no Moose; |
147 | no MooseX::ClassAttribute; |
148 | |
149 | # then later ... |
150 | |
151 | My::Class->Cache()->{thing} = ...; |
152 | |
153 | |
154 | =head1 DESCRIPTION |
155 | |
156 | This module allows you to declare class attributes in exactly the same |
157 | way as you declare object attributes, except using C<class_has()> |
158 | instead of C<has()>. It is also possible to make these attributes |
159 | immutable (and faster) just as you can with normal Moose attributes. |
160 | |
161 | You can use any feature of Moose's attribute declarations, including |
162 | overriding a parent's attributes, delegation (C<handles>), and |
163 | attribute metaclasses, and it should just work. |
164 | |
7dc1418a |
165 | The accessors methods for class attribute may be called on the class |
166 | directly, or on objects of that class. Passing a class attribute to |
167 | the constructor will not set it. |
168 | |
54a288bd |
169 | =head1 FUNCTIONS |
170 | |
171 | This class exports one function when you use it, C<class_has()>. This |
172 | works exactly like Moose's C<has()>, but it declares class attributes. |
173 | |
170db2d9 |
174 | One little nit is that if you include C<no Moose> in your class, you |
54a288bd |
175 | won't remove the C<class_has()> function. To do that you must include |
176 | C<no MooseX::ClassAttribute> as well. |
177 | |
8d655404 |
178 | If you want to use this module to create class attributes in I<other> |
179 | classes, you can call the C<process_class_attribute()> function like |
180 | this: |
181 | |
182 | MooseX::ClassAttribute::process_class_attribute( $package, ... ); |
183 | |
184 | The first argument is the package which will have the class attribute, |
185 | and the remaining arguments are the same as those passed to |
186 | C<class_has()>. |
187 | |
54a288bd |
188 | =head2 Implementation and Immutability |
189 | |
190 | Underneath the hood, this class creates one new class for each class |
191 | which has class attributes and sets up delegating methods in the class |
192 | for which you're creating class attributes. You don't need to worry |
193 | about this too much, except when it comes to making a class immutable. |
4dee0fd3 |
194 | |
54a288bd |
195 | Since the class attributes are not really stored in your class, you |
ac5d97b7 |
196 | need to make the container class immutable as well as your own ... |
4dee0fd3 |
197 | |
54a288bd |
198 | __PACKAGE__->meta()->make_immutable(); |
ac5d97b7 |
199 | MooseX::ClassAttribute::container_class()->meta()->make_immutable(); |
4dee0fd3 |
200 | |
54a288bd |
201 | I<This may change in the future!> |
4dee0fd3 |
202 | |
203 | =head1 AUTHOR |
204 | |
205 | Dave Rolsky, C<< <autarch@urth.org> >> |
206 | |
207 | =head1 BUGS |
208 | |
54a288bd |
209 | Please report any bugs or feature requests to |
210 | C<bug-moosex-classattribute@rt.cpan.org>, or through the web interface |
211 | at L<http://rt.cpan.org>. I will be notified, and then you'll |
212 | automatically be notified of progress on your bug as I make changes. |
4dee0fd3 |
213 | |
214 | =head1 COPYRIGHT & LICENSE |
215 | |
216 | Copyright 2007 Dave Rolsky, All Rights Reserved. |
217 | |
218 | This program is free software; you can redistribute it and/or modify |
219 | it under the same terms as Perl itself. |
220 | |
221 | =cut |