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} );
  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
  64     my %warned;
  65
  66     return sub {
  67         my ( $package, undef, undef, $sub ) = caller(1);
  68
  69         my $compat_version = $registry->{$package};
  70
  71         my $deprecated_at = $deprecated_at->{$sub};
  72
  73         return
  74             if defined $compat_version
  75                 && defined $deprecated_at
  76                 && $compat_version lt $deprecated_at;
  77
  78         return if $warned{$package}{$sub};
  79
  80         if ( ! @_ ) {
  81             my $msg = "$sub has been deprecated";
  82             $msg .= " since version $deprecated_at"
  83                 if defined $deprecated_at;
  84
  85             @_ = $msg;
  86         }
  87
  88         $warned{$package}{$sub} = 1;
  89
  90         goto &Carp::cluck;
  91     };
  92 }
  93
  94 1;
  95
  96 # ABSTRACT: Manage deprecation warnings for your distribution
  97
  98 __END__
  99
 100 =pod
 101
 102 =head1 SYNOPSIS
 103
 104   package My::Class;
 105
 106   use Package::DeprecationManager
 107       -deprecations => {
 108           'My::Class::foo' => '0.02',
 109           'My::Class::bar' => '0.05',
 110       };
 111
 112   sub foo {
 113       deprecated( 'Do not call foo!' );
 114
 115       ...
 116   }
 117
 118   sub bar {
 119       deprecated();
 120
 121       ...
 122   }
 123
 124   package Other::Class;
 125
 126   use My::Class -api_version => '0.04';
 127
 128   My::Class->new()->foo(); # warns
 129   My::Class->new()->bar(); # does not warn
 130   My::Class->new()->far(); # does not warn again
 131
 132 =head1 DESCRIPTION
 133
 134 This module allows you to manage a set of deprecations for one or more modules.
 135
 136 When you import C<Package::DeprecationManager>, you must provide a set of
 137 C<-deprecations> as a hash ref. The keys are fully qualified sub/method names,
 138 and the values are the version when that subroutine was deprecated.
 139
 140 As part of the import process, C<Package::DeprecationManager> will export two
 141 subroutines into its caller. It proves an C<import()> sub for the caller and a
 142 C<deprecated()> sub.
 143
 144 The C<import()> sub allows callers of I<your> class to specify an C<-api_version>
 145 parameter. If this is supplied, then deprecation warnings are only issued for
 146 deprecations for api versions earlier than the one specified.
 147
 148 You must call C<deprecated()> sub in each deprecated subroutine. When called,
 149 it will issue a warning using C<Carp::cluck()>. If you do not pass an explicit
 150 warning message, one will be generated for you.
 151
 152 Deprecation warnings are only issued once for a given package, regardless of
 153 how many times the deprecated sub/method is called.
 154
 155 =head1 BUGS
 156
 157 Please report any bugs or feature requests to
 158 C<bug-package-deprecationmanager@rt.cpan.org>, or through the web interface at
 159 L<http://rt.cpan.org>.  I will be notified, and then you'll automatically be
 160 notified of progress on your bug as I make changes.
 161
 162 =head1 DONATIONS
 163
 164 If you'd like to thank me for the work I've done on this module, please
 165 consider making a "donation" to me via PayPal. I spend a lot of free time
 166 creating free software, and would appreciate any support you'd care to offer.
 167
 168 Please note that B<I am not suggesting that you must do this> in order
 169 for me to continue working on this particular software. I will
 170 continue to do so, inasmuch as I have in the past, for as long as it
 171 interests me.
 172
 173 Similarly, a donation made in this way will probably not make me work on this
 174 software much more, unless I get so many donations that I can consider working
 175 on free software full time, which seems unlikely at best.
 176
 177 To donate, log into PayPal and send money to autarch@urth.org or use the
 178 button on this page: L<http://www.urth.org/~autarch/fs-donation.html>
 179
 180 =head1 CREDITS
 181
 182 The idea for this functionality and some of its implementation was originally
 183 created as L<Class::MOP::Deprecated> by Goro Fuji.
 184
 185 =cut