Commit | Line | Data |
---|---|---|
a559c259 LW |
1 | #!./perl |
2 | ||
7e736055 HS |
3 | BEGIN { |
4 | chdir 't' if -d 't'; | |
5 | @INC = '../lib'; | |
1c25d394 | 6 | require './test.pl'; |
7e736055 HS |
7 | } |
8 | ||
a49b10d0 | 9 | plan(tests => 130); |
a559c259 | 10 | |
b38b3145 | 11 | eval 'pass();'; |
a559c259 | 12 | |
b38b3145 | 13 | is($@, ''); |
a559c259 LW |
14 | |
15 | eval "\$foo\n = # this is a comment\n'ok 3';"; | |
b38b3145 | 16 | is($foo, 'ok 3'); |
a559c259 LW |
17 | |
18 | eval "\$foo\n = # this is a comment\n'ok 4\n';"; | |
b38b3145 | 19 | is($foo, "ok 4\n"); |
a559c259 | 20 | |
378cc40b | 21 | print eval ' |
79072805 | 22 | $foo =;'; # this tests for a call through yyerror() |
b38b3145 | 23 | like($@, qr/line 2/); |
a559c259 | 24 | |
378cc40b | 25 | print eval '$foo = /'; # this tests for a call through fatal() |
b38b3145 | 26 | like($@, qr/Search/); |
378cc40b | 27 | |
2bf54cc6 FC |
28 | is scalar(eval '++'), undef, 'eval syntax error in scalar context'; |
29 | is scalar(eval 'die'), undef, 'eval run-time error in scalar context'; | |
30 | is +()=eval '++', 0, 'eval syntax error in list context'; | |
31 | is +()=eval 'die', 0, 'eval run-time error in list context'; | |
32 | ||
b38b3145 | 33 | is(eval '"ok 7\n";', "ok 7\n"); |
378cc40b LW |
34 | |
35 | $foo = 5; | |
36 | $fact = 'if ($foo <= 1) {1;} else {push(@x,$foo--); (eval $fact) * pop(@x);}'; | |
37 | $ans = eval $fact; | |
b38b3145 | 38 | is($ans, 120, 'calculate a factorial with recursive evals'); |
378cc40b LW |
39 | |
40 | $foo = 5; | |
a687059c | 41 | $fact = 'local($foo)=$foo; $foo <= 1 ? 1 : $foo-- * (eval $fact);'; |
378cc40b | 42 | $ans = eval $fact; |
b38b3145 | 43 | is($ans, 120, 'calculate a factorial with recursive evals'); |
378cc40b | 44 | |
b38b3145 | 45 | my $curr_test = curr_test(); |
1c25d394 NC |
46 | my $tempfile = tempfile(); |
47 | open(try,'>',$tempfile); | |
b38b3145 | 48 | print try 'print "ok $curr_test\n";',"\n"; |
378cc40b LW |
49 | close try; |
50 | ||
1c25d394 | 51 | do "./$tempfile"; print $@; |
99b89507 LW |
52 | |
53 | # Test the singlequoted eval optimizer | |
54 | ||
b38b3145 | 55 | $i = $curr_test + 1; |
99b89507 LW |
56 | for (1..3) { |
57 | eval 'print "ok ", $i++, "\n"'; | |
58 | } | |
59 | ||
b38b3145 NC |
60 | $curr_test += 4; |
61 | ||
99b89507 | 62 | eval { |
b38b3145 NC |
63 | print "ok $curr_test\n"; |
64 | die sprintf "ok %d\n", $curr_test + 2; | |
99b89507 | 65 | 1; |
b38b3145 NC |
66 | } || printf "ok %d\n$@", $curr_test + 1; |
67 | ||
68 | curr_test($curr_test + 3); | |
99b89507 | 69 | |
c7cc6f1c GS |
70 | # check whether eval EXPR determines value of EXPR correctly |
71 | ||
72 | { | |
73 | my @a = qw(a b c d); | |
74 | my @b = eval @a; | |
b38b3145 NC |
75 | is("@b", '4'); |
76 | is($@, ''); | |
c7cc6f1c GS |
77 | |
78 | my $a = q[defined(wantarray) ? (wantarray ? ($b='A') : ($b='S')) : ($b='V')]; | |
79 | my $b; | |
80 | @a = eval $a; | |
b38b3145 NC |
81 | is("@a", 'A'); |
82 | is( $b, 'A'); | |
c7cc6f1c | 83 | $_ = eval $a; |
b38b3145 | 84 | is( $b, 'S'); |
c7cc6f1c | 85 | eval $a; |
b38b3145 | 86 | is( $b, 'V'); |
fc360e46 AB |
87 | |
88 | $b = 'wrong'; | |
89 | $x = sub { | |
90 | my $b = "right"; | |
b38b3145 | 91 | is(eval('"$b"'), $b); |
fc360e46 AB |
92 | }; |
93 | &$x(); | |
c7cc6f1c | 94 | } |
155fc61f | 95 | |
b38b3145 NC |
96 | { |
97 | my $b = 'wrong'; | |
98 | my $X = sub { | |
99 | my $b = "right"; | |
100 | is(eval('"$b"'), $b); | |
101 | }; | |
102 | &$X(); | |
103 | } | |
155fc61f GS |
104 | |
105 | # check navigation of multiple eval boundaries to find lexicals | |
106 | ||
b38b3145 | 107 | my $x = 'aa'; |
155fc61f | 108 | eval <<'EOT'; die if $@; |
0a00efa0 GS |
109 | print "# $x\n"; # clone into eval's pad |
110 | sub do_eval1 { | |
155fc61f GS |
111 | eval $_[0]; die if $@; |
112 | } | |
113 | EOT | |
b38b3145 | 114 | do_eval1('is($x, "aa")'); |
155fc61f | 115 | $x++; |
b38b3145 | 116 | do_eval1('eval q[is($x, "ab")]'); |
155fc61f | 117 | $x++; |
b38b3145 | 118 | do_eval1('sub { print "# $x\n"; eval q[is($x, "ac")] }->()'); |
0a00efa0 GS |
119 | $x++; |
120 | ||
121 | # calls from within eval'' should clone outer lexicals | |
122 | ||
123 | eval <<'EOT'; die if $@; | |
124 | sub do_eval2 { | |
125 | eval $_[0]; die if $@; | |
126 | } | |
b38b3145 | 127 | do_eval2('is($x, "ad")'); |
0a00efa0 | 128 | $x++; |
b38b3145 | 129 | do_eval2('eval q[is($x, "ae")]'); |
0a00efa0 | 130 | $x++; |
b38b3145 | 131 | do_eval2('sub { print "# $x\n"; eval q[is($x, "af")] }->()'); |
0a00efa0 GS |
132 | EOT |
133 | ||
134 | # calls outside eval'' should NOT clone lexicals from called context | |
135 | ||
a3985cdc DM |
136 | $main::ok = 'not ok'; |
137 | my $ok = 'ok'; | |
0a00efa0 GS |
138 | eval <<'EOT'; die if $@; |
139 | # $x unbound here | |
140 | sub do_eval3 { | |
141 | eval $_[0]; die if $@; | |
142 | } | |
143 | EOT | |
a3985cdc DM |
144 | { |
145 | my $ok = 'not ok'; | |
b38b3145 NC |
146 | do_eval3('is($ok, q{ok})'); |
147 | do_eval3('eval q[is($ok, q{ok})]'); | |
148 | do_eval3('sub { eval q[is($ok, q{ok})] }->()'); | |
a3985cdc | 149 | } |
6b35e009 | 150 | |
6b35e009 | 151 | { |
b38b3145 NC |
152 | my $x = curr_test(); |
153 | my $got; | |
154 | sub recurse { | |
155 | my $l = shift; | |
156 | if ($l < $x) { | |
157 | ++$l; | |
158 | eval 'print "# level $l\n"; recurse($l);'; | |
159 | die if $@; | |
160 | } | |
161 | else { | |
162 | $got = "ok $l"; | |
163 | } | |
164 | } | |
165 | local $SIG{__WARN__} = sub { fail() if $_[0] =~ /^Deep recurs/ }; | |
166 | recurse(curr_test() - 5); | |
167 | ||
168 | is($got, "ok $x", | |
169 | "recursive subroutine-call inside eval'' see its own lexicals"); | |
6b35e009 | 170 | } |
33b8ce05 | 171 | |
b38b3145 | 172 | |
33b8ce05 GS |
173 | eval <<'EOT'; |
174 | sub create_closure { | |
175 | my $self = shift; | |
176 | return sub { | |
b38b3145 | 177 | return $self; |
33b8ce05 GS |
178 | }; |
179 | } | |
180 | EOT | |
b38b3145 NC |
181 | is(create_closure("good")->(), "good", |
182 | 'closures created within eval bind correctly'); | |
2680586e | 183 | |
b38b3145 NC |
184 | $main::r = "good"; |
185 | sub terminal { eval '$r . q{!}' } | |
186 | is(do { | |
187 | my $r = "bad"; | |
2680586e | 188 | eval 'terminal($r)'; |
b38b3145 | 189 | }, 'good!', 'lexical search terminates correctly at subroutine boundary'); |
2680586e | 190 | |
b38b3145 NC |
191 | { |
192 | # Have we cured panic which occurred with require/eval in die handler ? | |
193 | local $SIG{__DIE__} = sub { eval {1}; die shift }; | |
194 | eval { die "wham_eth\n" }; | |
195 | is($@, "wham_eth\n"); | |
196 | } | |
a7c6d244 | 197 | |
a7ec2b44 GS |
198 | { |
199 | my $c = eval "(1,2)x10"; | |
b38b3145 | 200 | is($c, '2222222222', 'scalar eval"" pops stack correctly'); |
a7ec2b44 | 201 | } |
b45de488 GS |
202 | |
203 | # return from eval {} should clear $@ correctly | |
204 | { | |
205 | my $status = eval { | |
206 | eval { die }; | |
207 | print "# eval { return } test\n"; | |
208 | return; # removing this changes behavior | |
209 | }; | |
b38b3145 | 210 | is($@, '', 'return from eval {} should clear $@ correctly'); |
b45de488 GS |
211 | } |
212 | ||
213 | # ditto for eval "" | |
214 | { | |
215 | my $status = eval q{ | |
216 | eval q{ die }; | |
217 | print "# eval q{ return } test\n"; | |
218 | return; # removing this changes behavior | |
219 | }; | |
b38b3145 | 220 | is($@, '', 'return from eval "" should clear $@ correctly'); |
b45de488 | 221 | } |
3b2447bc RH |
222 | |
223 | # Check that eval catches bad goto calls | |
224 | # (BUG ID 20010305.003) | |
225 | { | |
226 | eval { | |
227 | eval { goto foo; }; | |
b38b3145 NC |
228 | like($@, qr/Can't "goto" into the middle of a foreach loop/, |
229 | 'eval catches bad goto calls'); | |
3b2447bc RH |
230 | last; |
231 | foreach my $i (1) { | |
b38b3145 | 232 | foo: fail('jumped into foreach'); |
3b2447bc RH |
233 | } |
234 | }; | |
b38b3145 NC |
235 | fail("Outer eval didn't execute the last"); |
236 | diag($@); | |
3b2447bc | 237 | } |
b6512f48 MJD |
238 | |
239 | # Make sure that "my $$x" is forbidden | |
240 | # 20011224 MJD | |
241 | { | |
b38b3145 NC |
242 | foreach (qw($$x @$x %$x $$$x)) { |
243 | eval 'my ' . $_; | |
244 | isnt($@, '', "my $_ is forbidden"); | |
245 | } | |
b6512f48 | 246 | } |
16a5162e | 247 | |
16a5162e JH |
248 | { |
249 | $@ = 5; | |
250 | eval q{}; | |
b38b3145 | 251 | cmp_ok(length $@, '==', 0, '[ID 20020623.002] eval "" doesn\'t clear $@'); |
16a5162e | 252 | } |
a3985cdc DM |
253 | |
254 | # DAPM Nov-2002. Perl should now capture the full lexical context during | |
255 | # evals. | |
256 | ||
257 | $::zzz = $::zzz = 0; | |
258 | my $zzz = 1; | |
259 | ||
260 | eval q{ | |
261 | sub fred1 { | |
b38b3145 | 262 | eval q{ is(eval '$zzz', 1); } |
a3985cdc DM |
263 | } |
264 | fred1(47); | |
265 | { my $zzz = 2; fred1(48) } | |
266 | }; | |
267 | ||
268 | eval q{ | |
269 | sub fred2 { | |
b38b3145 | 270 | is(eval('$zzz'), 1); |
a3985cdc DM |
271 | } |
272 | }; | |
273 | fred2(49); | |
274 | { my $zzz = 2; fred2(50) } | |
275 | ||
276 | # sort() starts a new context stack. Make sure we can still find | |
277 | # the lexically enclosing sub | |
278 | ||
279 | sub do_sort { | |
280 | my $zzz = 2; | |
281 | my @a = sort | |
b38b3145 | 282 | { is(eval('$zzz'), 2); $a <=> $b } |
a3985cdc DM |
283 | 2, 1; |
284 | } | |
285 | do_sort(); | |
286 | ||
287 | # more recursion and lexical scope leak tests | |
288 | ||
289 | eval q{ | |
290 | my $r = -1; | |
291 | my $yyy = 9; | |
292 | sub fred3 { | |
293 | my $l = shift; | |
294 | my $r = -2; | |
295 | return 1 if $l < 1; | |
296 | return 0 if eval '$zzz' != 1; | |
297 | return 0 if $yyy != 9; | |
298 | return 0 if eval '$yyy' != 9; | |
299 | return 0 if eval '$l' != $l; | |
300 | return $l * fred3($l-1); | |
301 | } | |
302 | my $r = fred3(5); | |
b38b3145 | 303 | is($r, 120); |
a3985cdc | 304 | $r = eval'fred3(5)'; |
b38b3145 | 305 | is($r, 120); |
a3985cdc DM |
306 | $r = 0; |
307 | eval '$r = fred3(5)'; | |
b38b3145 | 308 | is($r, 120); |
a3985cdc DM |
309 | $r = 0; |
310 | { my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' }; | |
b38b3145 | 311 | is($r, 120); |
a3985cdc DM |
312 | }; |
313 | my $r = fred3(5); | |
b38b3145 | 314 | is($r, 120); |
a3985cdc | 315 | $r = eval'fred3(5)'; |
b38b3145 | 316 | is($r, 120); |
a3985cdc DM |
317 | $r = 0; |
318 | eval'$r = fred3(5)'; | |
b38b3145 | 319 | is($r, 120); |
a3985cdc DM |
320 | $r = 0; |
321 | { my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' }; | |
b38b3145 | 322 | is($r, 120); |
a3985cdc DM |
323 | |
324 | # check that goto &sub within evals doesn't leak lexical scope | |
325 | ||
326 | my $yyy = 2; | |
327 | ||
a3985cdc DM |
328 | sub fred4 { |
329 | my $zzz = 3; | |
b38b3145 NC |
330 | is($zzz, 3); |
331 | is(eval '$zzz', 3); | |
332 | is(eval '$yyy', 2); | |
a3985cdc DM |
333 | } |
334 | ||
335 | eval q{ | |
336 | fred4(); | |
337 | sub fred5 { | |
338 | my $zzz = 4; | |
b38b3145 NC |
339 | is($zzz, 4); |
340 | is(eval '$zzz', 4); | |
341 | is(eval '$yyy', 2); | |
a3985cdc DM |
342 | goto &fred4; |
343 | } | |
344 | fred5(); | |
345 | }; | |
346 | fred5(); | |
347 | { my $yyy = 88; my $zzz = 99; fred5(); } | |
e8cf733a | 348 | eval q{ my $yyy = 888; my $zzz = 999; fred5(); }; |
a3985cdc | 349 | |
e8cf733a HS |
350 | { |
351 | $eval = eval 'sub { eval "sub { %S }" }'; | |
352 | $eval->({}); | |
b38b3145 | 353 | pass('[perl #9728] used to dump core'); |
e8cf733a | 354 | } |
a3985cdc | 355 | |
d819b83a DM |
356 | # evals that appear in the DB package should see the lexical scope of the |
357 | # thing outside DB that called them (usually the debugged code), rather | |
358 | # than the usual surrounding scope | |
359 | ||
d819b83a DM |
360 | our $x = 1; |
361 | { | |
362 | my $x=2; | |
363 | sub db1 { $x; eval '$x' } | |
364 | sub DB::db2 { $x; eval '$x' } | |
365 | package DB; | |
366 | sub db3 { eval '$x' } | |
367 | sub DB::db4 { eval '$x' } | |
368 | sub db5 { my $x=4; eval '$x' } | |
369 | package main; | |
370 | sub db6 { my $x=4; eval '$x' } | |
371 | } | |
372 | { | |
373 | my $x = 3; | |
b38b3145 NC |
374 | is(db1(), 2); |
375 | is(DB::db2(), 2); | |
376 | is(DB::db3(), 3); | |
377 | is(DB::db4(), 3); | |
378 | is(DB::db5(), 3); | |
379 | is(db6(), 4); | |
d819b83a | 380 | } |
b38b3145 | 381 | |
7e736055 HS |
382 | # [perl #19022] used to end up with shared hash warnings |
383 | # The program should generate no output, so anything we see is on stderr | |
384 | my $got = runperl (prog => '$h{a}=1; foreach my $k (keys %h) {eval qq{\$k}}', | |
385 | stderr => 1); | |
b38b3145 | 386 | is ($got, ''); |
7e736055 HS |
387 | |
388 | # And a buggy way of fixing #19022 made this fail - $k became undef after the | |
389 | # eval for a build with copy on write | |
390 | { | |
391 | my %h; | |
392 | $h{a}=1; | |
393 | foreach my $k (keys %h) { | |
b38b3145 | 394 | is($k, 'a'); |
7e736055 HS |
395 | |
396 | eval "\$k"; | |
397 | ||
b38b3145 | 398 | is($k, 'a'); |
7e736055 HS |
399 | } |
400 | } | |
77d32bb7 RGS |
401 | |
402 | sub Foo {} print Foo(eval {}); | |
b38b3145 | 403 | pass('#20798 (used to dump core)'); |
f48583aa MHM |
404 | |
405 | # check for context in string eval | |
406 | { | |
407 | my(@r,$r,$c); | |
408 | sub context { defined(wantarray) ? (wantarray ? ($c='A') : ($c='S')) : ($c='V') } | |
409 | ||
410 | my $code = q{ context() }; | |
411 | @r = qw( a b ); | |
412 | $r = 'ab'; | |
413 | @r = eval $code; | |
b38b3145 | 414 | is("@r$c", 'AA', 'string eval list context'); |
f48583aa | 415 | $r = eval $code; |
b38b3145 | 416 | is("$r$c", 'SS', 'string eval scalar context'); |
f48583aa | 417 | eval $code; |
b38b3145 | 418 | is("$c", 'V', 'string eval void context'); |
f48583aa | 419 | } |
6ab4a6ff DM |
420 | |
421 | # [perl #34682] escaping an eval with last could coredump or dup output | |
422 | ||
423 | $got = runperl ( | |
424 | prog => | |
425 | 'sub A::TIEARRAY { L: { eval { last L } } } tie @a, A; warn qq(ok\n)', | |
426 | stderr => 1); | |
427 | ||
b38b3145 | 428 | is($got, "ok\n", 'eval and last'); |
6ab4a6ff | 429 | |
eb034824 DM |
430 | # eval undef should be the same as eval "" barring any warnings |
431 | ||
432 | { | |
433 | local $@ = "foo"; | |
434 | eval undef; | |
b38b3145 | 435 | is($@, "", 'eval undef'); |
500960a6 RD |
436 | } |
437 | ||
438 | { | |
439 | no warnings; | |
e9d26e74 | 440 | eval "&& $b;"; |
b38b3145 | 441 | like($@, qr/^syntax error/, 'eval syntax error, no warnings'); |
eb034824 DM |
442 | } |
443 | ||
59a97017 | 444 | # a syntax error in an eval called magically (eg via tie or overload) |
410be5db | 445 | # resulted in an assertion failure in S_docatch, since doeval had already |
59a97017 | 446 | # popped the EVAL context due to the failure, but S_docatch expected the |
410be5db DM |
447 | # context to still be there. |
448 | ||
449 | { | |
450 | my $ok = 0; | |
451 | package Eval1; | |
452 | sub STORE { eval '('; $ok = 1 } | |
453 | sub TIESCALAR { bless [] } | |
454 | ||
455 | my $x; | |
456 | tie $x, bless []; | |
457 | $x = 1; | |
b38b3145 | 458 | ::is($ok, 1, 'eval docatch'); |
410be5db DM |
459 | } |
460 | ||
8433848b B |
461 | # [perl #51370] eval { die "\x{a10d}" } followed by eval { 1 } did not reset |
462 | # length $@ | |
463 | $@ = ""; | |
464 | eval { die "\x{a10d}"; }; | |
465 | $_ = length $@; | |
466 | eval { 1 }; | |
467 | ||
b38b3145 NC |
468 | cmp_ok($@, 'eq', "", 'length of $@ after eval'); |
469 | cmp_ok(length $@, '==', 0, 'length of $@ after eval'); | |
0d804ff6 | 470 | |
93f09d7b | 471 | # Check if eval { 1 }; completely resets $@ |
0d804ff6 | 472 | SKIP: { |
e0d4127d NC |
473 | skip_if_miniperl('no dynamic loading on miniperl, no Devel::Peek', 2); |
474 | require Config; | |
475 | skip('Devel::Peek was not built', 2) | |
476 | unless $Config::Config{extensions} =~ /\bDevel\/Peek\b/; | |
0d804ff6 NC |
477 | |
478 | my $tempfile = tempfile(); | |
479 | open $prog, ">", $tempfile or die "Can't create test file"; | |
480 | print $prog <<'END_EVAL_TEST'; | |
8433848b B |
481 | use Devel::Peek; |
482 | $! = 0; | |
483 | $@ = $!; | |
0d804ff6 NC |
484 | Dump($@); |
485 | print STDERR "******\n"; | |
486 | eval { die "\x{a10d}"; }; | |
487 | $_ = length $@; | |
488 | eval { 1 }; | |
489 | Dump($@); | |
490 | print STDERR "******\n"; | |
491 | print STDERR "Done\n"; | |
8433848b | 492 | END_EVAL_TEST |
0d804ff6 NC |
493 | close $prog or die "Can't close $tempfile: $!"; |
494 | my $got = runperl(progfile => $tempfile, stderr => 1); | |
495 | my ($first, $second, $tombstone) = split (/\*\*\*\*\*\*\n/, $got); | |
8433848b | 496 | |
0d804ff6 NC |
497 | is($tombstone, "Done\n", 'Program completed successfully'); |
498 | ||
4bac9ae4 | 499 | $first =~ s/p?[NI]OK,//g; |
0d804ff6 NC |
500 | s/ PV = 0x[0-9a-f]+/ PV = 0x/ foreach $first, $second; |
501 | s/ LEN = [0-9]+/ LEN = / foreach $first, $second; | |
673f72bf CB |
502 | # Dump may double newlines through pipes, though not files |
503 | # which is what this test used to use. | |
504 | $second =~ s/ IV = 0\n\n/ IV = 0\n/ if $^O eq 'VMS'; | |
0d804ff6 NC |
505 | |
506 | is($second, $first, 'eval { 1 } completely resets $@'); | |
8433848b | 507 | } |
410be5db | 508 | |
fa13de94 RGS |
509 | # Test that "use feature" and other hint transmission in evals and s///ee |
510 | # don't leak memory | |
511 | { | |
512 | use feature qw(:5.10); | |
e8514a9e | 513 | my $count_expected = ($^H & 0x20000) ? 2 : 1; |
fa13de94 RGS |
514 | my $t; |
515 | my $s = "a"; | |
516 | $s =~ s/a/$t = \%^H; qq( qq() );/ee; | |
0d804ff6 | 517 | is(Internals::SvREFCNT(%$t), $count_expected, 'RT 63110'); |
fa13de94 | 518 | } |
f5fa9033 | 519 | |
3b9d46a3 GG |
520 | { |
521 | # test that the CV compiled for the eval is freed by checking that no additional | |
522 | # reference to outside lexicals are made. | |
523 | my $x; | |
1c2e8cca | 524 | is(Internals::SvREFCNT($x), 1, "originally only 1 reference"); |
3b9d46a3 GG |
525 | eval '$x'; |
526 | is(Internals::SvREFCNT($x), 1, "execution eval doesn't create new references"); | |
527 | } | |
528 | ||
f5fa9033 NC |
529 | fresh_perl_is(<<'EOP', "ok\n", undef, 'RT #70862'); |
530 | $::{'@'}=''; | |
531 | eval {}; | |
532 | print "ok\n"; | |
533 | EOP | |
534 | ||
535 | fresh_perl_is(<<'EOP', "ok\n", undef, 'variant of RT #70862'); | |
536 | eval { | |
537 | $::{'@'}=''; | |
538 | }; | |
539 | print "ok\n"; | |
540 | EOP | |
dfd167e9 NC |
541 | |
542 | fresh_perl_is(<<'EOP', "ok\n", undef, 'related to RT #70862'); | |
543 | $::{'@'}=\3; | |
544 | eval {}; | |
545 | print "ok\n"; | |
546 | EOP | |
547 | ||
548 | fresh_perl_is(<<'EOP', "ok\n", undef, 'related to RT #70862'); | |
549 | eval { | |
550 | $::{'@'}=\3; | |
551 | }; | |
552 | print "ok\n"; | |
553 | EOP | |
ae533554 | 554 | |
ae533554 FR |
555 | fresh_perl_is(<<'EOP', "ok\n", undef, 'segfault on syntax errors in block evals'); |
556 | # localize the hits hash so the eval ends up with the pad offset of a copy of it in its targ | |
557 | BEGIN { $^H |= 0x00020000 } | |
558 | eval q{ eval { + } }; | |
559 | print "ok\n"; | |
560 | EOP | |
f678642f | 561 | |
3e5c0189 DM |
562 | fresh_perl_is(<<'EOP', "ok\n", undef, 'assert fail on non-string in Perl_lex_start'); |
563 | use overload '""' => sub { '1;' }; | |
564 | my $ov = bless []; | |
565 | eval $ov; | |
566 | print "ok\n"; | |
567 | EOP | |
568 | ||
3aadd5cd FC |
569 | for my $k (!0) { |
570 | eval 'my $do_something_with = $k'; | |
571 | eval { $k = 'mon' }; | |
572 | is "a" =~ /a/, "1", | |
573 | "string eval leaves readonly lexicals readonly [perl #19135]"; | |
574 | } | |
bc344123 | 575 | |
a72a1094 | 576 | # [perl #68750] |
bc344123 FC |
577 | fresh_perl_is(<<'EOP', "ok\nok\nok\n", undef, 'eval clears %^H'); |
578 | BEGIN { | |
579 | require re; re->import('/x'); # should only affect surrounding scope | |
580 | eval ' | |
581 | print "a b" =~ /a b/ ? "ok\n" : "nokay\n"; | |
582 | use re "/m"; | |
583 | print "a b" =~ /a b/ ? "ok\n" : "nokay\n"; | |
584 | '; | |
585 | } | |
586 | print "ab" =~ /a b/ ? "ok\n" : "nokay\n"; | |
587 | EOP | |
f45b078d FC |
588 | |
589 | # [perl #70151] | |
590 | { | |
591 | BEGIN { eval 'require re; import re "/x"' } | |
592 | ok "ab" =~ /a b/, 'eval does not localise %^H at run time'; | |
593 | } | |
bbde7ba3 FC |
594 | |
595 | # The fix for perl #70151 caused an assertion failure that broke | |
596 | # SNMP::Trapinfo, when toke.c finds no syntax errors but perly.y fails. | |
597 | eval(q|""!=!~//|); | |
598 | pass("phew! dodged the assertion after a parsing (not lexing) error"); | |
63429d50 FC |
599 | |
600 | # [perl #111462] | |
601 | { | |
602 | local $ENV{PERL_DESTRUCT_LEVEL} = 1; | |
603 | unlike | |
604 | runperl( | |
605 | prog => 'BEGIN { $^H{foo} = bar }' | |
606 | .'our %FIELDS; my main $x; eval q[$x->{foo}]', | |
607 | stderr => 1, | |
608 | ), | |
609 | qr/Unbalanced string table/, | |
610 | 'Errors in finalize_optree do not leak string eval op tree'; | |
611 | } | |
451f421f FC |
612 | |
613 | # [perl #114658] Line numbers at end of string eval | |
614 | for("{;", "{") { | |
615 | eval $_; is $@ =~ s/eval \d+/eval 1/rag, <<'EOE', | |
616 | Missing right curly or square bracket at (eval 1) line 1, at end of line | |
617 | syntax error at (eval 1) line 1, at EOF | |
618 | EOE | |
619 | qq'Right line number for eval "$_"'; | |
620 | } | |
cb1ad50e | 621 | |
a49b10d0 BF |
622 | { |
623 | my $w; | |
624 | local $SIG{__WARN__} = sub { $w .= shift }; | |
625 | ||
626 | eval "\${\nfoobar\n} = 10; warn q{should be line 3}"; | |
627 | is( | |
628 | $w =~ s/eval \d+/eval 1/ra, | |
629 | "should be line 3 at (eval 1) line 3.\n", | |
630 | 'eval qq{\${\nfoo\n}; warn} updates the line number correctly' | |
631 | ); | |
632 | } | |
633 | ||
cb1ad50e FC |
634 | sub _117941 { package _117941; eval '$a' } |
635 | delete $::{"_117941::"}; | |
636 | _117941(); | |
637 | pass("eval in freed package does not crash"); |