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 = qw<nevermentioned eat shoot>;
 219  @expected_stores    = map { ($_) x 2 } @expected_stores if "$]" < 5.017_004;
 220  push @expected_stores, 'nevermentioned'                 if "$]" < 5.017_001;
 221
 222  eval q{
 223   package Hlagh;
 224   undef &nevermentioned;
 225   undef &eat;
 226   undef &shoot;
 227  };
 228
 229  is $@, '', 'stash: delete executed fine';
 230  is_deeply \%mg, { store => \@expected_stores }, 'stash: delete';
 231 }
 232
 233 END {
 234  is_deeply \%mg, { }, 'stash: magic that remains at END time' if $run;
 235 }
 236
 237 dispell %Hlagh::, $wiz;
 238
 239 {
 240  package AutoHlagh;
 241
 242  use vars qw<$AUTOLOAD>;
 243
 244  sub AUTOLOAD { return $AUTOLOAD }
 245 }
 246
 247 cast %AutoHlagh::, $wiz;
 248
 249 {
 250  local %mg;
 251
 252  my $res = eval q{ AutoHlagh->autoloaded() };
 253
 254  is $@,   '',          'stash: autoloaded method call ran fine';
 255  is $res, 'AutoHlagh::autoloaded',
 256                        'stash: autoloaded method call returned the right thing';
 257  is_deeply \%mg, {
 258   fetch => [ qw<autoloaded> ],
 259   store => [ qw<autoloaded AUTOLOAD AUTOLOAD> ],
 260  }, 'stash: autoloaded method call';
 261 }
 262
 263 {
 264  package AutoHlagher;
 265
 266  our @ISA;
 267  BEGIN { @ISA = ('AutoHlagh') }
 268 }
 269
 270 {
 271  local %mg;
 272
 273  my $res = eval q{ AutoHlagher->also_autoloaded() };
 274
 275  is $@,   '',     'stash: inherited autoloaded method call ran fine';
 276  is $res, 'AutoHlagher::also_autoloaded',
 277                   'stash: inherited autoloaded method returned the right thing';
 278  is_deeply \%mg, {
 279   fetch => [ qw<also_autoloaded AUTOLOAD> ],
 280   store => [ qw<AUTOLOAD> ],
 281  }, 'stash: inherited autoloaded method call';
 282 }
 283
 284 dispell %AutoHlagh::, $wiz;
 285
 286 my $uo = 0;
 287 $code = 'wizard '
 288         . join (', ', map { <<CB;
 289 $_ => sub {
 290  my \$d = \$_[1];
 291  return 0 if \$d->{guard};
 292  local \$d->{guard} = 1;
 293  ++\$uo;
 294  ()
 295 }
 296 CB
 297 } qw<fetch store exists delete>);
 298
 299 my $uo_exp = "$]" < 5.011_002 ? 2 : 3;
 300
 301 $code .= ', data => sub { +{ guard => 0 } }';
 302
 303 $wiz = eval $code . ', op_info => ' . VMG_OP_INFO_NAME;
 304 diag $@ if $@;
 305
 306 cast %Hlagh::, $wiz;
 307
 308 is $uo, 0, 'stash: no undef op before function call with op name';
 309 eval q{
 310  die "ok\n";
 311  package Hlagh;
 312  meh();
 313 };
 314 is $@,  "ok\n",  'stash: function call with op name compiled fine';
 315 is $uo, $uo_exp, 'stash: undef op after function call with op name';
 316
 317 dispell %Hlagh::, $wiz;
 318 is $uo, $uo_exp, 'stash: undef op after dispell for function call with op name';
 319
 320 $uo = 0;
 321
 322 $wiz = eval $code . ', op_info => ' . VMG_OP_INFO_OBJECT;
 323 diag $@ if $@;
 324
 325 cast %Hlagh::, $wiz;
 326
 327 is $uo, 0, 'stash: no undef op before function call with op object';
 328 eval q{
 329  die "ok\n";
 330  package Hlagh;
 331  wat();
 332 };
 333 is $@,        "ok\n", 'stash: function call with op object compiled fine';
 334 is $uo, $uo_exp,
 335                'stash: undef op after dispell for function call with op object';
 336
 337 dispell %Hlagh::, $wiz;
 338 is $uo, $uo_exp,
 339                'stash: undef op after dispell for function call with op object';