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         $registry->{ caller() } = $args{-api_version}
  52             if $args{-api_version};
  53
  54         return;
  55     };
  56 }
  57
  58 sub _build_warn {
  59     my $registry      = shift;
  60     my $deprecated_at = shift;
  61
  62     my %warned;
  63
  64     return sub {
  65         my ( $package, undef, undef, $sub ) = caller(1);
  66
  67         my $compat_version = $registry->{$package};
  68
  69         my $deprecated_at = $deprecated_at->{$sub};
  70
  71         return
  72             if defined $compat_version
  73                 && defined $deprecated_at
  74                 && $compat_version lt $deprecated_at;
  75
  76         return if $warned{$package}{$sub};
  77
  78         if ( ! @_ ) {
  79             my $msg = "$sub has been deprecated";
  80             $msg .= " since version $deprecated_at"
  81                 if defined $deprecated_at;
  82
  83             @_ = $msg;
  84         }
  85
  86         $warned{$package}{$sub} = 1;
  87
  88         goto &Carp::cluck;
  89     };
  90 }
  91
  92 1;
  93
  94 # ABSTRACT: Manage deprecation warnings for your distribution
  95
  96 __END__
  97
  98 =pod
  99
 100 =head1 SYNOPSIS
 101
 102   ...
 103
 104 =head1 DESCRIPTION
 105
 106 =cut