Commit | Line | Data |
dc4fc8c7 |
1 | package Package::DeprecationManager; |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
6 | use Carp qw( croak ); |
e546f61d |
7 | use List::MoreUtils qw( any ); |
dc4fc8c7 |
8 | use Params::Util qw( _HASH ); |
9 | use Sub::Install; |
10 | |
11 | sub import { |
12 | shift; |
13 | my %args = @_; |
14 | |
15 | croak |
16 | 'You must provide a hash reference -deprecations parameter when importing Package::DeprecationManager' |
17 | unless $args{-deprecations} && _HASH( $args{-deprecations} ); |
18 | |
19 | my %registry; |
20 | |
21 | my $import = _build_import( \%registry ); |
d26afdef |
22 | my $warn = _build_warn( \%registry, $args{-deprecations}, $args{-ignore} ); |
dc4fc8c7 |
23 | |
24 | my $caller = caller(); |
25 | |
26 | Sub::Install::install_sub( |
27 | { |
28 | code => $import, |
29 | into => $caller, |
30 | as => 'import', |
31 | } |
32 | ); |
33 | |
34 | Sub::Install::install_sub( |
35 | { |
36 | code => $warn, |
37 | into => $caller, |
38 | as => 'deprecated', |
39 | } |
40 | ); |
41 | |
42 | return; |
43 | } |
44 | |
45 | sub _build_import { |
46 | my $registry = shift; |
47 | |
48 | return sub { |
49 | my $class = shift; |
50 | my %args = @_; |
51 | |
dee597ea |
52 | $args{-api_version} ||= delete $args{-compatible}; |
53 | |
dc4fc8c7 |
54 | $registry->{ caller() } = $args{-api_version} |
55 | if $args{-api_version}; |
56 | |
57 | return; |
58 | }; |
59 | } |
60 | |
61 | sub _build_warn { |
62 | my $registry = shift; |
63 | my $deprecated_at = shift; |
d26afdef |
64 | my $ignore = shift; |
65 | |
e546f61d |
66 | my %ignore = map { $_ => 1 } grep { !ref } @{ $ignore || [] }; |
67 | my @ignore_res = grep {ref} @{ $ignore || [] }; |
dc4fc8c7 |
68 | |
69 | my %warned; |
70 | |
71 | return sub { |
bce3492c |
72 | my %args = @_ < 2 ? ( message => shift ) : @_; |
73 | |
dc4fc8c7 |
74 | my ( $package, undef, undef, $sub ) = caller(1); |
75 | |
23bc88dc |
76 | my $skipped = 1; |
e546f61d |
77 | |
748d15e6 |
78 | if ( @ignore_res || keys %ignore ) { |
e546f61d |
79 | while ( defined $package |
80 | && ( $ignore{$package} || any { $package =~ $_ } @ignore_res ) |
81 | ) { |
82 | $package = caller( $skipped++ ); |
d26afdef |
83 | } |
84 | } |
85 | |
86 | $package = 'unknown package' unless defined $package; |
87 | |
bce3492c |
88 | unless ( defined $args{feature} ) { |
89 | $args{feature} = $sub; |
90 | } |
91 | |
dc4fc8c7 |
92 | my $compat_version = $registry->{$package}; |
93 | |
bce3492c |
94 | my $deprecated_at = $deprecated_at->{ $args{feature} }; |
dc4fc8c7 |
95 | |
96 | return |
97 | if defined $compat_version |
98 | && defined $deprecated_at |
99 | && $compat_version lt $deprecated_at; |
100 | |
d26afdef |
101 | my $msg; |
bce3492c |
102 | if ( defined $args{message} ) { |
d26afdef |
103 | $msg = $args{message}; |
bce3492c |
104 | } |
105 | else { |
d26afdef |
106 | $msg = "$args{feature} has been deprecated"; |
dc4fc8c7 |
107 | $msg .= " since version $deprecated_at" |
108 | if defined $deprecated_at; |
dc4fc8c7 |
109 | } |
110 | |
7bbad815 |
111 | return if $warned{$package}{ $args{feature} }{$msg}; |
112 | |
113 | $warned{$package}{ $args{feature} }{$msg} = 1; |
dc4fc8c7 |
114 | |
ba614f87 |
115 | # We skip at least two levels. One for this anon sub, and one for the |
116 | # sub calling it. |
23bc88dc |
117 | local $Carp::CarpLevel = $Carp::CarpLevel + $skipped; |
d26afdef |
118 | |
119 | Carp::cluck($msg); |
dc4fc8c7 |
120 | }; |
121 | } |
122 | |
123 | 1; |
124 | |
125 | # ABSTRACT: Manage deprecation warnings for your distribution |
126 | |
127 | __END__ |
128 | |
129 | =pod |
130 | |
131 | =head1 SYNOPSIS |
132 | |
dee597ea |
133 | package My::Class; |
134 | |
bce3492c |
135 | use Package::DeprecationManager -deprecations => { |
136 | 'My::Class::foo' => '0.02', |
137 | 'My::Class::bar' => '0.05', |
138 | 'feature-X' => '0.07', |
139 | }; |
dee597ea |
140 | |
141 | sub foo { |
142 | deprecated( 'Do not call foo!' ); |
143 | |
144 | ... |
145 | } |
146 | |
147 | sub bar { |
148 | deprecated(); |
149 | |
150 | ... |
151 | } |
152 | |
bce3492c |
153 | sub baz { |
154 | my %args = @_; |
155 | |
156 | if ( $args{foo} ) { |
157 | deprecated( |
158 | message => ..., |
159 | feature => 'feature-X', |
160 | ); |
161 | } |
162 | } |
163 | |
dee597ea |
164 | package Other::Class; |
165 | |
166 | use My::Class -api_version => '0.04'; |
167 | |
168 | My::Class->new()->foo(); # warns |
169 | My::Class->new()->bar(); # does not warn |
170 | My::Class->new()->far(); # does not warn again |
dc4fc8c7 |
171 | |
172 | =head1 DESCRIPTION |
173 | |
dee597ea |
174 | This module allows you to manage a set of deprecations for one or more modules. |
175 | |
176 | When you import C<Package::DeprecationManager>, you must provide a set of |
bce3492c |
177 | C<-deprecations> as a hash ref. The keys are "feature" names, and the values |
178 | are the version when that feature was deprecated. |
179 | |
180 | In many cases, you can simply use the fully qualified name of a subroutine or |
181 | method as the feature name. This works for cases where the whole subroutine is |
182 | deprecated. However, the feature names can be any string. This is useful if |
183 | you don't want to deprecate an entire subroutine, just a certain usage. |
dee597ea |
184 | |
d26afdef |
185 | You can also provide an optional array reference in the C<-ignore> |
e546f61d |
186 | parameter. |
187 | |
188 | The values to be ignored can be package names or regular expressions (made |
189 | with C<qr//>). Use this to ignore packages in your distribution that can |
190 | appear on the call stack when a deprecated feature is used. |
d26afdef |
191 | |
dee597ea |
192 | As part of the import process, C<Package::DeprecationManager> will export two |
23bc88dc |
193 | subroutines into its caller. It provides an C<import()> sub for the caller and a |
dee597ea |
194 | C<deprecated()> sub. |
195 | |
196 | The C<import()> sub allows callers of I<your> class to specify an C<-api_version> |
197 | parameter. If this is supplied, then deprecation warnings are only issued for |
198 | deprecations for api versions earlier than the one specified. |
199 | |
8040005c |
200 | You must call the C<deprecated()> sub in each deprecated subroutine. When |
201 | called, it will issue a warning using C<Carp::cluck()>. |
bce3492c |
202 | |
203 | The C<deprecated()> sub can be called in several ways. If you do not pass any |
204 | arguments, it will generate an appropriate warning message. If you pass a |
205 | single argument, this is used as the warning message. |
206 | |
207 | Finally, you can call it with named arguments. Currently, the only allowed |
208 | names are C<message> and C<feature>. The C<feature> argument should correspond |
209 | to the feature name passed in the C<-deprecations> hash. |
210 | |
211 | If you don't explicitly specify a feature, the C<deprecated()> sub uses |
212 | C<caller()> to identify its caller, using its fully qualified subroutine name. |
dee597ea |
213 | |
7bbad815 |
214 | A given deprecation warning is only issued once for a given package. This |
215 | module tracks this based on both the feature name I<and> the error message |
216 | itself. This means that if you provide severaldifferent error messages for the |
217 | same feature, all of those errors will appear. |
dee597ea |
218 | |
e1d24eef |
219 | =head1 BUGS |
220 | |
221 | Please report any bugs or feature requests to |
222 | C<bug-package-deprecationmanager@rt.cpan.org>, or through the web interface at |
223 | L<http://rt.cpan.org>. I will be notified, and then you'll automatically be |
224 | notified of progress on your bug as I make changes. |
225 | |
226 | =head1 DONATIONS |
227 | |
228 | If you'd like to thank me for the work I've done on this module, please |
229 | consider making a "donation" to me via PayPal. I spend a lot of free time |
230 | creating free software, and would appreciate any support you'd care to offer. |
231 | |
232 | Please note that B<I am not suggesting that you must do this> in order |
233 | for me to continue working on this particular software. I will |
234 | continue to do so, inasmuch as I have in the past, for as long as it |
235 | interests me. |
236 | |
237 | Similarly, a donation made in this way will probably not make me work on this |
238 | software much more, unless I get so many donations that I can consider working |
239 | on free software full time, which seems unlikely at best. |
240 | |
241 | To donate, log into PayPal and send money to autarch@urth.org or use the |
242 | button on this page: L<http://www.urth.org/~autarch/fs-donation.html> |
243 | |
244 | =head1 CREDITS |
245 | |
246 | The idea for this functionality and some of its implementation was originally |
247 | created as L<Class::MOP::Deprecated> by Goro Fuji. |
248 | |
dc4fc8c7 |
249 | =cut |