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
7print "1..35\n";
8my $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
18sub 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
33sub 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
45sub 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
55sub 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
65my $a;
66$a = eval '$b = 0/0 if 0; 3';
67is ($a, 3, 'constants in conditionals don\'t affect constant folding');
68is ($@, '', 'no error');
69
70my $b = 0;
71$a = eval 'if ($b) {return sqrt -3} 3';
72is ($a, 3, 'variables in conditionals don\'t affect constant folding');
73is ($@, '', '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};
81is ($a, 5, 'outer eval folds constant');
82is ($@, '', '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
123package 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
137print "not " unless stat(1 ? INSTALL : 0) eq stat("INSTALL");
138print "ok ", ++$test, " - stat(const ? word : ....)\n";
139# in case we are in t/
140print "not " unless stat(1 ? TEST : 0) eq stat("TEST");
141print "ok ", ++$test, " - stat(const ? word : ....)\n";
142
143# or truncate
144my $n = "for_fold_dot_t$$";
145open F, ">$n" or die "open: $!";
146print F "bralh blah blah \n";
147close F or die "close $!";
148eval "truncate 1 ? $n : 0, 0;";
149print "not " unless -z $n;
150print "ok ", ++$test, " - truncate(const ? word : ...)\n";
151unlink $n;
152
153# Constant folding should not change the mutability of returned values.
154for(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.
165eval { ${\"hello\n"}++ };
166print "not " unless $@ =~ "Modification of a read-only value attempted at";
167print "ok ", ++$test, " - qq with no vars is a constant\n";
168
169# [perl #119501]
170my @values;
171for (1,2) { for (\(1+3)) { push @values, $$_; $$_++ } }
172is "@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';
185is ($a, 3, "list constant folding doesn't signal compile-time error");
186is ($@, '', 'no error');
187
188$b = 0;
189$a = eval 'my @z; @z = 0..~0 if $b; 3';
190is ($a, 3, "list constant folding doesn't signal compile-time error");
191is ($@, '', 'no error');
192
193$a = eval 'local $SIG{__WARN__} = sub {}; join("", ":".."~", "z")';
194is ($a, ":z", "aborted list constant folding still executable");
195