File Coverage

blib/lib/Package/DeprecationManager.pm
Criterion Covered Total %
statement 87 87 100.0
branch 28 30 93.3
condition 17 21 80.9
subroutine 20 20 100.0
pod n/a
total 152 158 96.2


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