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