This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Magic flags harmonization.
[perl5.git] / t / op / eval.t
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     @INC = '../lib';
6     require './test.pl';
7 }
8
9 plan(tests => 126);
10
11 eval 'pass();';
12
13 is($@, '');
14
15 eval "\$foo\n    = # this is a comment\n'ok 3';";
16 is($foo, 'ok 3');
17
18 eval "\$foo\n    = # this is a comment\n'ok 4\n';";
19 is($foo, "ok 4\n");
20
21 print eval '
22 $foo =;';               # this tests for a call through yyerror()
23 like($@, qr/line 2/);
24
25 print eval '$foo = /';  # this tests for a call through fatal()
26 like($@, qr/Search/);
27
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
33 is(eval '"ok 7\n";', "ok 7\n");
34
35 $foo = 5;
36 $fact = 'if ($foo <= 1) {1;} else {push(@x,$foo--); (eval $fact) * pop(@x);}';
37 $ans = eval $fact;
38 is($ans, 120, 'calculate a factorial with recursive evals');
39
40 $foo = 5;
41 $fact = 'local($foo)=$foo; $foo <= 1 ? 1 : $foo-- * (eval $fact);';
42 $ans = eval $fact;
43 is($ans, 120, 'calculate a factorial with recursive evals');
44
45 my $curr_test = curr_test();
46 my $tempfile = tempfile();
47 open(try,'>',$tempfile);
48 print try 'print "ok $curr_test\n";',"\n";
49 close try;
50
51 do "./$tempfile"; print $@;
52
53 # Test the singlequoted eval optimizer
54
55 $i = $curr_test + 1;
56 for (1..3) {
57     eval 'print "ok ", $i++, "\n"';
58 }
59
60 $curr_test += 4;
61
62 eval {
63     print "ok $curr_test\n";
64     die sprintf "ok %d\n", $curr_test + 2;
65     1;
66 } || printf "ok %d\n$@", $curr_test + 1;
67
68 curr_test($curr_test + 3);
69
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;
75   is("@b", '4');
76   is($@, '');
77
78   my $a = q[defined(wantarray) ? (wantarray ? ($b='A') : ($b='S')) : ($b='V')];
79   my $b;
80   @a = eval $a;
81   is("@a", 'A');
82   is(  $b, 'A');
83   $_ = eval $a;
84   is(  $b, 'S');
85   eval $a;
86   is(  $b, 'V');
87
88   $b = 'wrong';
89   $x = sub {
90      my $b = "right";
91      is(eval('"$b"'), $b);
92   };
93   &$x();
94 }
95
96 {
97   my $b = 'wrong';
98   my $X = sub {
99      my $b = "right";
100      is(eval('"$b"'), $b);
101   };
102   &$X();
103 }
104
105 # check navigation of multiple eval boundaries to find lexicals
106
107 my $x = 'aa';
108 eval <<'EOT'; die if $@;
109   print "# $x\n";       # clone into eval's pad
110   sub do_eval1 {
111      eval $_[0]; die if $@;
112   }
113 EOT
114 do_eval1('is($x, "aa")');
115 $x++;
116 do_eval1('eval q[is($x, "ab")]');
117 $x++;
118 do_eval1('sub { print "# $x\n"; eval q[is($x, "ac")] }->()');
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   }
127 do_eval2('is($x, "ad")');
128 $x++;
129 do_eval2('eval q[is($x, "ae")]');
130 $x++;
131 do_eval2('sub { print "# $x\n"; eval q[is($x, "af")] }->()');
132 EOT
133
134 # calls outside eval'' should NOT clone lexicals from called context
135
136 $main::ok = 'not ok';
137 my $ok = 'ok';
138 eval <<'EOT'; die if $@;
139   # $x unbound here
140   sub do_eval3 {
141      eval $_[0]; die if $@;
142   }
143 EOT
144 {
145     my $ok = 'not ok';
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})] }->()');
149 }
150
151 {
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");
170 }
171
172
173 eval <<'EOT';
174   sub create_closure {
175     my $self = shift;
176     return sub {
177        return $self;
178     };
179   }
180 EOT
181 is(create_closure("good")->(), "good",
182    'closures created within eval bind correctly');
183
184 $main::r = "good";
185 sub terminal { eval '$r . q{!}' }
186 is(do {
187    my $r = "bad";
188    eval 'terminal($r)';
189 }, 'good!', 'lexical search terminates correctly at subroutine boundary');
190
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 }
197
198 {
199     my $c = eval "(1,2)x10";
200     is($c, '2222222222', 'scalar eval"" pops stack correctly');
201 }
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     };
210     is($@, '', 'return from eval {} should clear $@ correctly');
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     };
220     is($@, '', 'return from eval "" should clear $@ correctly');
221 }
222
223 # Check that eval catches bad goto calls
224 #   (BUG ID 20010305.003)
225 {
226     eval {
227         eval { goto foo; };
228         like($@, qr/Can't "goto" into the middle of a foreach loop/,
229              'eval catches bad goto calls');
230         last;
231         foreach my $i (1) {
232             foo: fail('jumped into foreach');
233         }
234     };
235     fail("Outer eval didn't execute the last");
236     diag($@);
237 }
238
239 # Make sure that "my $$x" is forbidden
240 # 20011224 MJD
241 {
242     foreach (qw($$x @$x %$x $$$x)) {
243         eval 'my ' . $_;
244         isnt($@, '', "my $_ is forbidden");
245     }
246 }
247
248 {
249     $@ = 5;
250     eval q{};
251     cmp_ok(length $@, '==', 0, '[ID 20020623.002] eval "" doesn\'t clear $@');
252 }
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 {
262         eval q{ is(eval '$zzz', 1); }
263     }
264     fred1(47);
265     { my $zzz = 2; fred1(48) }
266 };
267
268 eval q{
269     sub fred2 {
270         is(eval('$zzz'), 1);
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
282             { is(eval('$zzz'), 2); $a <=> $b }
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);
303     is($r, 120);
304     $r = eval'fred3(5)';
305     is($r, 120);
306     $r = 0;
307     eval '$r = fred3(5)';
308     is($r, 120);
309     $r = 0;
310     { my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' };
311     is($r, 120);
312 };
313 my $r = fred3(5);
314 is($r, 120);
315 $r = eval'fred3(5)';
316 is($r, 120);
317 $r = 0;
318 eval'$r = fred3(5)';
319 is($r, 120);
320 $r = 0;
321 { my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' };
322 is($r, 120);
323
324 # check that goto &sub within evals doesn't leak lexical scope
325
326 my $yyy = 2;
327
328 sub fred4 { 
329     my $zzz = 3;
330     is($zzz, 3);
331     is(eval '$zzz', 3);
332     is(eval '$yyy', 2);
333 }
334
335 eval q{
336     fred4();
337     sub fred5 {
338         my $zzz = 4;
339         is($zzz, 4);
340         is(eval '$zzz', 4);
341         is(eval '$yyy', 2);
342         goto &fred4;
343     }
344     fred5();
345 };
346 fred5();
347 { my $yyy = 88; my $zzz = 99; fred5(); }
348 eval q{ my $yyy = 888; my $zzz = 999; fred5(); };
349
350 {
351    $eval = eval 'sub { eval "sub { %S }" }';
352    $eval->({});
353    pass('[perl #9728] used to dump core');
354 }
355
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
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;
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);
380 }
381
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);
386 is ($got, '');
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) {
394     is($k, 'a');
395
396     eval "\$k";
397
398     is($k, 'a');
399   }
400 }
401
402 sub Foo {} print Foo(eval {});
403 pass('#20798 (used to dump core)');
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;
414   is("@r$c", 'AA', 'string eval list context');
415   $r = eval $code;
416   is("$r$c", 'SS', 'string eval scalar context');
417   eval $code;
418   is("$c", 'V', 'string eval void context');
419 }
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
428 is($got, "ok\n", 'eval and last');
429
430 # eval undef should be the same as eval "" barring any warnings
431
432 {
433     local $@ = "foo";
434     eval undef;
435     is($@, "", 'eval undef');
436 }
437
438 {
439     no warnings;
440     eval "&& $b;";
441     like($@, qr/^syntax error/, 'eval syntax error, no warnings');
442 }
443
444 # a syntax error in an eval called magically (eg via tie or overload)
445 # resulted in an assertion failure in S_docatch, since doeval had already
446 # popped the EVAL context due to the failure, but S_docatch expected the
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;
458     ::is($ok, 1, 'eval docatch');
459 }
460
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
468 cmp_ok($@, 'eq', "", 'length of $@ after eval');
469 cmp_ok(length $@, '==', 0, 'length of $@ after eval');
470
471 # Check if eval { 1 }; completely resets $@
472 SKIP: {
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/;
477
478     my $tempfile = tempfile();
479     open $prog, ">", $tempfile or die "Can't create test file";
480     print $prog <<'END_EVAL_TEST';
481     use Devel::Peek;
482     $! = 0;
483     $@ = $!;
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";
492 END_EVAL_TEST
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);
496
497     is($tombstone, "Done\n", 'Program completed successfully');
498
499     $first =~ s/p?[NI]OK,//g;
500     s/ PV = 0x[0-9a-f]+/ PV = 0x/ foreach $first, $second;
501     s/ LEN = [0-9]+/ LEN = / foreach $first, $second;
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';
505
506     is($second, $first, 'eval { 1 } completely resets $@');
507 }
508
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);
513     my $count_expected = ($^H & 0x20000) ? 2 : 1;
514     my $t;
515     my $s = "a";
516     $s =~ s/a/$t = \%^H;  qq( qq() );/ee;
517     is(Internals::SvREFCNT(%$t), $count_expected, 'RT 63110');
518 }
519
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;
524     is(Internals::SvREFCNT($x), 1, "originally only 1 reference");
525     eval '$x';
526     is(Internals::SvREFCNT($x), 1, "execution eval doesn't create new references");
527 }
528
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
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
554
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
561
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
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 }
575
576 # [perl #68750]
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
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 }
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");
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 }