-package Package::Stash;
+package Package::Stash::PP;
use strict;
use warnings;
-# ABSTRACT: routines for manipulating stashes
+# ABSTRACT: pure perl implementation of the Package::Stash API
use Carp qw(confess);
-use Scalar::Util qw(reftype);
+use Scalar::Util qw(blessed reftype);
use Symbol;
# before 5.12, assigning to the ISA glob would make it lose its magical ->isa
# powers
=head1 SYNOPSIS
- my $stash = Package::Stash->new('Foo');
- $stash->add_package_symbol('%foo', {bar => 1});
- # $Foo::foo{bar} == 1
- $stash->has_package_symbol('$foo') # false
- my $namespace = $stash->namespace;
- *{ $namespace->{foo} }{HASH} # {bar => 1}
+ use Package::Stash;
=head1 DESCRIPTION
-Manipulating stashes (Perl's symbol tables) is occasionally necessary, but
-incredibly messy, and easy to get wrong. This module hides all of that behind a
-simple API.
-
-NOTE: Most methods in this class require a variable specification that includes
-a sigil. If this sigil is absent, it is assumed to represent the IO slot.
-
-=method new $package_name
-
-Creates a new C<Package::Stash> object, for the package given as the only
-argument.
+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.
=cut
}, $class;
}
-=method name
-
-Returns the name of the package that this object represents.
-
-=cut
-
sub name {
+ confess "Can't call name as a class method"
+ unless blessed($_[0]);
return $_[0]->{package};
}
-=method namespace
-
-Returns the raw stash itself.
-
-=cut
-
sub namespace {
+ confess "Can't call namespace as a class method"
+ unless blessed($_[0]);
return $_[0]->{namespace};
}
}
}
-=method add_package_symbol $variable $value %opts
-
-Adds a new package symbol, for the symbol given as C<$variable>, and optionally
-gives it an initial value of C<$value>. C<$variable> should be the name of
-variable including the sigil, so
-
- Package::Stash->new('Foo')->add_package_symbol('%foo')
-
-will create C<%Foo::foo>.
-
-Valid options (all optional) are C<filename>, C<first_line_num>, and
-C<last_line_num>.
-
-C<$opts{filename}>, C<$opts{first_line_num}>, and C<$opts{last_line_num}> can
-be used to indicate where the symbol should be regarded as having been defined.
-Currently these values are only used if the symbol is a subroutine ('C<&>'
-sigil) and only if C<$^P & 0x10> is true, in which case the special C<%DB::sub>
-hash is updated to record the values of C<filename>, C<first_line_num>, and
-C<last_line_num> for the subroutine. If these are not passed, their values are
-inferred (as much as possible) from C<caller> information.
-
-This is especially useful for debuggers and profilers, which use C<%DB::sub> to
-determine where the source code for a subroutine can be found. See
-L<http://perldoc.perl.org/perldebguts.html#Debugger-Internals> for more
-information about C<%DB::sub>.
-
-=cut
-
sub _valid_for_type {
my $self = shift;
my ($value, $type) = @_;
}
}
-sub add_package_symbol {
+sub add_symbol {
my ($self, $variable, $initial_value, %opts) = @_;
my ($name, $sigil, $type) = ref $variable eq 'HASH'
*{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value;
}
-=method remove_package_glob $name
-
-Removes all package variables with the given name, regardless of sigil.
-
-=cut
-
-sub remove_package_glob {
+sub remove_glob {
my ($self, $name) = @_;
no strict 'refs';
delete ${$self->name . '::'}{$name};
}
-# ... these functions deal with stuff on the namespace level
-
-=method has_package_symbol $variable
-
-Returns whether or not the given package variable (including sigil) exists.
-
-=cut
-
-sub has_package_symbol {
+sub has_symbol {
my ($self, $variable) = @_;
my ($name, $sigil, $type) = ref $variable eq 'HASH'
}
}
-=method get_package_symbol $variable
-
-Returns the value of the given package variable (including sigil).
-
-=cut
-
-sub get_package_symbol {
+sub get_symbol {
my ($self, $variable, %opts) = @_;
my ($name, $sigil, $type) = ref $variable eq 'HASH'
if ($opts{vivify}) {
if ($type eq 'ARRAY') {
if (BROKEN_ISA_ASSIGNMENT) {
- $self->add_package_symbol(
+ $self->add_symbol(
$variable,
$name eq 'ISA' ? () : ([])
);
}
else {
- $self->add_package_symbol($variable, []);
+ $self->add_symbol($variable, []);
}
}
elsif ($type eq 'HASH') {
- $self->add_package_symbol($variable, {});
+ $self->add_symbol($variable, {});
}
elsif ($type eq 'SCALAR') {
- $self->add_package_symbol($variable);
+ $self->add_symbol($variable);
}
elsif ($type eq 'IO') {
- $self->add_package_symbol($variable, Symbol::geniosym);
+ $self->add_symbol($variable, Symbol::geniosym);
}
elsif ($type eq 'CODE') {
confess "Don't know how to vivify CODE variables";
# this, referencing the coderef at the end of this function
# will cause perl to auto-vivify a stub coderef in the slot,
# which isn't what we want
- $self->add_package_symbol($variable);
+ $self->add_symbol($variable);
}
}
}
}
}
-=method get_or_add_package_symbol $variable
-
-Like C<get_package_symbol>, except that it will return an empty hashref or
-arrayref if the variable doesn't exist.
-
-=cut
-
-sub get_or_add_package_symbol {
+sub get_or_add_symbol {
my $self = shift;
- $self->get_package_symbol(@_, vivify => 1);
+ $self->get_symbol(@_, vivify => 1);
}
-=method remove_package_symbol $variable
-
-Removes the package variable described by C<$variable> (which includes the
-sigil); other variables with the same name but different sigils will be
-untouched.
-
-=cut
-
-sub remove_package_symbol {
+sub remove_symbol {
my ($self, $variable) = @_;
my ($name, $sigil, $type) = ref $variable eq 'HASH'
my ($scalar, $array, $hash, $code, $io);
if ($type eq 'SCALAR') {
- $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
- $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
- $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
- $io = $self->get_package_symbol($io_desc) if $self->has_package_symbol($io_desc);
+ $array = $self->get_symbol($array_desc) if $self->has_symbol($array_desc);
+ $hash = $self->get_symbol($hash_desc) if $self->has_symbol($hash_desc);
+ $code = $self->get_symbol($code_desc) if $self->has_symbol($code_desc);
+ $io = $self->get_symbol($io_desc) if $self->has_symbol($io_desc);
}
elsif ($type eq 'ARRAY') {
- $scalar = $self->get_package_symbol($scalar_desc);
- $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
- $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
- $io = $self->get_package_symbol($io_desc) if $self->has_package_symbol($io_desc);
+ $scalar = $self->get_symbol($scalar_desc);
+ $hash = $self->get_symbol($hash_desc) if $self->has_symbol($hash_desc);
+ $code = $self->get_symbol($code_desc) if $self->has_symbol($code_desc);
+ $io = $self->get_symbol($io_desc) if $self->has_symbol($io_desc);
}
elsif ($type eq 'HASH') {
- $scalar = $self->get_package_symbol($scalar_desc);
- $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
- $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
- $io = $self->get_package_symbol($io_desc) if $self->has_package_symbol($io_desc);
+ $scalar = $self->get_symbol($scalar_desc);
+ $array = $self->get_symbol($array_desc) if $self->has_symbol($array_desc);
+ $code = $self->get_symbol($code_desc) if $self->has_symbol($code_desc);
+ $io = $self->get_symbol($io_desc) if $self->has_symbol($io_desc);
}
elsif ($type eq 'CODE') {
- $scalar = $self->get_package_symbol($scalar_desc);
- $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
- $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
- $io = $self->get_package_symbol($io_desc) if $self->has_package_symbol($io_desc);
+ $scalar = $self->get_symbol($scalar_desc);
+ $array = $self->get_symbol($array_desc) if $self->has_symbol($array_desc);
+ $hash = $self->get_symbol($hash_desc) if $self->has_symbol($hash_desc);
+ $io = $self->get_symbol($io_desc) if $self->has_symbol($io_desc);
}
elsif ($type eq 'IO') {
- $scalar = $self->get_package_symbol($scalar_desc);
- $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
- $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
- $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
+ $scalar = $self->get_symbol($scalar_desc);
+ $array = $self->get_symbol($array_desc) if $self->has_symbol($array_desc);
+ $hash = $self->get_symbol($hash_desc) if $self->has_symbol($hash_desc);
+ $code = $self->get_symbol($code_desc) if $self->has_symbol($code_desc);
}
else {
confess "This should never ever ever happen";
}
- $self->remove_package_glob($name);
+ $self->remove_glob($name);
- $self->add_package_symbol($scalar_desc => $scalar);
- $self->add_package_symbol($array_desc => $array) if defined $array;
- $self->add_package_symbol($hash_desc => $hash) if defined $hash;
- $self->add_package_symbol($code_desc => $code) if defined $code;
- $self->add_package_symbol($io_desc => $io) if defined $io;
+ $self->add_symbol($scalar_desc => $scalar);
+ $self->add_symbol($array_desc => $array) if defined $array;
+ $self->add_symbol($hash_desc => $hash) if defined $hash;
+ $self->add_symbol($code_desc => $code) if defined $code;
+ $self->add_symbol($io_desc => $io) if defined $io;
}
-=method list_all_package_symbols $type_filter
-
-Returns a list of package variable names in the package, without sigils. If a
-C<type_filter> is passed, it is used to select package variables of a given
-type, where valid types are the slots of a typeglob ('SCALAR', 'CODE', 'HASH',
-etc). Note that if the package contained any C<BEGIN> blocks, perl will leave
-an empty typeglob in the C<BEGIN> slot, so this will show up if no filter is
-used (and similarly for C<INIT>, C<END>, etc).
-
-=cut
-
-sub list_all_package_symbols {
+sub list_all_symbols {
my ($self, $type_filter) = @_;
my $namespace = $self->namespace;
}
}
+sub get_all_symbols {
+ my ($self, $type_filter) = @_;
+
+ my $namespace = $self->namespace;
+ return { %{$namespace} } unless defined $type_filter;
+
+ return {
+ map { $_ => $self->get_symbol({name => $_, type => $type_filter}) }
+ $self->list_all_symbols($type_filter)
+ }
+}
+
=head1 BUGS
-No known bugs.
+=over 4
+
+=item * Scalar slots are only considered to exist if they are defined
+
+This is due to a shortcoming within perl itself. See
+L<perlref/Making References> point 7 for more information.
+
+=item * remove_symbol also replaces the associated typeglob
+
+This can cause unexpected behavior when doing manipulation at compile time -
+removing subroutines will still allow them to be called from within the package
+as subroutines (although they will not be available as methods). This can be
+considered a feature in some cases (this is how L<namespace::clean> works, for
+instance), but should not be relied upon - use C<remove_glob> directly if you
+want this behavior.
+
+=back
Please report any bugs through RT: email
C<bug-package-stash at rt.cpan.org>, or browse to
+#!/usr/bin/env perl
use strict;
use warnings;
-
+use lib 't/lib';
use Test::More;
use Test::Fatal;
use Package::Stash;
-ok(exception { Package::Stash->name }, q{... can't call name() as a class method});
+like(exception { Package::Stash->name }, qr/Can't call name as a class method/,
+ q{... can't call name() as a class method});
{
package Foo;
my $foo_stash = Package::Stash->new('Foo');
ok(!defined($Foo::{foo}), '... the %foo slot has not been created yet');
-ok(!$foo_stash->has_package_symbol('%foo'), '... the object agrees');
+ok(!$foo_stash->has_symbol('%foo'), '... the object agrees');
ok(!defined($Foo::{foo}), '... checking doesn\' vivify');
-ok(!exception {
- $foo_stash->add_package_symbol('%foo' => { one => 1 });
-}, '... created %Foo::foo successfully');
+is(exception {
+ $foo_stash->add_symbol('%foo' => { one => 1 });
+}, undef, '... created %Foo::foo successfully');
# ... scalar should NOT be created here
-ok(!$foo_stash->has_package_symbol('$foo'), '... SCALAR shouldnt have been created too');
-ok(!$foo_stash->has_package_symbol('@foo'), '... ARRAY shouldnt have been created too');
-ok(!$foo_stash->has_package_symbol('&foo'), '... CODE shouldnt have been created too');
+ok(!$foo_stash->has_symbol('$foo'), '... SCALAR shouldnt have been created too');
+ok(!$foo_stash->has_symbol('@foo'), '... ARRAY shouldnt have been created too');
+ok(!$foo_stash->has_symbol('&foo'), '... CODE shouldnt have been created too');
ok(defined($Foo::{foo}), '... the %foo slot was created successfully');
-ok($foo_stash->has_package_symbol('%foo'), '... the meta agrees');
+ok($foo_stash->has_symbol('%foo'), '... the meta agrees');
# check the value ...
is(${'Foo::foo'}{one}, 1, '... our %foo was initialized correctly');
}
-my $foo = $foo_stash->get_package_symbol('%foo');
+my $foo = $foo_stash->get_symbol('%foo');
is_deeply({ one => 1 }, $foo, '... got the right package variable back');
# ... make sure changes propogate up
{
no strict 'refs';
- is(\%{'Foo::foo'}, $foo_stash->get_package_symbol('%foo'), '... our %foo is the same as the metas');
+ is(\%{'Foo::foo'}, $foo_stash->get_symbol('%foo'), '... our %foo is the same as the metas');
ok(exists ${'Foo::foo'}{two}, '... our %foo was updated correctly');
is(${'Foo::foo'}{two}, 2, '... our %foo was updated correctly');
ok(!defined($Foo::{bar}), '... the @bar slot has not been created yet');
-ok(!exception {
- $foo_stash->add_package_symbol('@bar' => [ 1, 2, 3 ]);
-}, '... created @Foo::bar successfully');
+is(exception {
+ $foo_stash->add_symbol('@bar' => [ 1, 2, 3 ]);
+}, undef, '... created @Foo::bar successfully');
ok(defined($Foo::{bar}), '... the @bar slot was created successfully');
-ok($foo_stash->has_package_symbol('@bar'), '... the meta agrees');
+ok($foo_stash->has_symbol('@bar'), '... the meta agrees');
# ... why does this not work ...
-ok(!$foo_stash->has_package_symbol('$bar'), '... SCALAR shouldnt have been created too');
-ok(!$foo_stash->has_package_symbol('%bar'), '... HASH shouldnt have been created too');
-ok(!$foo_stash->has_package_symbol('&bar'), '... CODE shouldnt have been created too');
+ok(!$foo_stash->has_symbol('$bar'), '... SCALAR shouldnt have been created too');
+ok(!$foo_stash->has_symbol('%bar'), '... HASH shouldnt have been created too');
+ok(!$foo_stash->has_symbol('&bar'), '... CODE shouldnt have been created too');
# check the value itself
ok(!defined($Foo::{baz}), '... the $baz slot has not been created yet');
-ok(!exception {
- $foo_stash->add_package_symbol('$baz' => 10);
-}, '... created $Foo::baz successfully');
+is(exception {
+ $foo_stash->add_symbol('$baz' => 10);
+}, undef, '... created $Foo::baz successfully');
ok(defined($Foo::{baz}), '... the $baz slot was created successfully');
-ok($foo_stash->has_package_symbol('$baz'), '... the meta agrees');
+ok($foo_stash->has_symbol('$baz'), '... the meta agrees');
-ok(!$foo_stash->has_package_symbol('@baz'), '... ARRAY shouldnt have been created too');
-ok(!$foo_stash->has_package_symbol('%baz'), '... HASH shouldnt have been created too');
-ok(!$foo_stash->has_package_symbol('&baz'), '... CODE shouldnt have been created too');
+ok(!$foo_stash->has_symbol('@baz'), '... ARRAY shouldnt have been created too');
+ok(!$foo_stash->has_symbol('%baz'), '... HASH shouldnt have been created too');
+ok(!$foo_stash->has_symbol('&baz'), '... CODE shouldnt have been created too');
-is(${$foo_stash->get_package_symbol('$baz')}, 10, '... got the right value back');
+is(${$foo_stash->get_symbol('$baz')}, 10, '... got the right value back');
{
no strict 'refs';
${'Foo::baz'} = 1;
is(${'Foo::baz'}, 1, '... our $baz was assigned to correctly');
- is(${$foo_stash->get_package_symbol('$baz')}, 1, '... the meta agrees');
+ is(${$foo_stash->get_symbol('$baz')}, 1, '... the meta agrees');
}
# ----------------------------------------------------------------------
ok(!defined($Foo::{funk}), '... the &funk slot has not been created yet');
-ok(!exception {
- $foo_stash->add_package_symbol('&funk' => sub { "Foo::funk" });
-}, '... created &Foo::funk successfully');
+is(exception {
+ $foo_stash->add_symbol('&funk' => sub { "Foo::funk" });
+}, undef, '... created &Foo::funk successfully');
ok(defined($Foo::{funk}), '... the &funk slot was created successfully');
-ok($foo_stash->has_package_symbol('&funk'), '... the meta agrees');
+ok($foo_stash->has_symbol('&funk'), '... the meta agrees');
-ok(!$foo_stash->has_package_symbol('$funk'), '... SCALAR shouldnt have been created too');
-ok(!$foo_stash->has_package_symbol('@funk'), '... ARRAY shouldnt have been created too');
-ok(!$foo_stash->has_package_symbol('%funk'), '... HASH shouldnt have been created too');
+ok(!$foo_stash->has_symbol('$funk'), '... SCALAR shouldnt have been created too');
+ok(!$foo_stash->has_symbol('@funk'), '... ARRAY shouldnt have been created too');
+ok(!$foo_stash->has_symbol('%funk'), '... HASH shouldnt have been created too');
{
no strict 'refs';
my $ARRAY = [ 1, 2, 3 ];
my $CODE = sub { "Foo::foo" };
-ok(!exception {
- $foo_stash->add_package_symbol('@foo' => $ARRAY);
-}, '... created @Foo::foo successfully');
+is(exception {
+ $foo_stash->add_symbol('@foo' => $ARRAY);
+}, undef, '... created @Foo::foo successfully');
-ok($foo_stash->has_package_symbol('@foo'), '... the @foo slot was added successfully');
-is($foo_stash->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo');
+ok($foo_stash->has_symbol('@foo'), '... the @foo slot was added successfully');
+is($foo_stash->get_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo');
-ok(!exception {
- $foo_stash->add_package_symbol('&foo' => $CODE);
-}, '... created &Foo::foo successfully');
+is(exception {
+ $foo_stash->add_symbol('&foo' => $CODE);
+}, undef, '... created &Foo::foo successfully');
-ok($foo_stash->has_package_symbol('&foo'), '... the meta agrees');
-is($foo_stash->get_package_symbol('&foo'), $CODE, '... got the right value for &Foo::foo');
+ok($foo_stash->has_symbol('&foo'), '... the meta agrees');
+is($foo_stash->get_symbol('&foo'), $CODE, '... got the right value for &Foo::foo');
-ok(!exception {
- $foo_stash->add_package_symbol('$foo' => 'Foo::foo');
-}, '... created $Foo::foo successfully');
+is(exception {
+ $foo_stash->add_symbol('$foo' => 'Foo::foo');
+}, undef, '... created $Foo::foo successfully');
-ok($foo_stash->has_package_symbol('$foo'), '... the meta agrees');
-my $SCALAR = $foo_stash->get_package_symbol('$foo');
+ok($foo_stash->has_symbol('$foo'), '... the meta agrees');
+my $SCALAR = $foo_stash->get_symbol('$foo');
is($$SCALAR, 'Foo::foo', '... got the right scalar value back');
{
is(${'Foo::foo'}, 'Foo::foo', '... got the right value from the scalar');
}
-ok(!exception {
- $foo_stash->remove_package_symbol('%foo');
-}, '... removed %Foo::foo successfully');
+is(exception {
+ $foo_stash->remove_symbol('%foo');
+}, undef, '... removed %Foo::foo successfully');
-ok(!$foo_stash->has_package_symbol('%foo'), '... the %foo slot was removed successfully');
-ok($foo_stash->has_package_symbol('@foo'), '... the @foo slot still exists');
-ok($foo_stash->has_package_symbol('&foo'), '... the &foo slot still exists');
-ok($foo_stash->has_package_symbol('$foo'), '... the $foo slot still exists');
+ok(!$foo_stash->has_symbol('%foo'), '... the %foo slot was removed successfully');
+ok($foo_stash->has_symbol('@foo'), '... the @foo slot still exists');
+ok($foo_stash->has_symbol('&foo'), '... the &foo slot still exists');
+ok($foo_stash->has_symbol('$foo'), '... the $foo slot still exists');
-is($foo_stash->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo');
-is($foo_stash->get_package_symbol('&foo'), $CODE, '... got the right value for &Foo::foo');
-is($foo_stash->get_package_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo');
+is($foo_stash->get_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo');
+is($foo_stash->get_symbol('&foo'), $CODE, '... got the right value for &Foo::foo');
+is($foo_stash->get_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo');
{
no strict 'refs';
ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed');
}
-ok(!exception {
- $foo_stash->remove_package_symbol('&foo');
-}, '... removed &Foo::foo successfully');
+is(exception {
+ $foo_stash->remove_symbol('&foo');
+}, undef, '... removed &Foo::foo successfully');
-ok(!$foo_stash->has_package_symbol('&foo'), '... the &foo slot no longer exists');
+ok(!$foo_stash->has_symbol('&foo'), '... the &foo slot no longer exists');
-ok($foo_stash->has_package_symbol('@foo'), '... the @foo slot still exists');
-ok($foo_stash->has_package_symbol('$foo'), '... the $foo slot still exists');
+ok($foo_stash->has_symbol('@foo'), '... the @foo slot still exists');
+ok($foo_stash->has_symbol('$foo'), '... the $foo slot still exists');
-is($foo_stash->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo');
-is($foo_stash->get_package_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo');
+is($foo_stash->get_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo');
+is($foo_stash->get_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo');
{
no strict 'refs';
ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed');
}
-ok(!exception {
- $foo_stash->remove_package_symbol('$foo');
-}, '... removed $Foo::foo successfully');
+is(exception {
+ $foo_stash->remove_symbol('$foo');
+}, undef, '... removed $Foo::foo successfully');
-ok(!$foo_stash->has_package_symbol('$foo'), '... the $foo slot no longer exists');
+ok(!$foo_stash->has_symbol('$foo'), '... the $foo slot no longer exists');
-ok($foo_stash->has_package_symbol('@foo'), '... the @foo slot still exists');
+ok($foo_stash->has_symbol('@foo'), '... the @foo slot still exists');
-is($foo_stash->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo');
+is($foo_stash->get_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo');
{
no strict 'refs';
ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed');
}
+{
+ my $syms = $foo_stash->get_all_symbols;
+ is_deeply(
+ [ sort keys %{ $syms } ],
+ [ sort $foo_stash->list_all_symbols ],
+ '... the fetched symbols are the same as the listed ones'
+ );
+}
+
+{
+ my $syms = $foo_stash->get_all_symbols('CODE');
+
+ is_deeply(
+ [ sort keys %{ $syms } ],
+ [ sort $foo_stash->list_all_symbols('CODE') ],
+ '... the fetched symbols are the same as the listed ones'
+ );
+
+ foreach my $symbol (keys %{ $syms }) {
+ is($syms->{$symbol}, $foo_stash->get_symbol('&' . $symbol), '... got the right symbol');
+ }
+}
+
+{
+ $foo_stash->add_symbol('%zork');
+
+ my $syms = $foo_stash->get_all_symbols('HASH');
+
+ is_deeply(
+ [ sort keys %{ $syms } ],
+ [ sort $foo_stash->list_all_symbols('HASH') ],
+ '... the fetched symbols are the same as the listed ones'
+ );
+
+ foreach my $symbol (keys %{ $syms }) {
+ is($syms->{$symbol}, $foo_stash->get_symbol('%' . $symbol), '... got the right symbol');
+ }
+
+ no warnings 'once';
+ is_deeply(
+ $syms,
+ { zork => \%Foo::zork },
+ "got the right ones",
+ );
+}
+
# check some errors
-ok(exception {
- $foo_stash->add_package_symbol('@bar', {})
-}, "can't initialize a slot with the wrong type of value");
+like(exception {
+ $foo_stash->add_symbol('@bar', {})
+}, qr/HASH.*is not of type ARRAY/, "can't initialize a slot with the wrong type of value");
-ok(exception {
- $foo_stash->add_package_symbol('bar', [])
-}, "can't initialize a slot with the wrong type of value");
+like(exception {
+ $foo_stash->add_symbol('bar', [])
+}, qr/ARRAY.*is not of type IO/, "can't initialize a slot with the wrong type of value");
-ok(exception {
- $foo_stash->add_package_symbol('$bar', sub { })
-}, "can't initialize a slot with the wrong type of value");
+like(exception {
+ $foo_stash->add_symbol('$bar', sub { })
+}, qr/CODE.*is not of type SCALAR/, "can't initialize a slot with the wrong type of value");
{
package Bar;
open *foo, '<', $0;
}
-ok(exception {
- $foo_stash->add_package_symbol('$bar', *Bar::foo{IO})
-}, "can't initialize a slot with the wrong type of value");
+like(exception {
+ $foo_stash->add_symbol('$bar', *Bar::foo{IO})
+}, qr/IO.*is not of type SCALAR/, "can't initialize a slot with the wrong type of value");
# check compile time manipulation
our %foo = (baz => 1);
sub foo { }
open *foo, '<', $0;
- BEGIN { Package::Stash->new(__PACKAGE__)->remove_package_symbol('&foo') }
+ BEGIN { Package::Stash->new(__PACKAGE__)->remove_symbol('&foo') }
}
{
my $stash = Package::Stash->new('Baz');
- is(${ $stash->get_package_symbol('$foo') }, 23, "got \$foo");
- is_deeply($stash->get_package_symbol('@foo'), ['bar'], "got \@foo");
- is_deeply($stash->get_package_symbol('%foo'), {baz => 1}, "got \%foo");
- ok(!$stash->has_package_symbol('&foo'), "got \&foo");
- is($stash->get_package_symbol('foo'), *Baz::foo{IO}, "got foo");
+ is(${ $stash->get_symbol('$foo') }, 23, "got \$foo");
+ is_deeply($stash->get_symbol('@foo'), ['bar'], "got \@foo");
+ is_deeply($stash->get_symbol('%foo'), {baz => 1}, "got \%foo");
+ ok(!$stash->has_symbol('&foo'), "got \&foo");
+ is($stash->get_symbol('foo'), *Baz::foo{IO}, "got foo");
}
{
for my $sym ( sort keys %expect ) {
is_deeply(
- $stash->get_package_symbol($sym),
+ $stash->get_symbol($sym),
$expect{$sym},
"got expected value for $sym"
);
}
- $stash->add_package_symbol('%bar' => {x => 42});
+ $stash->add_symbol('%bar' => {x => 42});
$expect{'%bar'} = {x => 42};
for my $sym ( sort keys %expect ) {
is_deeply(
- $stash->get_package_symbol($sym),
+ $stash->get_symbol($sym),
$expect{$sym},
"got expected value for $sym"
);
}
- $stash->add_package_symbol('%bar' => {x => 43});
+ $stash->add_symbol('%bar' => {x => 43});
$expect{'%bar'} = {x => 43};
for my $sym ( sort keys %expect ) {
is_deeply(
- $stash->get_package_symbol($sym),
+ $stash->get_symbol($sym),
$expect{$sym},
"got expected value for $sym"
);
{
package Quuux;
- our $foo = 1;
+ our $foo;
our @foo;
our @bar;
our %baz;
{
my $quuux = Package::Stash->new('Quuux');
is_deeply(
- [sort $quuux->list_all_package_symbols],
+ [sort $quuux->list_all_symbols],
[qw(BEGIN bar baz foo quuuux quuux quux)],
- "list_all_package_symbols",
+ "list_all_symbols",
);
+ { local $TODO = ($] < 5.010 || $Package::Stash::IMPLEMENTATION eq 'PP')
+ ? "undef scalars aren't visible on 5.8, or from pure perl at all"
+ : undef;
is_deeply(
- [sort $quuux->list_all_package_symbols('SCALAR')],
+ [sort $quuux->list_all_symbols('SCALAR')],
[qw(foo)],
- "list_all_package_symbols SCALAR",
+ "list_all_symbols SCALAR",
);
+ }
is_deeply(
- [sort $quuux->list_all_package_symbols('ARRAY')],
+ [sort $quuux->list_all_symbols('ARRAY')],
[qw(bar foo)],
- "list_all_package_symbols ARRAY",
+ "list_all_symbols ARRAY",
);
is_deeply(
- [sort $quuux->list_all_package_symbols('HASH')],
+ [sort $quuux->list_all_symbols('HASH')],
[qw(baz)],
- "list_all_package_symbols HASH",
+ "list_all_symbols HASH",
);
is_deeply(
- [sort $quuux->list_all_package_symbols('CODE')],
+ [sort $quuux->list_all_symbols('CODE')],
[qw(baz quuuux quuux quux)],
- "list_all_package_symbols CODE",
+ "list_all_symbols CODE",
);
}
+#!/usr/bin/env perl
use strict;
use warnings;
-
+use lib 't/lib';
use Test::More;
use Test::Fatal;
return $self;
}
- sub add_package_symbol {
+ sub add_symbol {
my ($self, $variable, $initial_value) = @_;
- my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable);
+ (my $name = $variable) =~ s/^[\$\@\%\&]//;
my $glob = gensym();
*{$glob} = $initial_value if defined $initial_value;
isa_ok($foo_stash, 'Package::Stash');
ok(!defined($Foo::{foo}), '... the %foo slot has not been created yet');
-ok(!$foo_stash->has_package_symbol('%foo'), '... the foo_stash agrees');
+ok(!$foo_stash->has_symbol('%foo'), '... the foo_stash agrees');
-ok(!exception {
- $foo_stash->add_package_symbol('%foo' => { one => 1 });
-}, '... the %foo symbol is created succcessfully');
+is(exception {
+ $foo_stash->add_symbol('%foo' => { one => 1 });
+}, undef, '... the %foo symbol is created succcessfully');
ok(!defined($Foo::{foo}), '... the %foo slot has not been created in the actual Foo package');
-ok($foo_stash->has_package_symbol('%foo'), '... the foo_stash agrees');
+ok($foo_stash->has_symbol('%foo'), '... the foo_stash agrees');
-my $foo = $foo_stash->get_package_symbol('%foo');
+my $foo = $foo_stash->get_symbol('%foo');
is_deeply({ one => 1 }, $foo, '... got the right package variable back');
$foo->{two} = 2;
-is($foo, $foo_stash->get_package_symbol('%foo'), '... our %foo is the same as the foo_stashs');
+is($foo, $foo_stash->get_symbol('%foo'), '... our %foo is the same as the foo_stashs');
ok(!defined($Foo::{bar}), '... the @bar slot has not been created yet');
-ok(!exception {
- $foo_stash->add_package_symbol('@bar' => [ 1, 2, 3 ]);
-}, '... created @Foo::bar successfully');
+is(exception {
+ $foo_stash->add_symbol('@bar' => [ 1, 2, 3 ]);
+}, undef, '... created @Foo::bar successfully');
ok(!defined($Foo::{bar}), '... the @bar slot has still not been created');
ok(!defined($Foo::{baz}), '... the %baz slot has not been created yet');
-ok(!exception {
- $foo_stash->add_package_symbol('%baz');
-}, '... created %Foo::baz successfully');
+is(exception {
+ $foo_stash->add_symbol('%baz');
+}, undef, '... created %Foo::baz successfully');
ok(!defined($Foo::{baz}), '... the %baz slot has still not been created');
#!/usr/bin/env perl
use strict;
use warnings;
+use lib 't/lib';
use Test::More;
use Test::Fatal;
{
my $stash = Package::Stash->new('Foo');
- ok($stash->has_package_symbol('&foo'), "has &foo");
- ok($stash->has_package_symbol('foo'), "has foo");
- $stash->remove_package_symbol('&foo');
- ok(!$stash->has_package_symbol('&foo'), "has &foo");
- ok($stash->has_package_symbol('foo'), "has foo");
+ ok($stash->has_symbol('&foo'), "has &foo");
+ ok($stash->has_symbol('foo'), "has foo");
+ $stash->remove_symbol('&foo');
+ ok(!$stash->has_symbol('&foo'), "has &foo");
+ ok($stash->has_symbol('foo'), "has foo");
}
{
my $stash = Package::Stash->new('Bar');
- ok($stash->has_package_symbol('&bar'), "has &bar");
- ok($stash->has_package_symbol('bar'), "has bar");
- $stash->remove_package_symbol('bar');
- ok($stash->has_package_symbol('&bar'), "has &bar");
- ok(!$stash->has_package_symbol('bar'), "has bar");
+ ok($stash->has_symbol('&bar'), "has &bar");
+ ok($stash->has_symbol('bar'), "has bar");
+ $stash->remove_symbol('bar');
+ ok($stash->has_symbol('&bar'), "has &bar");
+ ok(!$stash->has_symbol('bar'), "has bar");
}
{
my $stash = Package::Stash->new('Baz');
- ok(!exception {
- $stash->add_package_symbol('baz', *Foo::foo{IO});
- }, "can add an IO symbol");
- ok($stash->has_package_symbol('baz'), "has baz");
- is($stash->get_package_symbol('baz'), *Foo::foo{IO}, "got the right baz");
+ is(exception {
+ $stash->add_symbol('baz', *Foo::foo{IO});
+ }, undef, "can add an IO symbol");
+ ok($stash->has_symbol('baz'), "has baz");
+ is($stash->get_symbol('baz'), *Foo::foo{IO}, "got the right baz");
}
done_testing;
#!/usr/bin/env perl
use strict;
use warnings;
+use lib 't/lib';
use Test::More;
use Package::Stash;
+use Scalar::Util;
{
BEGIN {
my $stash = Package::Stash->new('Hash');
- my $val = $stash->get_package_symbol('%foo');
+ my $val = $stash->get_symbol('%foo');
is($val, undef, "got nothing yet");
}
{
}
BEGIN {
my $stash = Package::Stash->new('Hash');
- my $val = $stash->get_package_symbol('%foo');
+ my $val = $stash->get_symbol('%foo');
is(ref($val), 'HASH', "got something");
$val->{bar} = 1;
- is_deeply($stash->get_package_symbol('%foo'), {bar => 1},
+ is_deeply($stash->get_symbol('%foo'), {bar => 1},
"got the right variable");
is_deeply(\%Hash::foo, {bar => 1},
"stash has the right variable");
{
BEGIN {
my $stash = Package::Stash->new('Array');
- my $val = $stash->get_package_symbol('@foo');
+ my $val = $stash->get_symbol('@foo');
is($val, undef, "got nothing yet");
}
{
}
BEGIN {
my $stash = Package::Stash->new('Array');
- my $val = $stash->get_package_symbol('@foo');
+ my $val = $stash->get_symbol('@foo');
is(ref($val), 'ARRAY', "got something");
push @$val, 1;
- is_deeply($stash->get_package_symbol('@foo'), [1],
+ is_deeply($stash->get_symbol('@foo'), [1],
"got the right variable");
is_deeply(\@Array::foo, [1],
"stash has the right variable");
{
BEGIN {
my $stash = Package::Stash->new('Scalar');
- my $val = $stash->get_package_symbol('$foo');
+ my $val = $stash->get_symbol('$foo');
is($val, undef, "got nothing yet");
}
{
}
BEGIN {
my $stash = Package::Stash->new('Scalar');
- my $val = $stash->get_package_symbol('$foo');
+ my $val = $stash->get_symbol('$foo');
is(ref($val), 'SCALAR', "got something");
$$val = 1;
- is_deeply($stash->get_package_symbol('$foo'), \1,
+ is_deeply($stash->get_symbol('$foo'), \1,
"got the right variable");
is($Scalar::foo, 1,
"stash has the right variable");
{
BEGIN {
my $stash = Package::Stash->new('Code');
- my $val = $stash->get_package_symbol('&foo');
+ my $val = $stash->get_symbol('&foo');
is($val, undef, "got nothing yet");
}
{
}
BEGIN {
my $stash = Package::Stash->new('Code');
- my $val = $stash->get_package_symbol('&foo');
+ my $val = $stash->get_symbol('&foo');
is(ref($val), 'CODE', "got something");
is(prototype($val), undef, "got the right variable");
&Scalar::Util::set_prototype($val, '&');
- is($stash->get_package_symbol('&foo'), $val,
+ is($stash->get_symbol('&foo'), $val,
"got the right variable");
- is(prototype($stash->get_package_symbol('&foo')), '&',
+ is(prototype($stash->get_symbol('&foo')), '&',
"got the right variable");
is(prototype(\&Code::foo), '&',
"stash has the right variable");
{
BEGIN {
my $stash = Package::Stash->new('Io');
- my $val = $stash->get_package_symbol('FOO');
+ my $val = $stash->get_symbol('FOO');
is($val, undef, "got nothing yet");
}
{
}
BEGIN {
my $stash = Package::Stash->new('Io');
- my $val = $stash->get_package_symbol('FOO');
+ my $val = $stash->get_symbol('FOO');
isa_ok($val, 'IO');
my $str = "foo";
open $val, '<', \$str;
- is(readline($stash->get_package_symbol('FOO')), "foo",
+ is(readline($stash->get_symbol('FOO')), "foo",
"got the right variable");
- seek($stash->get_package_symbol('FOO'), 0, 0);
+ seek($stash->get_symbol('FOO'), 0, 0);
{
package Io;
::isa_ok(*FOO{IO}, 'IO');
{
my $stash = Package::Stash->new('Hash::Vivify');
- my $val = $stash->get_or_add_package_symbol('%foo');
+ my $val = $stash->get_or_add_symbol('%foo');
is(ref($val), 'HASH', "got something");
$val->{bar} = 1;
- is_deeply($stash->get_or_add_package_symbol('%foo'), {bar => 1},
+ is_deeply($stash->get_or_add_symbol('%foo'), {bar => 1},
"got the right variable");
no warnings 'once';
is_deeply(\%Hash::Vivify::foo, {bar => 1},
{
my $stash = Package::Stash->new('Array::Vivify');
- my $val = $stash->get_or_add_package_symbol('@foo');
+ my $val = $stash->get_or_add_symbol('@foo');
is(ref($val), 'ARRAY', "got something");
push @$val, 1;
- is_deeply($stash->get_or_add_package_symbol('@foo'), [1],
+ is_deeply($stash->get_or_add_symbol('@foo'), [1],
"got the right variable");
no warnings 'once';
is_deeply(\@Array::Vivify::foo, [1],
{
my $stash = Package::Stash->new('Scalar::Vivify');
- my $val = $stash->get_or_add_package_symbol('$foo');
+ my $val = $stash->get_or_add_symbol('$foo');
is(ref($val), 'SCALAR', "got something");
$$val = 1;
- is_deeply($stash->get_or_add_package_symbol('$foo'), \1,
+ is_deeply($stash->get_or_add_symbol('$foo'), \1,
"got the right variable");
no warnings 'once';
is($Scalar::Vivify::foo, 1,
{
BEGIN {
my $stash = Package::Stash->new('Io::Vivify');
- my $val = $stash->get_or_add_package_symbol('FOO');
+ my $val = $stash->get_or_add_symbol('FOO');
isa_ok($val, 'IO');
my $str = "foo";
open $val, '<', \$str;
- is(readline($stash->get_package_symbol('FOO')), "foo",
+ is(readline($stash->get_symbol('FOO')), "foo",
"got the right variable");
- seek($stash->get_package_symbol('FOO'), 0, 0);
+ seek($stash->get_symbol('FOO'), 0, 0);
}
{
package Io::Vivify;
#!/usr/bin/env perl
use strict;
use warnings;
+use lib 't/lib';
use Test::More;
use Package::Stash;
my $stash = Package::Stash->new('Foo');
my @ISA = ('Bar');
-@{$stash->get_or_add_package_symbol('@ISA')} = @ISA;
+@{$stash->get_or_add_symbol('@ISA')} = @ISA;
isa_ok('Foo', 'Bar');
done_testing;
+#!/usr/bin/env perl
use strict;
use warnings;
-
+use lib 't/lib';
use Test::More;
use Test::Fatal;
ok(!defined($Foo::{funk}), '... the &funk slot has not been created yet');
-ok(!exception {
- $foo_stash->add_package_symbol('&funk' => sub { "Foo::funk", __LINE__ });
-}, '... created &Foo::funk successfully');
+is(exception {
+ $foo_stash->add_symbol('&funk' => sub { "Foo::funk", __LINE__ });
+}, undef, '... created &Foo::funk successfully');
ok(defined($Foo::{funk}), '... the &funk slot was created successfully');
is $DB::sub{'Foo::funk'}, sprintf "%s:%d-%d", __FILE__, $line, $line,
'... got the right %DB::sub value for funk default args';
-$foo_stash->add_package_symbol(
+$foo_stash->add_symbol(
'&dunk' => sub { "Foo::dunk" },
filename => "FileName",
first_line_num => 100,
#!/usr/bin/env perl
use strict;
use warnings;
+use lib 't/lib';
use Test::More;
use Package::Stash;
}
my $stash = Package::Stash->new('Foo');
-{ local $TODO = "i think this is a perl bug (see comment in has_package_symbol)";
-ok($stash->has_package_symbol('$SCALAR'), '$SCALAR');
+{ local $TODO = ($] < 5.010 || $Package::Stash::IMPLEMENTATION eq 'PP')
+ ? "undef scalars aren't visible on 5.8, or from pure perl at all"
+ : undef;
+ok($stash->has_symbol('$SCALAR'), '$SCALAR');
}
-ok($stash->has_package_symbol('$SCALAR_WITH_VALUE'), '$SCALAR_WITH_VALUE');
-ok($stash->has_package_symbol('@ARRAY'), '@ARRAY');
-ok($stash->has_package_symbol('%HASH'), '%HASH');
+ok($stash->has_symbol('$SCALAR_WITH_VALUE'), '$SCALAR_WITH_VALUE');
+ok($stash->has_symbol('@ARRAY'), '@ARRAY');
+ok($stash->has_symbol('%HASH'), '%HASH');
is_deeply(
- [sort $stash->list_all_package_symbols('CODE')],
+ [sort $stash->list_all_symbols('CODE')],
[qw(BAR BAZ FOO QUUUX QUUX normal normal_with_proto stub stub_with_proto)],
"can see all code symbols"
);
-$stash->add_package_symbol('%added', {});
-ok(!$stash->has_package_symbol('$added'), '$added');
-ok(!$stash->has_package_symbol('@added'), '@added');
-ok($stash->has_package_symbol('%added'), '%added');
+$stash->add_symbol('%added', {});
+ok(!$stash->has_symbol('$added'), '$added');
+ok(!$stash->has_symbol('@added'), '@added');
+ok($stash->has_symbol('%added'), '%added');
+
+my $constant = $stash->get_symbol('&FOO');
+is(ref($constant), 'CODE', "expanded a constant into a coderef");
done_testing;
#!/usr/bin/env perl
use strict;
use warnings;
+use lib 't/lib';
use Test::More;
use Package::Stash;
my $stash = Package::Stash->new('Foo');
-$stash->add_package_symbol('%foo', {bar => 1});
+$stash->add_symbol('%foo', {bar => 1});
{
no warnings 'once';
is($Foo::foo{bar}, 1, "set in the stash properly");
}
-ok(!$stash->has_package_symbol('$foo'), "doesn't have anything in scalar slot");
+ok(!$stash->has_symbol('$foo'), "doesn't have anything in scalar slot");
my $namespace = $stash->namespace;
is_deeply(*{ $namespace->{foo} }{HASH}, {bar => 1}, "namespace works properly");
--- /dev/null
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use lib 't/lib';
+use Test::More;
+use Test::Fatal;
+use Test::Requires 'Test::LeakTrace';
+
+use Package::Stash;
+use Symbol;
+
+{
+ package Bar;
+}
+
+{
+ package Baz;
+ our $foo;
+ sub bar { }
+ use constant baz => 1;
+ our %quux = (a => 'b');
+}
+
+{
+ no_leaks_ok {
+ Package::Stash->new('Foo');
+ } "object construction doesn't leak";
+}
+
+{
+ no_leaks_ok {
+ Package::Stash->new('Bar');
+ } "object construction doesn't leak, with an existing package";
+}
+
+{
+ no_leaks_ok {
+ Package::Stash->new('Baz');
+ } "object construction doesn't leak, with an existing package with things in it";
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ no_leaks_ok {
+ $foo->name;
+ $foo->namespace;
+ } "accessors don't leak";
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ no_leaks_ok {
+ $foo->add_symbol('$scalar');
+ $foo->add_symbol('@array');
+ $foo->add_symbol('%hash');
+ $foo->add_symbol('io');
+ } "add_symbol doesn't leak";
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ no_leaks_ok {
+ $foo->add_symbol('$scalar_init' => 1);
+ $foo->add_symbol('@array_init' => []);
+ $foo->add_symbol('%hash_init' => {});
+ $foo->add_symbol('&code_init' => sub { "foo" });
+ $foo->add_symbol('io_init' => Symbol::geniosym);
+ } "add_symbol doesn't leak";
+ is(exception {
+ is(Foo->code_init, 'foo', "sub installed correctly")
+ }, undef, "code_init exists");
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ no_leaks_ok {
+ $foo->remove_symbol('$scalar_init');
+ $foo->remove_symbol('@array_init');
+ $foo->remove_symbol('%hash_init');
+ $foo->remove_symbol('&code_init');
+ $foo->remove_symbol('io_init');
+ } "remove_symbol doesn't leak";
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ $foo->add_symbol("${_}glob") for ('$', '@', '%', '&', '');
+ no_leaks_ok {
+ $foo->remove_glob('glob');
+ } "remove_glob doesn't leak";
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ no_leaks_ok {
+ $foo->has_symbol('io');
+ $foo->has_symbol('%hash');
+ $foo->has_symbol('@array_init');
+ $foo->has_symbol('$glob');
+ $foo->has_symbol('&something_else');
+ } "has_symbol doesn't leak";
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ no_leaks_ok {
+ $foo->get_symbol('io');
+ $foo->get_symbol('%hash');
+ $foo->get_symbol('@array_init');
+ $foo->get_symbol('$glob');
+ $foo->get_symbol('&something_else');
+ } "get_symbol doesn't leak";
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ ok(!$foo->has_symbol('$glob'));
+ ok(!$foo->has_symbol('@array_init'));
+ no_leaks_ok {
+ $foo->get_or_add_symbol('io');
+ $foo->get_or_add_symbol('%hash');
+ my @super = ('Exporter');
+ @{$foo->get_or_add_symbol('@ISA')} = @super;
+ $foo->get_or_add_symbol('$glob');
+ } "get_or_add_symbol doesn't leak";
+ { local $TODO = ($] < 5.010 || $Package::Stash::IMPLEMENTATION eq 'PP')
+ ? "undef scalars aren't visible on 5.8, or from pure perl at all"
+ : undef;
+ ok($foo->has_symbol('$glob'));
+ }
+ is(ref($foo->get_symbol('$glob')), 'SCALAR');
+ ok($foo->has_symbol('@ISA'));
+ is(ref($foo->get_symbol('@ISA')), 'ARRAY');
+ is_deeply($foo->get_symbol('@ISA'), ['Exporter']);
+ isa_ok('Foo', 'Exporter');
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ my $baz = Package::Stash->new('Baz');
+ no_leaks_ok {
+ $foo->list_all_symbols;
+ $foo->list_all_symbols('SCALAR');
+ $foo->list_all_symbols('CODE');
+ $baz->list_all_symbols('CODE');
+ } "list_all_symbols doesn't leak";
+}
+
+{
+ package Blah;
+ use constant 'baz';
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ my $blah = Package::Stash->new('Blah');
+ no_leaks_ok {
+ $foo->get_all_symbols;
+ $foo->get_all_symbols('SCALAR');
+ $foo->get_all_symbols('CODE');
+ $blah->get_all_symbols('CODE');
+ } "get_all_symbols doesn't leak";
+}
+
+# mimic CMOP::create_anon_class
+{
+ local $TODO = $] < 5.010 ? "deleting stashes is inherently leaky on 5.8"
+ : undef;
+ my $i = 0;
+ no_leaks_ok {
+ $i++;
+ eval "package Quux$i; 1;";
+ my $quux = Package::Stash->new("Quux$i");
+ $quux->get_or_add_symbol('@ISA');
+ delete $::{'Quux' . $i . '::'};
+ } "get_symbol doesn't leak during glob expansion";
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ no_leaks_ok {
+ eval { $foo->get_or_add_symbol('&blorg') };
+ } "doesn't leak on errors";
+}
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use lib 't/lib';
+use Test::More;
+use Test::Fatal;
+use Test::Requires 'Test::LeakTrace';
+
+BEGIN { $^P |= 0x210 } # PERLDBf_SUBLINE
+
+use Package::Stash;
+use Symbol;
+
+{
+ package Bar;
+}
+
+{
+ package Baz;
+ our $foo;
+ sub bar { }
+ use constant baz => 1;
+ our %quux = (a => 'b');
+}
+
+{
+ no_leaks_ok {
+ Package::Stash->new('Foo');
+ } "object construction doesn't leak";
+}
+
+{
+ no_leaks_ok {
+ Package::Stash->new('Bar');
+ } "object construction doesn't leak, with an existing package";
+}
+
+{
+ no_leaks_ok {
+ Package::Stash->new('Baz');
+ } "object construction doesn't leak, with an existing package with things in it";
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ no_leaks_ok {
+ $foo->name;
+ $foo->namespace;
+ } "accessors don't leak";
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ no_leaks_ok {
+ $foo->add_symbol('$scalar');
+ $foo->add_symbol('@array');
+ $foo->add_symbol('%hash');
+ $foo->add_symbol('io');
+ } "add_symbol doesn't leak";
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ no_leaks_ok {
+ $foo->add_symbol('$scalar_init' => 1);
+ $foo->add_symbol('@array_init' => []);
+ $foo->add_symbol('%hash_init' => {});
+ $foo->add_symbol('&code_init' => sub { "foo" });
+ $foo->add_symbol('io_init' => Symbol::geniosym);
+ } "add_symbol doesn't leak";
+ is(exception {
+ is(Foo->code_init, 'foo', "sub installed correctly")
+ }, undef, "code_init exists");
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ no_leaks_ok {
+ $foo->remove_symbol('$scalar_init');
+ $foo->remove_symbol('@array_init');
+ $foo->remove_symbol('%hash_init');
+ $foo->remove_symbol('&code_init');
+ $foo->remove_symbol('io_init');
+ } "remove_symbol doesn't leak";
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ $foo->add_symbol("${_}glob") for ('$', '@', '%', '&', '');
+ no_leaks_ok {
+ $foo->remove_glob('glob');
+ } "remove_glob doesn't leak";
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ no_leaks_ok {
+ $foo->has_symbol('io');
+ $foo->has_symbol('%hash');
+ $foo->has_symbol('@array_init');
+ $foo->has_symbol('$glob');
+ $foo->has_symbol('&something_else');
+ } "has_symbol doesn't leak";
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ no_leaks_ok {
+ $foo->get_symbol('io');
+ $foo->get_symbol('%hash');
+ $foo->get_symbol('@array_init');
+ $foo->get_symbol('$glob');
+ $foo->get_symbol('&something_else');
+ } "get_symbol doesn't leak";
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ ok(!$foo->has_symbol('$glob'));
+ ok(!$foo->has_symbol('@array_init'));
+ no_leaks_ok {
+ $foo->get_or_add_symbol('io');
+ $foo->get_or_add_symbol('%hash');
+ my @super = ('Exporter');
+ @{$foo->get_or_add_symbol('@ISA')} = @super;
+ $foo->get_or_add_symbol('$glob');
+ } "get_or_add_symbol doesn't leak";
+ { local $TODO = ($] < 5.010 || $Package::Stash::IMPLEMENTATION eq 'PP')
+ ? "undef scalars aren't visible on 5.8, or from pure perl at all"
+ : undef;
+ ok($foo->has_symbol('$glob'));
+ }
+ is(ref($foo->get_symbol('$glob')), 'SCALAR');
+ ok($foo->has_symbol('@ISA'));
+ is(ref($foo->get_symbol('@ISA')), 'ARRAY');
+ is_deeply($foo->get_symbol('@ISA'), ['Exporter']);
+ isa_ok('Foo', 'Exporter');
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ my $baz = Package::Stash->new('Baz');
+ no_leaks_ok {
+ $foo->list_all_symbols;
+ $foo->list_all_symbols('SCALAR');
+ $foo->list_all_symbols('CODE');
+ $baz->list_all_symbols('CODE');
+ } "list_all_symbols doesn't leak";
+}
+
+{
+ package Blah;
+ use constant 'baz';
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ my $blah = Package::Stash->new('Blah');
+ no_leaks_ok {
+ $foo->get_all_symbols;
+ $foo->get_all_symbols('SCALAR');
+ $foo->get_all_symbols('CODE');
+ $blah->get_all_symbols('CODE');
+ } "get_all_symbols doesn't leak";
+}
+
+# mimic CMOP::create_anon_class
+{
+ local $TODO = $] < 5.010 ? "deleting stashes is inherently leaky on 5.8"
+ : undef;
+ my $i = 0;
+ no_leaks_ok {
+ $i++;
+ eval "package Quux$i; 1;";
+ my $quux = Package::Stash->new("Quux$i");
+ $quux->get_or_add_symbol('@ISA');
+ delete $::{'Quux' . $i . '::'};
+ } "get_symbol doesn't leak during glob expansion";
+}
+
+{
+ my $foo = Package::Stash->new('Foo');
+ no_leaks_ok {
+ eval { $foo->get_or_add_symbol('&blorg') };
+ } "doesn't leak on errors";
+}
+
+done_testing;
--- /dev/null
+package # hide from PAUSE
+ Package::Stash;
+use strict;
+use warnings;
+
+use Package::Stash::PP;
+
+our $IMPLEMENTATION = 'PP';
+
+BEGIN {
+ my $ps = Package::Stash::PP->new(__PACKAGE__);
+ my $ps_pp = Package::Stash::PP->new('Package::Stash::PP');
+ for my $method ($ps_pp->list_all_symbols('CODE')) {
+ my $sym = '&' . $method;
+ $ps->add_symbol($sym => $ps_pp->get_symbol($sym));
+ }
+}
+
+1;
projects / gitmo/Package-Stash.git / commitdiff