lib/Package/DeprecationManager.pm

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