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