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         # We skip at least two levels. One for this anon sub, and one for the
 113         # sub calling it.
 114         local $Carp::CarpLevel = $Carp::CarpLevel + $skipped;
 115
 116         Carp::cluck($msg);
 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
 130   package My::Class;
 131
 132   use Package::DeprecationManager -deprecations => {
 133       'My::Class::foo' => '0.02',
 134       'My::Class::bar' => '0.05',
 135       'feature-X'      => '0.07',
 136   };
 137
 138   sub foo {
 139       deprecated( 'Do not call foo!' );
 140
 141       ...
 142   }
 143
 144   sub bar {
 145       deprecated();
 146
 147       ...
 148   }
 149
 150   sub baz {
 151       my %args = @_;
 152
 153       if ( $args{foo} ) {
 154           deprecated(
 155               message => ...,
 156               feature => 'feature-X',
 157           );
 158       }
 159   }
 160
 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
 168
 169 =head1 DESCRIPTION
 170
 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
 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.
 181
 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
 188 As part of the import process, C<Package::DeprecationManager> will export two
 189 subroutines into its caller. It provides an C<import()> sub for the caller and a
 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,
 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.
 209
 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.
 214
 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
 245 =cut