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