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