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

package Package::DeprecationManager;

use strict;
use warnings;

our $VERSION = '0.18';

use Carp qw( croak );
use List::Util 1.33 qw( any );
use Package::Stash;
use Params::Util qw( _HASH0 );
use Sub::Install;
use Sub::Util qw( set_subname );

sub import {
    shift;
    my %args = @_;

    croak
        'You must provide a hash reference -deprecations parameter when importing Package::DeprecationManager'
        unless $args{-deprecations} && _HASH0( $args{-deprecations} );

    my %registry;

    my $caller = caller();

    my $orig_import = $caller->can('import');

    my $import = _build_import( \%registry, $orig_import );
    my $warn
        = _build_warn( \%registry, $args{-deprecations}, $args{-ignore} );

    # We need to remove this to prevent a 'subroutine redefined' warning.
    if ($orig_import) {
        Package::Stash->new($caller)->remove_symbol('&import');
    }

    Sub::Install::install_sub(
        {
            code => set_subname( $caller . '::import', $import ),
            into => $caller,
            as   => 'import',
        }
    );

    Sub::Install::install_sub(
        {
            code => set_subname( $caller . '::deprecated', $warn ),
            into => $caller,
            as   => 'deprecated',
        }
    );

    return;
}

sub _build_import {
    my $registry    = shift;
    my $orig_import = shift;

    return sub {
        my $class = shift;

        my @args;

        my $api_version;
        ## no critic (ControlStructures::ProhibitCStyleForLoops)
        for ( my $i = 0; $i < @_; $i++ ) {
            if ( $_[$i] eq '-api_version' || $_[$i] eq '-compatible' ) {
                $api_version = $_[ ++$i ];
            }
            else {
                push @args, $_[$i];
            }
        }
        ## use critic

        my $caller = caller();
        $registry->{$caller} = $api_version
            if defined $api_version;

        if ($orig_import) {
            @_ = ( $class, @args );
            goto &{$orig_import};
        }

        return;
    };
}

sub _build_warn {
    my $registry      = shift;
    my $deprecated_at = shift;
    my $ignore        = shift;

    my %ignore     = map  { $_ => 1 } grep { !ref } @{ $ignore || [] };
    my @ignore_res = grep {ref} @{ $ignore || [] };

    my %warned;

    return sub {
        my %args = @_ < 2 ? ( message => shift ) : @_;

        my ( $package, undef, undef, $sub ) = caller(1);

        my $skipped = 1;

        if ( @ignore_res || keys %ignore ) {
            while (
                defined $package
                && ( $ignore{$package} || any { $package =~ $_ } @ignore_res )
            ) {
                $package = caller( $skipped++ );
            }
        }

        $package = 'unknown package' unless defined $package;

        unless ( defined $args{feature} ) {
            $args{feature} = $sub;
        }

        my $compat_version = $registry->{$package};

        my $at = $deprecated_at->{ $args{feature} };

        return
               if defined $compat_version
            && defined $deprecated_at
            && $compat_version lt $at;

        my $msg;
        if ( defined $args{message} ) {
            $msg = $args{message};
        }
        else {
            $msg = "$args{feature} has been deprecated";
            $msg .= " since version $at"
                if defined $at;
        }

        return if $warned{$package}{ $args{feature} }{$msg};

        $warned{$package}{ $args{feature} }{$msg} = 1;

        # We skip at least two levels. One for this anon sub, and one for the
        # sub calling it.
        local $Carp::CarpLevel = $Carp::CarpLevel + $skipped;

        Carp::cluck($msg);
    };
}

1;

# ABSTRACT: Manage deprecation warnings for your distribution

__END__