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