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