t/comp/fold.t

   1 #!./perl -w
   2
   3 # Uncomment this for testing, but don't leave it in for "production", as
   4 # we've not yet verified that use works.
   5 # use strict;
   6
   7 print "1..30\n";
   8 my $test = 0;
   9
  10 # Historically constant folding was performed by evaluating the ops, and if
  11 # they threw an exception compilation failed. This was seen as buggy, because
  12 # even illegal constants in unreachable code would cause failure. So now
  13 # illegal expressions are reported at runtime, if the expression is reached,
  14 # making constant folding consistent with many other languages, and purely an
  15 # optimisation rather than a behaviour change.
  16
  17
  18 sub failed {
  19     my ($got, $expected, $name) = @_;
  20
  21     print "not ok $test - $name\n";
  22     my @caller = caller(1);
  23     print "# Failed test at $caller[1] line $caller[2]\n";
  24     if (defined $got) {
  25         print "# Got '$got'\n";
  26     } else {
  27         print "# Got undef\n";
  28     }
  29     print "# Expected $expected\n";
  30     return;
  31 }
  32
  33 sub like {
  34     my ($got, $pattern, $name) = @_;
  35     $test = $test + 1;
  36     if (defined $got && $got =~ $pattern) {
  37         print "ok $test - $name\n";
  38         # Principle of least surprise - maintain the expected interface, even
  39         # though we aren't using it here (yet).
  40         return 1;
  41     }
  42     failed($got, $pattern, $name);
  43 }
  44
  45 sub is {
  46     my ($got, $expect, $name) = @_;
  47     $test = $test + 1;
  48     if (defined $got && $got eq $expect) {
  49         print "ok $test - $name\n";
  50         return 1;
  51     }
  52     failed($got, "'$expect'", $name);
  53 }
  54
  55 sub ok {
  56     my ($got, $name) = @_;
  57     $test = $test + 1;
  58     if ($got) {
  59         print "ok $test - $name\n";
  60         return 1;
  61     }
  62     failed($got, "a true value", $name);
  63 }
  64
  65 my $a;
  66 $a = eval '$b = 0/0 if 0; 3';
  67 is ($a, 3, 'constants in conditionals don\'t affect constant folding');
  68 is ($@, '', 'no error');
  69
  70 my $b = 0;
  71 $a = eval 'if ($b) {return sqrt -3} 3';
  72 is ($a, 3, 'variables in conditionals don\'t affect constant folding');
  73 is ($@, '', 'no error');
  74
  75 $a = eval q{
  76         $b = eval q{if ($b) {return log 0} 4};
  77         is ($b, 4, 'inner eval folds constant');
  78         is ($@, '', 'no error');
  79         5;
  80 };
  81 is ($a, 5, 'outer eval folds constant');
  82 is ($@, '', 'no error');
  83
  84 # warn and die hooks should be disabled during constant folding
  85
  86 {
  87     my $c = 0;
  88     local $SIG{__WARN__} = sub { $c++   };
  89     local $SIG{__DIE__}  = sub { $c+= 2 };
  90     eval q{
  91         is($c, 0, "premature warn/die: $c");
  92         my $x = "a"+5;
  93         is($c, 1, "missing warn hook");
  94         is($x, 5, "a+5");
  95         $c = 0;
  96         $x = 1/0;
  97     };
  98     like ($@, qr/division/, "eval caught division");
  99     is($c, 2, "missing die hook");
 100 }
 101
 102 # [perl #20444] Constant folding should not change the meaning of match
 103 # operators.
 104 {
 105  local *_;
 106  $_="foo"; my $jing = 1;
 107  ok scalar $jing =~ (1 ? /foo/ : /bar/),
 108    'lone m// is not bound via =~ after ? : folding';
 109  ok scalar $jing =~ (0 || /foo/),
 110    'lone m// is not bound via =~ after || folding';
 111  ok scalar $jing =~ (1 ? s/foo/foo/ : /bar/),
 112    'lone s/// is not bound via =~ after ? : folding';
 113  ok scalar $jing =~ (0 || s/foo/foo/),
 114    'lone s/// is not bound via =~ after || folding';
 115  $jing = 3;
 116  ok scalar $jing =~ (1 ? y/fo// : /bar/),
 117    'lone y/// is not bound via =~ after ? : folding';
 118  ok scalar $jing =~ (0 || y/fo//),
 119    'lone y/// is not bound via =~ after || folding';
 120 }
 121
 122 # [perl #78064] or print
 123 package other { # hide the "ok" sub
 124  BEGIN { $^W = 0 }
 125  print 0 ? not_ok : ok;
 126  print " ", ++$test, " - print followed by const ? BEAR : BEAR\n";
 127  print 1 ? ok : not_ok;
 128  print " ", ++$test, " - print followed by const ? BEAR : BEAR (again)\n";
 129  print 1 && ok;
 130  print " ", ++$test, " - print followed by const && BEAR\n";
 131  print 0 || ok;
 132  print " ", ++$test, " - print followed by const || URSINE\n";
 133  BEGIN { $^W = 1 }
 134 }
 135
 136 # or stat
 137 print "not " unless stat(1 ? INSTALL : 0) eq stat("INSTALL");
 138 print "ok ", ++$test, " - stat(const ? word : ....)\n";
 139 # in case we are in t/
 140 print "not " unless stat(1 ? TEST : 0) eq stat("TEST");
 141 print "ok ", ++$test, " - stat(const ? word : ....)\n";
 142
 143 # or truncate
 144 my $n = "for_fold_dot_t$$";
 145 open F, ">$n" or die "open: $!";
 146 print F "bralh blah blah \n";
 147 close F or die "close $!";
 148 eval "truncate 1 ? $n : 0, 0;";
 149 print "not " unless -z $n;
 150 print "ok ", ++$test, " - truncate(const ? word : ...)\n";
 151 unlink $n;
 152
 153 # Constant folding should not change the mutability of returned values.
 154 for(1+2) {
 155     eval { $_++ };
 156     print "not " unless $_ eq 4;
 157     print "ok ", ++$test,
 158           " - 1+2 returns mutable value, just like \$a+\$b",
 159           "\n";
 160 }
 161
 162 # [perl #119055]
 163 # We hide the implementation detail that qq "foo" is implemented using
 164 # constant folding.
 165 eval { ${\"hello\n"}++ };
 166 print "not " unless $@ =~ "Modification of a read-only value attempted at";
 167 print "ok ", ++$test, " - qq with no vars is a constant\n";
 168
 169 # [perl #119501]
 170 my @values;
 171 for (1,2) { for (\(1+3)) { push @values, $$_; $$_++ } }
 172 is "@values", "4 4",
 173    '\1+3 folding making modification affect future retvals';
 174
 175 {
 176     BEGIN { $^W = 0; $::{u} = \undef }
 177     my $w;
 178     local $SIG{__WARN__} = sub { ++$w };
 179     () = 1 + u;
 180     is $w, 1, '1+undef_constant is not folded outside warninsg scope';
 181     BEGIN { $^W = 1 }
 182 }