File Coverage

blib/lib/Sub/Remove.pm

Criterion	Covered	Total	%
statement	43	43	100.0
branch	12	12	100.0
condition	3	3	100.0
subroutine	7	8	87.5
pod	1	1	100.0
total	66	67	98.5

package Sub::Remove;

use strict;
use warnings;

use Carp qw(croak);
use Exporter qw(import);
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(
    sub_remove
);

our $VERSION = '0.01';

sub __placeholder {}

sub sub_remove {
    my ($sub_name, $class) = @_;

    if (! defined $sub_name) {
        croak "sub_remove() requires a subroutine name as parameter";
    }

    if (! defined $class) {
        $class = 'main';
    }

    if (! $class->can($sub_name)) {
        croak "Subroutine named '${class}::${sub_name}' doesn't exist";
    }

    my $src;

    # get the calling package symbol table name
    {
        no strict 'refs';
        $src = \%{ $class . '::' };
    }

    # loop through all symbols in calling package, looking for subs
    for my $symbol ( keys %$src ) {
        # get all code references, make sure they're valid
        my $sub = *{ $src->{$symbol} }{CODE};
        next unless defined $sub and defined &$sub;

        # save all other slots of the typeglob
        my @slots;

        for my $slot (qw( SCALAR ARRAY HASH IO FORMAT )) {
                my $elem = *{ $src->{$symbol} }{$slot};
                next unless defined $elem;
                push @slots, $elem;
        }

        # clear out the source glob
        undef $src->{$symbol};

        # replace the sub in the source
        if ($symbol ne $sub_name) {
            $src->{$symbol} = sub {
                my @args = @_;
                return $sub->(@_);
            };
        }

        # replace the other slot elements
        for my $elem (@slots) {
                $src->{$symbol} = $elem;
        }
    }
}

1;
__END__