1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176
|
#!./perl -w
# Check that lines from eval are correctly retained by the debugger
# Uncomment this for testing, but don't leave it in for "production", as
# we've not yet verified that use works.
# use strict;
print "1..75\n";
my $test = 0;
sub failed {
my ($got, $expected, $name) = @_;
print "not ok $test - $name\n";
my @caller = caller(1);
print "# Failed test at $caller[1] line $caller[2]\n";
if (defined $got) {
print "# Got '$got'\n";
} else {
print "# Got undef\n";
}
print "# Expected $expected\n";
return;
}
sub is($$$) {
my ($got, $expect, $name) = @_;
$test = $test + 1;
if (defined $expect) {
if (defined $got && $got eq $expect) {
print "ok $test - $name\n";
return 1;
}
failed($got, "'$expect'", $name);
} else {
if (!defined $got) {
print "ok $test - $name\n";
return 1;
}
failed($got, 'undef', $name);
}
}
$^P = 0xA;
my @before = grep { /eval/ } keys %::;
is ((scalar @before), 0, "No evals");
my %seen;
sub check_retained_lines {
my ($prog, $name) = @_;
# Is there a more efficient way to write this?
my @expect_lines = (undef, map ({"$_\n"} split "\n", $prog), "\n", ';');
my @keys = grep {!$seen{$_}} grep { /eval/ } keys %::;
is ((scalar @keys), 1, "1 new eval");
my @got_lines = @{$::{$keys[0]}};
is ((scalar @got_lines),
(scalar @expect_lines), "Right number of lines for $name");
for (0..$#expect_lines) {
is ($got_lines[$_], $expect_lines[$_], "Line $_ is correct");
}
$seen{$keys[0]}++;
}
my $name = 'foo';
for my $sep (' ', "\0") {
my $prog = "sub $name {
'Perl${sep}Rules'
};
1;
";
eval $prog or die;
check_retained_lines($prog, ord $sep);
$name++;
}
{
# This contains a syntax error
my $prog = "sub $name {
'This is $name'
}
1 +
";
eval $prog and die;
is (eval "$name()", "This is $name", "Subroutine was compiled, despite error")
or print STDERR "# $@\n";
check_retained_lines($prog,
'eval that defines subroutine but has syntax error');
$name++;
}
foreach my $flags (0x0, 0x800, 0x1000, 0x1800) {
local $^P = $^P | $flags;
# This is easier if we accept that the guts eval will add a trailing \n
# for us
my $prog = "1 + 1 + 1\n";
my $fail = "1 + \n";
is (eval $prog, 3, 'String eval works');
if ($flags & 0x800) {
check_retained_lines($prog, sprintf "%#X", $^P);
} else {
my @after = grep { /eval/ } keys %::;
is (scalar @after, 0 + keys %seen,
"evals that don't define subroutines are correctly cleaned up");
}
is (eval $fail, undef, 'Failed string eval fails');
if ($flags & 0x1000) {
check_retained_lines($fail, sprintf "%#X", $^P);
} else {
my @after = grep { /eval/ } keys %::;
is (scalar @after, 0 + keys %seen,
"evals that fail are correctly cleaned up");
}
}
# BEGIN blocks that die
for (0xA, 0) {
local $^P = $_;
eval (my $prog = "BEGIN{die}\n");
if ($_) {
check_retained_lines($prog, 'eval that defines BEGIN that dies');
}
else {
my @after = grep { /eval/ } keys %::;
is (scalar @after, 0 + keys %seen,
"evals with BEGIN{die} are correctly cleaned up");
}
}
# [perl #79442] A #line "foo" directive in a string eval was not updating
# *{"_<foo"} in threaded perls, and was not putting the right lines into
# the right elements of @{"_<foo"} in non-threaded perls.
{
local $^P = 0x400|0x100|0x10;
eval qq{#line 42 "hash-line-eval"\n labadalabada()\n};
is $::{"_<hash-line-eval"}[42], " labadalabada()\n",
'#line 42 "foo" in a string eval updates @{"_<foo"}';
eval qq{#line 42 "figgle"\n#line 85 "doggo"\n labadalabada()\n};
is $::{"_<doggo"}[85], " labadalabada()\n",
'subsequent #line 42 "foo" in a string eval updates @{"_<foo"}';
}
# Modifying ${"_<foo"} should not stop lines from being retained.
{
local $^P = 0x400|0x100|0x10;
eval <<'end';
#line 42 "copfilesv-modification"
BEGIN{ ${"_<copfilesv-modification"} = \1 }
#line 52 "copfilesv-modified"
abcdefg();
end
is $::{"_<copfilesv-modified"}[52], " abcdefg();\n",
'#line 42 "foo" in a str eval is not confused by ${"_<foo"} changing';
}
|