xref: /openbsd/gnu/usr.bin/perl/t/comp/retainedlines.t (revision a6445c1d) 
1#!./perl -w
2
3# Check that lines from eval are correctly retained by the debugger
4
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;
8
9print "1..75\n";
10my $test = 0;
11
12sub 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
27sub 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}
44
45$^P = 0xA;
46
47my @before = grep { /eval/ } keys %::;
48
49is ((scalar @before), 0, "No evals");
50
51my %seen;
52
53sub check_retained_lines {
54    my ($prog, $name) = @_;
55    # Is there a more efficient way to write this?
56    my @expect_lines = (undef, map ({"$_\n"} split "\n", $prog), "\n", ';');
57
58    my @keys = grep {!$seen{$_}} grep { /eval/ } keys %::;
59
60    is ((scalar @keys), 1, "1 new eval");
61
62    my @got_lines = @{$::{$keys[0]}};
63
64    is ((scalar @got_lines),
65	(scalar @expect_lines), "Right number of lines for $name");
66
67    for (0..$#expect_lines) {
68	is ($got_lines[$_], $expect_lines[$_], "Line $_ is correct");
69    }
70    $seen{$keys[0]}++;
71}
72
73my $name = 'foo';
74
75for my $sep (' ', "\0") {
76
77    my $prog = "sub $name {
78    'Perl${sep}Rules'
79};
801;
81";
82
83    eval $prog or die;
84    check_retained_lines($prog, ord $sep);
85    $name++;
86}
87
88{
89  # This contains a syntax error
90  my $prog = "sub $name {
91    'This is $name'
92  }
931 +
94";
95
96  eval $prog and die;
97
98  is (eval "$name()", "This is $name", "Subroutine was compiled, despite error")
99    or print STDERR "# $@\n";
100
101  check_retained_lines($prog,
102		       'eval that defines subroutine but has syntax error');
103  $name++;
104}
105
106foreach 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
119	is (scalar @after, 0 + keys %seen,
120	    "evals that don't define subroutines are correctly cleaned up");
121    }
122
123    is (eval $fail, undef, 'Failed string eval fails');
124
125    if ($flags & 0x1000) {
126	check_retained_lines($fail, sprintf "%#X", $^P);
127    } else {
128	my @after = grep { /eval/ } keys %::;
129
130	is (scalar @after, 0 + keys %seen,
131	    "evals that fail are correctly cleaned up");
132    }
133}
134
135# BEGIN blocks that die
136for (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}
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"}';
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"}';
163}
164
165# Modifying ${"_<foo"} should not stop lines from being retained.
166{
167  local $^P = 0x400|0x100|0x10;
168  eval <<'end';
169#line 42 "copfilesv-modification"
170    BEGIN{ ${"_<copfilesv-modification"} = \1 }
171#line 52 "copfilesv-modified"
172    abcdefg();
173end
174  is $::{"_<copfilesv-modified"}[52], "    abcdefg();\n",
175   '#line 42 "foo" in a str eval is not confused by ${"_<foo"} changing';
176}
177