From adda4f43e39cff45cf4d443dd93216644fca3afa Mon Sep 17 00:00:00 2001 From: Jesse Luehrs Date: Fri, 5 Aug 2011 13:08:04 -0500 Subject: remove test numbers --- t/01-basic.t | 420 ---------------------------------------- t/02-extension.t | 76 -------- t/03-io.t | 51 ----- t/04-get.t | 186 ------------------ t/05-isa.t | 22 --- t/06-addsub.t | 46 ----- t/07-edge-cases.t | 90 --------- t/10-synopsis.t | 19 -- t/addsub.t | 46 +++++ t/basic.t | 420 ++++++++++++++++++++++++++++++++++++++++ t/edge-cases.t | 90 +++++++++ t/extension.t | 76 ++++++++ t/get.t | 186 ++++++++++++++++++ t/impl-selection/01-choice.t | 17 -- t/impl-selection/02-env.t | 29 --- t/impl-selection/03-var.t | 29 --- t/impl-selection/10-basic-pp.t | 424 ---------------------------------------- t/impl-selection/11-basic-xs.t | 425 ----------------------------------------- t/impl-selection/basic-pp.t | 424 ++++++++++++++++++++++++++++++++++++++++ t/impl-selection/basic-xs.t | 425 +++++++++++++++++++++++++++++++++++++++++ t/impl-selection/choice.t | 17 ++ t/impl-selection/env.t | 29 +++ t/impl-selection/var.t | 29 +++ t/io.t | 51 +++++ t/isa.t | 22 +++ t/synopsis.t | 19 ++ 26 files changed, 1834 insertions(+), 1834 deletions(-) delete mode 100644 t/01-basic.t delete mode 100644 t/02-extension.t delete mode 100644 t/03-io.t delete mode 100644 t/04-get.t delete mode 100644 t/05-isa.t delete mode 100644 t/06-addsub.t delete mode 100755 t/07-edge-cases.t delete mode 100644 t/10-synopsis.t create mode 100644 t/addsub.t create mode 100644 t/basic.t create mode 100755 t/edge-cases.t create mode 100644 t/extension.t create mode 100644 t/get.t delete mode 100644 t/impl-selection/01-choice.t delete mode 100644 t/impl-selection/02-env.t delete mode 100644 t/impl-selection/03-var.t delete mode 100644 t/impl-selection/10-basic-pp.t delete mode 100644 t/impl-selection/11-basic-xs.t create mode 100644 t/impl-selection/basic-pp.t create mode 100644 t/impl-selection/basic-xs.t create mode 100644 t/impl-selection/choice.t create mode 100644 t/impl-selection/env.t create mode 100644 t/impl-selection/var.t create mode 100644 t/io.t create mode 100644 t/isa.t create mode 100644 t/synopsis.t diff --git a/t/01-basic.t b/t/01-basic.t deleted file mode 100644 index 77c9c13..0000000 --- a/t/01-basic.t +++ /dev/null @@ -1,420 +0,0 @@ -#!/usr/bin/env perl -use strict; -use warnings; -use lib 't/lib'; -use Test::More; -use Test::Fatal; - -use Package::Stash; - -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; - - use constant SOME_CONSTANT => 1; -} - -# ---------------------------------------------------------------------- -## tests adding a HASH - -my $foo_stash = Package::Stash->new('Foo'); -ok(!defined($Foo::{foo}), '... the %foo slot has not been created yet'); -ok(!$foo_stash->has_symbol('%foo'), '... the object agrees'); -ok(!defined($Foo::{foo}), '... checking doesn\' vivify'); - -is(exception { - $foo_stash->add_symbol('%foo' => { one => 1 }); -}, undef, '... created %Foo::foo successfully'); - -# ... scalar should NOT be created here - -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_symbol('%foo'), '... the meta agrees'); - -# check the value ... - -{ - no strict 'refs'; - ok(exists ${'Foo::foo'}{one}, '... our %foo was initialized correctly'); - is(${'Foo::foo'}{one}, 1, '... our %foo was initialized correctly'); -} - -my $foo = $foo_stash->get_symbol('%foo'); -is_deeply({ one => 1 }, $foo, '... got the right package variable back'); - -# ... make sure changes propogate up - -$foo->{two} = 2; - -{ - no strict 'refs'; - 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'); -} - -# ---------------------------------------------------------------------- -## test adding an ARRAY - -ok(!defined($Foo::{bar}), '... the @bar slot has not been created yet'); - -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_symbol('@bar'), '... the meta agrees'); - -# ... why does this not work ... - -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 - -{ - no strict 'refs'; - is(scalar @{'Foo::bar'}, 3, '... our @bar was initialized correctly'); - is(${'Foo::bar'}[1], 2, '... our @bar was initialized correctly'); -} - -# ---------------------------------------------------------------------- -## test adding a SCALAR - -ok(!defined($Foo::{baz}), '... the $baz slot has not been created yet'); - -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_symbol('$baz'), '... the meta agrees'); - -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_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_symbol('$baz')}, 1, '... the meta agrees'); -} - -# ---------------------------------------------------------------------- -## test adding a CODE - -ok(!defined($Foo::{funk}), '... the &funk slot has not been created yet'); - -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_symbol('&funk'), '... the meta agrees'); - -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'; - ok(defined &{'Foo::funk'}, '... our &funk exists'); -} - -is(Foo->funk(), 'Foo::funk', '... got the right value from the function'); - -# ---------------------------------------------------------------------- -## test multiple slots in the glob - -my $ARRAY = [ 1, 2, 3 ]; -my $CODE = sub { "Foo::foo" }; - -is(exception { - $foo_stash->add_symbol('@foo' => $ARRAY); -}, undef, '... created @Foo::foo successfully'); - -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'); - -is(exception { - $foo_stash->add_symbol('&foo' => $CODE); -}, undef, '... created &Foo::foo successfully'); - -ok($foo_stash->has_symbol('&foo'), '... the meta agrees'); -is($foo_stash->get_symbol('&foo'), $CODE, '... got the right value for &Foo::foo'); - -is(exception { - $foo_stash->add_symbol('$foo' => 'Foo::foo'); -}, undef, '... created $Foo::foo successfully'); - -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'); - -{ - no strict 'refs'; - is(${'Foo::foo'}, 'Foo::foo', '... got the right value from the scalar'); -} - -is(exception { - $foo_stash->remove_symbol('%foo'); -}, undef, '... removed %Foo::foo successfully'); - -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_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); -is($foo_stash->get_symbol('&foo'), $CODE, '... got the right value for &Foo::foo'); -is($foo_stash->get_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo'); - -{ - no strict 'refs'; - ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); - ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); - ok(defined(*{"Foo::foo"}{CODE}), '... the &foo slot has NOT been removed'); - ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed'); -} - -is(exception { - $foo_stash->remove_symbol('&foo'); -}, undef, '... removed &Foo::foo successfully'); - -ok(!$foo_stash->has_symbol('&foo'), '... the &foo slot no longer 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_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); -is($foo_stash->get_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo'); - -{ - no strict 'refs'; - ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); - ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed'); - ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); - ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed'); -} - -is(exception { - $foo_stash->remove_symbol('$foo'); -}, undef, '... removed $Foo::foo successfully'); - -ok(!$foo_stash->has_symbol('$foo'), '... the $foo slot no longer exists'); - -ok($foo_stash->has_symbol('@foo'), '... the @foo slot still exists'); - -is($foo_stash->get_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); - -{ - no strict 'refs'; - ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); - ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed'); - ok(!defined(${"Foo::foo"}), '... the $foo slot has now been removed'); - 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 - -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"); - -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"); - -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; -} - -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 - -{ - package Baz; - - our $foo = 23; - our @foo = "bar"; - our %foo = (baz => 1); - sub foo { } - open *foo, '<', $0; - BEGIN { Package::Stash->new(__PACKAGE__)->remove_symbol('&foo') } -} - -{ - my $stash = Package::Stash->new('Baz'); - 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"); -} - -{ - package Quux; - - our $foo = 23; - our @foo = "bar"; - our %foo = (baz => 1); - sub foo { } - open *foo, '<', $0; -} - -{ - my $stash = Package::Stash->new('Quux'); - - my %expect = ( - '$foo' => \23, - '@foo' => ["bar"], - '%foo' => { baz => 1 }, - '&foo' => \&Quux::foo, - 'foo' => *Quux::foo{IO}, - ); - - for my $sym ( sort keys %expect ) { - is_deeply( - $stash->get_symbol($sym), - $expect{$sym}, - "got expected value for $sym" - ); - } - - $stash->add_symbol('%bar' => {x => 42}); - - $expect{'%bar'} = {x => 42}; - - for my $sym ( sort keys %expect ) { - is_deeply( - $stash->get_symbol($sym), - $expect{$sym}, - "got expected value for $sym" - ); - } - - $stash->add_symbol('%bar' => {x => 43}); - - $expect{'%bar'} = {x => 43}; - - for my $sym ( sort keys %expect ) { - is_deeply( - $stash->get_symbol($sym), - $expect{$sym}, - "got expected value for $sym" - ); - } -} - -{ - package Quuux; - our $foo; - our @foo; - our @bar; - our %baz; - sub baz { } - use constant quux => 1; - use constant quuux => []; - sub quuuux; -} - -{ - my $quuux = Package::Stash->new('Quuux'); - is_deeply( - [sort $quuux->list_all_symbols], - [qw(BEGIN bar baz foo quuuux quuux quux)], - "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_symbols('SCALAR')], - [qw(foo)], - "list_all_symbols SCALAR", - ); - } - is_deeply( - [sort $quuux->list_all_symbols('ARRAY')], - [qw(bar foo)], - "list_all_symbols ARRAY", - ); - is_deeply( - [sort $quuux->list_all_symbols('HASH')], - [qw(baz)], - "list_all_symbols HASH", - ); - is_deeply( - [sort $quuux->list_all_symbols('CODE')], - [qw(baz quuuux quuux quux)], - "list_all_symbols CODE", - ); -} - -done_testing; diff --git a/t/02-extension.t b/t/02-extension.t deleted file mode 100644 index f8e4752..0000000 --- a/t/02-extension.t +++ /dev/null @@ -1,76 +0,0 @@ -#!/usr/bin/env perl -use strict; -use warnings; -use lib 't/lib'; -use Test::More; -use Test::Fatal; - -{ - package My::Package::Stash; - use strict; - use warnings; - - use base 'Package::Stash'; - - use Symbol 'gensym'; - - sub new { - my $class = shift; - my $self = $class->SUPER::new(@_); - $self->{namespace} = {}; - return $self; - } - - sub namespace { shift->{namespace} } - - sub add_symbol { - my ($self, $variable, $initial_value) = @_; - - (my $name = $variable) =~ s/^[\$\@\%\&]//; - - my $glob = gensym(); - *{$glob} = $initial_value if defined $initial_value; - $self->namespace->{$name} = *{$glob}; - } -} - -# No actually package Foo exists :) -my $foo_stash = My::Package::Stash->new('Foo'); - -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_symbol('%foo'), '... the foo_stash agrees'); - -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_symbol('%foo'), '... the foo_stash agrees'); - -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_symbol('%foo'), '... our %foo is the same as the foo_stashs'); - -ok(!defined($Foo::{bar}), '... the @bar slot has not been created yet'); - -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'); - -is(exception { - $foo_stash->add_symbol('%baz'); -}, undef, '... created %Foo::baz successfully'); - -ok(!defined($Foo::{baz}), '... the %baz slot has still not been created'); - -done_testing; diff --git a/t/03-io.t b/t/03-io.t deleted file mode 100644 index ecade2a..0000000 --- a/t/03-io.t +++ /dev/null @@ -1,51 +0,0 @@ -#!/usr/bin/env perl -use strict; -use warnings; -use lib 't/lib'; -use Test::More; -use Test::Fatal; - -{ - package Foo; - open *foo, "<", $0; - - sub foo { } -} - -{ - package Bar; - open *bar, "<", $0; - - sub bar { } -} - -use Package::Stash; - -{ - my $stash = Package::Stash->new('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_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'); - 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 deleted file mode 100644 index 4f0eb6a..0000000 --- a/t/04-get.t +++ /dev/null @@ -1,186 +0,0 @@ -#!/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_symbol('%foo'); - is($val, undef, "got nothing yet"); - } - { - no warnings 'void', 'once'; - %Hash::foo; - } - BEGIN { - my $stash = Package::Stash->new('Hash'); - my $val = $stash->get_symbol('%foo'); - is(ref($val), 'HASH', "got something"); - $val->{bar} = 1; - is_deeply($stash->get_symbol('%foo'), {bar => 1}, - "got the right variable"); - is_deeply(\%Hash::foo, {bar => 1}, - "stash has the right variable"); - } -} - -{ - BEGIN { - my $stash = Package::Stash->new('Array'); - my $val = $stash->get_symbol('@foo'); - is($val, undef, "got nothing yet"); - } - { - no warnings 'void', 'once'; - @Array::foo; - } - BEGIN { - my $stash = Package::Stash->new('Array'); - my $val = $stash->get_symbol('@foo'); - is(ref($val), 'ARRAY', "got something"); - push @$val, 1; - is_deeply($stash->get_symbol('@foo'), [1], - "got the right variable"); - is_deeply(\@Array::foo, [1], - "stash has the right variable"); - } -} - -{ - BEGIN { - my $stash = Package::Stash->new('Scalar'); - my $val = $stash->get_symbol('$foo'); - is($val, undef, "got nothing yet"); - } - { - no warnings 'void', 'once'; - $Scalar::foo; - } - BEGIN { - my $stash = Package::Stash->new('Scalar'); - my $val = $stash->get_symbol('$foo'); - is(ref($val), 'SCALAR', "got something"); - $$val = 1; - is_deeply($stash->get_symbol('$foo'), \1, - "got the right variable"); - is($Scalar::foo, 1, - "stash has the right variable"); - } -} - -{ - BEGIN { - my $stash = Package::Stash->new('Code'); - my $val = $stash->get_symbol('&foo'); - is($val, undef, "got nothing yet"); - } - { - no warnings 'void', 'once'; - sub Code::foo { } - } - BEGIN { - my $stash = Package::Stash->new('Code'); - 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_symbol('&foo'), $val, - "got the right variable"); - is(prototype($stash->get_symbol('&foo')), '&', - "got the right variable"); - is(prototype(\&Code::foo), '&', - "stash has the right variable"); - } -} - -{ - BEGIN { - my $stash = Package::Stash->new('Io'); - my $val = $stash->get_symbol('FOO'); - is($val, undef, "got nothing yet"); - } - { - no warnings 'void', 'once'; - package Io; - fileno(FOO); - } - BEGIN { - my $stash = Package::Stash->new('Io'); - my $val = $stash->get_symbol('FOO'); - isa_ok($val, 'IO'); - my $str = "foo"; - open $val, '<', \$str; - is(readline($stash->get_symbol('FOO')), "foo", - "got the right variable"); - seek($stash->get_symbol('FOO'), 0, 0); - { - package Io; - ::isa_ok(*FOO{IO}, 'IO'); - ::is(, "foo", - "stash has the right variable"); - } - } -} - -{ - my $stash = Package::Stash->new('Hash::Vivify'); - my $val = $stash->get_or_add_symbol('%foo'); - is(ref($val), 'HASH', "got something"); - $val->{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}, - "stash has the right variable"); -} - -{ - my $stash = Package::Stash->new('Array::Vivify'); - my $val = $stash->get_or_add_symbol('@foo'); - is(ref($val), 'ARRAY', "got something"); - push @$val, 1; - is_deeply($stash->get_or_add_symbol('@foo'), [1], - "got the right variable"); - no warnings 'once'; - is_deeply(\@Array::Vivify::foo, [1], - "stash has the right variable"); -} - -{ - my $stash = Package::Stash->new('Scalar::Vivify'); - my $val = $stash->get_or_add_symbol('$foo'); - is(ref($val), 'SCALAR', "got something"); - $$val = 1; - is_deeply($stash->get_or_add_symbol('$foo'), \1, - "got the right variable"); - no warnings 'once'; - is($Scalar::Vivify::foo, 1, - "stash has the right variable"); -} - -{ - BEGIN { - my $stash = Package::Stash->new('Io::Vivify'); - my $val = $stash->get_or_add_symbol('FOO'); - isa_ok($val, 'IO'); - my $str = "foo"; - open $val, '<', \$str; - is(readline($stash->get_symbol('FOO')), "foo", - "got the right variable"); - seek($stash->get_symbol('FOO'), 0, 0); - } - { - package Io::Vivify; - no warnings 'once'; - ::isa_ok(*FOO{IO}, 'IO'); - ::is(, "foo", - "stash has the right variable"); - } -} - -done_testing; diff --git a/t/05-isa.t b/t/05-isa.t deleted file mode 100644 index ce852a6..0000000 --- a/t/05-isa.t +++ /dev/null @@ -1,22 +0,0 @@ -#!/usr/bin/env perl -use strict; -use warnings; -use lib 't/lib'; -use Test::More; - -use Package::Stash; - -{ - package Foo; -} - -{ - package Bar; -} - -my $stash = Package::Stash->new('Foo'); -my @ISA = ('Bar'); -@{$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 deleted file mode 100644 index 4889d59..0000000 --- a/t/06-addsub.t +++ /dev/null @@ -1,46 +0,0 @@ -#!/usr/bin/env perl -use strict; -use warnings; -use lib 't/lib'; -use Test::More; -use Test::Fatal; - -BEGIN { $^P |= 0x210 } # PERLDBf_SUBLINE - -use Package::Stash; - -my $foo_stash = Package::Stash->new('Foo'); - -# ---------------------------------------------------------------------- -## test adding a CODE - -ok(!defined($Foo::{funk}), '... the &funk slot has not been created yet'); - -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'); - -{ - no strict 'refs'; - ok(defined &{'Foo::funk'}, '... our &funk exists'); -} - -is((Foo->funk())[0], 'Foo::funk', '... got the right value from the function'); - -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_symbol( - '&dunk' => sub { "Foo::dunk" }, - filename => "FileName", - first_line_num => 100, - last_line_num => 199 -); - -is $DB::sub{'Foo::dunk'}, sprintf "%s:%d-%d", "FileName", 100, 199, - '... got the right %DB::sub value for dunk with specified args'; - -done_testing; diff --git a/t/07-edge-cases.t b/t/07-edge-cases.t deleted file mode 100755 index 6bed48e..0000000 --- a/t/07-edge-cases.t +++ /dev/null @@ -1,90 +0,0 @@ -#!/usr/bin/env perl -use strict; -use warnings; -use lib 't/lib'; -use Test::More; -use Test::Fatal; - -use Package::Stash; - -{ - package Foo; - use constant FOO => 1; - use constant BAR => \1; - use constant BAZ => []; - use constant QUUX => {}; - use constant QUUUX => sub { }; - sub normal { } - sub stub; - sub normal_with_proto () { } - sub stub_with_proto (); - - our $SCALAR; - our $SCALAR_WITH_VALUE = 1; - our @ARRAY; - our %HASH; -} - -my $stash = Package::Stash->new('Foo'); -{ 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_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_symbols('CODE')], - [qw(BAR BAZ FOO QUUUX QUUX normal normal_with_proto stub stub_with_proto)], - "can see all code symbols" -); - -$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"); - -# ensure get doesn't prevent subsequent vivification (not sure what the deal -# was here) -is(ref($stash->get_symbol('$glob')), '', "nothing yet"); -is(ref($stash->get_or_add_symbol('$glob')), 'SCALAR', "got an empty scalar"); - -my $Bar = Package::Stash->new('Bar'); -my $foo = 3; -$foo =~ s/3/4/; -my $bar = 4.5; -$bar =~ s/4/5/; - -is(exception { $Bar->add_symbol('$foo', \$foo) }, undef, - "can add PVIV values"); -is(exception { $Bar->add_symbol('$bar', \$bar) }, undef, - "can add PVNV values"); -is(exception { bless \$bar, 'Foo'; $Bar->add_symbol('$bar2', $bar) }, undef, - "can add PVMG values"); -is(exception { $Bar->add_symbol('$baz', qr/foo/) }, undef, - "can add regex values"); -is(exception { undef $bar; $Bar->add_symbol('$quux', \$bar) }, undef, - "can add undef values that aren't NULL"); - -use_ok('CompileTime'); - -{ - package Gets::Deleted; - sub bar { } -} - -{ - my $delete = Package::Stash->new('Gets::Deleted'); - ok($delete->has_symbol('&bar'), "sees the method"); - { - no strict 'refs'; - delete ${'main::Gets::'}{'Deleted::'}; - } - ok(!$delete->has_symbol('&bar'), "method goes away when stash is deleted"); -} - -done_testing; diff --git a/t/10-synopsis.t b/t/10-synopsis.t deleted file mode 100644 index 9f59948..0000000 --- a/t/10-synopsis.t +++ /dev/null @@ -1,19 +0,0 @@ -#!/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_symbol('%foo', {bar => 1}); -{ - no warnings 'once'; - is($Foo::foo{bar}, 1, "set in the stash properly"); -} -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"); - -done_testing; diff --git a/t/addsub.t b/t/addsub.t new file mode 100644 index 0000000..4889d59 --- /dev/null +++ b/t/addsub.t @@ -0,0 +1,46 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use lib 't/lib'; +use Test::More; +use Test::Fatal; + +BEGIN { $^P |= 0x210 } # PERLDBf_SUBLINE + +use Package::Stash; + +my $foo_stash = Package::Stash->new('Foo'); + +# ---------------------------------------------------------------------- +## test adding a CODE + +ok(!defined($Foo::{funk}), '... the &funk slot has not been created yet'); + +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'); + +{ + no strict 'refs'; + ok(defined &{'Foo::funk'}, '... our &funk exists'); +} + +is((Foo->funk())[0], 'Foo::funk', '... got the right value from the function'); + +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_symbol( + '&dunk' => sub { "Foo::dunk" }, + filename => "FileName", + first_line_num => 100, + last_line_num => 199 +); + +is $DB::sub{'Foo::dunk'}, sprintf "%s:%d-%d", "FileName", 100, 199, + '... got the right %DB::sub value for dunk with specified args'; + +done_testing; diff --git a/t/basic.t b/t/basic.t new file mode 100644 index 0000000..77c9c13 --- /dev/null +++ b/t/basic.t @@ -0,0 +1,420 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use lib 't/lib'; +use Test::More; +use Test::Fatal; + +use Package::Stash; + +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; + + use constant SOME_CONSTANT => 1; +} + +# ---------------------------------------------------------------------- +## tests adding a HASH + +my $foo_stash = Package::Stash->new('Foo'); +ok(!defined($Foo::{foo}), '... the %foo slot has not been created yet'); +ok(!$foo_stash->has_symbol('%foo'), '... the object agrees'); +ok(!defined($Foo::{foo}), '... checking doesn\' vivify'); + +is(exception { + $foo_stash->add_symbol('%foo' => { one => 1 }); +}, undef, '... created %Foo::foo successfully'); + +# ... scalar should NOT be created here + +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_symbol('%foo'), '... the meta agrees'); + +# check the value ... + +{ + no strict 'refs'; + ok(exists ${'Foo::foo'}{one}, '... our %foo was initialized correctly'); + is(${'Foo::foo'}{one}, 1, '... our %foo was initialized correctly'); +} + +my $foo = $foo_stash->get_symbol('%foo'); +is_deeply({ one => 1 }, $foo, '... got the right package variable back'); + +# ... make sure changes propogate up + +$foo->{two} = 2; + +{ + no strict 'refs'; + 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'); +} + +# ---------------------------------------------------------------------- +## test adding an ARRAY + +ok(!defined($Foo::{bar}), '... the @bar slot has not been created yet'); + +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_symbol('@bar'), '... the meta agrees'); + +# ... why does this not work ... + +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 + +{ + no strict 'refs'; + is(scalar @{'Foo::bar'}, 3, '... our @bar was initialized correctly'); + is(${'Foo::bar'}[1], 2, '... our @bar was initialized correctly'); +} + +# ---------------------------------------------------------------------- +## test adding a SCALAR + +ok(!defined($Foo::{baz}), '... the $baz slot has not been created yet'); + +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_symbol('$baz'), '... the meta agrees'); + +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_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_symbol('$baz')}, 1, '... the meta agrees'); +} + +# ---------------------------------------------------------------------- +## test adding a CODE + +ok(!defined($Foo::{funk}), '... the &funk slot has not been created yet'); + +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_symbol('&funk'), '... the meta agrees'); + +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'; + ok(defined &{'Foo::funk'}, '... our &funk exists'); +} + +is(Foo->funk(), 'Foo::funk', '... got the right value from the function'); + +# ---------------------------------------------------------------------- +## test multiple slots in the glob + +my $ARRAY = [ 1, 2, 3 ]; +my $CODE = sub { "Foo::foo" }; + +is(exception { + $foo_stash->add_symbol('@foo' => $ARRAY); +}, undef, '... created @Foo::foo successfully'); + +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'); + +is(exception { + $foo_stash->add_symbol('&foo' => $CODE); +}, undef, '... created &Foo::foo successfully'); + +ok($foo_stash->has_symbol('&foo'), '... the meta agrees'); +is($foo_stash->get_symbol('&foo'), $CODE, '... got the right value for &Foo::foo'); + +is(exception { + $foo_stash->add_symbol('$foo' => 'Foo::foo'); +}, undef, '... created $Foo::foo successfully'); + +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'); + +{ + no strict 'refs'; + is(${'Foo::foo'}, 'Foo::foo', '... got the right value from the scalar'); +} + +is(exception { + $foo_stash->remove_symbol('%foo'); +}, undef, '... removed %Foo::foo successfully'); + +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_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); +is($foo_stash->get_symbol('&foo'), $CODE, '... got the right value for &Foo::foo'); +is($foo_stash->get_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo'); + +{ + no strict 'refs'; + ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); + ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); + ok(defined(*{"Foo::foo"}{CODE}), '... the &foo slot has NOT been removed'); + ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed'); +} + +is(exception { + $foo_stash->remove_symbol('&foo'); +}, undef, '... removed &Foo::foo successfully'); + +ok(!$foo_stash->has_symbol('&foo'), '... the &foo slot no longer 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_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); +is($foo_stash->get_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo'); + +{ + no strict 'refs'; + ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); + ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed'); + ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); + ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed'); +} + +is(exception { + $foo_stash->remove_symbol('$foo'); +}, undef, '... removed $Foo::foo successfully'); + +ok(!$foo_stash->has_symbol('$foo'), '... the $foo slot no longer exists'); + +ok($foo_stash->has_symbol('@foo'), '... the @foo slot still exists'); + +is($foo_stash->get_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); + +{ + no strict 'refs'; + ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); + ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed'); + ok(!defined(${"Foo::foo"}), '... the $foo slot has now been removed'); + 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 + +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"); + +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"); + +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; +} + +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 + +{ + package Baz; + + our $foo = 23; + our @foo = "bar"; + our %foo = (baz => 1); + sub foo { } + open *foo, '<', $0; + BEGIN { Package::Stash->new(__PACKAGE__)->remove_symbol('&foo') } +} + +{ + my $stash = Package::Stash->new('Baz'); + 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"); +} + +{ + package Quux; + + our $foo = 23; + our @foo = "bar"; + our %foo = (baz => 1); + sub foo { } + open *foo, '<', $0; +} + +{ + my $stash = Package::Stash->new('Quux'); + + my %expect = ( + '$foo' => \23, + '@foo' => ["bar"], + '%foo' => { baz => 1 }, + '&foo' => \&Quux::foo, + 'foo' => *Quux::foo{IO}, + ); + + for my $sym ( sort keys %expect ) { + is_deeply( + $stash->get_symbol($sym), + $expect{$sym}, + "got expected value for $sym" + ); + } + + $stash->add_symbol('%bar' => {x => 42}); + + $expect{'%bar'} = {x => 42}; + + for my $sym ( sort keys %expect ) { + is_deeply( + $stash->get_symbol($sym), + $expect{$sym}, + "got expected value for $sym" + ); + } + + $stash->add_symbol('%bar' => {x => 43}); + + $expect{'%bar'} = {x => 43}; + + for my $sym ( sort keys %expect ) { + is_deeply( + $stash->get_symbol($sym), + $expect{$sym}, + "got expected value for $sym" + ); + } +} + +{ + package Quuux; + our $foo; + our @foo; + our @bar; + our %baz; + sub baz { } + use constant quux => 1; + use constant quuux => []; + sub quuuux; +} + +{ + my $quuux = Package::Stash->new('Quuux'); + is_deeply( + [sort $quuux->list_all_symbols], + [qw(BEGIN bar baz foo quuuux quuux quux)], + "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_symbols('SCALAR')], + [qw(foo)], + "list_all_symbols SCALAR", + ); + } + is_deeply( + [sort $quuux->list_all_symbols('ARRAY')], + [qw(bar foo)], + "list_all_symbols ARRAY", + ); + is_deeply( + [sort $quuux->list_all_symbols('HASH')], + [qw(baz)], + "list_all_symbols HASH", + ); + is_deeply( + [sort $quuux->list_all_symbols('CODE')], + [qw(baz quuuux quuux quux)], + "list_all_symbols CODE", + ); +} + +done_testing; diff --git a/t/edge-cases.t b/t/edge-cases.t new file mode 100755 index 0000000..6bed48e --- /dev/null +++ b/t/edge-cases.t @@ -0,0 +1,90 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use lib 't/lib'; +use Test::More; +use Test::Fatal; + +use Package::Stash; + +{ + package Foo; + use constant FOO => 1; + use constant BAR => \1; + use constant BAZ => []; + use constant QUUX => {}; + use constant QUUUX => sub { }; + sub normal { } + sub stub; + sub normal_with_proto () { } + sub stub_with_proto (); + + our $SCALAR; + our $SCALAR_WITH_VALUE = 1; + our @ARRAY; + our %HASH; +} + +my $stash = Package::Stash->new('Foo'); +{ 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_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_symbols('CODE')], + [qw(BAR BAZ FOO QUUUX QUUX normal normal_with_proto stub stub_with_proto)], + "can see all code symbols" +); + +$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"); + +# ensure get doesn't prevent subsequent vivification (not sure what the deal +# was here) +is(ref($stash->get_symbol('$glob')), '', "nothing yet"); +is(ref($stash->get_or_add_symbol('$glob')), 'SCALAR', "got an empty scalar"); + +my $Bar = Package::Stash->new('Bar'); +my $foo = 3; +$foo =~ s/3/4/; +my $bar = 4.5; +$bar =~ s/4/5/; + +is(exception { $Bar->add_symbol('$foo', \$foo) }, undef, + "can add PVIV values"); +is(exception { $Bar->add_symbol('$bar', \$bar) }, undef, + "can add PVNV values"); +is(exception { bless \$bar, 'Foo'; $Bar->add_symbol('$bar2', $bar) }, undef, + "can add PVMG values"); +is(exception { $Bar->add_symbol('$baz', qr/foo/) }, undef, + "can add regex values"); +is(exception { undef $bar; $Bar->add_symbol('$quux', \$bar) }, undef, + "can add undef values that aren't NULL"); + +use_ok('CompileTime'); + +{ + package Gets::Deleted; + sub bar { } +} + +{ + my $delete = Package::Stash->new('Gets::Deleted'); + ok($delete->has_symbol('&bar'), "sees the method"); + { + no strict 'refs'; + delete ${'main::Gets::'}{'Deleted::'}; + } + ok(!$delete->has_symbol('&bar'), "method goes away when stash is deleted"); +} + +done_testing; diff --git a/t/extension.t b/t/extension.t new file mode 100644 index 0000000..f8e4752 --- /dev/null +++ b/t/extension.t @@ -0,0 +1,76 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use lib 't/lib'; +use Test::More; +use Test::Fatal; + +{ + package My::Package::Stash; + use strict; + use warnings; + + use base 'Package::Stash'; + + use Symbol 'gensym'; + + sub new { + my $class = shift; + my $self = $class->SUPER::new(@_); + $self->{namespace} = {}; + return $self; + } + + sub namespace { shift->{namespace} } + + sub add_symbol { + my ($self, $variable, $initial_value) = @_; + + (my $name = $variable) =~ s/^[\$\@\%\&]//; + + my $glob = gensym(); + *{$glob} = $initial_value if defined $initial_value; + $self->namespace->{$name} = *{$glob}; + } +} + +# No actually package Foo exists :) +my $foo_stash = My::Package::Stash->new('Foo'); + +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_symbol('%foo'), '... the foo_stash agrees'); + +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_symbol('%foo'), '... the foo_stash agrees'); + +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_symbol('%foo'), '... our %foo is the same as the foo_stashs'); + +ok(!defined($Foo::{bar}), '... the @bar slot has not been created yet'); + +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'); + +is(exception { + $foo_stash->add_symbol('%baz'); +}, undef, '... created %Foo::baz successfully'); + +ok(!defined($Foo::{baz}), '... the %baz slot has still not been created'); + +done_testing; diff --git a/t/get.t b/t/get.t new file mode 100644 index 0000000..4f0eb6a --- /dev/null +++ b/t/get.t @@ -0,0 +1,186 @@ +#!/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_symbol('%foo'); + is($val, undef, "got nothing yet"); + } + { + no warnings 'void', 'once'; + %Hash::foo; + } + BEGIN { + my $stash = Package::Stash->new('Hash'); + my $val = $stash->get_symbol('%foo'); + is(ref($val), 'HASH', "got something"); + $val->{bar} = 1; + is_deeply($stash->get_symbol('%foo'), {bar => 1}, + "got the right variable"); + is_deeply(\%Hash::foo, {bar => 1}, + "stash has the right variable"); + } +} + +{ + BEGIN { + my $stash = Package::Stash->new('Array'); + my $val = $stash->get_symbol('@foo'); + is($val, undef, "got nothing yet"); + } + { + no warnings 'void', 'once'; + @Array::foo; + } + BEGIN { + my $stash = Package::Stash->new('Array'); + my $val = $stash->get_symbol('@foo'); + is(ref($val), 'ARRAY', "got something"); + push @$val, 1; + is_deeply($stash->get_symbol('@foo'), [1], + "got the right variable"); + is_deeply(\@Array::foo, [1], + "stash has the right variable"); + } +} + +{ + BEGIN { + my $stash = Package::Stash->new('Scalar'); + my $val = $stash->get_symbol('$foo'); + is($val, undef, "got nothing yet"); + } + { + no warnings 'void', 'once'; + $Scalar::foo; + } + BEGIN { + my $stash = Package::Stash->new('Scalar'); + my $val = $stash->get_symbol('$foo'); + is(ref($val), 'SCALAR', "got something"); + $$val = 1; + is_deeply($stash->get_symbol('$foo'), \1, + "got the right variable"); + is($Scalar::foo, 1, + "stash has the right variable"); + } +} + +{ + BEGIN { + my $stash = Package::Stash->new('Code'); + my $val = $stash->get_symbol('&foo'); + is($val, undef, "got nothing yet"); + } + { + no warnings 'void', 'once'; + sub Code::foo { } + } + BEGIN { + my $stash = Package::Stash->new('Code'); + 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_symbol('&foo'), $val, + "got the right variable"); + is(prototype($stash->get_symbol('&foo')), '&', + "got the right variable"); + is(prototype(\&Code::foo), '&', + "stash has the right variable"); + } +} + +{ + BEGIN { + my $stash = Package::Stash->new('Io'); + my $val = $stash->get_symbol('FOO'); + is($val, undef, "got nothing yet"); + } + { + no warnings 'void', 'once'; + package Io; + fileno(FOO); + } + BEGIN { + my $stash = Package::Stash->new('Io'); + my $val = $stash->get_symbol('FOO'); + isa_ok($val, 'IO'); + my $str = "foo"; + open $val, '<', \$str; + is(readline($stash->get_symbol('FOO')), "foo", + "got the right variable"); + seek($stash->get_symbol('FOO'), 0, 0); + { + package Io; + ::isa_ok(*FOO{IO}, 'IO'); + ::is(, "foo", + "stash has the right variable"); + } + } +} + +{ + my $stash = Package::Stash->new('Hash::Vivify'); + my $val = $stash->get_or_add_symbol('%foo'); + is(ref($val), 'HASH', "got something"); + $val->{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}, + "stash has the right variable"); +} + +{ + my $stash = Package::Stash->new('Array::Vivify'); + my $val = $stash->get_or_add_symbol('@foo'); + is(ref($val), 'ARRAY', "got something"); + push @$val, 1; + is_deeply($stash->get_or_add_symbol('@foo'), [1], + "got the right variable"); + no warnings 'once'; + is_deeply(\@Array::Vivify::foo, [1], + "stash has the right variable"); +} + +{ + my $stash = Package::Stash->new('Scalar::Vivify'); + my $val = $stash->get_or_add_symbol('$foo'); + is(ref($val), 'SCALAR', "got something"); + $$val = 1; + is_deeply($stash->get_or_add_symbol('$foo'), \1, + "got the right variable"); + no warnings 'once'; + is($Scalar::Vivify::foo, 1, + "stash has the right variable"); +} + +{ + BEGIN { + my $stash = Package::Stash->new('Io::Vivify'); + my $val = $stash->get_or_add_symbol('FOO'); + isa_ok($val, 'IO'); + my $str = "foo"; + open $val, '<', \$str; + is(readline($stash->get_symbol('FOO')), "foo", + "got the right variable"); + seek($stash->get_symbol('FOO'), 0, 0); + } + { + package Io::Vivify; + no warnings 'once'; + ::isa_ok(*FOO{IO}, 'IO'); + ::is(, "foo", + "stash has the right variable"); + } +} + +done_testing; diff --git a/t/impl-selection/01-choice.t b/t/impl-selection/01-choice.t deleted file mode 100644 index 7bbe29c..0000000 --- a/t/impl-selection/01-choice.t +++ /dev/null @@ -1,17 +0,0 @@ -#!/usr/bin/env perl -use strict; -use warnings; -use Test::More; - -my $has_xs = eval "require Package::Stash::XS; 1"; - -require Package::Stash; - -no warnings 'once'; - -my $expected = $has_xs ? 'XS' : 'PP'; -is($Package::Stash::IMPLEMENTATION, $expected, - "autodetected properly: $expected"); -can_ok('Package::Stash', 'new'); - -done_testing; diff --git a/t/impl-selection/02-env.t b/t/impl-selection/02-env.t deleted file mode 100644 index 3369488..0000000 --- a/t/impl-selection/02-env.t +++ /dev/null @@ -1,29 +0,0 @@ -#!/usr/bin/env perl -use strict; -use warnings; -use Test::More; - -# XXX: work around dumb core segfault bug when you delete stashes -sub get_impl { eval '$Package::Stash::IMPLEMENTATION' } -sub set_impl { eval '$Package::Stash::IMPLEMENTATION = "' . $_[0] . '"' } - -{ - $ENV{PACKAGE_STASH_IMPLEMENTATION} = 'PP'; - require Package::Stash; - is(get_impl, 'PP', "autodetected properly: PP"); - can_ok('Package::Stash', 'new'); -} - -delete $Package::{'Stash::'}; -delete $INC{'Package/Stash.pm'}; -delete $INC{'Package/Stash/PP.pm'}; - -SKIP: { - skip "no XS", 2 unless eval "require Package::Stash::XS; 1"; - $ENV{PACKAGE_STASH_IMPLEMENTATION} = 'XS'; - require Package::Stash; - is(get_impl, 'XS', "autodetected properly: XS"); - can_ok('Package::Stash', 'new'); -} - -done_testing; diff --git a/t/impl-selection/03-var.t b/t/impl-selection/03-var.t deleted file mode 100644 index dd5e7d8..0000000 --- a/t/impl-selection/03-var.t +++ /dev/null @@ -1,29 +0,0 @@ -#!/usr/bin/env perl -use strict; -use warnings; -use Test::More; - -# XXX: work around dumb core segfault bug when you delete stashes -sub get_impl { eval '$Package::Stash::IMPLEMENTATION' } -sub set_impl { eval '$Package::Stash::IMPLEMENTATION = "' . $_[0] . '"' } - -{ - $Package::Stash::IMPLEMENTATION = 'PP'; - require Package::Stash; - is(get_impl, 'PP', "autodetected properly: PP"); - can_ok('Package::Stash', 'new'); -} - -delete $Package::{'Stash::'}; -delete $INC{'Package/Stash.pm'}; -delete $INC{'Package/Stash/PP.pm'}; - -SKIP: { - skip "no XS", 2 unless eval "require Package::Stash::XS; 1"; - $Package::Stash::IMPLEMENTATION = 'XS'; - require Package::Stash; - is(get_impl, 'XS', "autodetected properly: XS"); - can_ok('Package::Stash', 'new'); -} - -done_testing; diff --git a/t/impl-selection/10-basic-pp.t b/t/impl-selection/10-basic-pp.t deleted file mode 100644 index 7388e80..0000000 --- a/t/impl-selection/10-basic-pp.t +++ /dev/null @@ -1,424 +0,0 @@ -#!/usr/bin/env perl -use strict; -use warnings; -use Test::More; -use Test::Fatal; - -BEGIN { $Package::Stash::IMPLEMENTATION = 'PP' } - -use Package::Stash; - -ok(exists $INC{'Package/Stash/PP.pm'}, "loaded PP"); -ok(!exists $INC{'Package/Stash/XS.pm'}, "didn't load XS"); - -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; - - use constant SOME_CONSTANT => 1; -} - -# ---------------------------------------------------------------------- -## tests adding a HASH - -my $foo_stash = Package::Stash->new('Foo'); -ok(!defined($Foo::{foo}), '... the %foo slot has not been created yet'); -ok(!$foo_stash->has_symbol('%foo'), '... the object agrees'); -ok(!defined($Foo::{foo}), '... checking doesn\' vivify'); - -is(exception { - $foo_stash->add_symbol('%foo' => { one => 1 }); -}, undef, '... created %Foo::foo successfully'); - -# ... scalar should NOT be created here - -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_symbol('%foo'), '... the meta agrees'); - -# check the value ... - -{ - no strict 'refs'; - ok(exists ${'Foo::foo'}{one}, '... our %foo was initialized correctly'); - is(${'Foo::foo'}{one}, 1, '... our %foo was initialized correctly'); -} - -my $foo = $foo_stash->get_symbol('%foo'); -is_deeply({ one => 1 }, $foo, '... got the right package variable back'); - -# ... make sure changes propogate up - -$foo->{two} = 2; - -{ - no strict 'refs'; - 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'); -} - -# ---------------------------------------------------------------------- -## test adding an ARRAY - -ok(!defined($Foo::{bar}), '... the @bar slot has not been created yet'); - -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_symbol('@bar'), '... the meta agrees'); - -# ... why does this not work ... - -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 - -{ - no strict 'refs'; - is(scalar @{'Foo::bar'}, 3, '... our @bar was initialized correctly'); - is(${'Foo::bar'}[1], 2, '... our @bar was initialized correctly'); -} - -# ---------------------------------------------------------------------- -## test adding a SCALAR - -ok(!defined($Foo::{baz}), '... the $baz slot has not been created yet'); - -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_symbol('$baz'), '... the meta agrees'); - -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_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_symbol('$baz')}, 1, '... the meta agrees'); -} - -# ---------------------------------------------------------------------- -## test adding a CODE - -ok(!defined($Foo::{funk}), '... the &funk slot has not been created yet'); - -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_symbol('&funk'), '... the meta agrees'); - -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'; - ok(defined &{'Foo::funk'}, '... our &funk exists'); -} - -is(Foo->funk(), 'Foo::funk', '... got the right value from the function'); - -# ---------------------------------------------------------------------- -## test multiple slots in the glob - -my $ARRAY = [ 1, 2, 3 ]; -my $CODE = sub { "Foo::foo" }; - -is(exception { - $foo_stash->add_symbol('@foo' => $ARRAY); -}, undef, '... created @Foo::foo successfully'); - -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'); - -is(exception { - $foo_stash->add_symbol('&foo' => $CODE); -}, undef, '... created &Foo::foo successfully'); - -ok($foo_stash->has_symbol('&foo'), '... the meta agrees'); -is($foo_stash->get_symbol('&foo'), $CODE, '... got the right value for &Foo::foo'); - -is(exception { - $foo_stash->add_symbol('$foo' => 'Foo::foo'); -}, undef, '... created $Foo::foo successfully'); - -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'); - -{ - no strict 'refs'; - is(${'Foo::foo'}, 'Foo::foo', '... got the right value from the scalar'); -} - -is(exception { - $foo_stash->remove_symbol('%foo'); -}, undef, '... removed %Foo::foo successfully'); - -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_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); -is($foo_stash->get_symbol('&foo'), $CODE, '... got the right value for &Foo::foo'); -is($foo_stash->get_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo'); - -{ - no strict 'refs'; - ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); - ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); - ok(defined(*{"Foo::foo"}{CODE}), '... the &foo slot has NOT been removed'); - ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed'); -} - -is(exception { - $foo_stash->remove_symbol('&foo'); -}, undef, '... removed &Foo::foo successfully'); - -ok(!$foo_stash->has_symbol('&foo'), '... the &foo slot no longer 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_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); -is($foo_stash->get_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo'); - -{ - no strict 'refs'; - ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); - ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed'); - ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); - ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed'); -} - -is(exception { - $foo_stash->remove_symbol('$foo'); -}, undef, '... removed $Foo::foo successfully'); - -ok(!$foo_stash->has_symbol('$foo'), '... the $foo slot no longer exists'); - -ok($foo_stash->has_symbol('@foo'), '... the @foo slot still exists'); - -is($foo_stash->get_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); - -{ - no strict 'refs'; - ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); - ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed'); - ok(!defined(${"Foo::foo"}), '... the $foo slot has now been removed'); - 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 - -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"); - -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"); - -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; -} - -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 - -{ - package Baz; - - our $foo = 23; - our @foo = "bar"; - our %foo = (baz => 1); - sub foo { } - open *foo, '<', $0; - BEGIN { Package::Stash->new(__PACKAGE__)->remove_symbol('&foo') } -} - -{ - my $stash = Package::Stash->new('Baz'); - 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"); -} - -{ - package Quux; - - our $foo = 23; - our @foo = "bar"; - our %foo = (baz => 1); - sub foo { } - open *foo, '<', $0; -} - -{ - my $stash = Package::Stash->new('Quux'); - - my %expect = ( - '$foo' => \23, - '@foo' => ["bar"], - '%foo' => { baz => 1 }, - '&foo' => \&Quux::foo, - 'foo' => *Quux::foo{IO}, - ); - - for my $sym ( sort keys %expect ) { - is_deeply( - $stash->get_symbol($sym), - $expect{$sym}, - "got expected value for $sym" - ); - } - - $stash->add_symbol('%bar' => {x => 42}); - - $expect{'%bar'} = {x => 42}; - - for my $sym ( sort keys %expect ) { - is_deeply( - $stash->get_symbol($sym), - $expect{$sym}, - "got expected value for $sym" - ); - } - - $stash->add_symbol('%bar' => {x => 43}); - - $expect{'%bar'} = {x => 43}; - - for my $sym ( sort keys %expect ) { - is_deeply( - $stash->get_symbol($sym), - $expect{$sym}, - "got expected value for $sym" - ); - } -} - -{ - package Quuux; - our $foo; - our @foo; - our @bar; - our %baz; - sub baz { } - use constant quux => 1; - use constant quuux => []; - sub quuuux; -} - -{ - my $quuux = Package::Stash->new('Quuux'); - is_deeply( - [sort $quuux->list_all_symbols], - [qw(BEGIN bar baz foo quuuux quuux quux)], - "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_symbols('SCALAR')], - [qw(foo)], - "list_all_symbols SCALAR", - ); - } - is_deeply( - [sort $quuux->list_all_symbols('ARRAY')], - [qw(bar foo)], - "list_all_symbols ARRAY", - ); - is_deeply( - [sort $quuux->list_all_symbols('HASH')], - [qw(baz)], - "list_all_symbols HASH", - ); - is_deeply( - [sort $quuux->list_all_symbols('CODE')], - [qw(baz quuuux quuux quux)], - "list_all_symbols CODE", - ); -} - -done_testing; diff --git a/t/impl-selection/11-basic-xs.t b/t/impl-selection/11-basic-xs.t deleted file mode 100644 index bffd3b7..0000000 --- a/t/impl-selection/11-basic-xs.t +++ /dev/null @@ -1,425 +0,0 @@ -#!/usr/bin/env perl -use strict; -use warnings; -use Test::More; -use Test::Fatal; -use Test::Requires 'Package::Stash::XS'; - -BEGIN { $Package::Stash::IMPLEMENTATION = 'XS' } - -use Package::Stash; - -ok(exists $INC{'Package/Stash/XS.pm'}, "loaded XS"); -ok(!exists $INC{'Package/Stash/PP.pm'}, "didn't load PP"); - -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; - - use constant SOME_CONSTANT => 1; -} - -# ---------------------------------------------------------------------- -## tests adding a HASH - -my $foo_stash = Package::Stash->new('Foo'); -ok(!defined($Foo::{foo}), '... the %foo slot has not been created yet'); -ok(!$foo_stash->has_symbol('%foo'), '... the object agrees'); -ok(!defined($Foo::{foo}), '... checking doesn\' vivify'); - -is(exception { - $foo_stash->add_symbol('%foo' => { one => 1 }); -}, undef, '... created %Foo::foo successfully'); - -# ... scalar should NOT be created here - -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_symbol('%foo'), '... the meta agrees'); - -# check the value ... - -{ - no strict 'refs'; - ok(exists ${'Foo::foo'}{one}, '... our %foo was initialized correctly'); - is(${'Foo::foo'}{one}, 1, '... our %foo was initialized correctly'); -} - -my $foo = $foo_stash->get_symbol('%foo'); -is_deeply({ one => 1 }, $foo, '... got the right package variable back'); - -# ... make sure changes propogate up - -$foo->{two} = 2; - -{ - no strict 'refs'; - 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'); -} - -# ---------------------------------------------------------------------- -## test adding an ARRAY - -ok(!defined($Foo::{bar}), '... the @bar slot has not been created yet'); - -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_symbol('@bar'), '... the meta agrees'); - -# ... why does this not work ... - -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 - -{ - no strict 'refs'; - is(scalar @{'Foo::bar'}, 3, '... our @bar was initialized correctly'); - is(${'Foo::bar'}[1], 2, '... our @bar was initialized correctly'); -} - -# ---------------------------------------------------------------------- -## test adding a SCALAR - -ok(!defined($Foo::{baz}), '... the $baz slot has not been created yet'); - -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_symbol('$baz'), '... the meta agrees'); - -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_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_symbol('$baz')}, 1, '... the meta agrees'); -} - -# ---------------------------------------------------------------------- -## test adding a CODE - -ok(!defined($Foo::{funk}), '... the &funk slot has not been created yet'); - -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_symbol('&funk'), '... the meta agrees'); - -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'; - ok(defined &{'Foo::funk'}, '... our &funk exists'); -} - -is(Foo->funk(), 'Foo::funk', '... got the right value from the function'); - -# ---------------------------------------------------------------------- -## test multiple slots in the glob - -my $ARRAY = [ 1, 2, 3 ]; -my $CODE = sub { "Foo::foo" }; - -is(exception { - $foo_stash->add_symbol('@foo' => $ARRAY); -}, undef, '... created @Foo::foo successfully'); - -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'); - -is(exception { - $foo_stash->add_symbol('&foo' => $CODE); -}, undef, '... created &Foo::foo successfully'); - -ok($foo_stash->has_symbol('&foo'), '... the meta agrees'); -is($foo_stash->get_symbol('&foo'), $CODE, '... got the right value for &Foo::foo'); - -is(exception { - $foo_stash->add_symbol('$foo' => 'Foo::foo'); -}, undef, '... created $Foo::foo successfully'); - -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'); - -{ - no strict 'refs'; - is(${'Foo::foo'}, 'Foo::foo', '... got the right value from the scalar'); -} - -is(exception { - $foo_stash->remove_symbol('%foo'); -}, undef, '... removed %Foo::foo successfully'); - -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_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); -is($foo_stash->get_symbol('&foo'), $CODE, '... got the right value for &Foo::foo'); -is($foo_stash->get_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo'); - -{ - no strict 'refs'; - ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); - ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); - ok(defined(*{"Foo::foo"}{CODE}), '... the &foo slot has NOT been removed'); - ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed'); -} - -is(exception { - $foo_stash->remove_symbol('&foo'); -}, undef, '... removed &Foo::foo successfully'); - -ok(!$foo_stash->has_symbol('&foo'), '... the &foo slot no longer 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_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); -is($foo_stash->get_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo'); - -{ - no strict 'refs'; - ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); - ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed'); - ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); - ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed'); -} - -is(exception { - $foo_stash->remove_symbol('$foo'); -}, undef, '... removed $Foo::foo successfully'); - -ok(!$foo_stash->has_symbol('$foo'), '... the $foo slot no longer exists'); - -ok($foo_stash->has_symbol('@foo'), '... the @foo slot still exists'); - -is($foo_stash->get_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); - -{ - no strict 'refs'; - ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); - ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed'); - ok(!defined(${"Foo::foo"}), '... the $foo slot has now been removed'); - 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 - -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"); - -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"); - -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; -} - -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 - -{ - package Baz; - - our $foo = 23; - our @foo = "bar"; - our %foo = (baz => 1); - sub foo { } - open *foo, '<', $0; - BEGIN { Package::Stash->new(__PACKAGE__)->remove_symbol('&foo') } -} - -{ - my $stash = Package::Stash->new('Baz'); - 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"); -} - -{ - package Quux; - - our $foo = 23; - our @foo = "bar"; - our %foo = (baz => 1); - sub foo { } - open *foo, '<', $0; -} - -{ - my $stash = Package::Stash->new('Quux'); - - my %expect = ( - '$foo' => \23, - '@foo' => ["bar"], - '%foo' => { baz => 1 }, - '&foo' => \&Quux::foo, - 'foo' => *Quux::foo{IO}, - ); - - for my $sym ( sort keys %expect ) { - is_deeply( - $stash->get_symbol($sym), - $expect{$sym}, - "got expected value for $sym" - ); - } - - $stash->add_symbol('%bar' => {x => 42}); - - $expect{'%bar'} = {x => 42}; - - for my $sym ( sort keys %expect ) { - is_deeply( - $stash->get_symbol($sym), - $expect{$sym}, - "got expected value for $sym" - ); - } - - $stash->add_symbol('%bar' => {x => 43}); - - $expect{'%bar'} = {x => 43}; - - for my $sym ( sort keys %expect ) { - is_deeply( - $stash->get_symbol($sym), - $expect{$sym}, - "got expected value for $sym" - ); - } -} - -{ - package Quuux; - our $foo; - our @foo; - our @bar; - our %baz; - sub baz { } - use constant quux => 1; - use constant quuux => []; - sub quuuux; -} - -{ - my $quuux = Package::Stash->new('Quuux'); - is_deeply( - [sort $quuux->list_all_symbols], - [qw(BEGIN bar baz foo quuuux quuux quux)], - "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_symbols('SCALAR')], - [qw(foo)], - "list_all_symbols SCALAR", - ); - } - is_deeply( - [sort $quuux->list_all_symbols('ARRAY')], - [qw(bar foo)], - "list_all_symbols ARRAY", - ); - is_deeply( - [sort $quuux->list_all_symbols('HASH')], - [qw(baz)], - "list_all_symbols HASH", - ); - is_deeply( - [sort $quuux->list_all_symbols('CODE')], - [qw(baz quuuux quuux quux)], - "list_all_symbols CODE", - ); -} - -done_testing; diff --git a/t/impl-selection/basic-pp.t b/t/impl-selection/basic-pp.t new file mode 100644 index 0000000..7388e80 --- /dev/null +++ b/t/impl-selection/basic-pp.t @@ -0,0 +1,424 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +BEGIN { $Package::Stash::IMPLEMENTATION = 'PP' } + +use Package::Stash; + +ok(exists $INC{'Package/Stash/PP.pm'}, "loaded PP"); +ok(!exists $INC{'Package/Stash/XS.pm'}, "didn't load XS"); + +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; + + use constant SOME_CONSTANT => 1; +} + +# ---------------------------------------------------------------------- +## tests adding a HASH + +my $foo_stash = Package::Stash->new('Foo'); +ok(!defined($Foo::{foo}), '... the %foo slot has not been created yet'); +ok(!$foo_stash->has_symbol('%foo'), '... the object agrees'); +ok(!defined($Foo::{foo}), '... checking doesn\' vivify'); + +is(exception { + $foo_stash->add_symbol('%foo' => { one => 1 }); +}, undef, '... created %Foo::foo successfully'); + +# ... scalar should NOT be created here + +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_symbol('%foo'), '... the meta agrees'); + +# check the value ... + +{ + no strict 'refs'; + ok(exists ${'Foo::foo'}{one}, '... our %foo was initialized correctly'); + is(${'Foo::foo'}{one}, 1, '... our %foo was initialized correctly'); +} + +my $foo = $foo_stash->get_symbol('%foo'); +is_deeply({ one => 1 }, $foo, '... got the right package variable back'); + +# ... make sure changes propogate up + +$foo->{two} = 2; + +{ + no strict 'refs'; + 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'); +} + +# ---------------------------------------------------------------------- +## test adding an ARRAY + +ok(!defined($Foo::{bar}), '... the @bar slot has not been created yet'); + +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_symbol('@bar'), '... the meta agrees'); + +# ... why does this not work ... + +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 + +{ + no strict 'refs'; + is(scalar @{'Foo::bar'}, 3, '... our @bar was initialized correctly'); + is(${'Foo::bar'}[1], 2, '... our @bar was initialized correctly'); +} + +# ---------------------------------------------------------------------- +## test adding a SCALAR + +ok(!defined($Foo::{baz}), '... the $baz slot has not been created yet'); + +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_symbol('$baz'), '... the meta agrees'); + +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_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_symbol('$baz')}, 1, '... the meta agrees'); +} + +# ---------------------------------------------------------------------- +## test adding a CODE + +ok(!defined($Foo::{funk}), '... the &funk slot has not been created yet'); + +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_symbol('&funk'), '... the meta agrees'); + +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'; + ok(defined &{'Foo::funk'}, '... our &funk exists'); +} + +is(Foo->funk(), 'Foo::funk', '... got the right value from the function'); + +# ---------------------------------------------------------------------- +## test multiple slots in the glob + +my $ARRAY = [ 1, 2, 3 ]; +my $CODE = sub { "Foo::foo" }; + +is(exception { + $foo_stash->add_symbol('@foo' => $ARRAY); +}, undef, '... created @Foo::foo successfully'); + +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'); + +is(exception { + $foo_stash->add_symbol('&foo' => $CODE); +}, undef, '... created &Foo::foo successfully'); + +ok($foo_stash->has_symbol('&foo'), '... the meta agrees'); +is($foo_stash->get_symbol('&foo'), $CODE, '... got the right value for &Foo::foo'); + +is(exception { + $foo_stash->add_symbol('$foo' => 'Foo::foo'); +}, undef, '... created $Foo::foo successfully'); + +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'); + +{ + no strict 'refs'; + is(${'Foo::foo'}, 'Foo::foo', '... got the right value from the scalar'); +} + +is(exception { + $foo_stash->remove_symbol('%foo'); +}, undef, '... removed %Foo::foo successfully'); + +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_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); +is($foo_stash->get_symbol('&foo'), $CODE, '... got the right value for &Foo::foo'); +is($foo_stash->get_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo'); + +{ + no strict 'refs'; + ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); + ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); + ok(defined(*{"Foo::foo"}{CODE}), '... the &foo slot has NOT been removed'); + ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed'); +} + +is(exception { + $foo_stash->remove_symbol('&foo'); +}, undef, '... removed &Foo::foo successfully'); + +ok(!$foo_stash->has_symbol('&foo'), '... the &foo slot no longer 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_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); +is($foo_stash->get_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo'); + +{ + no strict 'refs'; + ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); + ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed'); + ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); + ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed'); +} + +is(exception { + $foo_stash->remove_symbol('$foo'); +}, undef, '... removed $Foo::foo successfully'); + +ok(!$foo_stash->has_symbol('$foo'), '... the $foo slot no longer exists'); + +ok($foo_stash->has_symbol('@foo'), '... the @foo slot still exists'); + +is($foo_stash->get_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); + +{ + no strict 'refs'; + ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); + ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed'); + ok(!defined(${"Foo::foo"}), '... the $foo slot has now been removed'); + 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 + +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"); + +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"); + +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; +} + +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 + +{ + package Baz; + + our $foo = 23; + our @foo = "bar"; + our %foo = (baz => 1); + sub foo { } + open *foo, '<', $0; + BEGIN { Package::Stash->new(__PACKAGE__)->remove_symbol('&foo') } +} + +{ + my $stash = Package::Stash->new('Baz'); + 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"); +} + +{ + package Quux; + + our $foo = 23; + our @foo = "bar"; + our %foo = (baz => 1); + sub foo { } + open *foo, '<', $0; +} + +{ + my $stash = Package::Stash->new('Quux'); + + my %expect = ( + '$foo' => \23, + '@foo' => ["bar"], + '%foo' => { baz => 1 }, + '&foo' => \&Quux::foo, + 'foo' => *Quux::foo{IO}, + ); + + for my $sym ( sort keys %expect ) { + is_deeply( + $stash->get_symbol($sym), + $expect{$sym}, + "got expected value for $sym" + ); + } + + $stash->add_symbol('%bar' => {x => 42}); + + $expect{'%bar'} = {x => 42}; + + for my $sym ( sort keys %expect ) { + is_deeply( + $stash->get_symbol($sym), + $expect{$sym}, + "got expected value for $sym" + ); + } + + $stash->add_symbol('%bar' => {x => 43}); + + $expect{'%bar'} = {x => 43}; + + for my $sym ( sort keys %expect ) { + is_deeply( + $stash->get_symbol($sym), + $expect{$sym}, + "got expected value for $sym" + ); + } +} + +{ + package Quuux; + our $foo; + our @foo; + our @bar; + our %baz; + sub baz { } + use constant quux => 1; + use constant quuux => []; + sub quuuux; +} + +{ + my $quuux = Package::Stash->new('Quuux'); + is_deeply( + [sort $quuux->list_all_symbols], + [qw(BEGIN bar baz foo quuuux quuux quux)], + "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_symbols('SCALAR')], + [qw(foo)], + "list_all_symbols SCALAR", + ); + } + is_deeply( + [sort $quuux->list_all_symbols('ARRAY')], + [qw(bar foo)], + "list_all_symbols ARRAY", + ); + is_deeply( + [sort $quuux->list_all_symbols('HASH')], + [qw(baz)], + "list_all_symbols HASH", + ); + is_deeply( + [sort $quuux->list_all_symbols('CODE')], + [qw(baz quuuux quuux quux)], + "list_all_symbols CODE", + ); +} + +done_testing; diff --git a/t/impl-selection/basic-xs.t b/t/impl-selection/basic-xs.t new file mode 100644 index 0000000..bffd3b7 --- /dev/null +++ b/t/impl-selection/basic-xs.t @@ -0,0 +1,425 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Test::Fatal; +use Test::Requires 'Package::Stash::XS'; + +BEGIN { $Package::Stash::IMPLEMENTATION = 'XS' } + +use Package::Stash; + +ok(exists $INC{'Package/Stash/XS.pm'}, "loaded XS"); +ok(!exists $INC{'Package/Stash/PP.pm'}, "didn't load PP"); + +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; + + use constant SOME_CONSTANT => 1; +} + +# ---------------------------------------------------------------------- +## tests adding a HASH + +my $foo_stash = Package::Stash->new('Foo'); +ok(!defined($Foo::{foo}), '... the %foo slot has not been created yet'); +ok(!$foo_stash->has_symbol('%foo'), '... the object agrees'); +ok(!defined($Foo::{foo}), '... checking doesn\' vivify'); + +is(exception { + $foo_stash->add_symbol('%foo' => { one => 1 }); +}, undef, '... created %Foo::foo successfully'); + +# ... scalar should NOT be created here + +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_symbol('%foo'), '... the meta agrees'); + +# check the value ... + +{ + no strict 'refs'; + ok(exists ${'Foo::foo'}{one}, '... our %foo was initialized correctly'); + is(${'Foo::foo'}{one}, 1, '... our %foo was initialized correctly'); +} + +my $foo = $foo_stash->get_symbol('%foo'); +is_deeply({ one => 1 }, $foo, '... got the right package variable back'); + +# ... make sure changes propogate up + +$foo->{two} = 2; + +{ + no strict 'refs'; + 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'); +} + +# ---------------------------------------------------------------------- +## test adding an ARRAY + +ok(!defined($Foo::{bar}), '... the @bar slot has not been created yet'); + +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_symbol('@bar'), '... the meta agrees'); + +# ... why does this not work ... + +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 + +{ + no strict 'refs'; + is(scalar @{'Foo::bar'}, 3, '... our @bar was initialized correctly'); + is(${'Foo::bar'}[1], 2, '... our @bar was initialized correctly'); +} + +# ---------------------------------------------------------------------- +## test adding a SCALAR + +ok(!defined($Foo::{baz}), '... the $baz slot has not been created yet'); + +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_symbol('$baz'), '... the meta agrees'); + +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_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_symbol('$baz')}, 1, '... the meta agrees'); +} + +# ---------------------------------------------------------------------- +## test adding a CODE + +ok(!defined($Foo::{funk}), '... the &funk slot has not been created yet'); + +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_symbol('&funk'), '... the meta agrees'); + +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'; + ok(defined &{'Foo::funk'}, '... our &funk exists'); +} + +is(Foo->funk(), 'Foo::funk', '... got the right value from the function'); + +# ---------------------------------------------------------------------- +## test multiple slots in the glob + +my $ARRAY = [ 1, 2, 3 ]; +my $CODE = sub { "Foo::foo" }; + +is(exception { + $foo_stash->add_symbol('@foo' => $ARRAY); +}, undef, '... created @Foo::foo successfully'); + +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'); + +is(exception { + $foo_stash->add_symbol('&foo' => $CODE); +}, undef, '... created &Foo::foo successfully'); + +ok($foo_stash->has_symbol('&foo'), '... the meta agrees'); +is($foo_stash->get_symbol('&foo'), $CODE, '... got the right value for &Foo::foo'); + +is(exception { + $foo_stash->add_symbol('$foo' => 'Foo::foo'); +}, undef, '... created $Foo::foo successfully'); + +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'); + +{ + no strict 'refs'; + is(${'Foo::foo'}, 'Foo::foo', '... got the right value from the scalar'); +} + +is(exception { + $foo_stash->remove_symbol('%foo'); +}, undef, '... removed %Foo::foo successfully'); + +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_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); +is($foo_stash->get_symbol('&foo'), $CODE, '... got the right value for &Foo::foo'); +is($foo_stash->get_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo'); + +{ + no strict 'refs'; + ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); + ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); + ok(defined(*{"Foo::foo"}{CODE}), '... the &foo slot has NOT been removed'); + ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed'); +} + +is(exception { + $foo_stash->remove_symbol('&foo'); +}, undef, '... removed &Foo::foo successfully'); + +ok(!$foo_stash->has_symbol('&foo'), '... the &foo slot no longer 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_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); +is($foo_stash->get_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo'); + +{ + no strict 'refs'; + ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); + ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed'); + ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); + ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed'); +} + +is(exception { + $foo_stash->remove_symbol('$foo'); +}, undef, '... removed $Foo::foo successfully'); + +ok(!$foo_stash->has_symbol('$foo'), '... the $foo slot no longer exists'); + +ok($foo_stash->has_symbol('@foo'), '... the @foo slot still exists'); + +is($foo_stash->get_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); + +{ + no strict 'refs'; + ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); + ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed'); + ok(!defined(${"Foo::foo"}), '... the $foo slot has now been removed'); + 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 + +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"); + +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"); + +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; +} + +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 + +{ + package Baz; + + our $foo = 23; + our @foo = "bar"; + our %foo = (baz => 1); + sub foo { } + open *foo, '<', $0; + BEGIN { Package::Stash->new(__PACKAGE__)->remove_symbol('&foo') } +} + +{ + my $stash = Package::Stash->new('Baz'); + 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"); +} + +{ + package Quux; + + our $foo = 23; + our @foo = "bar"; + our %foo = (baz => 1); + sub foo { } + open *foo, '<', $0; +} + +{ + my $stash = Package::Stash->new('Quux'); + + my %expect = ( + '$foo' => \23, + '@foo' => ["bar"], + '%foo' => { baz => 1 }, + '&foo' => \&Quux::foo, + 'foo' => *Quux::foo{IO}, + ); + + for my $sym ( sort keys %expect ) { + is_deeply( + $stash->get_symbol($sym), + $expect{$sym}, + "got expected value for $sym" + ); + } + + $stash->add_symbol('%bar' => {x => 42}); + + $expect{'%bar'} = {x => 42}; + + for my $sym ( sort keys %expect ) { + is_deeply( + $stash->get_symbol($sym), + $expect{$sym}, + "got expected value for $sym" + ); + } + + $stash->add_symbol('%bar' => {x => 43}); + + $expect{'%bar'} = {x => 43}; + + for my $sym ( sort keys %expect ) { + is_deeply( + $stash->get_symbol($sym), + $expect{$sym}, + "got expected value for $sym" + ); + } +} + +{ + package Quuux; + our $foo; + our @foo; + our @bar; + our %baz; + sub baz { } + use constant quux => 1; + use constant quuux => []; + sub quuuux; +} + +{ + my $quuux = Package::Stash->new('Quuux'); + is_deeply( + [sort $quuux->list_all_symbols], + [qw(BEGIN bar baz foo quuuux quuux quux)], + "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_symbols('SCALAR')], + [qw(foo)], + "list_all_symbols SCALAR", + ); + } + is_deeply( + [sort $quuux->list_all_symbols('ARRAY')], + [qw(bar foo)], + "list_all_symbols ARRAY", + ); + is_deeply( + [sort $quuux->list_all_symbols('HASH')], + [qw(baz)], + "list_all_symbols HASH", + ); + is_deeply( + [sort $quuux->list_all_symbols('CODE')], + [qw(baz quuuux quuux quux)], + "list_all_symbols CODE", + ); +} + +done_testing; diff --git a/t/impl-selection/choice.t b/t/impl-selection/choice.t new file mode 100644 index 0000000..7bbe29c --- /dev/null +++ b/t/impl-selection/choice.t @@ -0,0 +1,17 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; + +my $has_xs = eval "require Package::Stash::XS; 1"; + +require Package::Stash; + +no warnings 'once'; + +my $expected = $has_xs ? 'XS' : 'PP'; +is($Package::Stash::IMPLEMENTATION, $expected, + "autodetected properly: $expected"); +can_ok('Package::Stash', 'new'); + +done_testing; diff --git a/t/impl-selection/env.t b/t/impl-selection/env.t new file mode 100644 index 0000000..3369488 --- /dev/null +++ b/t/impl-selection/env.t @@ -0,0 +1,29 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; + +# XXX: work around dumb core segfault bug when you delete stashes +sub get_impl { eval '$Package::Stash::IMPLEMENTATION' } +sub set_impl { eval '$Package::Stash::IMPLEMENTATION = "' . $_[0] . '"' } + +{ + $ENV{PACKAGE_STASH_IMPLEMENTATION} = 'PP'; + require Package::Stash; + is(get_impl, 'PP', "autodetected properly: PP"); + can_ok('Package::Stash', 'new'); +} + +delete $Package::{'Stash::'}; +delete $INC{'Package/Stash.pm'}; +delete $INC{'Package/Stash/PP.pm'}; + +SKIP: { + skip "no XS", 2 unless eval "require Package::Stash::XS; 1"; + $ENV{PACKAGE_STASH_IMPLEMENTATION} = 'XS'; + require Package::Stash; + is(get_impl, 'XS', "autodetected properly: XS"); + can_ok('Package::Stash', 'new'); +} + +done_testing; diff --git a/t/impl-selection/var.t b/t/impl-selection/var.t new file mode 100644 index 0000000..dd5e7d8 --- /dev/null +++ b/t/impl-selection/var.t @@ -0,0 +1,29 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; + +# XXX: work around dumb core segfault bug when you delete stashes +sub get_impl { eval '$Package::Stash::IMPLEMENTATION' } +sub set_impl { eval '$Package::Stash::IMPLEMENTATION = "' . $_[0] . '"' } + +{ + $Package::Stash::IMPLEMENTATION = 'PP'; + require Package::Stash; + is(get_impl, 'PP', "autodetected properly: PP"); + can_ok('Package::Stash', 'new'); +} + +delete $Package::{'Stash::'}; +delete $INC{'Package/Stash.pm'}; +delete $INC{'Package/Stash/PP.pm'}; + +SKIP: { + skip "no XS", 2 unless eval "require Package::Stash::XS; 1"; + $Package::Stash::IMPLEMENTATION = 'XS'; + require Package::Stash; + is(get_impl, 'XS', "autodetected properly: XS"); + can_ok('Package::Stash', 'new'); +} + +done_testing; diff --git a/t/io.t b/t/io.t new file mode 100644 index 0000000..ecade2a --- /dev/null +++ b/t/io.t @@ -0,0 +1,51 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use lib 't/lib'; +use Test::More; +use Test::Fatal; + +{ + package Foo; + open *foo, "<", $0; + + sub foo { } +} + +{ + package Bar; + open *bar, "<", $0; + + sub bar { } +} + +use Package::Stash; + +{ + my $stash = Package::Stash->new('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_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'); + 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/isa.t b/t/isa.t new file mode 100644 index 0000000..ce852a6 --- /dev/null +++ b/t/isa.t @@ -0,0 +1,22 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use lib 't/lib'; +use Test::More; + +use Package::Stash; + +{ + package Foo; +} + +{ + package Bar; +} + +my $stash = Package::Stash->new('Foo'); +my @ISA = ('Bar'); +@{$stash->get_or_add_symbol('@ISA')} = @ISA; +isa_ok('Foo', 'Bar'); + +done_testing; diff --git a/t/synopsis.t b/t/synopsis.t new file mode 100644 index 0000000..9f59948 --- /dev/null +++ b/t/synopsis.t @@ -0,0 +1,19 @@ +#!/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_symbol('%foo', {bar => 1}); +{ + no warnings 'once'; + is($Foo::foo{bar}, 1, "set in the stash properly"); +} +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"); + +done_testing; -- cgit v1.2.3-54-g00ecf