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