t/op/yadayada.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     require './test.pl';
   7 }
   8
   9 use strict;
  10
  11 plan 9;
  12
  13 my $err;
  14 my $err1 = "Unimplemented at $0 line ";
  15 my $err2 = ".\n";
  16
  17 $err = $err1 . ( __LINE__ + 1 ) . $err2;
  18 eval { ... };
  19 is $@, $err, "Execution of ellipsis statement reported 'Unimplemented' code";
  20 $@ = '';
  21
  22 note("RT #122661: Semicolon before ellipsis statement disambiguates to indicate block rather than hash reference");
  23 my @input = (3..5);
  24 my @transformed;
  25 $err = $err1 . ( __LINE__ + 1 ) . $err2;
  26 eval { @transformed = map {; ... } @input; };
  27 is $@, $err, "Disambiguation case 1";
  28 $@ = '';
  29
  30 $err = $err1 . ( __LINE__ + 1 ) . $err2;
  31 eval { @transformed = map {;...} @input; };
  32 is $@, $err, "Disambiguation case 2";
  33 $@ = '';
  34
  35 $err = $err1 . ( __LINE__ + 1 ) . $err2;
  36 eval { @transformed = map {; ...} @input; };
  37 is $@, $err, "Disambiguation case 3";
  38 $@ = '';
  39
  40 $err = $err1 . ( __LINE__ + 1 ) . $err2;
  41 eval { @transformed = map {;... } @input; };
  42 is $@, $err, "Disambiguation case 4";
  43 $@ = '';
  44
  45 #
  46 # Regression tests, making sure ... is still parsable as an operator.
  47 #
  48 my @lines = split /\n/ => <<'--';
  49
  50 # Check simple range operator.
  51 my @arr = 'A' ... 'D';
  52
  53 # Range operator with print.
  54 print 'D' ... 'A';
  55
  56 # Without quotes, 'D' could be a file handle.
  57 print  D  ...  A ;
  58
  59 # Another possible interaction with a file handle.
  60 print ${\"D"}  ...  A ;
  61 --
  62
  63 foreach my $line (@lines) {
  64     next if $line =~ /^\s*#/ || $line !~ /\S/;
  65     my $mess = qq {Parsing '...' in "$line" as a range operator};
  66     eval qq {
  67        {local *STDOUT; no strict "subs"; $line;}
  68         pass \$mess;
  69         1;
  70     } or do {
  71         my $err = $@;
  72         $err =~ s/\n//g;
  73         fail "$mess ($err)";
  74     }
  75 }