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         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
  86         unless ( defined $args{feature} ) {
  87             $args{feature} = $sub;
  88         }
  89
  90         my $compat_version = $registry->{$package};
  91
  92         my $deprecated_at = $deprecated_at->{ $args{feature} };
  93
  94         return
  95             if defined $compat_version
  96                 && defined $deprecated_at
  97                 && $compat_version lt $deprecated_at;
  98
  99         return if $warned{$package}{ $args{feature} };
 100
 101         my $msg;
 102         if ( defined $args{message} ) {
 103             $msg = $args{message};
 104         }
 105         else {
 106             $msg = "$args{feature} has been deprecated";
 107             $msg .= " since version $deprecated_at"
 108                 if defined $deprecated_at;
 109         }
 110
 111         $warned{$package}{ $args{feature} } = 1;
 112
 113         local $Carp::CarpLevel = $Carp::CarpLevel + 1 + $skipped;
 114
 115         Carp::cluck($msg);
 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
 129   package My::Class;
 130
 131   use Package::DeprecationManager -deprecations => {
 132       'My::Class::foo' => '0.02',
 133       'My::Class::bar' => '0.05',
 134       'feature-X'      => '0.07',
 135   };
 136
 137   sub foo {
 138       deprecated( 'Do not call foo!' );
 139
 140       ...
 141   }
 142
 143   sub bar {
 144       deprecated();
 145
 146       ...
 147   }
 148
 149   sub baz {
 150       my %args = @_;
 151
 152       if ( $args{foo} ) {
 153           deprecated(
 154               message => ...,
 155               feature => 'feature-X',
 156           );
 157       }
 158   }
 159
 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
 167
 168 =head1 DESCRIPTION
 169
 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
 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.
 180
 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
 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,
 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.
 208
 209 Deprecation warnings are only issued once for a given package, regardless of
 210 how many times the deprecated sub/method is called.
 211
 212 =head1 BUGS
 213
 214 Please report any bugs or feature requests to
 215 C<bug-package-deprecationmanager@rt.cpan.org>, or through the web interface at
 216 L<http://rt.cpan.org>.  I will be notified, and then you'll automatically be
 217 notified of progress on your bug as I make changes.
 218
 219 =head1 DONATIONS
 220
 221 If you'd like to thank me for the work I've done on this module, please
 222 consider making a "donation" to me via PayPal. I spend a lot of free time
 223 creating free software, and would appreciate any support you'd care to offer.
 224
 225 Please note that B<I am not suggesting that you must do this> in order
 226 for me to continue working on this particular software. I will
 227 continue to do so, inasmuch as I have in the past, for as long as it
 228 interests me.
 229
 230 Similarly, a donation made in this way will probably not make me work on this
 231 software much more, unless I get so many donations that I can consider working
 232 on free software full time, which seems unlikely at best.
 233
 234 To donate, log into PayPal and send money to autarch@urth.org or use the
 235 button on this page: L<http://www.urth.org/~autarch/fs-donation.html>
 236
 237 =head1 CREDITS
 238
 239 The idea for this functionality and some of its implementation was originally
 240 created as L<Class::MOP::Deprecated> by Goro Fuji.
 241
 242 =cut