File Coverage

blib/lib/Package/DeprecationManager.pm
Criterion Covered Total %
statement 90 90 100.0
branch 28 30 93.3
condition 16 21 76.1
subroutine 21 21 100.0
pod n/a
total 155 162 95.6


line stmt bran cond sub pod time code
1             package Package::DeprecationManager;
2              
3 2     2   46644 use strict;
  2         4  
  2         54  
4 2     2   9 use warnings;
  2         3  
  2         47  
5 2     2   1067 use namespace::autoclean;
  2         31586  
  2         18  
6              
7             our $VERSION = '0.16';
8              
9 2     2   175 use Carp qw( croak );
  2         5  
  2         131  
10 2     2   14 use List::Util 1.33 qw( any );
  2         51  
  2         105  
11 2     2   12 use Package::Stash;
  2         2  
  2         40  
12 2     2   1385 use Params::Util qw( _HASH0 );
  2         11354  
  2         141  
13 2     2   1091 use Sub::Install;
  2         3024  
  2         8  
14 2     2   72 use Sub::Name qw( subname );
  2         3  
  2         1537  
15              
16             sub import {
17 5     5   187 shift;
18 5         17 my %args = @_;
19              
20             croak
21             'You must provide a hash reference -deprecations parameter when importing Package::DeprecationManager'
22 5 100 66     198 unless $args{-deprecations} && _HASH0( $args{-deprecations} );
23              
24 4         5 my %registry;
25              
26 4         7 my $caller = caller();
27              
28 4         52 my $orig_import = $caller->can('import');
29              
30 4         13 my $import = _build_import( \%registry, $orig_import );
31             my $warn
32 4         17 = _build_warn( \%registry, $args{-deprecations}, $args{-ignore} );
33              
34             # We need to remove this to prevent a 'subroutine redefined' warning.
35 4 100       12 if ($orig_import) {
36 1         17 Package::Stash->new($caller)->remove_symbol('&import');
37             }
38              
39             Sub::Install::install_sub(
40             {
41 4         49 code => subname( $caller . '::import', $import ),
42             into => $caller,
43             as => 'import',
44             }
45             );
46              
47 4         248 Sub::Install::install_sub(
48             {
49             code => subname( $caller . '::deprecated', $warn ),
50             into => $caller,
51             as => 'deprecated',
52             }
53             );
54              
55 4         4805 return;
56             }
57              
58             sub _build_import {
59 4     4   5 my $registry = shift;
60 4         6 my $orig_import = shift;
61              
62             return sub {
63 5     5   1926 my $class = shift;
        5      
        4      
        4      
64              
65 5         6 my @args;
66              
67             my $api_version;
68             ## no critic (ControlStructures::ProhibitCStyleForLoops)
69 5         33 for ( my $i = 0; $i < @_; $i++ ) {
70 4 100 66     18 if ( $_[$i] eq '-api_version' || $_[$i] eq '-compatible' ) {
71 3         10 $api_version = $_[ ++$i ];
72             }
73             else {
74 1         34 push @args, $_[$i];
75             }
76             }
77             ## use critic
78              
79 5         8 my $caller = caller();
80 5 100       12 $registry->{$caller} = $api_version
81             if defined $api_version;
82              
83 5 100       11 if ($orig_import) {
84 1         2 @_ = ( $class, @args );
85 1         1 goto &{$orig_import};
  1         55  
86             }
87              
88 4         6 return;
89 4         23 };
90             }
91              
92             sub _build_warn {
93 4     4   6 my $registry = shift;
94 4         5 my $deprecated_at = shift;
95 4         7 my $ignore = shift;
96              
97 4 100       14 my %ignore = map { $_ => 1 } grep { !ref } @{ $ignore || [] };
  2         6  
  3         10  
  4         24  
98 4 100       5 my @ignore_res = grep {ref} @{ $ignore || [] };
  3         8  
  4         17  
99              
100 4         5 my %warned;
101              
102             return sub {
103 24 100   24   9467 my %args = @_ < 2 ? ( message => shift ) : @_;
        24      
        23      
        23      
104              
105 24         116 my ( $package, undef, undef, $sub ) = caller(1);
106              
107 24         35 my $skipped = 1;
108              
109 24 100 100     105 if ( @ignore_res || keys %ignore ) {
110 7   100     34 while ( defined $package
      33        
111 8     8   40 && ( $ignore{$package} || any { $package =~ $_ } @ignore_res )
112             ) {
113 18         93 $package = caller( $skipped++ );
114             }
115             }
116              
117 24 50       45 $package = 'unknown package' unless defined $package;
118              
119 24 100       45 unless ( defined $args{feature} ) {
120 23         26 $args{feature} = $sub;
121             }
122              
123 24         22 my $compat_version = $registry->{$package};
124              
125 24         35 my $at = $deprecated_at->{ $args{feature} };
126              
127             return
128 24 100 66     78 if defined $compat_version
      100        
129             && defined $deprecated_at
130             && $compat_version lt $at;
131              
132 19         15 my $msg;
133 19 100       26 if ( defined $args{message} ) {
134 17         17 $msg = $args{message};
135             }
136             else {
137 2         3 $msg = "$args{feature} has been deprecated";
138 2 50       5 $msg .= " since version $at"
139             if defined $at;
140             }
141              
142 19 100       59 return if $warned{$package}{ $args{feature} }{$msg};
143              
144 11         22 $warned{$package}{ $args{feature} }{$msg} = 1;
145              
146             # We skip at least two levels. One for this anon sub, and one for the
147             # sub calling it.
148 11         11 local $Carp::CarpLevel = $Carp::CarpLevel + $skipped;
149              
150 11         1521 Carp::cluck($msg);
151 4         20 };
152             }
153              
154             1;
155              
156             # ABSTRACT: Manage deprecation warnings for your distribution
157              
158             __END__