Commit | Line | Data |
3fea05b9 |
1 | use strict; |
2 | use warnings; |
3 | |
4 | package Class::C3::Adopt::NEXT; |
5 | |
6 | use NEXT; |
7 | use MRO::Compat; |
8 | use List::MoreUtils qw/none/; |
9 | use warnings::register; |
10 | |
11 | our $VERSION = '0.12'; |
12 | |
13 | { |
14 | my %c3_mro_ok; |
15 | my %warned_for; |
16 | my @no_warn_regexes; |
17 | |
18 | { |
19 | my $orig = NEXT->can('AUTOLOAD'); |
20 | |
21 | no warnings 'redefine'; |
22 | *NEXT::AUTOLOAD = sub { |
23 | my $class = ref $_[0] || $_[0]; |
24 | my $caller = caller(); |
25 | |
26 | # 'NEXT::AUTOLOAD' is cargo-culted from C::P::C3, I have no idea if/why it's needed |
27 | my $wanted = our $AUTOLOAD || 'NEXT::AUTOLOAD'; |
28 | my ($wanted_class) = $wanted =~ m{(.*)::}; |
29 | |
30 | unless (exists $c3_mro_ok{$class}) { |
31 | eval { mro::get_linear_isa($class, 'c3') }; |
32 | if (my $error = $@) { |
33 | warn "Class::C3::calculateMRO('${class}') Error: '${error}';" |
34 | . ' Falling back to plain NEXT.pm behaviour for this class'; |
35 | $c3_mro_ok{$class} = 0; |
36 | } |
37 | else { |
38 | $c3_mro_ok{$class} = 1; |
39 | } |
40 | } |
41 | |
42 | if (length $c3_mro_ok{$class} && $c3_mro_ok{$class}) { |
43 | unless ($warned_for{$caller}) { |
44 | $warned_for{$caller} = 1; |
45 | if (!@no_warn_regexes || none { $caller =~ $_ } @no_warn_regexes) { |
46 | warnings::warnif("${caller} uses NEXT, which is deprecated. Please see " |
47 | . "the Class::C3::Adopt::NEXT documentation for details. NEXT used "); |
48 | } |
49 | } |
50 | } |
51 | |
52 | unless ($c3_mro_ok{$class}) { |
53 | $NEXT::AUTOLOAD = $wanted; |
54 | goto &$orig; |
55 | } |
56 | |
57 | goto &next::method if $wanted_class =~ /^NEXT:.*:ACTUAL/; |
58 | goto &maybe::next::method; |
59 | }; |
60 | |
61 | *NEXT::ACTUAL::AUTOLOAD = \&NEXT::AUTOLOAD; |
62 | } |
63 | |
64 | sub import { |
65 | my ($class, @args) = @_; |
66 | my $target = caller(); |
67 | |
68 | for my $arg (@args) { |
69 | $warned_for{$target} = 1 |
70 | if $arg eq '-no_warn'; |
71 | } |
72 | } |
73 | |
74 | sub unimport { |
75 | my $class = shift; |
76 | my @strings = grep { !ref $_ || ref($_) ne 'Regexp' } @_; |
77 | my @regexes = grep { ref($_) && ref($_) eq 'Regexp' } @_; |
78 | @c3_mro_ok{@strings} = ('') x @strings; |
79 | push @no_warn_regexes, @regexes; |
80 | } |
81 | } |
82 | |
83 | 1; |
84 | |
85 | __END__ |
86 | |
87 | =head1 NAME |
88 | |
89 | Class::C3::Adopt::NEXT - make NEXT suck less |
90 | |
91 | =head1 SYNOPSIS |
92 | |
93 | package MyApp::Plugin::FooBar; |
94 | #use NEXT; |
95 | use Class::C3::Adopt::NEXT; |
96 | # or 'use Class::C3::Adopt::NEXT -no_warn;' to suppress warnings |
97 | |
98 | # Or use warnings::register |
99 | # no warnings 'Class::C3::Adopt::NEXT'; |
100 | |
101 | # Or suppress warnings in a set of modules from one place |
102 | # no Class::C3::Adopt::NEXT qw/ Module1 Module2 Module3 /; |
103 | # Or suppress using a regex |
104 | # no Class::C3::Adopt::NEXT qr/^Module\d$/; |
105 | |
106 | sub a_method { |
107 | my ($self) = @_; |
108 | # Do some stuff |
109 | |
110 | # Re-dispatch method |
111 | # Note that this will generate a warning the _first_ time the package |
112 | # uses NEXT unless you un comment the 'no warnings' line above. |
113 | $self->NEXT::method(); |
114 | } |
115 | |
116 | =head1 DESCRIPTION |
117 | |
118 | L<NEXT> was a good solution a few years ago, but isn't any more. It's slow, |
119 | and the order in which it re-dispatches methods appears random at times. It |
120 | also encourages bad programming practices, as you end up with code to |
121 | re-dispatch methods when all you really wanted to do was run some code before |
122 | or after a method fired. |
123 | |
124 | However, if you have a large application, then weaning yourself off C<NEXT> |
125 | isn't easy. |
126 | |
127 | This module is intended as a drop-in replacement for NEXT, supporting the same |
128 | interface, but using L<Class::C3> to do the hard work. You can then write new |
129 | code without C<NEXT>, and migrate individual source files to use C<Class::C3> |
130 | or method modifiers as appropriate, at whatever pace you're comfortable with. |
131 | |
132 | =head1 WARNINGS |
133 | |
134 | This module will warn once for each package using NEXT. It uses |
135 | L<warnings::register>, and so can be disabled like by adding C<no warnings |
136 | 'Class::C3::Adopt::NEXT';> to each package which generates a warning, or adding |
137 | C<use Class::C3::Adopt::NEXT -no_warn;>, or disable multiple modules at once by |
138 | saying: |
139 | |
140 | no Class::C3::Adopt::NEXT qw/ Module1 Module2 Module3 /; |
141 | |
142 | somewhere before the warnings are first triggered. You can also setup entire |
143 | name spaces of modules which will not warn using a regex, e.g. |
144 | |
145 | no Class::C3::Adopt::NEXT qr/^Module\d$/; |
146 | |
147 | =head1 MIGRATING |
148 | |
149 | =head2 Current code using NEXT |
150 | |
151 | You add C<use MRO::Compat> to the top of a package as you start converting it, |
152 | and gradually replace your calls to C<NEXT::method()> with |
153 | C<maybe::next::method()>, and calls to C<NEXT::ACTUAL::method()> with |
154 | C<next::method()>. |
155 | |
156 | Example: |
157 | |
158 | sub yourmethod { |
159 | my $self = shift; |
160 | |
161 | # $self->NEXT::yourmethod(@_); becomes |
162 | $self->maybe::next::method(); |
163 | } |
164 | |
165 | sub othermethod { |
166 | my $self = shift; |
167 | |
168 | # $self->NEXT::ACTUAL::yourmethodname(); becomes |
169 | $self->next::method(); |
170 | } |
171 | |
172 | On systems with L<Class::C3::XS> present, this will automatically be used to |
173 | speed up method re-dispatch. If you are running perl version 5.9.5 or greater |
174 | then the C3 method resolution algorithm is included in perl. Correct use of |
175 | L<MRO::Compat> as shown above allows your code to be seamlessly forward and |
176 | backwards compatible, taking advantage of native versions if available, but |
177 | falling back to using pure perl C<Class::C3>. |
178 | |
179 | =head2 Writing new code |
180 | |
181 | Use L<Moose> and make all of your plugins L<Moose::Roles|Moose::Role>, then use |
182 | method modifiers to wrap methods. |
183 | |
184 | Example: |
185 | |
186 | package MyApp::Role::FooBar; |
187 | use Moose::Role; |
188 | |
189 | before 'a_method' => sub { |
190 | my ($self) = @_; |
191 | # Do some stuff |
192 | }; |
193 | |
194 | around 'a_method' => sub { |
195 | my $orig = shift; |
196 | my $self = shift; |
197 | # Do some stuff before |
198 | my $ret = $self->$orig(@_); # Run wrapped method (or not!) |
199 | # Do some stuff after |
200 | return $ret; |
201 | }; |
202 | |
203 | package MyApp; |
204 | use Moose; |
205 | |
206 | with 'MyApp::Role::FooBar'; |
207 | |
208 | =head1 CAVEATS |
209 | |
210 | There are some inheritance hierarchies that it is possible to create which |
211 | cannot be resolved to a simple C3 hierarchy. In that case, this module will |
212 | fall back to using C<NEXT>. In this case a warning will be emitted. |
213 | |
214 | Because calculating the MRO of every class every time C<< ->NEXT::foo >> is |
215 | used from within it is too expensive, runtime manipulations of C<@ISA> are |
216 | prohibited. |
217 | |
218 | =head1 FUNCTIONS |
219 | |
220 | This module replaces C<NEXT::AUTOLOAD> with it's own version. If warnings are |
221 | enabled then a warning will be emitted on the first use of C<NEXT> by each |
222 | package. |
223 | |
224 | =head1 SEE ALSO |
225 | |
226 | L<MRO::Compat> and L<Class::C3> for method re-dispatch and L<Moose> for method |
227 | modifiers and L<roles|Moose::Role>. |
228 | |
229 | L<NEXT> for documentation on the functionality you'll be removing. |
230 | |
231 | =head1 AUTHORS |
232 | |
233 | Florian Ragwitz C<rafl@debian.org> |
234 | |
235 | Tomas Doran C<bobtfish@bobtfish.net> |
236 | |
237 | =head1 COPYRIGHT AND LICENSE |
238 | |
239 | Copyright (c) 2008, 2009 Florian Ragwitz |
240 | |
241 | You may distribute this code under the same terms as Perl itself. |
242 | |
243 | =cut |