t/35-stash.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More;
   7
   8 use Variable::Magic qw/wizard cast dispell VMG_UVAR VMG_OP_INFO_NAME VMG_OP_INFO_OBJECT/;
   9
  10 my $run;
  11 if (VMG_UVAR) {
  12  plan tests => 41;
  13  $run = 1;
  14 } else {
  15  plan skip_all => 'uvar magic is required to test symbol table hooks';
  16 }
  17
  18 our %mg;
  19
  20 my $code = 'wizard '
  21         . join (', ', map { <<CB;
  22 $_ => sub {
  23  my \$d = \$_[1];
  24  return 0 if \$d->{guard};
  25  local \$d->{guard} = 1;
  26  push \@{\$mg{$_}}, \$_[2];
  27  ()
  28 }
  29 CB
  30 } qw/fetch store exists delete/);
  31
  32 $code .= ', data => sub { +{ guard => 0 } }';
  33
  34 my $wiz = eval $code;
  35 diag $@ if $@;
  36
  37 cast %Hlagh::, $wiz;
  38
  39 {
  40  local %mg;
  41
  42  eval q{
  43   die "ok\n";
  44   package Hlagh;
  45   our $thing;
  46   {
  47    package NotHlagh;
  48    our $what = @Hlagh::stuff;
  49   }
  50  };
  51
  52  is $@, "ok\n", 'stash: variables compiled fine';
  53  is_deeply \%mg, {
  54   fetch => [ qw/thing stuff/ ],
  55   store => [ qw/thing stuff/ ],
  56  }, 'stash: variables';
  57 }
  58
  59 {
  60  local %mg;
  61
  62  eval q[
  63   die "ok\n";
  64   package Hlagh;
  65   sub eat;
  66   sub shoot;
  67   sub leave { "bye" };
  68   sub shoot { "bang" };
  69  ];
  70
  71  is $@, "ok\n", 'stash: function definitions compiled fine';
  72  is_deeply \%mg, {
  73   store => [ qw/eat shoot leave shoot/ ],
  74  }, 'stash: function definitions';
  75 }
  76
  77 {
  78  local %mg;
  79
  80  eval q{
  81   die "ok\n";
  82   package Hlagh;
  83   eat();
  84   shoot();
  85   leave();
  86   roam();
  87   yawn();
  88   roam();
  89  };
  90
  91  is $@, "ok\n", 'stash: function calls compiled fine';
  92  is_deeply \%mg, {
  93   fetch => [ qw/eat shoot leave roam yawn roam/ ],
  94   store => [ qw/eat shoot leave roam yawn roam/ ],
  95  }, 'stash: function calls';
  96 }
  97
  98 {
  99  local %mg;
 100
 101  eval q{ Hlagh->shoot() };
 102
 103  is $@, '', 'stash: valid method call ran fine';
 104  is_deeply \%mg, {
 105   fetch => [ qw/shoot/ ],
 106  }, 'stash: valid method call';
 107 }
 108
 109 {
 110  local %mg;
 111
 112  eval q{ Hlagh->shoot() };
 113
 114  is $@, '', 'stash: second valid method call ran fine';
 115  is_deeply \%mg, {
 116   fetch => [ qw/shoot/ ],
 117  }, 'stash: second valid method call';
 118 }
 119
 120 {
 121  local %mg;
 122
 123  eval q{ my $meth = 'shoot'; Hlagh->$meth() };
 124
 125  is $@, '', 'stash: valid dynamic method call ran fine';
 126  is_deeply \%mg, {
 127   store => [ qw/shoot/ ],
 128  }, 'stash: valid dynamic method call';
 129 }
 130
 131 {
 132  local %mg;
 133
 134  eval q[
 135   package Hlagher;
 136   our @ISA;
 137   BEGIN { @ISA = 'Hlagh' }
 138   Hlagher->leave()
 139  ];
 140
 141  is $@, '', 'inherited valid method call ran fine';
 142  is_deeply \%mg, {
 143   fetch => [ qw/ISA leave/ ],
 144  }, 'stash: inherited valid method call';
 145 }
 146
 147 {
 148  local %mg;
 149
 150  eval q{ Hlagher->leave() };
 151
 152  is $@, '', 'second inherited valid method call ran fine';
 153  is_deeply \%mg, { }, 'stash: second inherited valid method call doesn\'t call magic';
 154 }
 155
 156 {
 157  local %mg;
 158
 159  eval q{ Hlagher->shoot() };
 160
 161  is $@, '', 'inherited previously called valid method call ran fine';
 162  is_deeply \%mg, {
 163   fetch => [ qw/shoot/ ],
 164  }, 'stash: inherited previously called valid method call';
 165 }
 166
 167 {
 168  local %mg;
 169
 170  eval q{ Hlagher->shoot() };
 171
 172  is $@, '', 'second inherited previously called valid method call ran fine';
 173  is_deeply \%mg, { }, 'stash: second inherited previously called valid method call doesn\'t call magic';
 174 }
 175
 176 {
 177  local %mg;
 178
 179  eval q{ Hlagh->unknown() };
 180
 181  like $@, qr/^Can't locate object method "unknown" via package "Hlagh"/, 'stash: invalid method call croaked';
 182  is_deeply \%mg, {
 183   fetch => [ qw/unknown/ ],
 184   store => [ qw/unknown AUTOLOAD/ ],
 185  }, 'stash: invalid method call';
 186 }
 187
 188 {
 189  local %mg;
 190
 191  eval q{ my $meth = 'unknown_too'; Hlagh->$meth() };
 192
 193  like $@, qr/^Can't locate object method "unknown_too" via package "Hlagh"/, 'stash: invalid dynamic method call croaked';
 194  is_deeply \%mg, {
 195   store => [ qw/unknown_too AUTOLOAD/ ],
 196  }, 'stash: invalid dynamic method call';
 197 }
 198
 199 {
 200  local %mg;
 201
 202  eval q{ Hlagher->also_unknown() };
 203
 204  like $@, qr/^Can't locate object method "also_unknown" via package "Hlagher"/, 'stash: invalid inherited method call croaked';
 205  is_deeply \%mg, {
 206   fetch => [ qw/also_unknown AUTOLOAD/ ],
 207  }, 'stash: invalid method call';
 208 }
 209
 210 {
 211  local %mg;
 212
 213  eval q{
 214   package Hlagh;
 215   undef &nevermentioned;
 216   undef &eat;
 217   undef &shoot;
 218  };
 219
 220  is $@, '', 'stash: delete executed fine';
 221  is_deeply \%mg, {
 222   store => [
 223    qw/nevermentioned nevermentioned eat eat shoot shoot nevermentioned/
 224   ],
 225  }, 'stash: delete';
 226 }
 227
 228 END {
 229  is_deeply \%mg, { }, 'stash: magic that remains at END time' if $run;
 230 }
 231
 232 dispell %Hlagh::, $wiz;
 233
 234 {
 235  package AutoHlagh;
 236
 237  use vars qw/$AUTOLOAD/;
 238
 239  sub AUTOLOAD { return $AUTOLOAD }
 240 }
 241
 242 cast %AutoHlagh::, $wiz;
 243
 244 {
 245  local %mg;
 246
 247  my $res = eval q{ AutoHlagh->autoloaded() };
 248
 249  is $@,   '',          'stash: autoloaded method call ran fine';
 250  is $res, 'AutoHlagh::autoloaded',
 251                        'stash: autoloaded method call returned the right thing';
 252  is_deeply \%mg, {
 253   fetch => [ qw/autoloaded/ ],
 254   store => [ qw/autoloaded AUTOLOAD AUTOLOAD/ ],
 255  }, 'stash: autoloaded method call';
 256 }
 257
 258 {
 259  package AutoHlagher;
 260
 261  our @ISA;
 262  BEGIN { @ISA = ('AutoHlagh') }
 263 }
 264
 265 {
 266  local %mg;
 267
 268  my $res = eval q{ AutoHlagher->also_autoloaded() };
 269
 270  is $@,   '',     'stash: inherited autoloaded method call ran fine';
 271  is $res, 'AutoHlagher::also_autoloaded',
 272                   'stash: inherited autoloaded method returned the right thing';
 273  is_deeply \%mg, {
 274   fetch => [ qw/also_autoloaded AUTOLOAD/ ],
 275   store => [ qw/AUTOLOAD/ ],
 276  }, 'stash: inherited autoloaded method call';
 277 }
 278
 279 dispell %AutoHlagh::, $wiz;
 280
 281 $code = 'wizard '
 282         . join (', ', map { <<CB;
 283 $_ => sub {
 284  my \$d = \$_[1];
 285  return 0 if \$d->{guard};
 286  local \$d->{guard} = 1;
 287  is \$_[3], undef, 'stash: undef op';
 288  ()
 289 }
 290 CB
 291 } qw/fetch store exists delete/);
 292
 293 $code .= ', data => sub { +{ guard => 0 } }';
 294
 295 $wiz = eval $code . ', op_info => ' . VMG_OP_INFO_NAME;
 296 diag $@ if $@;
 297
 298 cast %Hlagh::, $wiz;
 299
 300 eval q{
 301  die "ok\n";
 302  package Hlagh;
 303  meh();
 304 };
 305
 306 is $@, "ok\n", 'stash: function call with op name compiled fine';
 307
 308 dispell %Hlagh::, $wiz;
 309
 310 $wiz = eval $code . ', op_info => ' . VMG_OP_INFO_OBJECT;
 311 diag $@ if $@;
 312
 313 cast %Hlagh::, $wiz;
 314
 315 eval q{
 316  die "ok\n";
 317  package Hlagh;
 318  wat();
 319 };
 320
 321 is $@, "ok\n", 'stash: function call with op object compiled fine';
 322
 323 dispell %Hlagh::, $wiz;