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