File Coverage

blib/lib/Symbol/Rename.pm

Criterion	Covered	Total	%
statement	90	92	97.8
branch	33	40	82.5
condition	4	6	66.6
subroutine	17	17	100.0
pod	0	1	0.0
total	144	156	92.3

package Symbol::Rename;
use strict;
use warnings;

use Carp qw/croak/;
use B;

our $VERSION = '0.000002';

my %SIGMAP = (
    '&' => 'CODE',
    '$' => 'SCALAR',
    '%' => 'HASH',
    '@' => 'ARRAY',
    # Others are unsupported.
);
my %TYPEMAP = reverse %SIGMAP;

sub import {
    my $class = shift;
    return unless @_;
    my ($opts, %renames) = _parse_args(@_);

    my $package = delete $opts->{package} || caller;

    croak "Unsupported option(s): " . join(", ", keys %$opts)
        if keys %$opts;

    _rename_symbols($package, %renames);
}

sub rename_symbols {
    my $class = shift;
    my ($opts, %renames) = _parse_args(@_);

    croak "Unsupported options: " . join(", ", keys %$opts)
        if keys %$opts;

    _rename_symbols($class, %renames);
}

sub _parse_args {
    my (%opts, %renames);

    while (my $symbol = shift @_) {
        if ($symbol =~ m/^-(.*)$/) {
            $opts{$1} = shift @_ or croak "No argument provided for option '-$1'";
            next;
        }

        my ($sig, $name) = ($symbol =~ qw/^(\W?)(.*)$/);
        my $type = $sig ? $SIGMAP{$sig} : 'CODE';
        croak "Unsupported sigil ($sig) on symbol '$symbol'" unless $type;

        my $new_name = shift(@_) or croak "No new name was specified for symbol '$symbol'";

        croak "Symbol '$symbol' ($type, $name) listed multiple times"
            if $renames{$name}->{$type};

        $renames{$name}->{$type} = $new_name;
    }

    return (\%opts, %renames);
}

sub _symbol_exists {
    my ($globref, $type) = @_;

    return defined(*{$globref}{$type})
        unless $type eq 'SCALAR';

    return defined(${ *{$globref}{$type} })
        if $] < 5.010;

    my $sv = B::svref_2object($globref)->SV;
    return 1 if $sv->isa('B::SV');
    return 0 unless $sv->isa('B::SPECIAL');
    return $B::specialsv_name[$$sv] ne 'Nullsv';
}

sub _rename_symbols {
    my $class = shift;
    my %renames = @_;

    no strict 'refs';
    my $stash = \%{"$class\::"};
    use strict 'refs';

    for my $name (keys %renames) {
        my $types = $renames{$name};

        no strict 'refs';
        local *GLOBCLONE = *{"$class\::$name"};
        use strict 'refs';

        delete $stash->{$name};

        for my $type (qw/CODE SCALAR HASH ARRAY FORMAT IO/) {
            if (my $new_name = $types->{$type}) {
                croak "Origin symbol '$TYPEMAP{$type}$class\::$name' does not exist"
                    unless _symbol_exists(\*GLOBCLONE, $type);

                if (my $ref = ref($new_name)) {
                    croak "'$ref' references cannot be used as a renaming destination for '$TYPEMAP{$type}$class\::$name'"
                        unless $ref eq 'SCALAR';

                    $$new_name = *GLOBCLONE{$type};

                    next;
                }

                no strict 'refs';
                my $destglob = \*{"$class\::$new_name"};
                use strict 'refs';

                croak "Destination symbol '$TYPEMAP{$type}$class\::$new_name' already exists"
                    if !ref($new_name) && _symbol_exists($destglob, $type);

                no strict 'refs';
                *{"$class\::$new_name"} = *GLOBCLONE{$type};
            }
            elsif($type eq 'SCALAR' ? defined ${*GLOBCLONE{$type}} : defined *GLOBCLONE{$type}) {
                no strict 'refs';
                *{"$class\::$name"} = *GLOBCLONE{$type};
            }
        }
    }
}

1;

__END__