Commit | Line | Data |
aac018bb |
1 | #!./perl -w |
2 | |
3 | # Check that lines from eval are correctly retained by the debugger |
4 | |
5 | BEGIN { |
6 | chdir 't' if -d 't'; |
7 | @INC = '../lib'; |
8 | require "./test.pl"; |
9 | } |
10 | |
11 | use strict; |
12 | |
eb044b10 |
13 | plan (tests => 65); |
606f8fc8 |
14 | |
15 | $^P = 0xA; |
aac018bb |
16 | |
17 | my @before = grep { /eval/ } keys %::; |
18 | |
19 | is (@before, 0, "No evals"); |
20 | |
1d963ff3 |
21 | my %seen; |
aac018bb |
22 | |
83fca67e |
23 | sub check_retained_lines { |
24 | my ($prog, $name) = @_; |
aac018bb |
25 | # Is there a more efficient way to write this? |
26 | my @expect_lines = (undef, map ({"$_\n"} split "\n", $prog), "\n", ';'); |
27 | |
1d963ff3 |
28 | my @keys = grep {!$seen{$_}} grep { /eval/ } keys %::; |
aac018bb |
29 | |
1d963ff3 |
30 | is (@keys, 1, "1 new eval"); |
aac018bb |
31 | |
32 | my @got_lines = @{$::{$keys[0]}}; |
33 | |
83fca67e |
34 | is (@got_lines, @expect_lines, "Right number of lines for $name"); |
aac018bb |
35 | |
36 | for (0..$#expect_lines) { |
37 | is ($got_lines[$_], $expect_lines[$_], "Line $_ is correct"); |
38 | } |
1d963ff3 |
39 | $seen{$keys[0]}++; |
83fca67e |
40 | } |
41 | |
42 | my $name = 'foo'; |
43 | |
44 | for my $sep (' ', "\0") { |
45 | |
46 | my $prog = "sub $name { |
47 | 'Perl${sep}Rules' |
48 | }; |
49 | 1; |
50 | "; |
51 | |
52 | eval $prog or die; |
53 | check_retained_lines($prog, ord $sep); |
1d963ff3 |
54 | $name++; |
aac018bb |
55 | } |
606f8fc8 |
56 | |
99d3381e |
57 | { |
58 | # This contains a syntax error |
59 | my $prog = "sub $name { |
60 | 'This is $name' |
61 | } |
62 | 1 + |
63 | "; |
64 | |
65 | eval $prog and die; |
66 | |
67 | is (eval "$name()", "This is $name", "Subroutine was compiled, despite error") |
68 | or diag $@; |
69 | |
eb044b10 |
70 | check_retained_lines($prog, |
71 | 'eval that defines subroutine but has syntax error'); |
99d3381e |
72 | $name++; |
73 | } |
74 | |
83fca67e |
75 | foreach my $flags (0x0, 0x800, 0x1000, 0x1800) { |
76 | local $^P = $^P | $flags; |
77 | # This is easier if we accept that the guts eval will add a trailing \n |
78 | # for us |
79 | my $prog = "1 + 1 + 1\n"; |
80 | my $fail = "1 + \n"; |
81 | |
82 | is (eval $prog, 3, 'String eval works'); |
83 | if ($flags & 0x800) { |
84 | check_retained_lines($prog, sprintf "%#X", $^P); |
85 | } else { |
86 | my @after = grep { /eval/ } keys %::; |
87 | |
88 | is (@after, 0 + keys %seen, |
89 | "evals that don't define subroutines are correctly cleaned up"); |
90 | } |
606f8fc8 |
91 | |
83fca67e |
92 | is (eval $fail, undef, 'Failed string eval fails'); |
606f8fc8 |
93 | |
83fca67e |
94 | if ($flags & 0x1000) { |
f9bddea7 |
95 | check_retained_lines($fail, sprintf "%#X", $^P); |
83fca67e |
96 | } else { |
97 | my @after = grep { /eval/ } keys %::; |
606f8fc8 |
98 | |
83fca67e |
99 | is (@after, 0 + keys %seen, |
100 | "evals that fail are correctly cleaned up"); |
101 | } |
102 | } |