view release on metacpan or  search on metacpan

local/lib/perl5/Package/Stash/PP.pm  view on Meta::CPAN

package Package::Stash::PP;
use strict;
use warnings;
# ABSTRACT: Pure perl implementation of the Package::Stash API

our $VERSION = '0.40';

use B;
use Carp qw(confess);
use Scalar::Util qw(blessed reftype weaken);
use Symbol;
# before 5.12, assigning to the ISA glob would make it lose its magical ->isa
# powers
use constant BROKEN_ISA_ASSIGNMENT => ($] < 5.012);
# before 5.10, stashes don't ever seem to drop to a refcount of zero, so
# weakening them isn't helpful
use constant BROKEN_WEAK_STASH     => ($] < 5.010);
# before 5.10, the scalar slot was always treated as existing if the
# glob existed
use constant BROKEN_SCALAR_INITIALIZATION => ($] < 5.010);
# add_method on anon stashes triggers rt.perl #1804 otherwise
# fixed in perl commit v5.13.3-70-g0fe688f
use constant BROKEN_GLOB_ASSIGNMENT => ($] < 5.013004);
# pre-5.10, ->isa lookups were cached in the ::ISA::CACHE:: slot
use constant HAS_ISA_CACHE => ($] < 5.010);

#pod =head1 SYNOPSIS
#pod
#pod   use Package::Stash;
#pod
#pod =head1 DESCRIPTION
#pod
#pod This is a backend for L<Package::Stash> implemented in pure perl, for those without a compiler or who would like to use this inline in scripts.
#pod
#pod =cut

sub new {
    my $class = shift;
    my ($package) = @_;

    if (!defined($package) || (ref($package) && reftype($package) ne 'HASH')) {
        confess "Package::Stash->new must be passed the name of the "
              . "package to access";
    }
    elsif (ref($package) && reftype($package) eq 'HASH') {
        confess "The PP implementation of Package::Stash does not support "
              . "anonymous stashes before perl 5.14"
            if BROKEN_GLOB_ASSIGNMENT;

        return bless {
            'namespace' => $package,
        }, $class;
    }
    elsif ($package =~ /\A[0-9A-Z_a-z]+(?:::[0-9A-Z_a-z]+)*\z/) {
        return bless {
            'package' => $package,
        }, $class;
    }
    else {
        confess "$package is not a module name";
    }

}

sub name {
    confess "Can't call name as a class method"
        unless blessed($_[0]);
    confess "Can't get the name of an anonymous package"
        unless defined($_[0]->{package});
    return $_[0]->{package};
}

sub namespace {
    confess "Can't call namespace as a class method"
        unless blessed($_[0]);

    if (BROKEN_WEAK_STASH) {
        no strict 'refs';
        return \%{$_[0]->name . '::'};
    }
    else {
        return $_[0]->{namespace} if defined $_[0]->{namespace};

        {
            no strict 'refs';
            $_[0]->{namespace} = \%{$_[0]->name . '::'};
        }

        weaken($_[0]->{namespace});

        return $_[0]->{namespace};
    }
}

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

    sub _deconstruct_variable_name {
        my ($variable) = @_;

        my @ret;
        if (ref($variable) eq 'HASH') {
            @ret = @{$variable}{qw[name sigil type]};
        }
        else {
            (defined $variable && length $variable)
                || confess "You must pass a variable name";

            my $sigil = substr($variable, 0, 1, '');

            if (exists $SIGIL_MAP{$sigil}) {
                @ret = ($variable, $sigil, $SIGIL_MAP{$sigil});
            }
            else {
                @ret = ("${sigil}${variable}", '', $SIGIL_MAP{''});
            }
        }

        # XXX in pure perl, this will access things in inner packages,
        # in xs, this will segfault - probably look more into this at
        # some point
        ($ret[0] !~ /::/)
            || confess "Variable names may not contain ::";

        return @ret;
    }
}

sub _valid_for_type {
    my ($value, $type) = @_;
    if ($type eq 'HASH' || $type eq 'ARRAY'
     || $type eq 'IO'   || $type eq 'CODE') {
        return reftype($value) eq $type;
    }
    else {
        my $ref = reftype($value);
        return !defined($ref) || $ref eq 'SCALAR' || $ref eq 'REF' || $ref eq 'LVALUE' || $ref eq 'REGEXP' || $ref eq 'VSTRING';
    }
}

sub add_symbol {
    my ($self, $variable, $initial_value, %opts) = @_;