#!./perl
-print "1..27\n";
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require './test.pl';
+}
+
+plan(tests => 125);
-eval 'print "ok 1\n";';
+eval 'pass();';
-if ($@ eq '') {print "ok 2\n";} else {print "not ok 2\n";}
+is($@, '');
eval "\$foo\n = # this is a comment\n'ok 3';";
-print $foo,"\n";
+is($foo, 'ok 3');
eval "\$foo\n = # this is a comment\n'ok 4\n';";
-print $foo;
+is($foo, "ok 4\n");
print eval '
$foo =;'; # this tests for a call through yyerror()
-if ($@ =~ /line 2/) {print "ok 5\n";} else {print "not ok 5\n";}
+like($@, qr/line 2/);
print eval '$foo = /'; # this tests for a call through fatal()
-if ($@ =~ /Search/) {print "ok 6\n";} else {print "not ok 6\n";}
+like($@, qr/Search/);
-print eval '"ok 7\n";';
+is scalar(eval '++'), undef, 'eval syntax error in scalar context';
+is scalar(eval 'die'), undef, 'eval run-time error in scalar context';
+is +()=eval '++', 0, 'eval syntax error in list context';
+is +()=eval 'die', 0, 'eval run-time error in list context';
-# calculate a factorial with recursive evals
+is(eval '"ok 7\n";', "ok 7\n");
$foo = 5;
$fact = 'if ($foo <= 1) {1;} else {push(@x,$foo--); (eval $fact) * pop(@x);}';
$ans = eval $fact;
-if ($ans == 120) {print "ok 8\n";} else {print "not ok 8\n";}
+is($ans, 120, 'calculate a factorial with recursive evals');
$foo = 5;
$fact = 'local($foo)=$foo; $foo <= 1 ? 1 : $foo-- * (eval $fact);';
$ans = eval $fact;
-if ($ans == 120) {print "ok 9\n";} else {print "not ok 9 $ans\n";}
+is($ans, 120, 'calculate a factorial with recursive evals');
-open(try,'>Op.eval');
-print try 'print "ok 10\n"; unlink "Op.eval";',"\n";
+my $curr_test = curr_test();
+my $tempfile = tempfile();
+open(try,'>',$tempfile);
+print try 'print "ok $curr_test\n";',"\n";
close try;
-do 'Op.eval'; print $@;
+do "./$tempfile"; print $@;
# Test the singlequoted eval optimizer
-$i = 11;
+$i = $curr_test + 1;
for (1..3) {
eval 'print "ok ", $i++, "\n"';
}
+$curr_test += 4;
+
eval {
- print "ok 14\n";
- die "ok 16\n";
+ print "ok $curr_test\n";
+ die sprintf "ok %d\n", $curr_test + 2;
1;
-} || print "ok 15\n$@";
+} || printf "ok %d\n$@", $curr_test + 1;
+
+curr_test($curr_test + 3);
# check whether eval EXPR determines value of EXPR correctly
{
my @a = qw(a b c d);
my @b = eval @a;
- print "@b" eq '4' ? "ok 17\n" : "not ok 17\n";
- print $@ ? "not ok 18\n" : "ok 18\n";
+ is("@b", '4');
+ is($@, '');
my $a = q[defined(wantarray) ? (wantarray ? ($b='A') : ($b='S')) : ($b='V')];
my $b;
@a = eval $a;
- print "@a" eq 'A' ? "ok 19\n" : "# $b\nnot ok 19\n";
- print $b eq 'A' ? "ok 20\n" : "# $b\nnot ok 20\n";
+ is("@a", 'A');
+ is( $b, 'A');
$_ = eval $a;
- print $b eq 'S' ? "ok 21\n" : "# $b\nnot ok 21\n";
+ is( $b, 'S');
eval $a;
- print $b eq 'V' ? "ok 22\n" : "# $b\nnot ok 22\n";
+ is( $b, 'V');
$b = 'wrong';
$x = sub {
my $b = "right";
- print eval('"$b"') eq $b ? "ok 23\n" : "not ok 23\n";
+ is(eval('"$b"'), $b);
};
&$x();
}
-my $b = 'wrong';
-my $X = sub {
- my $b = "right";
- print eval('"$b"') eq $b ? "ok 24\n" : "not ok 24\n";
-};
-&$X();
-
+{
+ my $b = 'wrong';
+ my $X = sub {
+ my $b = "right";
+ is(eval('"$b"'), $b);
+ };
+ &$X();
+}
# check navigation of multiple eval boundaries to find lexicals
-my $x = 25;
+my $x = 'aa';
eval <<'EOT'; die if $@;
- sub do_eval {
+ print "# $x\n"; # clone into eval's pad
+ sub do_eval1 {
eval $_[0]; die if $@;
}
EOT
-do_eval('print "ok $x\n"');
+do_eval1('is($x, "aa")');
$x++;
-do_eval('eval q[print "ok $x\n"]');
+do_eval1('eval q[is($x, "ab")]');
$x++;
-do_eval('sub { eval q[print "ok $x\n"] }->()');
+do_eval1('sub { print "# $x\n"; eval q[is($x, "ac")] }->()');
$x++;
+
+# calls from within eval'' should clone outer lexicals
+
+eval <<'EOT'; die if $@;
+ sub do_eval2 {
+ eval $_[0]; die if $@;
+ }
+do_eval2('is($x, "ad")');
+$x++;
+do_eval2('eval q[is($x, "ae")]');
+$x++;
+do_eval2('sub { print "# $x\n"; eval q[is($x, "af")] }->()');
+EOT
+
+# calls outside eval'' should NOT clone lexicals from called context
+
+$main::ok = 'not ok';
+my $ok = 'ok';
+eval <<'EOT'; die if $@;
+ # $x unbound here
+ sub do_eval3 {
+ eval $_[0]; die if $@;
+ }
+EOT
+{
+ my $ok = 'not ok';
+ do_eval3('is($ok, q{ok})');
+ do_eval3('eval q[is($ok, q{ok})]');
+ do_eval3('sub { eval q[is($ok, q{ok})] }->()');
+}
+
+{
+ my $x = curr_test();
+ my $got;
+ sub recurse {
+ my $l = shift;
+ if ($l < $x) {
+ ++$l;
+ eval 'print "# level $l\n"; recurse($l);';
+ die if $@;
+ }
+ else {
+ $got = "ok $l";
+ }
+ }
+ local $SIG{__WARN__} = sub { fail() if $_[0] =~ /^Deep recurs/ };
+ recurse(curr_test() - 5);
+
+ is($got, "ok $x",
+ "recursive subroutine-call inside eval'' see its own lexicals");
+}
+
+
+eval <<'EOT';
+ sub create_closure {
+ my $self = shift;
+ return sub {
+ return $self;
+ };
+ }
+EOT
+is(create_closure("good")->(), "good",
+ 'closures created within eval bind correctly');
+
+$main::r = "good";
+sub terminal { eval '$r . q{!}' }
+is(do {
+ my $r = "bad";
+ eval 'terminal($r)';
+}, 'good!', 'lexical search terminates correctly at subroutine boundary');
+
+{
+ # Have we cured panic which occurred with require/eval in die handler ?
+ local $SIG{__DIE__} = sub { eval {1}; die shift };
+ eval { die "wham_eth\n" };
+ is($@, "wham_eth\n");
+}
+
+{
+ my $c = eval "(1,2)x10";
+ is($c, '2222222222', 'scalar eval"" pops stack correctly');
+}
+
+# return from eval {} should clear $@ correctly
+{
+ my $status = eval {
+ eval { die };
+ print "# eval { return } test\n";
+ return; # removing this changes behavior
+ };
+ is($@, '', 'return from eval {} should clear $@ correctly');
+}
+
+# ditto for eval ""
+{
+ my $status = eval q{
+ eval q{ die };
+ print "# eval q{ return } test\n";
+ return; # removing this changes behavior
+ };
+ is($@, '', 'return from eval "" should clear $@ correctly');
+}
+
+# Check that eval catches bad goto calls
+# (BUG ID 20010305.003)
+{
+ eval {
+ eval { goto foo; };
+ like($@, qr/Can't "goto" into the middle of a foreach loop/,
+ 'eval catches bad goto calls');
+ last;
+ foreach my $i (1) {
+ foo: fail('jumped into foreach');
+ }
+ };
+ fail("Outer eval didn't execute the last");
+ diag($@);
+}
+
+# Make sure that "my $$x" is forbidden
+# 20011224 MJD
+{
+ foreach (qw($$x @$x %$x $$$x)) {
+ eval 'my ' . $_;
+ isnt($@, '', "my $_ is forbidden");
+ }
+}
+
+{
+ $@ = 5;
+ eval q{};
+ cmp_ok(length $@, '==', 0, '[ID 20020623.002] eval "" doesn\'t clear $@');
+}
+
+# DAPM Nov-2002. Perl should now capture the full lexical context during
+# evals.
+
+$::zzz = $::zzz = 0;
+my $zzz = 1;
+
+eval q{
+ sub fred1 {
+ eval q{ is(eval '$zzz', 1); }
+ }
+ fred1(47);
+ { my $zzz = 2; fred1(48) }
+};
+
+eval q{
+ sub fred2 {
+ is(eval('$zzz'), 1);
+ }
+};
+fred2(49);
+{ my $zzz = 2; fred2(50) }
+
+# sort() starts a new context stack. Make sure we can still find
+# the lexically enclosing sub
+
+sub do_sort {
+ my $zzz = 2;
+ my @a = sort
+ { is(eval('$zzz'), 2); $a <=> $b }
+ 2, 1;
+}
+do_sort();
+
+# more recursion and lexical scope leak tests
+
+eval q{
+ my $r = -1;
+ my $yyy = 9;
+ sub fred3 {
+ my $l = shift;
+ my $r = -2;
+ return 1 if $l < 1;
+ return 0 if eval '$zzz' != 1;
+ return 0 if $yyy != 9;
+ return 0 if eval '$yyy' != 9;
+ return 0 if eval '$l' != $l;
+ return $l * fred3($l-1);
+ }
+ my $r = fred3(5);
+ is($r, 120);
+ $r = eval'fred3(5)';
+ is($r, 120);
+ $r = 0;
+ eval '$r = fred3(5)';
+ is($r, 120);
+ $r = 0;
+ { my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' };
+ is($r, 120);
+};
+my $r = fred3(5);
+is($r, 120);
+$r = eval'fred3(5)';
+is($r, 120);
+$r = 0;
+eval'$r = fred3(5)';
+is($r, 120);
+$r = 0;
+{ my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' };
+is($r, 120);
+
+# check that goto &sub within evals doesn't leak lexical scope
+
+my $yyy = 2;
+
+sub fred4 {
+ my $zzz = 3;
+ is($zzz, 3);
+ is(eval '$zzz', 3);
+ is(eval '$yyy', 2);
+}
+
+eval q{
+ fred4();
+ sub fred5 {
+ my $zzz = 4;
+ is($zzz, 4);
+ is(eval '$zzz', 4);
+ is(eval '$yyy', 2);
+ goto &fred4;
+ }
+ fred5();
+};
+fred5();
+{ my $yyy = 88; my $zzz = 99; fred5(); }
+eval q{ my $yyy = 888; my $zzz = 999; fred5(); };
+
+{
+ $eval = eval 'sub { eval "sub { %S }" }';
+ $eval->({});
+ pass('[perl #9728] used to dump core');
+}
+
+# evals that appear in the DB package should see the lexical scope of the
+# thing outside DB that called them (usually the debugged code), rather
+# than the usual surrounding scope
+
+our $x = 1;
+{
+ my $x=2;
+ sub db1 { $x; eval '$x' }
+ sub DB::db2 { $x; eval '$x' }
+ package DB;
+ sub db3 { eval '$x' }
+ sub DB::db4 { eval '$x' }
+ sub db5 { my $x=4; eval '$x' }
+ package main;
+ sub db6 { my $x=4; eval '$x' }
+}
+{
+ my $x = 3;
+ is(db1(), 2);
+ is(DB::db2(), 2);
+ is(DB::db3(), 3);
+ is(DB::db4(), 3);
+ is(DB::db5(), 3);
+ is(db6(), 4);
+}
+
+# [perl #19022] used to end up with shared hash warnings
+# The program should generate no output, so anything we see is on stderr
+my $got = runperl (prog => '$h{a}=1; foreach my $k (keys %h) {eval qq{\$k}}',
+ stderr => 1);
+is ($got, '');
+
+# And a buggy way of fixing #19022 made this fail - $k became undef after the
+# eval for a build with copy on write
+{
+ my %h;
+ $h{a}=1;
+ foreach my $k (keys %h) {
+ is($k, 'a');
+
+ eval "\$k";
+
+ is($k, 'a');
+ }
+}
+
+sub Foo {} print Foo(eval {});
+pass('#20798 (used to dump core)');
+
+# check for context in string eval
+{
+ my(@r,$r,$c);
+ sub context { defined(wantarray) ? (wantarray ? ($c='A') : ($c='S')) : ($c='V') }
+
+ my $code = q{ context() };
+ @r = qw( a b );
+ $r = 'ab';
+ @r = eval $code;
+ is("@r$c", 'AA', 'string eval list context');
+ $r = eval $code;
+ is("$r$c", 'SS', 'string eval scalar context');
+ eval $code;
+ is("$c", 'V', 'string eval void context');
+}
+
+# [perl #34682] escaping an eval with last could coredump or dup output
+
+$got = runperl (
+ prog =>
+ 'sub A::TIEARRAY { L: { eval { last L } } } tie @a, A; warn qq(ok\n)',
+stderr => 1);
+
+is($got, "ok\n", 'eval and last');
+
+# eval undef should be the same as eval "" barring any warnings
+
+{
+ local $@ = "foo";
+ eval undef;
+ is($@, "", 'eval undef');
+}
+
+{
+ no warnings;
+ eval "/ /b;";
+ like($@, qr/^syntax error/, 'eval syntax error, no warnings');
+}
+
+# a syntax error in an eval called magically (eg via tie or overload)
+# resulted in an assertion failure in S_docatch, since doeval had already
+# popped the EVAL context due to the failure, but S_docatch expected the
+# context to still be there.
+
+{
+ my $ok = 0;
+ package Eval1;
+ sub STORE { eval '('; $ok = 1 }
+ sub TIESCALAR { bless [] }
+
+ my $x;
+ tie $x, bless [];
+ $x = 1;
+ ::is($ok, 1, 'eval docatch');
+}
+
+# [perl #51370] eval { die "\x{a10d}" } followed by eval { 1 } did not reset
+# length $@
+$@ = "";
+eval { die "\x{a10d}"; };
+$_ = length $@;
+eval { 1 };
+
+cmp_ok($@, 'eq', "", 'length of $@ after eval');
+cmp_ok(length $@, '==', 0, 'length of $@ after eval');
+
+# Check if eval { 1 }; completely resets $@
+SKIP: {
+ skip_if_miniperl('no dynamic loading on miniperl, no Devel::Peek', 2);
+ require Config;
+ skip('Devel::Peek was not built', 2)
+ unless $Config::Config{extensions} =~ /\bDevel\/Peek\b/;
+
+ my $tempfile = tempfile();
+ open $prog, ">", $tempfile or die "Can't create test file";
+ print $prog <<'END_EVAL_TEST';
+ use Devel::Peek;
+ $! = 0;
+ $@ = $!;
+ Dump($@);
+ print STDERR "******\n";
+ eval { die "\x{a10d}"; };
+ $_ = length $@;
+ eval { 1 };
+ Dump($@);
+ print STDERR "******\n";
+ print STDERR "Done\n";
+END_EVAL_TEST
+ close $prog or die "Can't close $tempfile: $!";
+ my $got = runperl(progfile => $tempfile, stderr => 1);
+ my ($first, $second, $tombstone) = split (/\*\*\*\*\*\*\n/, $got);
+
+ is($tombstone, "Done\n", 'Program completed successfully');
+
+ $first =~ s/,pNOK//;
+ s/ PV = 0x[0-9a-f]+/ PV = 0x/ foreach $first, $second;
+ s/ LEN = [0-9]+/ LEN = / foreach $first, $second;
+ # Dump may double newlines through pipes, though not files
+ # which is what this test used to use.
+ $second =~ s/ IV = 0\n\n/ IV = 0\n/ if $^O eq 'VMS';
+
+ is($second, $first, 'eval { 1 } completely resets $@');
+}
+
+# Test that "use feature" and other hint transmission in evals and s///ee
+# don't leak memory
+{
+ use feature qw(:5.10);
+ my $count_expected = ($^H & 0x20000) ? 2 : 1;
+ my $t;
+ my $s = "a";
+ $s =~ s/a/$t = \%^H; qq( qq() );/ee;
+ is(Internals::SvREFCNT(%$t), $count_expected, 'RT 63110');
+}
+
+{
+ # test that the CV compiled for the eval is freed by checking that no additional
+ # reference to outside lexicals are made.
+ my $x;
+ is(Internals::SvREFCNT($x), 1, "originally only 1 reference");
+ eval '$x';
+ is(Internals::SvREFCNT($x), 1, "execution eval doesn't create new references");
+}
+
+fresh_perl_is(<<'EOP', "ok\n", undef, 'RT #70862');
+$::{'@'}='';
+eval {};
+print "ok\n";
+EOP
+
+fresh_perl_is(<<'EOP', "ok\n", undef, 'variant of RT #70862');
+eval {
+ $::{'@'}='';
+};
+print "ok\n";
+EOP
+
+fresh_perl_is(<<'EOP', "ok\n", undef, 'related to RT #70862');
+$::{'@'}=\3;
+eval {};
+print "ok\n";
+EOP
+
+fresh_perl_is(<<'EOP', "ok\n", undef, 'related to RT #70862');
+eval {
+ $::{'@'}=\3;
+};
+print "ok\n";
+EOP
+
+ fresh_perl_is(<<'EOP', "ok\n", undef, 'segfault on syntax errors in block evals');
+# localize the hits hash so the eval ends up with the pad offset of a copy of it in its targ
+BEGIN { $^H |= 0x00020000 }
+eval q{ eval { + } };
+print "ok\n";
+EOP
+
+fresh_perl_is(<<'EOP', "ok\n", undef, 'assert fail on non-string in Perl_lex_start');
+use overload '""' => sub { '1;' };
+my $ov = bless [];
+eval $ov;
+print "ok\n";
+EOP
+
+for my $k (!0) {
+ eval 'my $do_something_with = $k';
+ eval { $k = 'mon' };
+ is "a" =~ /a/, "1",
+ "string eval leaves readonly lexicals readonly [perl #19135]";
+}
+
+# [perl #68750]
+fresh_perl_is(<<'EOP', "ok\nok\nok\n", undef, 'eval clears %^H');
+ BEGIN {
+ require re; re->import('/x'); # should only affect surrounding scope
+ eval '
+ print "a b" =~ /a b/ ? "ok\n" : "nokay\n";
+ use re "/m";
+ print "a b" =~ /a b/ ? "ok\n" : "nokay\n";
+ ';
+ }
+ print "ab" =~ /a b/ ? "ok\n" : "nokay\n";
+EOP
+
+# [perl #70151]
+{
+ BEGIN { eval 'require re; import re "/x"' }
+ ok "ab" =~ /a b/, 'eval does not localise %^H at run time';
+}
+
+# The fix for perl #70151 caused an assertion failure that broke
+# SNMP::Trapinfo, when toke.c finds no syntax errors but perly.y fails.
+eval(q|""!=!~//|);
+pass("phew! dodged the assertion after a parsing (not lexing) error");
https://perl5.git.perl.org / perl5.git / blobdiff