Commit | Line | Data |
aac018bb |
1 | #!./perl -w |
2 | |
3 | # Check that lines from eval are correctly retained by the debugger |
4 | |
2ab76064 |
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 | |
1909e25b |
9 | print "1..65\n"; |
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 | |
27 | sub is { |
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 |
44 | |
45 | $^P = 0xA; |
aac018bb |
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 |
53 | sub check_retained_lines { |
54 | my ($prog, $name) = @_; |
aac018bb |
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 |
61 | |
62 | my @got_lines = @{$::{$keys[0]}}; |
63 | |
12f74f45 |
64 | is ((scalar @got_lines), |
65 | (scalar @expect_lines), "Right number of lines for $name"); |
aac018bb |
66 | |
67 | for (0..$#expect_lines) { |
68 | is ($got_lines[$_], $expect_lines[$_], "Line $_ is correct"); |
69 | } |
1d963ff3 |
70 | $seen{$keys[0]}++; |
83fca67e |
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 |
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 |
101 | check_retained_lines($prog, |
102 | 'eval that defines subroutine but has syntax error'); |
99d3381e |
103 | $name++; |
104 | } |
105 | |
83fca67e |
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 |
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 |
127 | } else { |
128 | my @after = grep { /eval/ } keys %::; |
606f8fc8 |
129 | |
12f74f45 |
130 | is (scalar @after, 0 + keys %seen, |
83fca67e |
131 | "evals that fail are correctly cleaned up"); |
132 | } |
133 | } |