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