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