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