File Coverage

blib/lib/Symbol/Methods.pm

Criterion	Covered	Total	%
statement	90	97	92.7
branch	21	26	80.7
condition	15	19	78.9
subroutine	19	19	100.0
pod			n/a
total	145	161	90.0

package Symbol::Methods;
use strict;
use warnings;

use Carp qw/croak/;
use B;

our $VERSION = '0.000001';
our @CARP_NOT = (
    'Symbol::Alias',
    'Symbol::Delete',
    'Symbol::Extract',
    'Symbol::Move',
);

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

sub symbol::exists {
    my ($class, $sym) = @_;
    $sym = _parse_symbol($sym, $class);
    my $ref = _get_ref($sym);
    return $ref ? 1 : 0;
}

sub symbol::fetch {
    my ($class, $sym) = @_;
    $sym = _parse_symbol($sym, $class);
    return _get_ref($sym);
}

sub symbol::delete {
    my ($class, $sym) = @_;
    $sym = _parse_symbol($sym, $class);
    my $ref = _get_ref($sym);
    _purge_symbol($sym);
    return $ref;
}

sub symbol::alias {
    my ($class, $old_sym, $new_sym) = @_;
    $old_sym = _parse_symbol($old_sym, $class);
    $new_sym = _parse_symbol($new_sym, $class, $old_sym->{sigil});

    croak "Origin and Destination symbols must be the same type, got '$old_sym->{type}' and '$new_sym->{type}'"
        unless $old_sym->{type} eq $new_sym->{type};

    my $old_ref = _get_ref($old_sym) or  croak "Symbol $old_sym->{sym} does not exist";
    my $new_ref = _get_ref($new_sym) and croak "Symbol $new_sym->{sym} already exists";

    *{_get_glob($new_sym)} = $old_ref;
}

sub symbol::move {
    my ($class, $old_sym, $new_sym) = @_;
    $old_sym = _parse_symbol($old_sym, $class);
    $new_sym = _parse_symbol($new_sym, $class, $old_sym->{sigil});

    symbol::alias($class, $old_sym, $new_sym);

    _purge_symbol($old_sym);
}

sub _parse_symbol {
    my ($sym, $class, $def_sig) = @_;
    return $sym if ref $sym;

    my ($sig, $pkg, $name) = ($sym =~ m/^(\W)?(.*::)?([^:]+)$/);

    $sig ||= $def_sig || '&';

    $pkg ||= $class;
    $pkg = 'main' if $pkg eq '::';
    $pkg =~ s/::$//;

    my $type = $SIGMAP{$sig} || croak "Unsupported sigil '$sig'";

    return {
        sym   => "$sig$pkg\::$name",
        name  => $name,
        sigil => $sig,
        type  => $type,
        pkg   => $pkg,
    };
}

sub _get_stash {
    my ($sym) = @_;
    no strict 'refs';
    no warnings 'once';
    return \%{"$sym->{pkg}\::"};
}

sub _get_glob {
    my ($sym) = @_;
    no strict 'refs';
    no warnings 'once';
    return \*{"$sym->{pkg}\::$sym->{name}"};
}

sub _get_ref {
    my ($sym, $globref) = @_;
    $globref ||= _get_glob($sym);
    my $type = $sym->{type};

    return *{$globref}{$type} if $type ne 'SCALAR' && defined(*{$globref}{$type});

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

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

sub _set_symbol {
    my ($sym, $ref) = @_;
    *{_get_glob($sym)} = $ref;
}

sub _purge_symbol {
    my ($sym) = @_;

    local *GLOBCLONE = *{_get_glob($sym)};
    delete _get_stash($sym)->{$sym->{name}};
    my $new_glob = _get_glob($sym);

    for my $type (qw/CODE SCALAR HASH ARRAY FORMAT IO/) {
        next if $type eq $sym->{type};
        my $ref = _get_ref({type => $type}, \*GLOBCLONE) || next;
        *$new_glob = $ref;
    }

    return *GLOBCLONE{$sym->{type}};
}

1;

__END__