1 | # tr.t |
---|
2 | |
---|
3 | BEGIN { |
---|
4 | chdir 't' if -d 't'; |
---|
5 | @INC = '../lib'; |
---|
6 | require './test.pl'; |
---|
7 | } |
---|
8 | |
---|
9 | plan tests => 99; |
---|
10 | |
---|
11 | my $Is_EBCDIC = (ord('i') == 0x89 & ord('J') == 0xd1); |
---|
12 | |
---|
13 | $_ = "abcdefghijklmnopqrstuvwxyz"; |
---|
14 | |
---|
15 | tr/a-z/A-Z/; |
---|
16 | |
---|
17 | is($_, "ABCDEFGHIJKLMNOPQRSTUVWXYZ", 'uc'); |
---|
18 | |
---|
19 | tr/A-Z/a-z/; |
---|
20 | |
---|
21 | is($_, "abcdefghijklmnopqrstuvwxyz", 'lc'); |
---|
22 | |
---|
23 | tr/b-y/B-Y/; |
---|
24 | is($_, "aBCDEFGHIJKLMNOPQRSTUVWXYz", 'partial uc'); |
---|
25 | |
---|
26 | |
---|
27 | # In EBCDIC 'I' is \xc9 and 'J' is \0xd1, 'i' is \x89 and 'j' is \x91. |
---|
28 | # Yes, discontinuities. Regardless, the \xca in the below should stay |
---|
29 | # untouched (and not became \x8a). |
---|
30 | { |
---|
31 | no utf8; |
---|
32 | $_ = "I\xcaJ"; |
---|
33 | |
---|
34 | tr/I-J/i-j/; |
---|
35 | |
---|
36 | is($_, "i\xcaj", 'EBCDIC discontinuity'); |
---|
37 | } |
---|
38 | # |
---|
39 | |
---|
40 | |
---|
41 | ($x = 12) =~ tr/1/3/; |
---|
42 | (my $y = 12) =~ tr/1/3/; |
---|
43 | ($f = 1.5) =~ tr/1/3/; |
---|
44 | (my $g = 1.5) =~ tr/1/3/; |
---|
45 | is($x + $y + $f + $g, 71, 'tr cancels IOK and NOK'); |
---|
46 | |
---|
47 | |
---|
48 | # perlbug [ID 20000511.005] |
---|
49 | $_ = 'fred'; |
---|
50 | /([a-z]{2})/; |
---|
51 | $1 =~ tr/A-Z//; |
---|
52 | s/^(\s*)f/$1F/; |
---|
53 | is($_, 'Fred', 'harmless if explicitly not updating'); |
---|
54 | |
---|
55 | |
---|
56 | # A variant of the above, added in 5.7.2 |
---|
57 | $_ = 'fred'; |
---|
58 | /([a-z]{2})/; |
---|
59 | eval '$1 =~ tr/A-Z/A-Z/;'; |
---|
60 | s/^(\s*)f/$1F/; |
---|
61 | is($_, 'Fred', 'harmless if implicitly not updating'); |
---|
62 | is($@, '', ' no error'); |
---|
63 | |
---|
64 | |
---|
65 | # check tr handles UTF8 correctly |
---|
66 | ($x = 256.65.258) =~ tr/a/b/; |
---|
67 | is($x, 256.65.258, 'handles UTF8'); |
---|
68 | is(length $x, 3); |
---|
69 | |
---|
70 | $x =~ tr/A/B/; |
---|
71 | is(length $x, 3); |
---|
72 | if (ord("\t") == 9) { # ASCII |
---|
73 | is($x, 256.66.258); |
---|
74 | } |
---|
75 | else { |
---|
76 | is($x, 256.65.258); |
---|
77 | } |
---|
78 | |
---|
79 | # EBCDIC variants of the above tests |
---|
80 | ($x = 256.193.258) =~ tr/a/b/; |
---|
81 | is(length $x, 3); |
---|
82 | is($x, 256.193.258); |
---|
83 | |
---|
84 | $x =~ tr/A/B/; |
---|
85 | is(length $x, 3); |
---|
86 | if (ord("\t") == 9) { # ASCII |
---|
87 | is($x, 256.193.258); |
---|
88 | } |
---|
89 | else { |
---|
90 | is($x, 256.194.258); |
---|
91 | } |
---|
92 | |
---|
93 | |
---|
94 | { |
---|
95 | my $l = chr(300); my $r = chr(400); |
---|
96 | $x = 200.300.400; |
---|
97 | $x =~ tr/\x{12c}/\x{190}/; |
---|
98 | is($x, 200.400.400, |
---|
99 | 'changing UTF8 chars in a UTF8 string, same length'); |
---|
100 | is(length $x, 3); |
---|
101 | |
---|
102 | $x = 200.300.400; |
---|
103 | $x =~ tr/\x{12c}/\x{be8}/; |
---|
104 | is($x, 200.3048.400, ' more bytes'); |
---|
105 | is(length $x, 3); |
---|
106 | |
---|
107 | $x = 100.125.60; |
---|
108 | $x =~ tr/\x{64}/\x{190}/; |
---|
109 | is($x, 400.125.60, 'Putting UT8 chars into a non-UTF8 string'); |
---|
110 | is(length $x, 3); |
---|
111 | |
---|
112 | $x = 400.125.60; |
---|
113 | $x =~ tr/\x{190}/\x{64}/; |
---|
114 | is($x, 100.125.60, 'Removing UTF8 chars from UTF8 string'); |
---|
115 | is(length $x, 3); |
---|
116 | |
---|
117 | $x = 400.125.60.400; |
---|
118 | $y = $x =~ tr/\x{190}/\x{190}/; |
---|
119 | is($y, 2, 'Counting UTF8 chars in UTF8 string'); |
---|
120 | |
---|
121 | $x = 60.400.125.60.400; |
---|
122 | $y = $x =~ tr/\x{3c}/\x{3c}/; |
---|
123 | is($y, 2, ' non-UTF8 chars in UTF8 string'); |
---|
124 | |
---|
125 | # 17 - counting UTF8 chars in non-UTF8 string |
---|
126 | $x = 200.125.60; |
---|
127 | $y = $x =~ tr/\x{190}/\x{190}/; |
---|
128 | is($y, 0, ' UTF8 chars in non-UTFs string'); |
---|
129 | } |
---|
130 | |
---|
131 | $_ = "abcdefghijklmnopqrstuvwxyz"; |
---|
132 | eval 'tr/a-z-9/ /'; |
---|
133 | like($@, qr/^Ambiguous range in transliteration operator/, 'tr/a-z-9//'); |
---|
134 | |
---|
135 | # 19-21: Make sure leading and trailing hyphens still work |
---|
136 | $_ = "car-rot9"; |
---|
137 | tr/-a-m/./; |
---|
138 | is($_, '..r.rot9', 'hyphens, leading'); |
---|
139 | |
---|
140 | $_ = "car-rot9"; |
---|
141 | tr/a-m-/./; |
---|
142 | is($_, '..r.rot9', ' trailing'); |
---|
143 | |
---|
144 | $_ = "car-rot9"; |
---|
145 | tr/-a-m-/./; |
---|
146 | is($_, '..r.rot9', ' both'); |
---|
147 | |
---|
148 | $_ = "abcdefghijklmnop"; |
---|
149 | tr/ae-hn/./; |
---|
150 | is($_, '.bcd....ijklm.op'); |
---|
151 | |
---|
152 | $_ = "abcdefghijklmnop"; |
---|
153 | tr/a-cf-kn-p/./; |
---|
154 | is($_, '...de......lm...'); |
---|
155 | |
---|
156 | $_ = "abcdefghijklmnop"; |
---|
157 | tr/a-ceg-ikm-o/./; |
---|
158 | is($_, '...d.f...j.l...p'); |
---|
159 | |
---|
160 | |
---|
161 | # 20000705 MJD |
---|
162 | eval "tr/m-d/ /"; |
---|
163 | like($@, qr/^Invalid range "m-d" in transliteration operator/, |
---|
164 | 'reversed range check'); |
---|
165 | |
---|
166 | eval '$1 =~ tr/x/y/'; |
---|
167 | like($@, qr/^Modification of a read-only value attempted/, |
---|
168 | 'cannot update read-only var'); |
---|
169 | |
---|
170 | 'abcdef' =~ /(bcd)/; |
---|
171 | is(eval '$1 =~ tr/abcd//', 3, 'explicit read-only count'); |
---|
172 | is($@, '', ' no error'); |
---|
173 | |
---|
174 | 'abcdef' =~ /(bcd)/; |
---|
175 | is(eval '$1 =~ tr/abcd/abcd/', 3, 'implicit read-only count'); |
---|
176 | is($@, '', ' no error'); |
---|
177 | |
---|
178 | is(eval '"123" =~ tr/12//', 2, 'LHS of non-updating tr'); |
---|
179 | |
---|
180 | eval '"123" =~ tr/1/2/'; |
---|
181 | like($@, qr|^Can't modify constant item in transliteration \(tr///\)|, |
---|
182 | 'LHS bad on updating tr'); |
---|
183 | |
---|
184 | |
---|
185 | # v300 (0x12c) is UTF-8-encoded as 196 172 (0xc4 0xac) |
---|
186 | # v400 (0x190) is UTF-8-encoded as 198 144 (0xc6 0x90) |
---|
187 | |
---|
188 | # Transliterate a byte to a byte, all four ways. |
---|
189 | |
---|
190 | ($a = v300.196.172.300.196.172) =~ tr/\xc4/\xc5/; |
---|
191 | is($a, v300.197.172.300.197.172, 'byte2byte transliteration'); |
---|
192 | |
---|
193 | ($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{c5}/; |
---|
194 | is($a, v300.197.172.300.197.172); |
---|
195 | |
---|
196 | ($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\xc5/; |
---|
197 | is($a, v300.197.172.300.197.172); |
---|
198 | |
---|
199 | ($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\x{c5}/; |
---|
200 | is($a, v300.197.172.300.197.172); |
---|
201 | |
---|
202 | |
---|
203 | ($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/; |
---|
204 | is($a, v300.301.172.300.301.172, 'byte2wide transliteration'); |
---|
205 | |
---|
206 | ($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc3/; |
---|
207 | is($a, v195.196.172.195.196.172, ' wide2byte'); |
---|
208 | |
---|
209 | ($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/; |
---|
210 | is($a, v301.196.172.301.196.172, ' wide2wide'); |
---|
211 | |
---|
212 | |
---|
213 | ($a = v300.196.172.300.196.172) =~ tr/\xc4\x{12c}/\x{12d}\xc3/; |
---|
214 | is($a, v195.301.172.195.301.172, 'byte2wide & wide2byte'); |
---|
215 | |
---|
216 | |
---|
217 | ($a = v300.196.172.300.196.172.400.198.144) =~ |
---|
218 | tr/\xac\xc4\x{12c}\x{190}/\xad\x{12d}\xc5\x{191}/; |
---|
219 | is($a, v197.301.173.197.301.173.401.198.144, 'all together now!'); |
---|
220 | |
---|
221 | |
---|
222 | is((($a = v300.196.172.300.196.172) =~ tr/\xc4/\xc5/), 2, |
---|
223 | 'transliterate and count'); |
---|
224 | |
---|
225 | is((($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/), 2); |
---|
226 | |
---|
227 | |
---|
228 | ($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/c; |
---|
229 | is($a, v301.196.301.301.196.301, 'translit w/complement'); |
---|
230 | |
---|
231 | ($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc5/c; |
---|
232 | is($a, v300.197.197.300.197.197); |
---|
233 | |
---|
234 | |
---|
235 | ($a = v300.196.172.300.196.172) =~ tr/\xc4//d; |
---|
236 | is($a, v300.172.300.172, 'translit w/deletion'); |
---|
237 | |
---|
238 | ($a = v300.196.172.300.196.172) =~ tr/\x{12c}//d; |
---|
239 | is($a, v196.172.196.172); |
---|
240 | |
---|
241 | |
---|
242 | ($a = v196.196.172.300.300.196.172) =~ tr/\xc4/\xc5/s; |
---|
243 | is($a, v197.172.300.300.197.172, 'translit w/squeeze'); |
---|
244 | |
---|
245 | ($a = v196.172.300.300.196.172.172) =~ tr/\x{12c}/\x{12d}/s; |
---|
246 | is($a, v196.172.301.196.172.172); |
---|
247 | |
---|
248 | |
---|
249 | # Tricky cases (When Simon Cozens Attacks) |
---|
250 | ($a = v196.172.200) =~ tr/\x{12c}/a/; |
---|
251 | is(sprintf("%vd", $a), '196.172.200'); |
---|
252 | |
---|
253 | ($a = v196.172.200) =~ tr/\x{12c}/\x{12c}/; |
---|
254 | is(sprintf("%vd", $a), '196.172.200'); |
---|
255 | |
---|
256 | ($a = v196.172.200) =~ tr/\x{12c}//d; |
---|
257 | is(sprintf("%vd", $a), '196.172.200'); |
---|
258 | |
---|
259 | |
---|
260 | # UTF8 range tests from Inaba Hiroto |
---|
261 | |
---|
262 | # Not working in EBCDIC as of 12674. |
---|
263 | ($a = v300.196.172.302.197.172) =~ tr/\x{12c}-\x{130}/\xc0-\xc4/; |
---|
264 | is($a, v192.196.172.194.197.172, 'UTF range'); |
---|
265 | |
---|
266 | ($a = v300.196.172.302.197.172) =~ tr/\xc4-\xc8/\x{12c}-\x{130}/; |
---|
267 | is($a, v300.300.172.302.301.172); |
---|
268 | |
---|
269 | |
---|
270 | # UTF8 range tests from Karsten Sperling (patch #9008 required) |
---|
271 | |
---|
272 | ($a = "\x{0100}") =~ tr/\x00-\x{100}/X/; |
---|
273 | is($a, "X"); |
---|
274 | |
---|
275 | ($a = "\x{0100}") =~ tr/\x{0000}-\x{00ff}/X/c; |
---|
276 | is($a, "X"); |
---|
277 | |
---|
278 | ($a = "\x{0100}") =~ tr/\x{0000}-\x{00ff}\x{0101}/X/c; |
---|
279 | is($a, "X"); |
---|
280 | |
---|
281 | ($a = v256) =~ tr/\x{0000}-\x{00ff}\x{0101}/X/c; |
---|
282 | is($a, "X"); |
---|
283 | |
---|
284 | |
---|
285 | # UTF8 range tests from Inaba Hiroto |
---|
286 | |
---|
287 | ($a = "\x{200}") =~ tr/\x00-\x{100}/X/c; |
---|
288 | is($a, "X"); |
---|
289 | |
---|
290 | ($a = "\x{200}") =~ tr/\x00-\x{100}/X/cs; |
---|
291 | is($a, "X"); |
---|
292 | |
---|
293 | |
---|
294 | # Tricky on EBCDIC: while [a-z] [A-Z] must not match the gap characters, |
---|
295 | # (i-j, r-s, I-J, R-S), [\x89-\x91] [\xc9-\xd1] has to match them, |
---|
296 | # from Karsten Sperling. |
---|
297 | |
---|
298 | # Not working in EBCDIC as of 12674. |
---|
299 | $c = ($a = "\x89\x8a\x8b\x8c\x8d\x8f\x90\x91") =~ tr/\x89-\x91/X/; |
---|
300 | is($c, 8); |
---|
301 | is($a, "XXXXXXXX"); |
---|
302 | |
---|
303 | # Not working in EBCDIC as of 12674. |
---|
304 | $c = ($a = "\xc9\xca\xcb\xcc\xcd\xcf\xd0\xd1") =~ tr/\xc9-\xd1/X/; |
---|
305 | is($c, 8); |
---|
306 | is($a, "XXXXXXXX"); |
---|
307 | |
---|
308 | |
---|
309 | SKIP: { |
---|
310 | skip "not EBCDIC", 4 unless $Is_EBCDIC; |
---|
311 | |
---|
312 | $c = ($a = "\x89\x8a\x8b\x8c\x8d\x8f\x90\x91") =~ tr/i-j/X/; |
---|
313 | is($c, 2); |
---|
314 | is($a, "X\x8a\x8b\x8c\x8d\x8f\x90X"); |
---|
315 | |
---|
316 | $c = ($a = "\xc9\xca\xcb\xcc\xcd\xcf\xd0\xd1") =~ tr/I-J/X/; |
---|
317 | is($c, 2); |
---|
318 | is($a, "X\xca\xcb\xcc\xcd\xcf\xd0X"); |
---|
319 | } |
---|
320 | |
---|
321 | ($a = "\x{100}") =~ tr/\x00-\xff/X/c; |
---|
322 | is(ord($a), ord("X")); |
---|
323 | |
---|
324 | ($a = "\x{100}") =~ tr/\x00-\xff/X/cs; |
---|
325 | is(ord($a), ord("X")); |
---|
326 | |
---|
327 | ($a = "\x{100}\x{100}") =~ tr/\x{101}-\x{200}//c; |
---|
328 | is($a, "\x{100}\x{100}"); |
---|
329 | |
---|
330 | ($a = "\x{100}\x{100}") =~ tr/\x{101}-\x{200}//cs; |
---|
331 | is($a, "\x{100}"); |
---|
332 | |
---|
333 | $a = "\xfe\xff"; $a =~ tr/\xfe\xff/\x{1ff}\x{1fe}/; |
---|
334 | is($a, "\x{1ff}\x{1fe}"); |
---|
335 | |
---|
336 | |
---|
337 | # From David Dyck |
---|
338 | ($a = "R0_001") =~ tr/R_//d; |
---|
339 | is(hex($a), 1); |
---|
340 | |
---|
341 | # From Inaba Hiroto |
---|
342 | @a = (1,2); map { y/1/./ for $_ } @a; |
---|
343 | is("@a", ". 2"); |
---|
344 | |
---|
345 | @a = (1,2); map { y/1/./ for $_.'' } @a; |
---|
346 | is("@a", "1 2"); |
---|
347 | |
---|
348 | |
---|
349 | # Additional test for Inaba Hiroto patch (robin@kitsite.com) |
---|
350 | ($a = "\x{100}\x{102}\x{101}") =~ tr/\x00-\377/XYZ/c; |
---|
351 | is($a, "XZY"); |
---|
352 | |
---|
353 | |
---|
354 | # Used to fail with "Modification of a read-only value attempted" |
---|
355 | %a = (N=>1); |
---|
356 | foreach (keys %a) { |
---|
357 | eval 'tr/N/n/'; |
---|
358 | is($_, 'n', 'pp_trans needs to unshare shared hash keys'); |
---|
359 | is($@, '', ' no error'); |
---|
360 | } |
---|
361 | |
---|
362 | |
---|
363 | $x = eval '"1213" =~ tr/1/1/'; |
---|
364 | is($x, 2, 'implicit count on constant'); |
---|
365 | is($@, '', ' no error'); |
---|
366 | |
---|
367 | |
---|
368 | my @foo = (); |
---|
369 | eval '$foo[-1] =~ tr/N/N/'; |
---|
370 | is( $@, '', 'implicit count outside array bounds, index negative' ); |
---|
371 | is( scalar @foo, 0, " doesn't extend the array"); |
---|
372 | |
---|
373 | eval '$foo[1] =~ tr/N/N/'; |
---|
374 | is( $@, '', 'implicit count outside array bounds, index positive' ); |
---|
375 | is( scalar @foo, 0, " doesn't extend the array"); |
---|
376 | |
---|
377 | |
---|
378 | my %foo = (); |
---|
379 | eval '$foo{bar} =~ tr/N/N/'; |
---|
380 | is( $@, '', 'implicit count outside hash bounds' ); |
---|
381 | is( scalar keys %foo, 0, " doesn't extend the hash"); |
---|
382 | |
---|
383 | $x = \"foo"; |
---|
384 | is( $x =~ tr/A/A/, 2, 'non-modifying tr/// on a scalar ref' ); |
---|
385 | is( ref $x, 'SCALAR', " doesn't stringify its argument" ); |
---|