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    @INC = '../lib';
   6    require './test.pl';
   7 }
   8
   9 use strict;
  10 plan(tests => 39);
  11
  12
  13 # heredoc without newline (#65838)
  14 {
  15     my $string = <<'HEREDOC';
  16 testing for 65838
  17 HEREDOC
  18
  19     my $code = "<<'HEREDOC';\n${string}HEREDOC";  # HD w/o newline, in eval-string
  20     my $hd = eval $code or warn "$@ ---";
  21     is($hd, $string, "no terminating newline in string-eval");
  22 }
  23
  24
  25 # here-doc edge cases
  26 {
  27     my $string = "testing for 65838";
  28
  29     fresh_perl_is(
  30         "print <<'HEREDOC';\n${string}\nHEREDOC",
  31         $string,
  32         {},
  33         "heredoc at EOF without trailing newline"
  34     );
  35
  36     fresh_perl_is(
  37         "print <<;\n$string\n",
  38         $string,
  39         { switches => ['-X'] },
  40         "blank-terminated heredoc at EOF"
  41     );
  42     fresh_perl_is(
  43         "print <<\n$string\n",
  44         $string,
  45         { switches => ['-X'] },
  46         "blank-terminated heredoc at EOF and no semicolon"
  47     );
  48     fresh_perl_is(
  49         "print <<foo\r\nick and queasy\r\nfoo\r\n",
  50         'ick and queasy',
  51         { switches => ['-X'] },
  52         "crlf-terminated heredoc"
  53     );
  54     fresh_perl_is(
  55         "print qq|\${\\<<foo}|\nick and queasy\nfoo\n",
  56         'ick and queasy',
  57         { switches => ['-w'], stderr => 1 },
  58         'no warning for qq|${\<<foo}| in file'
  59     );
  60 }
  61
  62
  63 # here-doc parse failures
  64 {
  65     fresh_perl_like(
  66         "print <<HEREDOC;\nwibble\n HEREDOC",
  67         qr/find string terminator/,
  68         {},
  69         "string terminator must start at newline"
  70     );
  71
  72     # Loop over various lengths to try to force at least one to cause a
  73     # reallocation in S_scan_heredoc()
  74     # Timing on a modern machine suggests that this loop executes in less than
  75     # 0.1s, so it's a very small cost for the default build. The benefit is
  76     # that building with ASAN will reveal the bug and any related regressions.
  77     for (1..31) {
  78         fresh_perl_like(
  79             "print <<;\n" . "x" x $_,
  80             qr/find string terminator/,
  81             { switches => ['-X'] },
  82             "empty string terminator still needs a newline (length $_)"
  83         );
  84     }
  85
  86     fresh_perl_like(
  87         "print <<ThisTerminatorIsLongerThanTheData;\nno more newlines",
  88         qr/find string terminator/,
  89         {},
  90         "long terminator fails correctly"
  91     );
  92 }