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