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