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 }