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