This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Convert the remainder of t/op/eval.t to test.pl
[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 => 118);
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(eval '"ok 7\n";', "ok 7\n");
29
30 $foo = 5;
31 $fact = 'if ($foo <= 1) {1;} else {push(@x,$foo--); (eval $fact) * pop(@x);}';
32 $ans = eval $fact;
33 is($ans, 120, 'calculate a factorial with recursive evals');
34
35 $foo = 5;
36 $fact = 'local($foo)=$foo; $foo <= 1 ? 1 : $foo-- * (eval $fact);';
37 $ans = eval $fact;
38 is($ans, 120, 'calculate a factorial with recursive evals');
39
40 my $curr_test = curr_test();
41 my $tempfile = tempfile();
42 open(try,'>',$tempfile);
43 print try 'print "ok $curr_test\n";',"\n";
44 close try;
45
46 do "./$tempfile"; print $@;
47
48 # Test the singlequoted eval optimizer
49
50 $i = $curr_test + 1;
51 for (1..3) {
52     eval 'print "ok ", $i++, "\n"';
53 }
54
55 $curr_test += 4;
56
57 eval {
58     print "ok $curr_test\n";
59     die sprintf "ok %d\n", $curr_test + 2;
60     1;
61 } || printf "ok %d\n$@", $curr_test + 1;
62
63 curr_test($curr_test + 3);
64
65 # check whether eval EXPR determines value of EXPR correctly
66
67 {
68   my @a = qw(a b c d);
69   my @b = eval @a;
70   is("@b", '4');
71   is($@, '');
72
73   my $a = q[defined(wantarray) ? (wantarray ? ($b='A') : ($b='S')) : ($b='V')];
74   my $b;
75   @a = eval $a;
76   is("@a", 'A');
77   is(  $b, 'A');
78   $_ = eval $a;
79   is(  $b, 'S');
80   eval $a;
81   is(  $b, 'V');
82
83   $b = 'wrong';
84   $x = sub {
85      my $b = "right";
86      is(eval('"$b"'), $b);
87   };
88   &$x();
89 }
90
91 {
92   my $b = 'wrong';
93   my $X = sub {
94      my $b = "right";
95      is(eval('"$b"'), $b);
96   };
97   &$X();
98 }
99
100 # check navigation of multiple eval boundaries to find lexicals
101
102 my $x = 'aa';
103 eval <<'EOT'; die if $@;
104   print "# $x\n";       # clone into eval's pad
105   sub do_eval1 {
106      eval $_[0]; die if $@;
107   }
108 EOT
109 do_eval1('is($x, "aa")');
110 $x++;
111 do_eval1('eval q[is($x, "ab")]');
112 $x++;
113 do_eval1('sub { print "# $x\n"; eval q[is($x, "ac")] }->()');
114 $x++;
115
116 # calls from within eval'' should clone outer lexicals
117
118 eval <<'EOT'; die if $@;
119   sub do_eval2 {
120      eval $_[0]; die if $@;
121   }
122 do_eval2('is($x, "ad")');
123 $x++;
124 do_eval2('eval q[is($x, "ae")]');
125 $x++;
126 do_eval2('sub { print "# $x\n"; eval q[is($x, "af")] }->()');
127 EOT
128
129 # calls outside eval'' should NOT clone lexicals from called context
130
131 $main::ok = 'not ok';
132 my $ok = 'ok';
133 eval <<'EOT'; die if $@;
134   # $x unbound here
135   sub do_eval3 {
136      eval $_[0]; die if $@;
137   }
138 EOT
139 {
140     my $ok = 'not ok';
141     do_eval3('is($ok, q{ok})');
142     do_eval3('eval q[is($ok, q{ok})]');
143     do_eval3('sub { eval q[is($ok, q{ok})] }->()');
144 }
145
146 {
147     my $x = curr_test();
148     my $got;
149     sub recurse {
150         my $l = shift;
151         if ($l < $x) {
152             ++$l;
153             eval 'print "# level $l\n"; recurse($l);';
154             die if $@;
155         }
156         else {
157             $got = "ok $l";
158         }
159     }
160     local $SIG{__WARN__} = sub { fail() if $_[0] =~ /^Deep recurs/ };
161     recurse(curr_test() - 5);
162
163     is($got, "ok $x",
164        "recursive subroutine-call inside eval'' see its own lexicals");
165 }
166
167
168 eval <<'EOT';
169   sub create_closure {
170     my $self = shift;
171     return sub {
172        return $self;
173     };
174   }
175 EOT
176 is(create_closure("good")->(), "good",
177    'closures created within eval bind correctly');
178
179 $main::r = "good";
180 sub terminal { eval '$r . q{!}' }
181 is(do {
182    my $r = "bad";
183    eval 'terminal($r)';
184 }, 'good!', 'lexical search terminates correctly at subroutine boundary');
185
186 {
187     # Have we cured panic which occurred with require/eval in die handler ?
188     local $SIG{__DIE__} = sub { eval {1}; die shift };
189     eval { die "wham_eth\n" };
190     is($@, "wham_eth\n");
191 }
192
193 {
194     my $c = eval "(1,2)x10";
195     is($c, '2222222222', 'scalar eval"" pops stack correctly');
196 }
197
198 # return from eval {} should clear $@ correctly
199 {
200     my $status = eval {
201         eval { die };
202         print "# eval { return } test\n";
203         return; # removing this changes behavior
204     };
205     is($@, '', 'return from eval {} should clear $@ correctly');
206 }
207
208 # ditto for eval ""
209 {
210     my $status = eval q{
211         eval q{ die };
212         print "# eval q{ return } test\n";
213         return; # removing this changes behavior
214     };
215     is($@, '', 'return from eval "" should clear $@ correctly');
216 }
217
218 # Check that eval catches bad goto calls
219 #   (BUG ID 20010305.003)
220 {
221     eval {
222         eval { goto foo; };
223         like($@, qr/Can't "goto" into the middle of a foreach loop/,
224              'eval catches bad goto calls');
225         last;
226         foreach my $i (1) {
227             foo: fail('jumped into foreach');
228         }
229     };
230     fail("Outer eval didn't execute the last");
231     diag($@);
232 }
233
234 # Make sure that "my $$x" is forbidden
235 # 20011224 MJD
236 {
237     foreach (qw($$x @$x %$x $$$x)) {
238         eval 'my ' . $_;
239         isnt($@, '', "my $_ is forbidden");
240     }
241 }
242
243 {
244     $@ = 5;
245     eval q{};
246     cmp_ok(length $@, '==', 0, '[ID 20020623.002] eval "" doesn\'t clear $@');
247 }
248
249 # DAPM Nov-2002. Perl should now capture the full lexical context during
250 # evals.
251
252 $::zzz = $::zzz = 0;
253 my $zzz = 1;
254
255 eval q{
256     sub fred1 {
257         eval q{ is(eval '$zzz', 1); }
258     }
259     fred1(47);
260     { my $zzz = 2; fred1(48) }
261 };
262
263 eval q{
264     sub fred2 {
265         is(eval('$zzz'), 1);
266     }
267 };
268 fred2(49);
269 { my $zzz = 2; fred2(50) }
270
271 # sort() starts a new context stack. Make sure we can still find
272 # the lexically enclosing sub
273
274 sub do_sort {
275     my $zzz = 2;
276     my @a = sort
277             { is(eval('$zzz'), 2); $a <=> $b }
278             2, 1;
279 }
280 do_sort();
281
282 # more recursion and lexical scope leak tests
283
284 eval q{
285     my $r = -1;
286     my $yyy = 9;
287     sub fred3 {
288         my $l = shift;
289         my $r = -2;
290         return 1 if $l < 1;
291         return 0 if eval '$zzz' != 1;
292         return 0 if       $yyy  != 9;
293         return 0 if eval '$yyy' != 9;
294         return 0 if eval '$l' != $l;
295         return $l * fred3($l-1);
296     }
297     my $r = fred3(5);
298     is($r, 120);
299     $r = eval'fred3(5)';
300     is($r, 120);
301     $r = 0;
302     eval '$r = fred3(5)';
303     is($r, 120);
304     $r = 0;
305     { my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' };
306     is($r, 120);
307 };
308 my $r = fred3(5);
309 is($r, 120);
310 $r = eval'fred3(5)';
311 is($r, 120);
312 $r = 0;
313 eval'$r = fred3(5)';
314 is($r, 120);
315 $r = 0;
316 { my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' };
317 is($r, 120);
318
319 # check that goto &sub within evals doesn't leak lexical scope
320
321 my $yyy = 2;
322
323 sub fred4 { 
324     my $zzz = 3;
325     is($zzz, 3);
326     is(eval '$zzz', 3);
327     is(eval '$yyy', 2);
328 }
329
330 eval q{
331     fred4();
332     sub fred5 {
333         my $zzz = 4;
334         is($zzz, 4);
335         is(eval '$zzz', 4);
336         is(eval '$yyy', 2);
337         goto &fred4;
338     }
339     fred5();
340 };
341 fred5();
342 { my $yyy = 88; my $zzz = 99; fred5(); }
343 eval q{ my $yyy = 888; my $zzz = 999; fred5(); };
344
345 {
346    $eval = eval 'sub { eval "sub { %S }" }';
347    $eval->({});
348    pass('[perl #9728] used to dump core');
349 }
350
351 # evals that appear in the DB package should see the lexical scope of the
352 # thing outside DB that called them (usually the debugged code), rather
353 # than the usual surrounding scope
354
355 our $x = 1;
356 {
357     my $x=2;
358     sub db1     { $x; eval '$x' }
359     sub DB::db2 { $x; eval '$x' }
360     package DB;
361     sub db3     { eval '$x' }
362     sub DB::db4 { eval '$x' }
363     sub db5     { my $x=4; eval '$x' }
364     package main;
365     sub db6     { my $x=4; eval '$x' }
366 }
367 {
368     my $x = 3;
369     is(db1(),      2);
370     is(DB::db2(),  2);
371     is(DB::db3(),  3);
372     is(DB::db4(),  3);
373     is(DB::db5(),  3);
374     is(db6(),      4);
375 }
376
377 # [perl #19022] used to end up with shared hash warnings
378 # The program should generate no output, so anything we see is on stderr
379 my $got = runperl (prog => '$h{a}=1; foreach my $k (keys %h) {eval qq{\$k}}',
380                    stderr => 1);
381 is ($got, '');
382
383 # And a buggy way of fixing #19022 made this fail - $k became undef after the
384 # eval for a build with copy on write
385 {
386   my %h;
387   $h{a}=1;
388   foreach my $k (keys %h) {
389     is($k, 'a');
390
391     eval "\$k";
392
393     is($k, 'a');
394   }
395 }
396
397 sub Foo {} print Foo(eval {});
398 pass('#20798 (used to dump core)');
399
400 # check for context in string eval
401 {
402   my(@r,$r,$c);
403   sub context { defined(wantarray) ? (wantarray ? ($c='A') : ($c='S')) : ($c='V') }
404
405   my $code = q{ context() };
406   @r = qw( a b );
407   $r = 'ab';
408   @r = eval $code;
409   is("@r$c", 'AA', 'string eval list context');
410   $r = eval $code;
411   is("$r$c", 'SS', 'string eval scalar context');
412   eval $code;
413   is("$c", 'V', 'string eval void context');
414 }
415
416 # [perl #34682] escaping an eval with last could coredump or dup output
417
418 $got = runperl (
419     prog => 
420     'sub A::TIEARRAY { L: { eval { last L } } } tie @a, A; warn qq(ok\n)',
421 stderr => 1);
422
423 is($got, "ok\n", 'eval and last');
424
425 # eval undef should be the same as eval "" barring any warnings
426
427 {
428     local $@ = "foo";
429     eval undef;
430     is($@, "", 'eval undef');
431 }
432
433 {
434     no warnings;
435     eval "/ /b;";
436     like($@, qr/^syntax error/, 'eval syntax error, no warnings');
437 }
438
439 # a syntax error in an eval called magically 9eg vie tie or overload)
440 # resulted in an assertion failure in S_docatch, since doeval had already
441 # poppedthe EVAL context due to the failure, but S_docatch expected the
442 # context to still be there.
443
444 {
445     my $ok  = 0;
446     package Eval1;
447     sub STORE { eval '('; $ok = 1 }
448     sub TIESCALAR { bless [] }
449
450     my $x;
451     tie $x, bless [];
452     $x = 1;
453     ::is($ok, 1, 'eval docatch');
454 }
455
456 # [perl #51370] eval { die "\x{a10d}" } followed by eval { 1 } did not reset
457 # length $@ 
458 $@ = "";
459 eval { die "\x{a10d}"; };
460 $_ = length $@;
461 eval { 1 };
462
463 cmp_ok($@, 'eq', "", 'length of $@ after eval');
464 cmp_ok(length $@, '==', 0, 'length of $@ after eval');
465
466 # Check if eval { 1 }; completely resets $@
467 SKIP: {
468     skip("Can't load Devel::Peek: $@", 2)
469         unless eval "use Devel::Peek; 1;";
470
471     my $tempfile = tempfile();
472     open $prog, ">", $tempfile or die "Can't create test file";
473     print $prog <<'END_EVAL_TEST';
474     use Devel::Peek;
475     $! = 0;
476     $@ = $!;
477     Dump($@);
478     print STDERR "******\n";
479     eval { die "\x{a10d}"; };
480     $_ = length $@;
481     eval { 1 };
482     Dump($@);
483     print STDERR "******\n";
484     print STDERR "Done\n";
485 END_EVAL_TEST
486     close $prog or die "Can't close $tempfile: $!";
487     my $got = runperl(progfile => $tempfile, stderr => 1);
488     my ($first, $second, $tombstone) = split (/\*\*\*\*\*\*\n/, $got);
489
490     is($tombstone, "Done\n", 'Program completed successfully');
491
492     $first =~ s/,pNOK//;
493     s/ PV = 0x[0-9a-f]+/ PV = 0x/ foreach $first, $second;
494     s/ LEN = [0-9]+/ LEN = / foreach $first, $second;
495
496     is($second, $first, 'eval { 1 } completely resets $@');
497 }
498
499 # Test that "use feature" and other hint transmission in evals and s///ee
500 # don't leak memory
501 {
502     use feature qw(:5.10);
503     my $count_expected = ($^H & 0x20000) ? 2 : 1;
504     my $t;
505     my $s = "a";
506     $s =~ s/a/$t = \%^H;  qq( qq() );/ee;
507     is(Internals::SvREFCNT(%$t), $count_expected, 'RT 63110');
508 }
509
510 {
511     # test that the CV compiled for the eval is freed by checking that no additional 
512     # reference to outside lexicals are made.
513     my $x;
514     is(Internals::SvREFCNT($x), 1, "originally only 1 referece");
515     eval '$x';
516     is(Internals::SvREFCNT($x), 1, "execution eval doesn't create new references");
517 }
518
519 fresh_perl_is(<<'EOP', "ok\n", undef, 'RT #70862');
520 $::{'@'}='';
521 eval {};
522 print "ok\n";
523 EOP
524
525 fresh_perl_is(<<'EOP', "ok\n", undef, 'variant of RT #70862');
526 eval {
527     $::{'@'}='';
528 };
529 print "ok\n";
530 EOP
531
532 fresh_perl_is(<<'EOP', "ok\n", undef, 'related to RT #70862');
533 $::{'@'}=\3;
534 eval {};
535 print "ok\n";
536 EOP
537
538 fresh_perl_is(<<'EOP', "ok\n", undef, 'related to RT #70862');
539 eval {
540     $::{'@'}=\3;
541 };
542 print "ok\n";
543 EOP
544
545     fresh_perl_is(<<'EOP', "ok\n", undef, 'segfault on syntax errors in block evals');
546 # localize the hits hash so the eval ends up with the pad offset of a copy of it in its targ
547 BEGIN { $^H |= 0x00020000 }
548 eval q{ eval { + } };
549 print "ok\n";
550 EOP
551
552 fresh_perl_is(<<'EOP', "ok\n", undef, 'assert fail on non-string in Perl_lex_start');
553 use overload '""'  => sub { '1;' };
554 my $ov = bless [];
555 eval $ov;
556 print "ok\n";
557 EOP
558
559 for my $k (!0) {
560   eval 'my $do_something_with = $k';
561   eval { $k = 'mon' };
562   is "a" =~ /a/, "1",
563     "string eval leaves readonly lexicals readonly [perl #19135]";
564 }