File Coverage

lib/Sub/Override.pm

Criterion	Covered	Total	%
statement	147	148	99.3
branch	23	24	95.8
condition	11	12	91.6
subroutine	33	33	100.0
pod	6	6	100.0
total	220	223	98.6

package Sub::Override;

use strict;
use warnings;

use Carp qw(croak);
use Scalar::Util qw(set_prototype);

our $VERSION = '0.12';

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

{
    no warnings 'once';
    # 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->_get_fully_qualified_sub_name($sub_to_replace);
    $self->_ensure_code_slot_exists($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 inject {
    my ( $self, $sub_to_inject, $new_sub ) = @_;
    $sub_to_inject = $self->_get_fully_qualified_sub_name($sub_to_inject);
    $self->_ensure_code_slot_does_not_exist($sub_to_inject)->_validate_sub_ref($new_sub);
    {
        no strict 'refs';
        $self->{$sub_to_inject} = undef;
        no warnings 'redefine';
        *$sub_to_inject = $new_sub;
    }
    return $self;
}

sub inherit {
    my ( $self, $sub_to_inherit, $new_sub ) = @_;
    $sub_to_inherit = $self->_get_fully_qualified_sub_name($sub_to_inherit);
    $self->_ensure_code_slot_exists_in_parent_class($sub_to_inherit)->_validate_sub_ref($new_sub);
    {
        no strict 'refs';
        $self->{$sub_to_inherit} = undef;
        no warnings 'redefine';
        *$sub_to_inherit = $new_sub;
    }
    return $self;
}

sub wrap {
    my ( $self, $sub_to_replace, $new_sub ) = @_;
    $sub_to_replace = $self->_get_fully_qualified_sub_name($sub_to_replace);
    $self->_ensure_code_slot_exists($sub_to_replace)->_validate_sub_ref($new_sub);
    {
        no strict 'refs';
        $self->{$sub_to_replace} ||= *$sub_to_replace{CODE};

        # passing $sub_to_replace directly to arguments prevents early destruction.
        my $weakened_sub_to_replace = $self->{$sub_to_replace};
        my $code = sub { unshift(@_, $weakened_sub_to_replace); goto &$new_sub };
        my $prototype = prototype($self->{$sub_to_replace});
        set_prototype(\&$code, $prototype) if defined $prototype;

        no warnings 'redefine';
        *$sub_to_replace = $code;
    }
    return $self;
}

sub restore {
    my ( $self, $name_of_sub ) = @_;
    $name_of_sub = $self->_get_fully_qualified_sub_name($name_of_sub);
    if ( !$name_of_sub && 1 == keys %$self ) {
        ($name_of_sub) = keys %$self;
    }
    croak(
        sprintf 'You must provide the name of a sub to restore: (%s)' => join
          ', ' => sort keys %$self )
        unless $name_of_sub;
    croak("Cannot restore a sub that was not replaced ($name_of_sub)")
        unless exists $self->{$name_of_sub};

    no strict 'refs';
    no warnings 'redefine';
    my $maybe_sub_ref = delete $self->{$name_of_sub};
    if ( defined $maybe_sub_ref ) {
        *$name_of_sub = $maybe_sub_ref;
    }
    else {
        undef *$name_of_sub;
    }
    return $self;
}

sub DESTROY {
    my $self = shift;
    no strict 'refs';
    # "misc" suppresses warning: 'Undefined value assigned to typeglob'
    no warnings 'redefine', 'misc';
    while ( my ( $sub_name, $maybe_sub_ref ) = each %$self ) {
        if ( defined $maybe_sub_ref ) {
            *$sub_name = $maybe_sub_ref;
        }
        else {
            undef *$sub_name;
        }
    }
}

sub _get_fully_qualified_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 _validate_sub_ref {
    my ( $self, $sub_ref ) = @_;
    unless ( 'CODE' eq ref $sub_ref ) {
        croak("($sub_ref) must be a code reference");
    }
    return $self;
};

sub _ensure_code_slot_exists {
    my ( $self, $code_slot ) = @_;
    no strict 'refs';
    unless ( defined *{$code_slot}{CODE} ) {
        croak("Cannot replace non-existent sub ($code_slot)");
    }
    return $self;
};

sub _ensure_code_slot_does_not_exist {
    my ( $self, $code_slot ) = @_;
    no strict 'refs';
    if ( defined *{$code_slot}{CODE} ) {
        croak("Cannot create a sub that already exists ($code_slot)");
    }
    return $self;
};

sub _ensure_code_slot_exists_in_parent_class {
    my ( $self, $code_slot ) = @_;
    $self->_ensure_code_slot_does_not_exist($code_slot);
    {
        no strict 'refs';
        my $class  = *{$code_slot}{PACKAGE};
        my $method = *{$code_slot}{NAME};
        croak("Sub does not exist in parent class ($code_slot)")
            unless $class->can($method);
    }
    return $self;
};

1;

__END__