summaryrefslogtreecommitdiffstats
path: root/t
diff options
context:
space:
mode:
authorJesse Luehrs <doy@tozt.net>2010-11-15 13:02:14 -0600
committerJesse Luehrs <doy@tozt.net>2010-11-15 13:05:14 -0600
commit2905fb35f8d7e19e0b9422060689d71c72bb6f39 (patch)
treef7609ecb5acc5517e36a26dd68cb51838ec8e8c3 /t
parentd1f721b320d72e83c0cb24c45fe9995a6dcf29c2 (diff)
downloadpackage-stash-2905fb35f8d7e19e0b9422060689d71c72bb6f39.tar.gz
package-stash-2905fb35f8d7e19e0b9422060689d71c72bb6f39.zip
almost complete pure perl implementation
the leak tests are failing for some reason, need to track that down
Diffstat (limited to 't')
-rw-r--r--t/01-basic.t268
-rw-r--r--t/02-extension.t33
-rw-r--r--t/03-io.t31
-rw-r--r--t/04-get.t54
-rw-r--r--t/05-isa.t3
-rw-r--r--t/06-addsub.t11
-rwxr-xr-xt/07-edge-cases.t26
-rw-r--r--t/10-synopsis.t5
-rw-r--r--t/20-leaks.t186
-rw-r--r--t/21-leaks-debug.t188
-rw-r--r--t/lib/Package/Stash.pm19
11 files changed, 641 insertions, 183 deletions
diff --git a/t/01-basic.t b/t/01-basic.t
index 4d78764..77c9c13 100644
--- a/t/01-basic.t
+++ b/t/01-basic.t
@@ -1,12 +1,14 @@
+#!/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;
@@ -19,21 +21,21 @@ ok(exception { Package::Stash->name }, q{... can't call name() as a class method
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 ...
@@ -43,7 +45,7 @@ ok($foo_stash->has_package_symbol('%foo'), '... the meta agrees');
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
@@ -52,7 +54,7 @@ $foo->{two} = 2;
{
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');
@@ -63,18 +65,18 @@ $foo->{two} = 2;
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
@@ -89,25 +91,25 @@ ok(!$foo_stash->has_package_symbol('&bar'), '... CODE shouldnt have been created
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');
}
# ----------------------------------------------------------------------
@@ -115,16 +117,16 @@ is(${$foo_stash->get_package_symbol('$baz')}, 10, '... got the right value back'
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';
@@ -139,26 +141,26 @@ is(Foo->funk(), 'Foo::funk', '... got the right value from the function');
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');
{
@@ -166,18 +168,18 @@ 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';
@@ -187,17 +189,17 @@ is($foo_stash->get_package_symbol('$foo'), $SCALAR, '... got the right value for
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';
@@ -207,15 +209,15 @@ is($foo_stash->get_package_symbol('$foo'), $SCALAR, '... got the right value for
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';
@@ -225,28 +227,74 @@ is($foo_stash->get_package_symbol('@foo'), $ARRAY, '... got the right values for
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
@@ -258,16 +306,16 @@ ok(exception {
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");
}
{
@@ -293,31 +341,31 @@ ok(exception {
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"
);
@@ -326,7 +374,7 @@ ok(exception {
{
package Quuux;
- our $foo = 1;
+ our $foo;
our @foo;
our @bar;
our %baz;
@@ -339,29 +387,33 @@ ok(exception {
{
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",
);
}
diff --git a/t/02-extension.t b/t/02-extension.t
index 1ac20c0..2096221 100644
--- a/t/02-extension.t
+++ b/t/02-extension.t
@@ -1,6 +1,7 @@
+#!/usr/bin/env perl
use strict;
use warnings;
-
+use lib 't/lib';
use Test::More;
use Test::Fatal;
@@ -20,10 +21,10 @@ 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;
@@ -38,35 +39,35 @@ isa_ok($foo_stash, 'My::Package::Stash');
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');
diff --git a/t/03-io.t b/t/03-io.t
index 147b745..ecade2a 100644
--- a/t/03-io.t
+++ b/t/03-io.t
@@ -1,6 +1,7 @@
#!/usr/bin/env perl
use strict;
use warnings;
+use lib 't/lib';
use Test::More;
use Test::Fatal;
@@ -22,29 +23,29 @@ use Package::Stash;
{
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;
diff --git a/t/04-get.t b/t/04-get.t
index 3c4ae43..4f0eb6a 100644
--- a/t/04-get.t
+++ b/t/04-get.t
@@ -1,14 +1,16 @@
#!/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");
}
{
@@ -17,10 +19,10 @@ use Package::Stash;
}
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");
@@ -30,7 +32,7 @@ use Package::Stash;
{
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");
}
{
@@ -39,10 +41,10 @@ use Package::Stash;
}
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");
@@ -52,7 +54,7 @@ use Package::Stash;
{
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");
}
{
@@ -61,10 +63,10 @@ use Package::Stash;
}
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");
@@ -74,7 +76,7 @@ use Package::Stash;
{
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");
}
{
@@ -83,13 +85,13 @@ use Package::Stash;
}
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");
@@ -99,7 +101,7 @@ use Package::Stash;
{
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");
}
{
@@ -109,13 +111,13 @@ use Package::Stash;
}
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');
@@ -127,10 +129,10 @@ use Package::Stash;
{
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},
@@ -139,10 +141,10 @@ use Package::Stash;
{
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],
@@ -151,10 +153,10 @@ use Package::Stash;
{
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,
@@ -164,13 +166,13 @@ use Package::Stash;
{
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;
diff --git a/t/05-isa.t b/t/05-isa.t
index 0b41b72..ce852a6 100644
--- a/t/05-isa.t
+++ b/t/05-isa.t
@@ -1,6 +1,7 @@
#!/usr/bin/env perl
use strict;
use warnings;
+use lib 't/lib';
use Test::More;
use Package::Stash;
@@ -15,7 +16,7 @@ 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;
diff --git a/t/06-addsub.t b/t/06-addsub.t
index e8445f7..4889d59 100644
--- a/t/06-addsub.t
+++ b/t/06-addsub.t
@@ -1,6 +1,7 @@
+#!/usr/bin/env perl
use strict;
use warnings;
-
+use lib 't/lib';
use Test::More;
use Test::Fatal;
@@ -15,9 +16,9 @@ my $foo_stash = Package::Stash->new('Foo');
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');
@@ -32,7 +33,7 @@ my $line = (Foo->funk())[1];
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,
diff --git a/t/07-edge-cases.t b/t/07-edge-cases.t
index e544c7a..feec31e 100755
--- a/t/07-edge-cases.t
+++ b/t/07-edge-cases.t
@@ -1,6 +1,7 @@
#!/usr/bin/env perl
use strict;
use warnings;
+use lib 't/lib';
use Test::More;
use Package::Stash;
@@ -24,21 +25,26 @@ 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;
diff --git a/t/10-synopsis.t b/t/10-synopsis.t
index 4c93f32..9f59948 100644
--- a/t/10-synopsis.t
+++ b/t/10-synopsis.t
@@ -1,17 +1,18 @@
#!/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");
diff --git a/t/20-leaks.t b/t/20-leaks.t
new file mode 100644
index 0000000..570b56e
--- /dev/null
+++ b/t/20-leaks.t
@@ -0,0 +1,186 @@
+#!/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;
diff --git a/t/21-leaks-debug.t b/t/21-leaks-debug.t
new file mode 100644
index 0000000..345c30c
--- /dev/null
+++ b/t/21-leaks-debug.t
@@ -0,0 +1,188 @@
+#!/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;
diff --git a/t/lib/Package/Stash.pm b/t/lib/Package/Stash.pm
new file mode 100644
index 0000000..7d8cd23
--- /dev/null
+++ b/t/lib/Package/Stash.pm
@@ -0,0 +1,19 @@
+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;