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