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