Commit | Line | Data |
---|---|---|
2eaa2210 NC |
1 | #!./perl -w |
2 | ||
2eaa2210 NC |
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; | |
a5871da3 | 6 | |
06b58b76 | 7 | print "1..26\n"; |
76c3cfbe | 8 | my $test = 0; |
a5871da3 NC |
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 | ||
5f2d9966 | 17 | |
76c3cfbe NC |
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 | ||
2474a784 FC |
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 | ||
a5871da3 NC |
65 | my $a; |
66 | $a = eval '$b = 0/0 if 0; 3'; | |
a6d95d3b NC |
67 | is ($a, 3, 'constants in conditionals don\'t affect constant folding'); |
68 | is ($@, '', 'no error'); | |
a5871da3 NC |
69 | |
70 | my $b = 0; | |
71 | $a = eval 'if ($b) {return sqrt -3} 3'; | |
a6d95d3b NC |
72 | is ($a, 3, 'variables in conditionals don\'t affect constant folding'); |
73 | is ($@, '', 'no error'); | |
a5871da3 NC |
74 | |
75 | $a = eval q{ | |
76 | $b = eval q{if ($b) {return log 0} 4}; | |
a6d95d3b NC |
77 | is ($b, 4, 'inner eval folds constant'); |
78 | is ($@, '', 'no error'); | |
a5871da3 NC |
79 | 5; |
80 | }; | |
a6d95d3b NC |
81 | is ($a, 5, 'outer eval folds constant'); |
82 | is ($@, '', 'no error'); | |
a5871da3 | 83 | |
5f2d9966 DM |
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 | } | |
2474a784 FC |
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 | } | |
01050d49 FC |
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 | } | |
9a0c9949 FC |
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"; | |
06b58b76 FC |
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; |