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