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 => 43;
  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  my @calls = qw/eat shoot leave roam yawn roam/;
  92
  93  is $@, "ok\n", 'stash: function calls compiled fine';
  94  is_deeply \%mg, {
  95   fetch => \@calls,
  96   store => ($] < 5.011002 ? \@calls : [ map { ($_) x 2 } @calls ]),
  97  }, 'stash: function calls';
  98 }
  99
 100 {
 101  local %mg;
 102
 103  eval q{ Hlagh->shoot() };
 104
 105  is $@, '', 'stash: valid method call ran fine';
 106  is_deeply \%mg, {
 107   fetch => [ qw/shoot/ ],
 108  }, 'stash: valid method call';
 109 }
 110
 111 {
 112  local %mg;
 113
 114  eval q{ Hlagh->shoot() };
 115
 116  is $@, '', 'stash: second valid method call ran fine';
 117  is_deeply \%mg, {
 118   fetch => [ qw/shoot/ ],
 119  }, 'stash: second valid method call';
 120 }
 121
 122 {
 123  local %mg;
 124
 125  eval q{ my $meth = 'shoot'; Hlagh->$meth() };
 126
 127  is $@, '', 'stash: valid dynamic method call ran fine';
 128  is_deeply \%mg, {
 129   store => [ qw/shoot/ ],
 130  }, 'stash: valid dynamic method call';
 131 }
 132
 133 {
 134  local %mg;
 135
 136  eval q[
 137   package Hlagher;
 138   our @ISA;
 139   BEGIN { @ISA = 'Hlagh' }
 140   Hlagher->leave()
 141  ];
 142
 143  is $@, '', 'inherited valid method call ran fine';
 144  is_deeply \%mg, {
 145   fetch => [ qw/ISA leave/ ],
 146  }, 'stash: inherited valid method call';
 147 }
 148
 149 {
 150  local %mg;
 151
 152  eval q{ Hlagher->leave() };
 153
 154  is $@, '', 'second inherited valid method call ran fine';
 155  is_deeply \%mg, { }, 'stash: second inherited valid method call doesn\'t call magic';
 156 }
 157
 158 {
 159  local %mg;
 160
 161  eval q{ Hlagher->shoot() };
 162
 163  is $@, '', 'inherited previously called valid method call ran fine';
 164  is_deeply \%mg, {
 165   fetch => [ qw/shoot/ ],
 166  }, 'stash: inherited previously called valid method call';
 167 }
 168
 169 {
 170  local %mg;
 171
 172  eval q{ Hlagher->shoot() };
 173
 174  is $@, '', 'second inherited previously called valid method call ran fine';
 175  is_deeply \%mg, { }, 'stash: second inherited previously called valid method call doesn\'t call magic';
 176 }
 177
 178 {
 179  local %mg;
 180
 181  eval q{ Hlagh->unknown() };
 182
 183  like $@, qr/^Can't locate object method "unknown" via package "Hlagh"/, 'stash: invalid method call croaked';
 184  is_deeply \%mg, {
 185   fetch => [ qw/unknown/ ],
 186   store => [ qw/unknown AUTOLOAD/ ],
 187  }, 'stash: invalid method call';
 188 }
 189
 190 {
 191  local %mg;
 192
 193  eval q{ my $meth = 'unknown_too'; Hlagh->$meth() };
 194
 195  like $@, qr/^Can't locate object method "unknown_too" via package "Hlagh"/, 'stash: invalid dynamic method call croaked';
 196  is_deeply \%mg, {
 197   store => [ qw/unknown_too AUTOLOAD/ ],
 198  }, 'stash: invalid dynamic method call';
 199 }
 200
 201 {
 202  local %mg;
 203
 204  eval q{ Hlagher->also_unknown() };
 205
 206  like $@, qr/^Can't locate object method "also_unknown" via package "Hlagher"/, 'stash: invalid inherited method call croaked';
 207  is_deeply \%mg, {
 208   fetch => [ qw/also_unknown AUTOLOAD/ ],
 209  }, 'stash: invalid method call';
 210 }
 211
 212 {
 213  local %mg;
 214
 215  eval q{
 216   package Hlagh;
 217   undef &nevermentioned;
 218   undef &eat;
 219   undef &shoot;
 220  };
 221
 222  is $@, '', 'stash: delete executed fine';
 223  is_deeply \%mg, {
 224   store => [
 225    qw/nevermentioned nevermentioned eat eat shoot shoot nevermentioned/
 226   ],
 227  }, 'stash: delete';
 228 }
 229
 230 END {
 231  is_deeply \%mg, { }, 'stash: magic that remains at END time' if $run;
 232 }
 233
 234 dispell %Hlagh::, $wiz;
 235
 236 {
 237  package AutoHlagh;
 238
 239  use vars qw/$AUTOLOAD/;
 240
 241  sub AUTOLOAD { return $AUTOLOAD }
 242 }
 243
 244 cast %AutoHlagh::, $wiz;
 245
 246 {
 247  local %mg;
 248
 249  my $res = eval q{ AutoHlagh->autoloaded() };
 250
 251  is $@,   '',          'stash: autoloaded method call ran fine';
 252  is $res, 'AutoHlagh::autoloaded',
 253                        'stash: autoloaded method call returned the right thing';
 254  is_deeply \%mg, {
 255   fetch => [ qw/autoloaded/ ],
 256   store => [ qw/autoloaded AUTOLOAD AUTOLOAD/ ],
 257  }, 'stash: autoloaded method call';
 258 }
 259
 260 {
 261  package AutoHlagher;
 262
 263  our @ISA;
 264  BEGIN { @ISA = ('AutoHlagh') }
 265 }
 266
 267 {
 268  local %mg;
 269
 270  my $res = eval q{ AutoHlagher->also_autoloaded() };
 271
 272  is $@,   '',     'stash: inherited autoloaded method call ran fine';
 273  is $res, 'AutoHlagher::also_autoloaded',
 274                   'stash: inherited autoloaded method returned the right thing';
 275  is_deeply \%mg, {
 276   fetch => [ qw/also_autoloaded AUTOLOAD/ ],
 277   store => [ qw/AUTOLOAD/ ],
 278  }, 'stash: inherited autoloaded method call';
 279 }
 280
 281 dispell %AutoHlagh::, $wiz;
 282
 283 my $uo = 0;
 284 $code = 'wizard '
 285         . join (', ', map { <<CB;
 286 $_ => sub {
 287  my \$d = \$_[1];
 288  return 0 if \$d->{guard};
 289  local \$d->{guard} = 1;
 290  ++\$uo;
 291  ()
 292 }
 293 CB
 294 } qw/fetch store exists delete/);
 295
 296 my $uo_exp = $] < 5.011002 ? 2 : 3;
 297
 298 $code .= ', data => sub { +{ guard => 0 } }';
 299
 300 $wiz = eval $code . ', op_info => ' . VMG_OP_INFO_NAME;
 301 diag $@ if $@;
 302
 303 cast %Hlagh::, $wiz;
 304
 305 is $uo, 0, 'stash: no undef op before function call with op name';
 306 eval q{
 307  die "ok\n";
 308  package Hlagh;
 309  meh();
 310 };
 311 is $@,  "ok\n",  'stash: function call with op name compiled fine';
 312 is $uo, $uo_exp, 'stash: undef op after function call with op name';
 313
 314 dispell %Hlagh::, $wiz;
 315 is $uo, $uo_exp, 'stash: undef op after dispell for function call with op name';
 316
 317 $uo = 0;
 318
 319 $wiz = eval $code . ', op_info => ' . VMG_OP_INFO_OBJECT;
 320 diag $@ if $@;
 321
 322 cast %Hlagh::, $wiz;
 323
 324 is $uo, 0, 'stash: no undef op before function call with op object';
 325 eval q{
 326  die "ok\n";
 327  package Hlagh;
 328  wat();
 329 };
 330 is $@,        "ok\n", 'stash: function call with op object compiled fine';
 331 is $uo, $uo_exp,
 332                'stash: undef op after dispell for function call with op object';
 333
 334 dispell %Hlagh::, $wiz;
 335 is $uo, $uo_exp,
 336                'stash: undef op after dispell for function call with op object';