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