<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">package Test2::Util::Stash;
use strict;
use warnings;

our $VERSION = '0.000162';

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 = (
    '&amp;' =&gt; 'CODE',
    '$' =&gt; 'SCALAR',
    '%' =&gt; 'HASH',
    '@' =&gt; '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-&gt;{package}\::$sym-&gt;{name}"};
}

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

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

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

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

        $symbol-&gt;{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 &amp;&amp; $package &amp;&amp; $pkg ne $package;

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

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

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

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

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

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

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

    if ($] &lt; 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)-&gt;SV;
    return *{$glob}{$type} if $sv-&gt;isa('B::SV');
    return undef unless $sv-&gt;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-&gt;{package})-&gt;{$sym-&gt;{name}};
    my $new_glob = get_glob($sym);

    for my $type (qw/CODE SCALAR HASH ARRAY FORMAT IO/) {
        next if $type eq $sym-&gt;{type};
        my $ref = get_symbol({type =&gt; $type, name =&gt; 'GLOBCLONE', sigil =&gt; $SLOTMAP{$type}}, __PACKAGE__);
        next unless $ref;
        *$new_glob = $ref;
    }

    return *GLOBCLONE{$sym-&gt;{type}};
}

1;

__END__


=pod

=encoding UTF-8

=head1 NAME

Test2::Util::Stash - Utilities for manipulating stashes and globs.

=head1 DESCRIPTION

This is a collection of utilities for manipulating and inspecting package
stashes and globs.

=head1 EXPORTS

=over 4

=item $stash = get_stash($package)

Gets the package stash. This is the same as C&lt;$stash = \%Package::Name::&gt;.

=item $sym_spec = parse_symbol($symbol)

=item $sym_spec = parse_symbol($symbol, $package)

Parse a symbol name, and return a hashref with info about the symbol.

C&lt;$symbol&gt; can be a simple name, or a fully qualified symbol name. The sigil is
optional, and C&lt;&amp;&gt; is assumed if none is provided. If C&lt;$symbol&gt; is fully qualified,
and C&lt;$package&gt; is also provided, then the package of the symbol must match the
C&lt;$package&gt;.

Returns a structure like this:

    return {
        name    =&gt; 'BAZ',
        sigil   =&gt; '$',
        type    =&gt; 'SCALAR',
        symbol  =&gt; '&amp;Foo::Bar::BAZ',
        package =&gt; 'Foo::Bar',
    };

=item $glob_ref = get_glob($symbol)

=item $glob_ref = get_glob($symbol, $package)

Get a glob ref. Arguments are the same as for C&lt;parse_symbol&gt;.

=item $ref = get_symbol($symbol)

=item $ref = get_symbol($symbol, $package)

Get a reference to the symbol. Arguments are the same as for C&lt;parse_symbol&gt;.

=item $ref = purge_symbol($symbol)

=item $ref = purge_symbol($symbol, $package)

Completely remove the symbol from the package symbol table. Arguments are the
same as for C&lt;parse_symbol&gt;. A reference to the removed symbol is returned.

=item $sig = slot_to_sig($slot)

Convert a slot (like 'SCALAR') to a sigil (like '$').

=item $slot = sig_to_slot($sig)

Convert a sigil (like '$') to a slot (like 'SCALAR').

=back

=head1 SOURCE

The source code repository for Test2-Suite can be found at
F&lt;https://github.com/Test-More/Test2-Suite/&gt;.

=head1 MAINTAINERS

=over 4

=item Chad Granum E&lt;lt&gt;exodist@cpan.orgE&lt;gt&gt;

=back

=head1 AUTHORS

=over 4

=item Chad Granum E&lt;lt&gt;exodist@cpan.orgE&lt;gt&gt;

=back

=head1 COPYRIGHT

Copyright 2018 Chad Granum E&lt;lt&gt;exodist@cpan.orgE&lt;gt&gt;.

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

See F&lt;http://dev.perl.org/licenses/&gt;

=cut
</pre></body></html>