Small optimisations, by Brandon Black
[p5sagit/p5-mst-13.2.git] / t / op / eval.t
CommitLineData
a559c259 1#!./perl
2
7e736055 3BEGIN {
4 chdir 't' if -d 't';
5 @INC = '../lib';
6}
7
eb034824 8print "1..93\n";
a559c259 9
10eval 'print "ok 1\n";';
11
12if ($@ eq '') {print "ok 2\n";} else {print "not ok 2\n";}
13
14eval "\$foo\n = # this is a comment\n'ok 3';";
15print $foo,"\n";
16
17eval "\$foo\n = # this is a comment\n'ok 4\n';";
18print $foo;
19
378cc40b 20print eval '
79072805 21$foo =;'; # this tests for a call through yyerror()
a559c259 22if ($@ =~ /line 2/) {print "ok 5\n";} else {print "not ok 5\n";}
23
378cc40b 24print eval '$foo = /'; # this tests for a call through fatal()
a559c259 25if ($@ =~ /Search/) {print "ok 6\n";} else {print "not ok 6\n";}
378cc40b 26
27print 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;
34if ($ans == 120) {print "ok 8\n";} else {print "not ok 8\n";}
35
36$foo = 5;
a687059c 37$fact = 'local($foo)=$foo; $foo <= 1 ? 1 : $foo-- * (eval $fact);';
378cc40b 38$ans = eval $fact;
39if ($ans == 120) {print "ok 9\n";} else {print "not ok 9 $ans\n";}
40
41open(try,'>Op.eval');
42print try 'print "ok 10\n"; unlink "Op.eval";',"\n";
43close try;
44
4343e7c3 45do './Op.eval'; print $@;
99b89507 46
47# Test the singlequoted eval optimizer
48
49$i = 11;
50for (1..3) {
51 eval 'print "ok ", $i++, "\n"';
52}
53
54eval {
55 print "ok 14\n";
56 die "ok 16\n";
57 1;
58} || print "ok 15\n$@";
59
c7cc6f1c 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";
fc360e46 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();
c7cc6f1c 84}
155fc61f 85
86my $b = 'wrong';
87my $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
96my $x = 25;
97eval <<'EOT'; die if $@;
0a00efa0 98 print "# $x\n"; # clone into eval's pad
99 sub do_eval1 {
155fc61f 100 eval $_[0]; die if $@;
101 }
102EOT
0a00efa0 103do_eval1('print "ok $x\n"');
155fc61f 104$x++;
0a00efa0 105do_eval1('eval q[print "ok $x\n"]');
155fc61f 106$x++;
b318f128 107do_eval1('sub { print "# $x\n"; eval q[print "ok $x\n"] }->()');
0a00efa0 108$x++;
109
110# calls from within eval'' should clone outer lexicals
111
112eval <<'EOT'; die if $@;
113 sub do_eval2 {
114 eval $_[0]; die if $@;
115 }
116do_eval2('print "ok $x\n"');
117$x++;
118do_eval2('eval q[print "ok $x\n"]');
119$x++;
b318f128 120do_eval2('sub { print "# $x\n"; eval q[print "ok $x\n"] }->()');
0a00efa0 121$x++;
122EOT
123
124# calls outside eval'' should NOT clone lexicals from called context
125
a3985cdc 126$main::ok = 'not ok';
127my $ok = 'ok';
0a00efa0 128eval <<'EOT'; die if $@;
129 # $x unbound here
130 sub do_eval3 {
131 eval $_[0]; die if $@;
132 }
133EOT
a3985cdc 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}
6b35e009 140
141# can recursive subroutine-call inside eval'' see its own lexicals?
142sub 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}
33b8ce05 157$x++;
158
159# do closures created within eval bind correctly?
160eval <<'EOT';
161 sub create_closure {
162 my $self = shift;
163 return sub {
164 print $self;
165 };
166 }
167EOT
168create_closure("ok $x\n")->();
2680586e 169$x++;
170
171# does lexical search terminate correctly at subroutine boundary?
172$main::r = "ok $x\n";
173sub terminal { eval 'print $r' }
174{
175 my $r = "not ok $x\n";
176 eval 'terminal($r)';
177}
178$x++;
179
a7c6d244 180# Have we cured panic which occurred with require/eval in die handler ?
181$SIG{__DIE__} = sub { eval {1}; die shift };
182eval { die "ok ".$x++,"\n" };
183print $@;
184
a7ec2b44 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}
b45de488 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}
3b2447bc 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}
b6512f48 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}
16a5162e 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}
a3985cdc 250
251# DAPM Nov-2002. Perl should now capture the full lexical context during
252# evals.
253
254$::zzz = $::zzz = 0;
255my $zzz = 1;
256
257eval 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
265eval q{
266 sub fred2 {
267 print eval('$zzz') == 1 ? 'ok' : 'not ok', " $_[0]\n";
268 }
269};
270fred2(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
276sub 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}
282do_sort();
283
284# more recursion and lexical scope leak tests
285
286eval 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};
310my $r = fred3(5);
311print $r == 120 ? 'ok' : 'not ok', " 56\n";
312$r = eval'fred3(5)';
313print $r == 120 ? 'ok' : 'not ok', " 57\n";
314$r = 0;
315eval'$r = fred3(5)';
316print $r == 120 ? 'ok' : 'not ok', " 58\n";
317$r = 0;
318{ my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' };
319print $r == 120 ? 'ok' : 'not ok', " 59\n";
320
321# check that goto &sub within evals doesn't leak lexical scope
322
323my $yyy = 2;
324
325my $test = 60;
326sub 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
334eval 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};
346fred5();
347{ my $yyy = 88; my $zzz = 99; fred5(); }
e8cf733a 348eval q{ my $yyy = 888; my $zzz = 999; fred5(); };
a3985cdc 349
e8cf733a 350# [perl #9728] used to dump core
351{
352 $eval = eval 'sub { eval "sub { %S }" }';
353 $eval->({});
7e736055 354 print "ok $test\n";
355 $test++;
e8cf733a 356}
a3985cdc 357
d819b83a 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;
363our $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}
7e736055 384require './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
388my $got = runperl (prog => '$h{a}=1; foreach my $k (keys %h) {eval qq{\$k}}',
389 stderr => 1);
390
391if ($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}
77d32bb7 422
423sub Foo {} print Foo(eval {});
424print "ok ",$test++," - #20798 (used to dump core)\n";
f48583aa 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}
6ab4a6ff 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)',
447stderr => 1);
448
449print "not " unless $got eq "ok\n";
450print "ok $test - eval and last\n"; $test++;
451
eb034824 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 unef \n"; $test++;
459}
460