view release on metacpan or  search on metacpan

lib/Tie/Symbol.pm  view on Meta::CPAN

use strict;
use warnings 'all';

package Tie::Symbol;

# ABSTRACT: Tied interface to the symbol table

use Carp qw(croak);
use base 'Tie::Hash';
no strict 'refs';    ## no critic

our $VERSION = '0.001';    # VERSION

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

sub _globtype {
    my $glob = shift;
    my %R;
    foreach my $type (qw(ARRAY HASH CODE SCALAR)) {
        my $ref = *{$glob}{$type};
        return $ref if $ref;
    }
}

use namespace::clean;

sub TIEHASH {
    my ( $class, $namespace ) = @_;

    $namespace //= 'main';

    my $classname = ref $class || $class;

    my $self = { ns => "$namespace", };

    bless $self => $classname;
}

sub FETCH {
    my ( $self, $name, $force ) = @_;
    return $self->{$name} if ( not $force and scalar caller eq __PACKAGE__ );
    my $namespace = $self->namespace;
    if ( my ( $sigil, $label ) = ( $name =~ m{^([\$\@\%\&])(.+)$} ) ) {
        my $type     = $sigils{$sigil};
        my $symbol   = *{"${namespace}::${label}"} // return;
        my $referent = *{$symbol}{$type} // return;
        return $referent;
    }
    else {
        return if $namespace eq 'main' and $name eq 'main';
        return $self->new("${namespace}::${name}");
    }
}

sub FIRSTKEY {
    my $self       = shift;
    my $notnextkey = shift;
    my $namespace  = $self->namespace;
    my $base       = *{"${namespace}::"};
    my @symbols;
    foreach my $key ( keys %$base ) {
        if ( $key =~ m{^(.+)::$} ) {
            push @symbols => $1;
        }
        else {
            my $symbol = *{"${namespace}::${key}"};
            my $ref = _globtype($symbol) // croak "not a valid symbol: $symbol";
            next unless exists $sigils{ ref($ref) };
            my $name = $sigils{ ref($ref) } . $key;
            push @symbols => $name;
        }
    }
    $self->{symbols} = [ sort @symbols ];
    $self->NEXTKEY unless $notnextkey;
}

sub NEXTKEY {
    my $self = shift;
    shift @{ $self->{symbols} };
}

sub EXISTS {
    my ( $self, $key ) = @_;
    defined $self->FETCH( $key, 1 );
}

sub STORE {
    my $self = shift;
    my $name = shift;
    return ( $self->{$name} = shift ) if ( scalar caller eq __PACKAGE__ );
    my $namespace = $self->namespace;
    if ( my ( $sigil, $label ) = ( $name =~ m{^([\$\@\%\&])(.+)$} ) ) {
        my $ref = shift;
        unless ( ref $ref ) {
            croak "cannot assign unreferenced thing to $sigil$label";
        }