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