From: Jesse Luehrs Date: Mon, 15 Nov 2010 19:02:14 +0000 (-0600) Subject: almost complete pure perl implementation X-Git-Tag: 0.15~8 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=2905fb35f8d7e19e0b9422060689d71c72bb6f39;p=gitmo%2FPackage-Stash.git almost complete pure perl implementation the leak tests are failing for some reason, need to track that down --- diff --git a/lib/Package/Stash.pm b/lib/Package/Stash/PP.pm similarity index 57% rename from lib/Package/Stash.pm rename to lib/Package/Stash/PP.pm index 4f1db68..446642b 100644 --- a/lib/Package/Stash.pm +++ b/lib/Package/Stash/PP.pm @@ -1,10 +1,10 @@ -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 @@ -12,26 +12,11 @@ use constant BROKEN_ISA_ASSIGNMENT => ($] < 5.012); =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 object, for the package given as the only -argument. +This is a backend for L implemented in pure perl, for those without a compiler or who would like to use this inline in scripts. =cut @@ -51,23 +36,15 @@ sub new { }, $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}; } @@ -97,34 +74,6 @@ sub 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, C, and -C. - -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, C, and -C for the subroutine. If these are not passed, their values are -inferred (as much as possible) from C 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 for more -information about C<%DB::sub>. - -=cut - sub _valid_for_type { my $self = shift; my ($value, $type) = @_; @@ -138,7 +87,7 @@ sub _valid_for_type { } } -sub add_package_symbol { +sub add_symbol { my ($self, $variable, $initial_value, %opts) = @_; my ($name, $sigil, $type) = ref $variable eq 'HASH' @@ -171,27 +120,13 @@ sub add_package_symbol { *{$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' @@ -222,13 +157,7 @@ sub has_package_symbol { } } -=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' @@ -241,23 +170,23 @@ sub get_package_symbol { 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"; @@ -272,7 +201,7 @@ sub get_package_symbol { # 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); } } } @@ -293,27 +222,12 @@ sub get_package_symbol { } } -=method get_or_add_package_symbol $variable - -Like C, 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' @@ -334,60 +248,49 @@ sub remove_package_symbol { 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 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 blocks, perl will leave -an empty typeglob in the C slot, so this will show up if no filter is -used (and similarly for C, C, etc). - -=cut - -sub list_all_package_symbols { +sub list_all_symbols { my ($self, $type_filter) = @_; my $namespace = $self->namespace; @@ -418,9 +321,37 @@ sub list_all_package_symbols { } } +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 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 works, for +instance), but should not be relied upon - use C directly if you +want this behavior. + +=back Please report any bugs through RT: email C, or browse to 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;