1use strict;
2use warnings;
3use lib 't/lib';
4use Test::More;
5use Test::Fatal;
6
7use Package::Stash;
8
9like(exception { Package::Stash->name }, qr/Can't call name as a class method/,
10   q{... can't call name() as a class method});
11
12{
13    package Foo;
14
15    use constant SOME_CONSTANT => 1;
16}
17
18# ----------------------------------------------------------------------
19## tests adding a HASH
20
21my $foo_stash = Package::Stash->new('Foo');
22ok(!defined($Foo::{foo}), '... the %foo slot has not been created yet');
23ok(!$foo_stash->has_symbol('%foo'), '... the object agrees');
24ok(!defined($Foo::{foo}), '... checking doesn\' vivify');
25
26is(exception {
27    $foo_stash->add_symbol('%foo' => { one => 1 });
28}, undef, '... created %Foo::foo successfully');
29
30# ... scalar should NOT be created here
31
32ok(!$foo_stash->has_symbol('$foo'), '... SCALAR shouldnt have been created too');
33ok(!$foo_stash->has_symbol('@foo'), '... ARRAY shouldnt have been created too');
34ok(!$foo_stash->has_symbol('&foo'), '... CODE shouldnt have been created too');
35
36ok(defined($Foo::{foo}), '... the %foo slot was created successfully');
37ok($foo_stash->has_symbol('%foo'), '... the meta agrees');
38
39# check the value ...
40
41{
42    no strict 'refs';
43    ok(exists ${'Foo::foo'}{one}, '... our %foo was initialized correctly');
44    is(${'Foo::foo'}{one}, 1, '... our %foo was initialized correctly');
45}
46
47my $foo = $foo_stash->get_symbol('%foo');
48is_deeply({ one => 1 }, $foo, '... got the right package variable back');
49
50# ... make sure changes propogate up
51
52$foo->{two} = 2;
53
54{
55    no strict 'refs';
56    is(\%{'Foo::foo'}, $foo_stash->get_symbol('%foo'), '... our %foo is the same as the metas');
57
58    ok(exists ${'Foo::foo'}{two}, '... our %foo was updated correctly');
59    is(${'Foo::foo'}{two}, 2, '... our %foo was updated correctly');
60}
61
62# ----------------------------------------------------------------------
63## test adding an ARRAY
64
65ok(!defined($Foo::{bar}), '... the @bar slot has not been created yet');
66
67is(exception {
68    $foo_stash->add_symbol('@bar' => [ 1, 2, 3 ]);
69}, undef, '... created @Foo::bar successfully');
70
71ok(defined($Foo::{bar}), '... the @bar slot was created successfully');
72ok($foo_stash->has_symbol('@bar'), '... the meta agrees');
73
74# ... why does this not work ...
75
76ok(!$foo_stash->has_symbol('$bar'), '... SCALAR shouldnt have been created too');
77ok(!$foo_stash->has_symbol('%bar'), '... HASH shouldnt have been created too');
78ok(!$foo_stash->has_symbol('&bar'), '... CODE shouldnt have been created too');
79
80# check the value itself
81
82{
83    no strict 'refs';
84    is(scalar @{'Foo::bar'}, 3, '... our @bar was initialized correctly');
85    is(${'Foo::bar'}[1], 2, '... our @bar was initialized correctly');
86}
87
88# ----------------------------------------------------------------------
89## test adding a SCALAR
90
91ok(!defined($Foo::{baz}), '... the $baz slot has not been created yet');
92
93is(exception {
94    $foo_stash->add_symbol('$baz' => 10);
95}, undef, '... created $Foo::baz successfully');
96
97ok(defined($Foo::{baz}), '... the $baz slot was created successfully');
98ok($foo_stash->has_symbol('$baz'), '... the meta agrees');
99
100ok(!$foo_stash->has_symbol('@baz'), '... ARRAY shouldnt have been created too');
101ok(!$foo_stash->has_symbol('%baz'), '... HASH shouldnt have been created too');
102ok(!$foo_stash->has_symbol('&baz'), '... CODE shouldnt have been created too');
103
104is(${$foo_stash->get_symbol('$baz')}, 10, '... got the right value back');
105
106{
107    no strict 'refs';
108    ${'Foo::baz'} = 1;
109
110    is(${'Foo::baz'}, 1, '... our $baz was assigned to correctly');
111    is(${$foo_stash->get_symbol('$baz')}, 1, '... the meta agrees');
112}
113
114# ----------------------------------------------------------------------
115## test adding a CODE
116
117ok(!defined($Foo::{funk}), '... the &funk slot has not been created yet');
118
119is(exception {
120    $foo_stash->add_symbol('&funk' => sub { "Foo::funk" });
121}, undef, '... created &Foo::funk successfully');
122
123ok(defined($Foo::{funk}), '... the &funk slot was created successfully');
124ok($foo_stash->has_symbol('&funk'), '... the meta agrees');
125
126ok(!$foo_stash->has_symbol('$funk'), '... SCALAR shouldnt have been created too');
127ok(!$foo_stash->has_symbol('@funk'), '... ARRAY shouldnt have been created too');
128ok(!$foo_stash->has_symbol('%funk'), '... HASH shouldnt have been created too');
129
130{
131    no strict 'refs';
132    ok(defined &{'Foo::funk'}, '... our &funk exists');
133}
134
135is(Foo->funk(), 'Foo::funk', '... got the right value from the function');
136
137# ----------------------------------------------------------------------
138## test multiple slots in the glob
139
140my $ARRAY = [ 1, 2, 3 ];
141my $CODE = sub { "Foo::foo" };
142
143is(exception {
144    $foo_stash->add_symbol('@foo' => $ARRAY);
145}, undef, '... created @Foo::foo successfully');
146
147ok($foo_stash->has_symbol('@foo'), '... the @foo slot was added successfully');
148is($foo_stash->get_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo');
149
150is(exception {
151    $foo_stash->add_symbol('&foo' => $CODE);
152}, undef, '... created &Foo::foo successfully');
153
154ok($foo_stash->has_symbol('&foo'), '... the meta agrees');
155is($foo_stash->get_symbol('&foo'), $CODE, '... got the right value for &Foo::foo');
156
157is(exception {
158    $foo_stash->add_symbol('$foo' => 'Foo::foo');
159}, undef, '... created $Foo::foo successfully');
160
161ok($foo_stash->has_symbol('$foo'), '... the meta agrees');
162my $SCALAR = $foo_stash->get_symbol('$foo');
163is($$SCALAR, 'Foo::foo', '... got the right scalar value back');
164
165{
166    no strict 'refs';
167    is(${'Foo::foo'}, 'Foo::foo', '... got the right value from the scalar');
168}
169
170is(exception {
171    $foo_stash->remove_symbol('%foo');
172}, undef, '... removed %Foo::foo successfully');
173
174ok(!$foo_stash->has_symbol('%foo'), '... the %foo slot was removed successfully');
175ok($foo_stash->has_symbol('@foo'), '... the @foo slot still exists');
176ok($foo_stash->has_symbol('&foo'), '... the &foo slot still exists');
177ok($foo_stash->has_symbol('$foo'), '... the $foo slot still exists');
178
179is($foo_stash->get_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo');
180is($foo_stash->get_symbol('&foo'), $CODE, '... got the right value for &Foo::foo');
181is($foo_stash->get_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo');
182
183{
184    no strict 'refs';
185    ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully');
186    ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed');
187    ok(defined(*{"Foo::foo"}{CODE}), '... the &foo slot has NOT been removed');
188    ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed');
189}
190
191is(exception {
192    $foo_stash->remove_symbol('&foo');
193}, undef, '... removed &Foo::foo successfully');
194
195ok(!$foo_stash->has_symbol('&foo'), '... the &foo slot no longer exists');
196
197ok($foo_stash->has_symbol('@foo'), '... the @foo slot still exists');
198ok($foo_stash->has_symbol('$foo'), '... the $foo slot still exists');
199
200is($foo_stash->get_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo');
201is($foo_stash->get_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo');
202
203{
204    no strict 'refs';
205    ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully');
206    ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed');
207    ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed');
208    ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed');
209}
210
211is(exception {
212    $foo_stash->remove_symbol('$foo');
213}, undef, '... removed $Foo::foo successfully');
214
215ok(!$foo_stash->has_symbol('$foo'), '... the $foo slot no longer exists');
216
217ok($foo_stash->has_symbol('@foo'), '... the @foo slot still exists');
218
219is($foo_stash->get_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo');
220
221{
222    no strict 'refs';
223    ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully');
224    ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed');
225    ok(!defined(${"Foo::foo"}), '... the $foo slot has now been removed');
226    ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed');
227}
228
229{
230    my $syms = $foo_stash->get_all_symbols;
231    is_deeply(
232        [ sort keys %{ $syms } ],
233        [ sort $foo_stash->list_all_symbols ],
234        '... the fetched symbols are the same as the listed ones'
235    );
236}
237
238{
239    my $syms = $foo_stash->get_all_symbols('CODE');
240
241    is_deeply(
242        [ sort keys %{ $syms } ],
243        [ sort $foo_stash->list_all_symbols('CODE') ],
244        '... the fetched symbols are the same as the listed ones'
245    );
246
247    foreach my $symbol (keys %{ $syms }) {
248        is($syms->{$symbol}, $foo_stash->get_symbol('&' . $symbol), '... got the right symbol');
249    }
250}
251
252{
253    $foo_stash->add_symbol('%bare');
254    ok(!$foo_stash->has_symbol('$bare'),
255       "add_symbol with single argument doesn't vivify scalar slot");
256}
257
258{
259    $foo_stash->add_symbol('%zork', {});
260
261    my $syms = $foo_stash->get_all_symbols('HASH');
262
263    is_deeply(
264        [ sort keys %{ $syms } ],
265        [ sort $foo_stash->list_all_symbols('HASH') ],
266        '... the fetched symbols are the same as the listed ones'
267    );
268
269    foreach my $symbol (keys %{ $syms }) {
270        is($syms->{$symbol}, $foo_stash->get_symbol('%' . $symbol), '... got the right symbol');
271    }
272
273    is_deeply(
274        $syms,
275        {
276            zork => *{ $Foo::{zork} }{HASH},
277            bare => *{ $Foo::{bare} }{HASH},
278        },
279        "got the right ones",
280    );
281}
282
283# check some errors
284
285like(exception {
286    $foo_stash->add_symbol('@bar', {})
287}, qr/HASH.*is not of type ARRAY/, "can't initialize a slot with the wrong type of value");
288
289like(exception {
290    $foo_stash->add_symbol('bar', [])
291}, qr/ARRAY.*is not of type IO/, "can't initialize a slot with the wrong type of value");
292
293like(exception {
294    $foo_stash->add_symbol('$bar', sub { })
295}, qr/CODE.*is not of type SCALAR/, "can't initialize a slot with the wrong type of value");
296
297{
298    package Bar;
299    open *foo, '<', $0;
300}
301
302like(exception {
303    $foo_stash->add_symbol('$bar', *Bar::foo{IO})
304}, qr/IO.*is not of type SCALAR/, "can't initialize a slot with the wrong type of value");
305
306# check compile time manipulation
307
308{
309    package Baz;
310
311    our $foo = 23;
312    our @foo = "bar";
313    our %foo = (baz => 1);
314    sub foo { }
315    open *foo, '<', $0;
316    BEGIN { Package::Stash->new(__PACKAGE__)->remove_symbol('&foo') }
317}
318
319{
320    my $stash = Package::Stash->new('Baz');
321    is(${ $stash->get_symbol('$foo') }, 23, "got \$foo");
322    is_deeply($stash->get_symbol('@foo'), ['bar'], "got \@foo");
323    is_deeply($stash->get_symbol('%foo'), {baz => 1}, "got \%foo");
324    ok(!$stash->has_symbol('&foo'), "got \&foo");
325    is($stash->get_symbol('foo'), *Baz::foo{IO}, "got foo");
326}
327
328{
329    package Quux;
330
331    our $foo = 23;
332    our @foo = "bar";
333    our %foo = (baz => 1);
334    sub foo { }
335    open *foo, '<', $0;
336}
337
338{
339    my $stash = Package::Stash->new('Quux');
340
341    my %expect = (
342        '$foo' => \23,
343        '@foo' => ["bar"],
344        '%foo' => { baz => 1 },
345        '&foo' => \&Quux::foo,
346        'foo'  => *Quux::foo{IO},
347    );
348
349    for my $sym ( sort keys %expect ) {
350        is_deeply(
351            $stash->get_symbol($sym),
352            $expect{$sym},
353            "got expected value for $sym"
354        );
355    }
356
357    $stash->add_symbol('%bar' => {x => 42});
358
359    $expect{'%bar'} = {x => 42};
360
361    for my $sym ( sort keys %expect ) {
362        is_deeply(
363            $stash->get_symbol($sym),
364            $expect{$sym},
365            "got expected value for $sym"
366        );
367    }
368
369    $stash->add_symbol('%bar' => {x => 43});
370
371    $expect{'%bar'} = {x => 43};
372
373    for my $sym ( sort keys %expect ) {
374        is_deeply(
375            $stash->get_symbol($sym),
376            $expect{$sym},
377            "got expected value for $sym"
378        );
379    }
380}
381
382{
383    package Quuux;
384    our $foo;
385    our @foo;
386    our @bar;
387    our %baz;
388    sub baz { }
389    use constant quux => 1;
390    use constant quuux => [];
391    sub quuuux;
392}
393
394{
395    my $quuux = Package::Stash->new('Quuux');
396    is_deeply(
397        [sort $quuux->list_all_symbols],
398        [qw(BEGIN bar baz foo quuuux quuux quux)],
399        "list_all_symbols",
400    );
401    { local $TODO = $] < 5.010
402          ? "undef scalars aren't visible on 5.8"
403          : undef;
404    is_deeply(
405        [sort $quuux->list_all_symbols('SCALAR')],
406        [qw(foo)],
407        "list_all_symbols SCALAR",
408    );
409    }
410    is_deeply(
411        [sort $quuux->list_all_symbols('ARRAY')],
412        [qw(bar foo)],
413        "list_all_symbols ARRAY",
414    );
415    is_deeply(
416        [sort $quuux->list_all_symbols('HASH')],
417        [qw(baz)],
418        "list_all_symbols HASH",
419    );
420    is_deeply(
421        [sort $quuux->list_all_symbols('CODE')],
422        [qw(baz quuuux quuux quux)],
423        "list_all_symbols CODE",
424    );
425}
426
427for my $package ('Foo:Bar', 'Foo/Bar', 'Foo Bar', 'Foo:::Bar', '') {
428    like(
429        exception { Package::Stash->new($package) },
430        qr/^$package is not a module name/,
431        "$package is not a module name"
432    );
433}
434
435like(
436    exception { Package::Stash->new([]) },
437    qr/^Package::Stash->new must be passed the name of the package to access/,
438    "module name must be a string"
439);
440
441like(
442    exception { Package::Stash->new(undef) },
443    qr/^Package::Stash->new must be passed the name of the package to access/,
444    "module name must be a string"
445);
446
447done_testing;
448