]> git.vpit.fr Git - perl/modules/Variable-Magic.git/blob - t/35-stash.t
a9600bc44d3f6b1a73e6ec5282fb706fcb5166ec
[perl/modules/Variable-Magic.git] / 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  my %expected = ( fetch => [ qw<shoot> ] );
118  # Typeglob reification may cause a store in 5.28+
119  if ("$]" >= 5.027 && %mg == 2) {
120   $expected{store} = $expected{fetch};
121  }
122  is_deeply \%mg, \%expected, '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 && "$]" < 5.021_004 ? 3 : 2;
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';