PATCH: [perl #134133] read beyond end of buffer
[perl.git] / 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..35\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 }
183
184 $a = eval 'my @z; @z = 0..~0 if 0; 3';
185 is ($a, 3, "list constant folding doesn't signal compile-time error");
186 is ($@, '', 'no error');
187
188 $b = 0;
189 $a = eval 'my @z; @z = 0..~0 if $b; 3';
190 is ($a, 3, "list constant folding doesn't signal compile-time error");
191 is ($@, '', 'no error');
192
193 $a = eval 'local $SIG{__WARN__} = sub {}; join("", ":".."~", "z")';
194 is ($a, ":z", "aborted list constant folding still executable");