Update Time-HiRes Changes for 1.9760
[perl.git] / t / op / heredoc.t
1 # tests for heredocs besides what is tested in base/lex.t
2
3 BEGIN {
4     chdir 't' if -d 't';
5     require './test.pl';
6     set_up_inc('../lib');
7 }
8
9 use strict;
10 plan(tests => 137);
11
12 # heredoc without newline (#65838)
13 {
14     my $string = <<'HEREDOC';
15 testing for 65838
16 HEREDOC
17
18     my $code = "<<'HEREDOC';\n${string}HEREDOC";  # HD w/o newline, in eval-string
19     my $hd = eval $code or warn "$@ ---";
20     is($hd, $string, "no terminating newline in string-eval");
21 }
22
23
24 # here-doc edge cases
25 {
26     my $string = "testing for 65838";
27
28     fresh_perl_is(
29         "print <<'HEREDOC';\n${string}\nHEREDOC",
30         $string,
31         {},
32         "heredoc at EOF without trailing newline"
33     );
34
35     fresh_perl_is(
36         qq(print <<"";\n$string\n),
37         $string,
38         { switches => ['-X'] },
39         "blank-terminated heredoc at EOF"
40     );
41     fresh_perl_is(
42         qq(print <<""\n$string\n),
43         $string,
44         { switches => ['-X'] },
45         "blank-terminated heredoc at EOF and no semicolon"
46     );
47     fresh_perl_is(
48         "print <<foo\r\nick and queasy\r\nfoo\r\n",
49         'ick and queasy',
50         { switches => ['-X'] },
51         "crlf-terminated heredoc"
52     );
53     fresh_perl_is(
54         "print qq|\${\\<<foo}|\nick and queasy\nfoo\n",
55         'ick and queasy',
56         { switches => ['-w'], stderr => 1 },
57         'no warning for qq|${\<<foo}| in file'
58     );
59 }
60
61
62 # here-doc parse failures
63 {
64     fresh_perl_like(
65         "print <<HEREDOC;\nwibble\n HEREDOC",
66         qr/find string terminator/,
67         {},
68         "string terminator must start at newline"
69     );
70
71     # Loop over various lengths to try to force at least one to cause a
72     # reallocation in S_scan_heredoc()
73     # Timing on a modern machine suggests that this loop executes in less than
74     # 0.1s, so it's a very small cost for the default build. The benefit is
75     # that building with ASAN will reveal the bug and any related regressions.
76     for (1..31) {
77         fresh_perl_like(
78             qq(print <<"";\n) . "x" x $_,
79             qr/find string terminator/,
80             { switches => ['-X'] },
81             "empty string terminator still needs a newline (length $_)"
82         );
83     }
84
85     fresh_perl_like(
86         "print <<ThisTerminatorIsLongerThanTheData;\nno more newlines",
87         qr/find string terminator/,
88         {},
89         "long terminator fails correctly"
90     );
91
92     # this would read freed memory
93     fresh_perl_like(
94         qq(0<<<<""0\n\n),
95         # valgrind and asan reports an error between these two lines
96         qr/^Number found where operator expected at - line 1, near "<<""0"\s+\(Missing operator/,
97         {},
98         "don't use an invalid oldoldbufptr"
99     );
100
101     # also read freed memory, but got an invalid oldoldbufptr in a different way
102     fresh_perl_like(
103         qq(<<""\n\$          \n),
104         # valgrind and asan reports an error between these two lines
105         qr/^Final \$/,
106         {},
107         "don't use an invalid oldoldbufptr (some more)"
108     );
109
110     # [perl #125540] this asserted or crashed
111     fresh_perl_like(
112         q(map d<<<<""),
113         qr/Can't find string terminator "" anywhere before EOF at - line 1\./,
114         {},
115         "Don't assert parsing a here-doc if we hit EOF early"
116     );
117
118     # [perl #129064] heap-buffer-overflow S_scan_heredoc
119     fresh_perl_like(
120         qq(<<`\\),
121         # valgrind and asan reports an error between these two lines
122         qr/^Unterminated delimiter for here document/,
123         {},
124         "delimcpy(): handle last char being backslash properly"
125     );
126 }
127
128
129 # indented here-docs
130 {
131     my $string = 'some data';
132
133     my %delimiters = (
134         q{EOF}     => "EOF",
135         q{'EOF'}   => "EOF",
136         q{"EOF"}   => "EOF",
137         q{\EOF}    => "EOF",
138         q{' EOF'}  => " EOF",
139         q{'EOF '}  => "EOF ",
140         q{' EOF '} => " EOF ",
141         q{" EOF"}  => " EOF",
142         q{"EOF "}  => "EOF ",
143         q{" EOF "} => " EOF ",
144         q{''}      => "",
145         q{""}      => "",
146     );
147
148     my @modifiers = ("~", "~ ");
149
150     my @script_ends = ("", "\n");
151
152     my @tests;
153
154     for my $start_delim (sort keys %delimiters) {
155         my $end_delim = $delimiters{$start_delim};
156
157         for my $modifier (@modifiers) {
158             # For now, "<<~ EOF" and "<<~ \EOF" aren't allowed
159             next if $modifier =~ /\s/ && $start_delim !~ /('|")/n;
160
161             for my $script_end (@script_ends) {
162                 # Normal heredoc
163                 my $test =   "print <<$modifier$start_delim\n  $string\n"
164                            . "  $end_delim$script_end";
165                 unshift @tests, [
166                     $test,
167                     $string,
168                     "Indented here-doc: <<$modifier$start_delim with end delim '$end_delim'" . ($script_end ? "\\n" : ""),
169                 ];
170
171                 # Eval'd heredoc
172                 my $safe_start_delim = $start_delim =~ s/'/\\'/gr;
173                 my $eval = "
174                     \$_ = '';
175                     eval 's//<<$modifier$safe_start_delim.\"\"/e; print
176                         $string
177                         $end_delim$script_end'
178                     or die \$\@
179                 ";
180                 push @tests, [
181                     $eval,
182                     $string,
183                     "Eval'd Indented here-doc: <<$modifier$start_delim with end delim '$end_delim'" . ($script_end ? "\\n" : ""),
184
185                 ];
186             }
187         }
188     }
189
190     push @tests, [
191         "print <<~EOF;\n\t \t$string\n\t \tEOF\n",
192         $string,
193         "indented here-doc with tabs and spaces",
194     ];
195
196     push @tests, [
197         "print <<~EOF;\n\t \tx EOF\n\t \t$string\n\t \tEOF\n",
198          "x EOF\n$string",
199         "Embedded delimiter ignored",
200     ];
201
202     push @tests, [
203         "print <<~EOF;\n\t \t$string\n\t \tTEOF",
204         "Can't find string terminator \"EOF\" anywhere before EOF at - line 1.",
205         "indented here-doc missing terminator error is correct"
206     ];
207
208     push @tests, [
209         "print <<~EOF;\n $string\n$string\n   $string\n $string\n   EOF",
210         "Indentation on line 1 of here-doc doesn't match delimiter at - line 1.\n",
211         "indented here-doc with bad indentation"
212     ];
213
214     push @tests, [
215         "print <<~EOF;\n   $string\n   $string\n$string\n $string\n   EOF",
216         "Indentation on line 3 of here-doc doesn't match delimiter at - line 1.\n",
217         "indented here-doc with bad indentation"
218     ];
219
220     # If our delim is " EOF ", make sure other spaced version don't match
221     push @tests, [
222         "print <<~' EOF ';\n $string\n EOF\nEOF \n  EOF  \n EOF \n",
223         " $string\n EOF\nEOF \n  EOF  \n",
224         "indented here-doc matches final delimiter correctly"
225     ];
226
227     for my $test (@tests) {
228         fresh_perl_is(
229             $test->[0],
230             $test->[1],
231             { switches => ['-w'], stderr => 1 },
232             $test->[2],
233         );
234     }
235 }