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 => 23;
  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 $a;
  46   {
  47    package NotHlagh;
  48    our $x = @Hlagh::b;
  49   }
  50  };
  51
  52  is $@, "ok\n", 'stash: variables compiled fine';
  53  is_deeply \%mg, {
  54   fetch => [ qw/a b/ ],
  55   store => [ qw/a b/ ],
  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 $code = 'wizard '
 173         . join (', ', map { <<CB;
 174 $_ => sub {
 175  my \$d = \$_[1];
 176  return 0 if \$d->{guard};
 177  local \$d->{guard} = 1;
 178  is \$_[3], undef, 'stash: undef op';
 179  ()
 180 }
 181 CB
 182 } qw/fetch store exists delete/);
 183
 184 $code .= ', data => sub { +{ guard => 0 } }';
 185
 186 $wiz = eval $code . ', op_info => ' . VMG_OP_INFO_NAME;
 187 diag $@ if $@;
 188
 189 cast %Hlagh::, $wiz;
 190
 191 eval q{
 192  die "ok\n";
 193  package Hlagh;
 194  meh();
 195 };
 196
 197 is $@, "ok\n", 'stash: function call with op name compiled fine';
 198
 199 dispell %Hlagh::, $wiz;
 200
 201 $wiz = eval $code . ', op_info => ' . VMG_OP_INFO_OBJECT;
 202 diag $@ if $@;
 203
 204 cast %Hlagh::, $wiz;
 205
 206 eval q{
 207  die "ok\n";
 208  package Hlagh;
 209  wat();
 210 };
 211
 212 is $@, "ok\n", 'stash: function call with op object compiled fine';
 213
 214 dispell %Hlagh::, $wiz;