1use strict;
2use warnings;
3use lib 't/lib';
4use Test::More;
5use Test::Fatal;
6
7{
8    package My::Package::Stash;
9    use strict;
10    use warnings;
11
12    use base 'Package::Stash';
13
14    use Symbol 'gensym';
15
16    sub new {
17        my $class = shift;
18        my $self = $class->SUPER::new(@_);
19        $self->{namespace} = {};
20        return $self;
21    }
22
23    sub namespace { shift->{namespace} }
24
25    sub add_symbol {
26        my ($self, $variable, $initial_value) = @_;
27
28        (my $name = $variable) =~ s/^[\$\@\%\&]//;
29
30        my $glob = gensym();
31        *{$glob} = $initial_value if defined $initial_value;
32        $self->namespace->{$name} = *{$glob};
33    }
34}
35
36# No actually package Foo exists :)
37my $foo_stash = My::Package::Stash->new('Foo');
38
39isa_ok($foo_stash, 'My::Package::Stash');
40isa_ok($foo_stash, 'Package::Stash');
41
42ok(!defined($Foo::{foo}), '... the %foo slot has not been created yet');
43ok(!$foo_stash->has_symbol('%foo'), '... the foo_stash agrees');
44
45is(exception {
46    $foo_stash->add_symbol('%foo' => { one => 1 });
47}, undef, '... the %foo symbol is created succcessfully');
48
49ok(!defined($Foo::{foo}), '... the %foo slot has not been created in the actual Foo package');
50ok($foo_stash->has_symbol('%foo'), '... the foo_stash agrees');
51
52my $foo = $foo_stash->get_symbol('%foo');
53is_deeply({ one => 1 }, $foo, '... got the right package variable back');
54
55$foo->{two} = 2;
56
57is($foo, $foo_stash->get_symbol('%foo'), '... our %foo is the same as the foo_stashs');
58
59ok(!defined($Foo::{bar}), '... the @bar slot has not been created yet');
60
61is(exception {
62    $foo_stash->add_symbol('@bar' => [ 1, 2, 3 ]);
63}, undef, '... created @Foo::bar successfully');
64
65ok(!defined($Foo::{bar}), '... the @bar slot has still not been created');
66
67ok(!defined($Foo::{baz}), '... the %baz slot has not been created yet');
68
69is(exception {
70    $foo_stash->add_symbol('%baz');
71}, undef, '... created %Foo::baz successfully');
72
73ok(!defined($Foo::{baz}), '... the %baz slot has still not been created');
74
75done_testing;
76