lib/Package/DeprecationManager.pm

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