]> git.vpit.fr Git - perl/modules/Variable-Magic.git/blob - t/17-ctl.t
Give a saner default to pPTBLMS
[perl/modules/Variable-Magic.git] / t / 17-ctl.t
1 #!perl
2
3 use strict;
4 use warnings;
5
6 use Test::More tests => 4 * 8 + 10 + 1 + 1;
7
8 use Variable::Magic qw/wizard cast VMG_UVAR/;
9
10 sub expect {
11  my ($name, $where, $suffix) = @_;
12  $where  = defined $where ? quotemeta $where : '\(eval \d+\)';
13  my $end = defined $suffix ? "$suffix\$" : '$';
14  qr/^\Q$name\E at $where line \d+\.$end/
15 }
16
17 my @scalar_tests = (
18  [ 'data', sub { \(my $x) },   sub { }                    ],
19  [ 'get',  sub { \(my $x) },   sub { my $y = ${$_[0]} }   ],
20  [ 'set',  sub { \(my $x) },   sub { ${$_[0]} = 1 }       ],
21  [ 'len',  sub { [ 1 .. 3 ] }, sub { my $res = @{$_[0]} } ],
22 );
23
24 # Data, get, set, len
25
26 for my $t (@scalar_tests) {
27  my ($name, $init, $code) = @$t;
28
29  my $wiz = wizard $name => sub { die 'leek' };
30
31  {
32   local $@;
33   eval {
34    my $x = $init->();
35    &cast($x, $wiz);
36    $code->($x);
37   };
38   like $@, expect('leek', $0),
39                             "die in $name callback (direct, \$@ unset) in eval";
40  }
41
42  {
43   local $@;
44   eval {
45    my $x = $init->();
46    &cast($x, $wiz);
47    $@ = 'artichoke';
48    $code->($x);
49   };
50   like $@, expect('leek', $0),
51                               "die in $name callback (direct, \$@ set) in eval";
52  }
53
54  {
55   local $@;
56   eval q{BEGIN {
57    my $x = $init->();
58    &cast($x, $wiz);
59    $code->($x);
60   }};
61   like $@, expect('leek', $0, "\nBEGIN.*"),
62                            "die in $name callback (direct, \$@ unset) in BEGIN";
63  }
64
65  {
66   local $@;
67   eval q{BEGIN {
68    my $x = $init->();
69    &cast($x, $wiz);
70    $@ = 'artichoke';
71    $code->($x);
72   }};
73   like $@, expect('leek', $0, "\nBEGIN.*"),
74                              "die in $name callback (direct, \$@ set) in BEGIN";
75  }
76
77  $wiz = wizard(
78   ($name eq 'data' ? () : (data  => sub { $_[1] })),
79    $name => sub { $_[1]->(); () },
80  );
81
82  {
83   local $@;
84   eval {
85    my $x = $init->();
86    &cast($x, $wiz, sub { die 'lettuce' });
87    $code->($x);
88   };
89   like $@, expect('lettuce', $0),
90                           "die in $name callback (indirect, \$@ unset) in eval";
91  }
92
93  {
94   local $@;
95   eval {
96    my $x = $init->();
97    &cast($x, $wiz, sub { die 'carrot' });
98    $@ = 'artichoke';
99    $code->($x);
100   };
101   like $@, expect('carrot', $0),
102                           "die in $name callback (indirect, \$@ unset) in eval";
103  }
104
105  {
106   local $@;
107   eval q{BEGIN {
108    my $x = $init->();
109    &cast($x, $wiz, sub { die "pumpkin" });
110    $code->($x);
111   }};
112   like $@, expect('pumpkin', undef, "\nBEGIN.*"),
113                          "die in $name callback (indirect, \$@ unset) in BEGIN";
114  }
115
116  {
117   local $@;
118   eval q{BEGIN {
119    my $x = $init->();
120    &cast($x, $wiz, sub { die "chard" });
121    $@ = 'artichoke';
122    $code->($x);
123   }};
124   like $@, expect('chard', undef, "\nBEGIN.*"),
125                            "die in $name callback (indirect, \$@ set) in BEGIN";
126  }
127 }
128
129 # Free
130
131 my $wiz;
132
133 eval {
134  $wiz = wizard data => sub { $_[1] },
135                free => sub { $_[1]->(); () };
136  my $x;
137  cast $x, $wiz, sub { die "spinach" };
138 };
139
140 like $@, expect('spinach', $0), 'die in free callback';
141
142 eval {
143  $wiz = wizard free => sub { die 'zucchini' };
144  $@ = "";
145  {
146   my $x;
147   cast $x, $wiz;
148  }
149  die 'not reached';
150 };
151
152 like $@, expect('zucchini', $0),
153                           'die in free callback in block in eval with $@ unset';
154
155 eval {
156  $wiz = wizard free => sub { die 'eggplant' };
157  $@ = "artichoke";
158  {
159   my $x;
160   cast $x, $wiz;
161  }
162  die 'not reached again';
163 };
164
165 like $@, expect('eggplant', $0),
166                             'die in free callback in block in eval with $@ set';
167
168 eval q{BEGIN {
169  $wiz = wizard free => sub { die 'onion' };
170  my $x;
171  cast $x, $wiz;
172 }};
173
174 like $@, expect('onion', undef, "\nBEGIN.*"), 'die in free callback in BEGIN';
175
176 eval q{BEGIN {
177  $wiz = wizard data => sub { $_[1] },
178                len  => sub { $_[1]->(); $_[2] },
179                free => sub { my $x = @{$_[0]}; () };
180  my @a = (1 .. 5);
181  cast @a, $wiz, sub { die "pepperoni" };
182 }};
183
184 like $@, expect('pepperoni', undef, "\nBEGIN.*"),
185                                 'die in free callback in len callback in BEGIN';
186
187 # Inspired by B::Hooks::EndOfScope
188
189 eval q{BEGIN {
190  $wiz = wizard data => sub { $_[1] },
191                free => sub { $_[1]->(); () };
192  $^H |= 0x020000;
193  cast %^H, $wiz, sub { die 'cabbage' };
194 }};
195
196 like $@, expect('cabbage'), 'die in free callback at end of scope';
197
198 use lib 't/lib';
199
200 my $vm_tse_file = 't/lib/Variable/Magic/TestScopeEnd.pm';
201
202 eval "use Variable::Magic::TestScopeEnd";
203 like $@, expect('turnip', $vm_tse_file, "\nBEGIN(?s:.*)"),
204         'die in BEGIN in require in eval string triggers hints hash destructor';
205
206 eval q{BEGIN {
207  Variable::Magic::TestScopeEnd::hook {
208   pass 'in hints hash destructor 2';
209  };
210  die "tomato";
211 }};
212
213 like $@, expect('tomato', undef, "\nBEGIN.*"),
214                           'die in BEGIN in eval triggers hints hash destructor';
215
216 sub run_perl {
217  my $code = shift;
218
219  my $SystemRoot   = $ENV{SystemRoot};
220  local %ENV;
221  $ENV{SystemRoot} = $SystemRoot if $^O eq 'MSWin32' and defined $SystemRoot;
222
223  system { $^X } $^X, '-T', map("-I$_", @INC), '-e', $code;
224 }
225
226 my $has_capture_tiny = do { local $@; eval 'use Capture::Tiny 0.08 (); 1' };
227
228 SKIP:
229 {
230  my $count = 1;
231
232  skip 'Capture::Tiny 0.08 is not installed' => $count unless $has_capture_tiny;
233
234  my $output = Capture::Tiny::capture_merged(sub { run_perl <<' CODE' });
235 use Variable::Magic qw/wizard cast/; { BEGIN { $^H |= 0x020000; cast %^H, wizard free => sub { die q[cucumber] } } }
236  CODE
237  skip 'Test code didn\'t run properly' => 1 unless defined $output;
238  like $output, expect('cucumber', '-e', "\nExecution(?s:.*)"),
239                   'die in free callback at compile time and not in eval string';
240  --$count;
241 }
242
243 # Uvar
244
245 SKIP:
246 {
247  my $count = 1;
248
249  skip 'No nice uvar magic for this perl'    => $count unless VMG_UVAR;
250  skip 'Capture::Tiny 0.08 is not installed' => $count unless $has_capture_tiny;
251
252  my $output = Capture::Tiny::capture_merged(sub { run_perl <<' CODE' });
253 use Variable::Magic qw/wizard cast/; BEGIN { cast %::, wizard fetch => sub { die q[salsify] } } hlagh()
254  CODE
255  skip 'Test code didn\'t run properly' => $count unless defined $output;
256  my $suffix = "\nExecution(?s:.*)";
257  if ($] >= 5.011005) {
258   $suffix = "(?:\nsalsify at -e line \\d+.){12}" . $suffix;
259  } elsif ($] >= 5.011) {
260   $suffix = "(?:\nsalsify at -e line \\d+.){3}" . $suffix;
261  }
262  like $output, expect('salsify', '-e', $suffix),
263                   'die in free callback at compile time and not in eval string';
264  --$count;
265 }