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