Commit | Line | Data |
fe14fcc3 |
1 | #!./perl |
2 | |
a5727619 |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
5 | @INC = '../lib'; |
6 | } |
fe14fcc3 |
7 | |
a5727619 |
8 | require './test.pl'; |
2b573ace |
9 | plan(tests => 45); |
10 | |
11 | use Config; |
fe14fcc3 |
12 | |
13 | # compile time |
14 | |
a5727619 |
15 | is('-' x 5, '-----', 'compile time x'); |
2b573ace |
16 | is('-' x 3.1, '---', 'compile time 3.1'); |
17 | is('-' x 3.9, '---', 'compile time 3.9'); |
a5727619 |
18 | is('-' x 1, '-', ' x 1'); |
19 | is('-' x 0, '', ' x 0'); |
3b8c0df9 |
20 | is('-' x -1, '', ' x -1'); |
21 | is('-' x undef, '', ' x undef'); |
2b573ace |
22 | is('-' x "foo", '', ' x "foo"'); |
23 | is('-' x "3rd", '---', ' x "3rd"'); |
fe14fcc3 |
24 | |
a5727619 |
25 | is('ab' x 3, 'ababab', ' more than one char'); |
fe14fcc3 |
26 | |
27 | # run time |
28 | |
29 | $a = '-'; |
a5727619 |
30 | is($a x 5, '-----', 'run time x'); |
2b573ace |
31 | is($a x 3.1, '---', ' x 3.1'); |
32 | is($a x 3.9, '---', ' x 3.9'); |
a5727619 |
33 | is($a x 1, '-', ' x 1'); |
34 | is($a x 0, '', ' x 0'); |
3b8c0df9 |
35 | is($a x -3, '', ' x -3'); |
36 | is($a x undef, '', ' x undef'); |
2b573ace |
37 | is($a x "foo", '', ' x "foo"'); |
38 | is($a x "3rd", '---', ' x "3rd"'); |
fe14fcc3 |
39 | |
40 | $a = 'ab'; |
a5727619 |
41 | is($a x 3, 'ababab', ' more than one char'); |
3b8c0df9 |
42 | $a = 'ab'; |
43 | is($a x 0, '', ' more than one char'); |
44 | $a = 'ab'; |
45 | is($a x -12, '', ' more than one char'); |
fe14fcc3 |
46 | |
47 | $a = 'xyz'; |
48 | $a x= 2; |
a5727619 |
49 | is($a, 'xyzxyz', 'x=2'); |
fe14fcc3 |
50 | $a x= 1; |
a5727619 |
51 | is($a, 'xyzxyz', 'x=1'); |
fe14fcc3 |
52 | $a x= 0; |
a5727619 |
53 | is($a, '', 'x=0'); |
fe14fcc3 |
54 | |
55 | @x = (1,2,3); |
56 | |
a5727619 |
57 | is(join('', @x x 4), '3333', '@x x Y'); |
58 | is(join('', (@x) x 4), '123123123123', '(@x) x Y'); |
59 | is(join('', (@x,()) x 4), '123123123123', '(@x,()) x Y'); |
60 | is(join('', (@x,1) x 4), '1231123112311231', '(@x,1) x Y'); |
61 | is(join(':', () x 4), '', '() x Y'); |
62 | is(join(':', (9) x 4), '9:9:9:9', '(X) x Y'); |
63 | is(join(':', (9,9) x 4), '9:9:9:9:9:9:9:9', '(X,X) x Y'); |
64 | is(join('', (split(//,"123")) x 2), '123123', 'split and x'); |
5926133d |
65 | |
3b8c0df9 |
66 | is(join('', @x x -12), '', '@x x -12'); |
67 | is(join('', (@x) x -14), '', '(@x) x -14'); |
68 | |
a5727619 |
69 | |
70 | # This test is actually testing for Digital C compiler optimizer bug, |
13476c87 |
71 | # present in Dec C versions 5.* and 6.0 (used in Digital UNIX and VMS), |
72 | # found in December 1998. The bug was reported to Digital^WCompaq as |
73 | # DECC 2745 (21-Dec-1998) |
74 | # GEM_BUGS 7619 (23-Dec-1998) |
75 | # As of April 1999 the bug has been fixed in Tru64 UNIX 5.0 and is planned |
76 | # to be fixed also in 4.0G. |
5926133d |
77 | # |
13476c87 |
78 | # The bug was as follows: broken code was produced for util.c:repeatcpy() |
5926133d |
79 | # (a utility function for the 'x' operator) in the case *all* these |
80 | # four conditions held: |
81 | # |
82 | # (1) len == 1 |
83 | # (2) "from" had the 8th bit on in its single character |
84 | # (3) count > 7 (the 'x' count > 16) |
85 | # (4) the highest optimization level was used in compilation |
86 | # (which is the default when compiling Perl) |
87 | # |
88 | # The bug looked like this (. being the eight-bit character and ? being \xff): |
89 | # |
90 | # 16 ................ |
91 | # 17 .........???????. |
92 | # 18 .........???????.. |
93 | # 19 .........???????... |
94 | # 20 .........???????.... |
95 | # 21 .........???????..... |
96 | # 22 .........???????...... |
97 | # 23 .........???????....... |
98 | # 24 .........???????.??????? |
99 | # 25 .........???????.???????. |
100 | # |
5926133d |
101 | # The bug was triggered in the "if (len == 1)" branch. The fix |
102 | # was to introduce a new temporary variable. In diff -u format: |
103 | # |
104 | # register char *frombase = from; |
105 | # |
106 | # if (len == 1) { |
107 | #- todo = *from; |
108 | #+ register char c = *from; |
109 | # while (count-- > 0) |
110 | #- *to++ = todo; |
111 | #+ *to++ = c; |
112 | # return; |
113 | # } |
114 | # |
13476c87 |
115 | # The bug could also be (obscurely) avoided by changing "from" to |
116 | # be an unsigned char pointer. |
117 | # |
5926133d |
118 | # This obscure bug was not found by the then test suite but instead |
119 | # by Mark.Martinec@nsc.ijs.si while trying to install Digest-MD5-2.00. |
120 | # |
121 | # jhi@iki.fi |
122 | # |
a5727619 |
123 | is("\xdd" x 24, "\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd", 'Dec C bug'); |
124 | |
b80b6069 |
125 | |
126 | # When we use a list repeat in a scalar context, it behaves like |
127 | # a scalar repeat. Make sure that works properly, and doesn't leave |
128 | # extraneous values on the stack. |
129 | # -- robin@kitsite.com |
130 | |
131 | my ($x, $y) = scalar ((1,2)x2); |
a5727619 |
132 | is($x, "22", 'list repeat in scalar context'); |
133 | is($y, undef, ' no extra values on stack'); |
b80b6069 |
134 | |
135 | # Make sure the stack doesn't get truncated too much - the left |
136 | # operand of the eq binop needs to remain! |
a5727619 |
137 | is(77, scalar ((1,7)x2), 'stack truncation'); |
138 | |
139 | |
140 | # perlbug 20011113.110 works in 5.6.1, broken in 5.7.2 |
141 | { |
976c8a39 |
142 | my $x= [("foo") x 2]; |
143 | is( join('', @$x), 'foofoo', 'list repeat in anon array ref broken [ID 20011113.110]' ); |
a5727619 |
144 | } |
976c8a39 |
145 | |
146 | # [ID 20010809.028] x operator not copying elements in 'for' list? |
147 | { |
148 | local $TODO = "x operator not copying elements in 'for' list? [ID 20010809.028]"; |
149 | my $x = 'abcd'; |
150 | my $y = ''; |
151 | for (($x =~ /./g) x 2) { |
152 | $y .= chop; |
153 | } |
154 | is($y, 'abcdabcd'); |
155 | } |
156 | |
2b573ace |
157 | # Test the "malloc wrappage" guards introduced in Perl 5.8.4. |
158 | |
159 | # Note that the guards do not catch everything: for example |
160 | # "0"x0x7f...f is fine because it will attempt to allocate |
161 | # "only" 0x7f...f+1 bytes: no wrappage there. |
162 | |
163 | if ($Config{ptrsize} == 4) { |
164 | eval '@a=(0)x0x7fffffff'; |
165 | like($@, qr/Out of memory during list extend/, "list extend"); |
166 | |
167 | eval '@a=(0)x0x80000000'; |
168 | like($@, qr/Out of memory during list extend/, "list extend"); |
169 | |
170 | eval '$a="012"x0x7fffffff'; |
171 | like($@, qr/Out of memory during string extend/, "string extend"); |
172 | |
173 | eval '$a="012"x0x80000000'; |
174 | like($@, qr/Out of memory during string extend/, "string extend"); |
175 | } elsif ($Config{ptrsize} == 8) { |
176 | eval '@a=(0)x0x7fffffffffffffff'; |
177 | like($@, qr/Out of memory during list extend/, "list extend"); |
178 | |
179 | eval '@a=(0)x0x8000000000000000'; |
180 | like($@, qr/Out of memory during list extend/, "list extend"); |
181 | |
182 | eval '$a="012"x0x7fffffffffffffff'; |
183 | like($@, qr/Out of memory during string extend/, "string extend"); |
184 | |
185 | eval '$a="012"x0x8000000000000000'; |
186 | like($@, qr/Out of memory during string extend/, "string extend"); |
187 | } else { |
188 | die "\$Config{ptrsize} == $Config{ptrsize}?"; |
189 | } |
190 | |