File Coverage

blib/lib/Test2/Util/Stash.pm

Criterion	Covered	Total	%
statement	76	92	82.6
branch	27	42	64.2
condition	21	29	72.4
subroutine	16	17	94.1
pod	7	7	100.0
total	147	187	78.6

package Test2::Util::Stash;
use strict;
use warnings;

our $VERSION = '0.000155';

use Carp qw/croak/;
use B;

our @EXPORT_OK = qw{
    get_stash
    get_glob
    get_symbol
    parse_symbol
    purge_symbol
    slot_to_sig sig_to_slot
};
use base 'Exporter';

my %SIGMAP = (
    '&' => 'CODE',
    '$' => 'SCALAR',
    '%' => 'HASH',
    '@' => 'ARRAY',
);

my %SLOTMAP = reverse %SIGMAP;

sub slot_to_sig { $SLOTMAP{$_[0]} || croak "unsupported slot: '$_[0]'" }
sub sig_to_slot { $SIGMAP{$_[0]}  || croak "unsupported sigil: $_[0]"  }

sub get_stash {
    my $package = shift || caller;
    no strict 'refs';
    return \%{"${package}\::"};
}

sub get_glob {
    my $sym = _parse_symbol(scalar(caller), @_);
    no strict 'refs';
    no warnings 'once';
    return \*{"$sym->{package}\::$sym->{name}"};
}

sub parse_symbol { _parse_symbol(scalar(caller), @_) }

sub _parse_symbol {
    my ($caller, $symbol, $package) = @_;

    if (ref($symbol)) {
        my $pkg = $symbol->{package};

        croak "Symbol package ($pkg) and package argument ($package) do not match"
            if $pkg && $package && $pkg ne $package;

        $symbol->{package} ||= $caller;

        return $symbol;
    }

    utf8::downgrade($symbol) if $] == 5.010000; # prevent crash on 5.10.0
    my ($sig, $pkg, $name) = ($symbol =~ m/^(\W?)(.*::)?([^:]+)$/)
        or croak "Invalid symbol: '$symbol'";

    # Normalize package, '::' becomes 'main', 'Foo::' becomes 'Foo'
    $pkg = $pkg
        ? $pkg eq '::'
            ? 'main'
            : substr($pkg, 0, -2)
        : undef;

    croak "Symbol package ($pkg) and package argument ($package) do not match"
        if $pkg && $package && $pkg ne $package;

    $sig ||= '&';
    my $type = $SIGMAP{$sig} || croak "unsupported sigil: '$sig'";

    my $real_package = $package || $pkg || $caller;

    return {
        name    => $name,
        sigil   => $sig,
        type    => $type,
        symbol  => "${sig}${real_package}::${name}",
        package => $real_package,
    };
}

sub get_symbol {
    my $sym = _parse_symbol(scalar(caller), @_);

    my $name    = $sym->{name};
    my $type    = $sym->{type};
    my $package = $sym->{package};
    my $symbol  = $sym->{symbol};

    my $stash = get_stash($package);
    return undef unless exists $stash->{$name};

    my $glob = get_glob($sym);
    return *{$glob}{$type} if $type ne 'SCALAR' && defined(*{$glob}{$type});

    if ($] < 5.010) {
        return undef unless defined(*{$glob}{$type});

        {
            local ($@, $!);
            local $SIG{__WARN__} = sub { 1 };
            return *{$glob}{$type} if eval "package $package; my \$y = $symbol; 1";
        }

        return undef unless defined *{$glob}{$type};
        return *{$glob}{$type} if defined ${*{$glob}{$type}};
        return undef;
    }

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

sub purge_symbol {
    my $sym = _parse_symbol(scalar(caller), @_);

    local *GLOBCLONE = *{get_glob($sym)};
    delete get_stash($sym->{package})->{$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_symbol({type => $type, name => 'GLOBCLONE', sigil => $SLOTMAP{$type}}, __PACKAGE__);
        next unless $ref;
        *$new_glob = $ref;
    }

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

1;

__END__