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