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