File Coverage

lib/Sub/Override.pm

Criterion	Covered	Total	%
statement	49	49	100.0
branch	8	8	100.0
condition	5	5	100.0
subroutine	13	13	100.0
pod	3	3	100.0
total	78	78	100.0

package Sub::Override;

use strict;
use warnings;

our $VERSION = '0.09';

my $_croak = sub {
    local *__ANON__ = '__ANON__croak';
    my ( $proto, $message ) = @_;
    require Carp;
    Carp::croak($message);
};

my $_validate_code_slot = sub {
    local *__ANON__ = '__ANON__validate_code_slot';
    my ( $self, $code_slot ) = @_;
    no strict 'refs';
    unless ( defined *{$code_slot}{CODE} ) {
        $self->$_croak("Cannot replace non-existent sub ($code_slot)");
    }
    return $self;
};

my $_validate_sub_ref = sub {
    local *__ANON__ = '__ANON__validate_sub_ref';
    my ( $self, $sub_ref ) = @_;
    unless ( 'CODE' eq ref $sub_ref ) {
        $self->$_croak("($sub_ref) must be a code reference");
    }
    return $self;
};

my $_normalize_sub_name = sub {
    local *__ANON__ = '__ANON__normalize_sub_name';
    my ( $self, $subname ) = @_;
    if ( ( $subname || '' ) =~ /^\w+$/ ) { # || "" for suppressing test warnings
        my $package = do {
            my $call_level = 0;
            my $this_package;
            while ( !$this_package || __PACKAGE__ eq $this_package ) {
                ($this_package) = caller($call_level);
                $call_level++;
            }
            $this_package;
        };
        $subname = "${package}::$subname";
    }
    return $subname;
};

sub new {
    my $class = shift;
    my $self = bless {}, $class;
    $self->replace(@_) if @_;
    return $self;
}

# because override() was a better name and this is what it should have been
# called.
*override = *replace{CODE};

sub replace {
    my ( $self, $sub_to_replace, $new_sub ) = @_;
    $sub_to_replace = $self->$_normalize_sub_name($sub_to_replace);
    $self->$_validate_code_slot($sub_to_replace)->$_validate_sub_ref($new_sub);
    {
        no strict 'refs';
        $self->{$sub_to_replace} ||= *$sub_to_replace{CODE};
        no warnings 'redefine';
        *$sub_to_replace = $new_sub;
    }
    return $self;
}

sub restore {
    my ( $self, $name_of_sub ) = @_;
    $name_of_sub = $self->$_normalize_sub_name($name_of_sub);
    if ( !$name_of_sub && 1 == keys %$self ) {
        ($name_of_sub) = keys %$self;
    }
    $self->$_croak(
        sprintf 'You must provide the name of a sub to restore: (%s)' => join
          ', ' => sort keys %$self )
      unless $name_of_sub;
    $self->$_croak("Cannot restore a sub that was not replaced ($name_of_sub)")
      unless exists $self->{$name_of_sub};
    no strict 'refs';
    no warnings 'redefine';
    *$name_of_sub = delete $self->{$name_of_sub};
    return $self;
}

sub DESTROY {
    my $self = shift;
    no strict 'refs';
    no warnings 'redefine';
    while ( my ( $sub_name, $sub_ref ) = each %$self ) {
        *$sub_name = $sub_ref;
    }
}

1;

__END__