Commit | Line | Data |
---|---|---|
c8e3bb4c GS |
1 | # tr.t |
2 | ||
cb6d3474 KW |
3 | use utf8; |
4 | ||
f05dd7cc JH |
5 | BEGIN { |
6 | chdir 't' if -d 't'; | |
953ab6e5 | 7 | require './test.pl'; |
e265c5e6 FC |
8 | @INC = () unless is_miniperl(); |
9 | unshift @INC, '../lib'; | |
f05dd7cc | 10 | } |
a5095b95 | 11 | |
d8b516a1 | 12 | plan tests => 134; |
953ab6e5 MS |
13 | |
14 | my $Is_EBCDIC = (ord('i') == 0x89 & ord('J') == 0xd1); | |
c8e3bb4c GS |
15 | |
16 | $_ = "abcdefghijklmnopqrstuvwxyz"; | |
17 | ||
18 | tr/a-z/A-Z/; | |
19 | ||
953ab6e5 | 20 | is($_, "ABCDEFGHIJKLMNOPQRSTUVWXYZ", 'uc'); |
c8e3bb4c GS |
21 | |
22 | tr/A-Z/a-z/; | |
23 | ||
953ab6e5 | 24 | is($_, "abcdefghijklmnopqrstuvwxyz", 'lc'); |
c8e3bb4c GS |
25 | |
26 | tr/b-y/B-Y/; | |
953ab6e5 | 27 | is($_, "aBCDEFGHIJKLMNOPQRSTUVWXYz", 'partial uc'); |
c8e3bb4c | 28 | |
c8e3bb4c GS |
29 | |
30 | # In EBCDIC 'I' is \xc9 and 'J' is \0xd1, 'i' is \x89 and 'j' is \x91. | |
31 | # Yes, discontinuities. Regardless, the \xca in the below should stay | |
32 | # untouched (and not became \x8a). | |
5e037136 GS |
33 | { |
34 | no utf8; | |
35 | $_ = "I\xcaJ"; | |
c8e3bb4c | 36 | |
5e037136 | 37 | tr/I-J/i-j/; |
c8e3bb4c | 38 | |
ff36f15d | 39 | is($_, "i\xcaj", 'EBCDIC discontinuity'); |
5e037136 | 40 | } |
c8e3bb4c | 41 | # |
2de7b02f | 42 | |
953ab6e5 | 43 | |
2de7b02f GS |
44 | ($x = 12) =~ tr/1/3/; |
45 | (my $y = 12) =~ tr/1/3/; | |
46 | ($f = 1.5) =~ tr/1/3/; | |
47 | (my $g = 1.5) =~ tr/1/3/; | |
953ab6e5 MS |
48 | is($x + $y + $f + $g, 71, 'tr cancels IOK and NOK'); |
49 | ||
bb16bae8 FC |
50 | # /r |
51 | $_ = 'adam'; | |
52 | is y/dam/ve/rd, 'eve', '/r'; | |
53 | is $_, 'adam', '/r leaves param alone'; | |
54 | $g = 'ruby'; | |
55 | is $g =~ y/bury/repl/r, 'perl', '/r with explicit param'; | |
56 | is $g, 'ruby', '/r leaves explicit param alone'; | |
57 | is "aaa" =~ y\a\b\r, 'bbb', '/r with constant param'; | |
58 | ok !eval '$_ !~ y///r', "!~ y///r is forbidden"; | |
59 | like $@, qr\^Using !~ with tr///r doesn't make sense\, | |
60 | "!~ y///r error message"; | |
61 | { | |
62 | my $w; | |
63 | my $wc; | |
64 | local $SIG{__WARN__} = sub { $w = shift; ++$wc }; | |
65 | local $^W = 1; | |
66 | eval 'y///r; 1'; | |
67 | like $w, qr '^Useless use of non-destructive transliteration \(tr///r\)', | |
68 | '/r warns in void context'; | |
69 | is $wc, 1, '/r warns just once'; | |
70 | } | |
2de7b02f | 71 | |
953ab6e5 | 72 | # perlbug [ID 20000511.005] |
2de7b02f GS |
73 | $_ = 'fred'; |
74 | /([a-z]{2})/; | |
75 | $1 =~ tr/A-Z//; | |
76 | s/^(\s*)f/$1F/; | |
953ab6e5 MS |
77 | is($_, 'Fred', 'harmless if explicitly not updating'); |
78 | ||
79 | ||
80 | # A variant of the above, added in 5.7.2 | |
81 | $_ = 'fred'; | |
82 | /([a-z]{2})/; | |
83 | eval '$1 =~ tr/A-Z/A-Z/;'; | |
84 | s/^(\s*)f/$1F/; | |
85 | is($_, 'Fred', 'harmless if implicitly not updating'); | |
86 | is($@, '', ' no error'); | |
87 | ||
2de7b02f GS |
88 | |
89 | # check tr handles UTF8 correctly | |
90 | ($x = 256.65.258) =~ tr/a/b/; | |
953ab6e5 MS |
91 | is($x, 256.65.258, 'handles UTF8'); |
92 | is(length $x, 3); | |
93 | ||
2de7b02f | 94 | $x =~ tr/A/B/; |
953ab6e5 | 95 | is(length $x, 3); |
67a17885 | 96 | if (ord("\t") == 9) { # ASCII |
953ab6e5 | 97 | is($x, 256.66.258); |
67a17885 PP |
98 | } |
99 | else { | |
953ab6e5 | 100 | is($x, 256.65.258); |
67a17885 | 101 | } |
953ab6e5 | 102 | |
cbe7f703 PP |
103 | # EBCDIC variants of the above tests |
104 | ($x = 256.193.258) =~ tr/a/b/; | |
953ab6e5 MS |
105 | is(length $x, 3); |
106 | is($x, 256.193.258); | |
107 | ||
cbe7f703 | 108 | $x =~ tr/A/B/; |
953ab6e5 | 109 | is(length $x, 3); |
cbe7f703 | 110 | if (ord("\t") == 9) { # ASCII |
953ab6e5 | 111 | is($x, 256.193.258); |
cbe7f703 PP |
112 | } |
113 | else { | |
953ab6e5 | 114 | is($x, 256.194.258); |
cbe7f703 | 115 | } |
953ab6e5 | 116 | |
036b4402 GS |
117 | |
118 | { | |
953ab6e5 MS |
119 | my $l = chr(300); my $r = chr(400); |
120 | $x = 200.300.400; | |
121 | $x =~ tr/\x{12c}/\x{190}/; | |
122 | is($x, 200.400.400, | |
123 | 'changing UTF8 chars in a UTF8 string, same length'); | |
124 | is(length $x, 3); | |
125 | ||
126 | $x = 200.300.400; | |
127 | $x =~ tr/\x{12c}/\x{be8}/; | |
128 | is($x, 200.3048.400, ' more bytes'); | |
129 | is(length $x, 3); | |
130 | ||
131 | $x = 100.125.60; | |
132 | $x =~ tr/\x{64}/\x{190}/; | |
133 | is($x, 400.125.60, 'Putting UT8 chars into a non-UTF8 string'); | |
134 | is(length $x, 3); | |
135 | ||
136 | $x = 400.125.60; | |
137 | $x =~ tr/\x{190}/\x{64}/; | |
138 | is($x, 100.125.60, 'Removing UTF8 chars from UTF8 string'); | |
139 | is(length $x, 3); | |
140 | ||
141 | $x = 400.125.60.400; | |
142 | $y = $x =~ tr/\x{190}/\x{190}/; | |
143 | is($y, 2, 'Counting UTF8 chars in UTF8 string'); | |
144 | ||
145 | $x = 60.400.125.60.400; | |
146 | $y = $x =~ tr/\x{3c}/\x{3c}/; | |
147 | is($y, 2, ' non-UTF8 chars in UTF8 string'); | |
148 | ||
149 | # 17 - counting UTF8 chars in non-UTF8 string | |
150 | $x = 200.125.60; | |
151 | $y = $x =~ tr/\x{190}/\x{190}/; | |
152 | is($y, 0, ' UTF8 chars in non-UTFs string'); | |
036b4402 | 153 | } |
c2e66d9e | 154 | |
c2e66d9e | 155 | $_ = "abcdefghijklmnopqrstuvwxyz"; |
953ab6e5 MS |
156 | eval 'tr/a-z-9/ /'; |
157 | like($@, qr/^Ambiguous range in transliteration operator/, 'tr/a-z-9//'); | |
c2e66d9e | 158 | |
cbe7f703 | 159 | # 19-21: Make sure leading and trailing hyphens still work |
c2e66d9e GS |
160 | $_ = "car-rot9"; |
161 | tr/-a-m/./; | |
953ab6e5 | 162 | is($_, '..r.rot9', 'hyphens, leading'); |
c2e66d9e GS |
163 | |
164 | $_ = "car-rot9"; | |
165 | tr/a-m-/./; | |
953ab6e5 | 166 | is($_, '..r.rot9', ' trailing'); |
c2e66d9e GS |
167 | |
168 | $_ = "car-rot9"; | |
169 | tr/-a-m-/./; | |
953ab6e5 | 170 | is($_, '..r.rot9', ' both'); |
c2e66d9e GS |
171 | |
172 | $_ = "abcdefghijklmnop"; | |
173 | tr/ae-hn/./; | |
953ab6e5 | 174 | is($_, '.bcd....ijklm.op'); |
c2e66d9e GS |
175 | |
176 | $_ = "abcdefghijklmnop"; | |
177 | tr/a-cf-kn-p/./; | |
953ab6e5 | 178 | is($_, '...de......lm...'); |
c2e66d9e GS |
179 | |
180 | $_ = "abcdefghijklmnop"; | |
181 | tr/a-ceg-ikm-o/./; | |
953ab6e5 MS |
182 | is($_, '...d.f...j.l...p'); |
183 | ||
c2e66d9e | 184 | |
c2e66d9e GS |
185 | # 20000705 MJD |
186 | eval "tr/m-d/ /"; | |
321ecc04 | 187 | like($@, qr/^Invalid range "m-d" in transliteration operator/, |
953ab6e5 | 188 | 'reversed range check'); |
c2e66d9e | 189 | |
d897a58d | 190 | 'abcdef' =~ /(bcd)/; |
953ab6e5 MS |
191 | is(eval '$1 =~ tr/abcd//', 3, 'explicit read-only count'); |
192 | is($@, '', ' no error'); | |
d897a58d | 193 | |
953ab6e5 MS |
194 | 'abcdef' =~ /(bcd)/; |
195 | is(eval '$1 =~ tr/abcd/abcd/', 3, 'implicit read-only count'); | |
196 | is($@, '', ' no error'); | |
197 | ||
198 | is(eval '"123" =~ tr/12//', 2, 'LHS of non-updating tr'); | |
d897a58d | 199 | |
94bfe852 | 200 | eval '"123" =~ tr/1/2/'; |
953ab6e5 MS |
201 | like($@, qr|^Can't modify constant item in transliteration \(tr///\)|, |
202 | 'LHS bad on updating tr'); | |
203 | ||
d897a58d | 204 | |
381d18bc JH |
205 | # v300 (0x12c) is UTF-8-encoded as 196 172 (0xc4 0xac) |
206 | # v400 (0x190) is UTF-8-encoded as 198 144 (0xc6 0x90) | |
207 | ||
208 | # Transliterate a byte to a byte, all four ways. | |
209 | ||
210 | ($a = v300.196.172.300.196.172) =~ tr/\xc4/\xc5/; | |
953ab6e5 | 211 | is($a, v300.197.172.300.197.172, 'byte2byte transliteration'); |
381d18bc JH |
212 | |
213 | ($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{c5}/; | |
953ab6e5 | 214 | is($a, v300.197.172.300.197.172); |
381d18bc JH |
215 | |
216 | ($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\xc5/; | |
953ab6e5 | 217 | is($a, v300.197.172.300.197.172); |
381d18bc JH |
218 | |
219 | ($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\x{c5}/; | |
953ab6e5 | 220 | is($a, v300.197.172.300.197.172); |
381d18bc | 221 | |
381d18bc JH |
222 | |
223 | ($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/; | |
953ab6e5 | 224 | is($a, v300.301.172.300.301.172, 'byte2wide transliteration'); |
381d18bc JH |
225 | |
226 | ($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc3/; | |
953ab6e5 | 227 | is($a, v195.196.172.195.196.172, ' wide2byte'); |
381d18bc JH |
228 | |
229 | ($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/; | |
953ab6e5 | 230 | is($a, v301.196.172.301.196.172, ' wide2wide'); |
381d18bc | 231 | |
381d18bc JH |
232 | |
233 | ($a = v300.196.172.300.196.172) =~ tr/\xc4\x{12c}/\x{12d}\xc3/; | |
953ab6e5 | 234 | is($a, v195.301.172.195.301.172, 'byte2wide & wide2byte'); |
381d18bc | 235 | |
381d18bc JH |
236 | |
237 | ($a = v300.196.172.300.196.172.400.198.144) =~ | |
238 | tr/\xac\xc4\x{12c}\x{190}/\xad\x{12d}\xc5\x{191}/; | |
953ab6e5 | 239 | is($a, v197.301.173.197.301.173.401.198.144, 'all together now!'); |
381d18bc | 240 | |
381d18bc | 241 | |
953ab6e5 MS |
242 | is((($a = v300.196.172.300.196.172) =~ tr/\xc4/\xc5/), 2, |
243 | 'transliterate and count'); | |
381d18bc | 244 | |
953ab6e5 | 245 | is((($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/), 2); |
381d18bc | 246 | |
381d18bc JH |
247 | |
248 | ($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/c; | |
953ab6e5 | 249 | is($a, v301.196.301.301.196.301, 'translit w/complement'); |
381d18bc JH |
250 | |
251 | ($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc5/c; | |
953ab6e5 | 252 | is($a, v300.197.197.300.197.197); |
381d18bc | 253 | |
381d18bc JH |
254 | |
255 | ($a = v300.196.172.300.196.172) =~ tr/\xc4//d; | |
953ab6e5 | 256 | is($a, v300.172.300.172, 'translit w/deletion'); |
381d18bc JH |
257 | |
258 | ($a = v300.196.172.300.196.172) =~ tr/\x{12c}//d; | |
953ab6e5 | 259 | is($a, v196.172.196.172); |
381d18bc | 260 | |
381d18bc JH |
261 | |
262 | ($a = v196.196.172.300.300.196.172) =~ tr/\xc4/\xc5/s; | |
953ab6e5 | 263 | is($a, v197.172.300.300.197.172, 'translit w/squeeze'); |
381d18bc JH |
264 | |
265 | ($a = v196.172.300.300.196.172.172) =~ tr/\x{12c}/\x{12d}/s; | |
953ab6e5 | 266 | is($a, v196.172.301.196.172.172); |
381d18bc | 267 | |
a1874b66 | 268 | |
953ab6e5 | 269 | # Tricky cases (When Simon Cozens Attacks) |
a1874b66 | 270 | ($a = v196.172.200) =~ tr/\x{12c}/a/; |
953ab6e5 | 271 | is(sprintf("%vd", $a), '196.172.200'); |
a1874b66 JH |
272 | |
273 | ($a = v196.172.200) =~ tr/\x{12c}/\x{12c}/; | |
953ab6e5 | 274 | is(sprintf("%vd", $a), '196.172.200'); |
a1874b66 JH |
275 | |
276 | ($a = v196.172.200) =~ tr/\x{12c}//d; | |
953ab6e5 MS |
277 | is(sprintf("%vd", $a), '196.172.200'); |
278 | ||
a1874b66 | 279 | |
8973db79 | 280 | # UTF8 range tests from Inaba Hiroto |
f9a63242 | 281 | |
a26bfc40 | 282 | # Not working in EBCDIC as of 12674. |
f9a63242 | 283 | ($a = v300.196.172.302.197.172) =~ tr/\x{12c}-\x{130}/\xc0-\xc4/; |
953ab6e5 | 284 | is($a, v192.196.172.194.197.172, 'UTF range'); |
f9a63242 JH |
285 | |
286 | ($a = v300.196.172.302.197.172) =~ tr/\xc4-\xc8/\x{12c}-\x{130}/; | |
953ab6e5 MS |
287 | is($a, v300.300.172.302.301.172); |
288 | ||
8973db79 JH |
289 | |
290 | # UTF8 range tests from Karsten Sperling (patch #9008 required) | |
291 | ||
292 | ($a = "\x{0100}") =~ tr/\x00-\x{100}/X/; | |
953ab6e5 | 293 | is($a, "X"); |
8973db79 JH |
294 | |
295 | ($a = "\x{0100}") =~ tr/\x{0000}-\x{00ff}/X/c; | |
953ab6e5 | 296 | is($a, "X"); |
8973db79 JH |
297 | |
298 | ($a = "\x{0100}") =~ tr/\x{0000}-\x{00ff}\x{0101}/X/c; | |
953ab6e5 | 299 | is($a, "X"); |
8973db79 JH |
300 | |
301 | ($a = v256) =~ tr/\x{0000}-\x{00ff}\x{0101}/X/c; | |
953ab6e5 MS |
302 | is($a, "X"); |
303 | ||
8973db79 | 304 | |
94472101 JH |
305 | # UTF8 range tests from Inaba Hiroto |
306 | ||
307 | ($a = "\x{200}") =~ tr/\x00-\x{100}/X/c; | |
953ab6e5 | 308 | is($a, "X"); |
94472101 JH |
309 | |
310 | ($a = "\x{200}") =~ tr/\x00-\x{100}/X/cs; | |
953ab6e5 MS |
311 | is($a, "X"); |
312 | ||
94472101 | 313 | |
6b6bd37b JH |
314 | # Tricky on EBCDIC: while [a-z] [A-Z] must not match the gap characters, |
315 | # (i-j, r-s, I-J, R-S), [\x89-\x91] [\xc9-\xd1] has to match them, | |
316 | # from Karsten Sperling. | |
317 | ||
318 | $c = ($a = "\x89\x8a\x8b\x8c\x8d\x8f\x90\x91") =~ tr/\x89-\x91/X/; | |
953ab6e5 MS |
319 | is($c, 8); |
320 | is($a, "XXXXXXXX"); | |
4c3a8340 | 321 | |
6b6bd37b | 322 | $c = ($a = "\xc9\xca\xcb\xcc\xcd\xcf\xd0\xd1") =~ tr/\xc9-\xd1/X/; |
953ab6e5 MS |
323 | is($c, 8); |
324 | is($a, "XXXXXXXX"); | |
6b6bd37b | 325 | |
4c3a8340 | 326 | SKIP: { |
953ab6e5 MS |
327 | skip "not EBCDIC", 4 unless $Is_EBCDIC; |
328 | ||
329 | $c = ($a = "\x89\x8a\x8b\x8c\x8d\x8f\x90\x91") =~ tr/i-j/X/; | |
330 | is($c, 2); | |
331 | is($a, "X\x8a\x8b\x8c\x8d\x8f\x90X"); | |
332 | ||
333 | $c = ($a = "\xc9\xca\xcb\xcc\xcd\xcf\xd0\xd1") =~ tr/I-J/X/; | |
334 | is($c, 2); | |
335 | is($a, "X\xca\xcb\xcc\xcd\xcf\xd0X"); | |
6b6bd37b | 336 | } |
1ed601ec JH |
337 | |
338 | ($a = "\x{100}") =~ tr/\x00-\xff/X/c; | |
953ab6e5 | 339 | is(ord($a), ord("X")); |
1ed601ec JH |
340 | |
341 | ($a = "\x{100}") =~ tr/\x00-\xff/X/cs; | |
953ab6e5 | 342 | is(ord($a), ord("X")); |
1ed601ec JH |
343 | |
344 | ($a = "\x{100}\x{100}") =~ tr/\x{101}-\x{200}//c; | |
953ab6e5 | 345 | is($a, "\x{100}\x{100}"); |
1ed601ec JH |
346 | |
347 | ($a = "\x{100}\x{100}") =~ tr/\x{101}-\x{200}//cs; | |
953ab6e5 | 348 | is($a, "\x{100}"); |
1ed601ec | 349 | |
629b4584 | 350 | $a = "\xfe\xff"; $a =~ tr/\xfe\xff/\x{1ff}\x{1fe}/; |
953ab6e5 MS |
351 | is($a, "\x{1ff}\x{1fe}"); |
352 | ||
76ef7183 JH |
353 | |
354 | # From David Dyck | |
355 | ($a = "R0_001") =~ tr/R_//d; | |
953ab6e5 | 356 | is(hex($a), 1); |
76ef7183 | 357 | |
800b4dc4 JH |
358 | # From Inaba Hiroto |
359 | @a = (1,2); map { y/1/./ for $_ } @a; | |
953ab6e5 | 360 | is("@a", ". 2"); |
800b4dc4 JH |
361 | |
362 | @a = (1,2); map { y/1/./ for $_.'' } @a; | |
953ab6e5 MS |
363 | is("@a", "1 2"); |
364 | ||
800b4dc4 | 365 | |
bec89253 RH |
366 | # Additional test for Inaba Hiroto patch (robin@kitsite.com) |
367 | ($a = "\x{100}\x{102}\x{101}") =~ tr/\x00-\377/XYZ/c; | |
953ab6e5 MS |
368 | is($a, "XZY"); |
369 | ||
bec89253 | 370 | |
2233f375 NC |
371 | # Used to fail with "Modification of a read-only value attempted" |
372 | %a = (N=>1); | |
373 | foreach (keys %a) { | |
953ab6e5 MS |
374 | eval 'tr/N/n/'; |
375 | is($_, 'n', 'pp_trans needs to unshare shared hash keys'); | |
376 | is($@, '', ' no error'); | |
2233f375 | 377 | } |
94bfe852 | 378 | |
953ab6e5 | 379 | |
94bfe852 | 380 | $x = eval '"1213" =~ tr/1/1/'; |
953ab6e5 MS |
381 | is($x, 2, 'implicit count on constant'); |
382 | is($@, '', ' no error'); | |
383 | ||
384 | ||
385 | my @foo = (); | |
386 | eval '$foo[-1] =~ tr/N/N/'; | |
387 | is( $@, '', 'implicit count outside array bounds, index negative' ); | |
388 | is( scalar @foo, 0, " doesn't extend the array"); | |
389 | ||
390 | eval '$foo[1] =~ tr/N/N/'; | |
391 | is( $@, '', 'implicit count outside array bounds, index positive' ); | |
392 | is( scalar @foo, 0, " doesn't extend the array"); | |
393 | ||
394 | ||
395 | my %foo = (); | |
396 | eval '$foo{bar} =~ tr/N/N/'; | |
397 | is( $@, '', 'implicit count outside hash bounds' ); | |
398 | is( scalar keys %foo, 0, " doesn't extend the hash"); | |
d59e14db RGS |
399 | |
400 | $x = \"foo"; | |
401 | is( $x =~ tr/A/A/, 2, 'non-modifying tr/// on a scalar ref' ); | |
402 | is( ref $x, 'SCALAR', " doesn't stringify its argument" ); | |
0d65d7d5 MS |
403 | |
404 | # rt.perl.org 36622. Perl didn't like a y/// at end of file. No trailing | |
405 | # newline allowed. | |
406 | fresh_perl_is(q[$_ = "foo"; y/A-Z/a-z/], ''); | |
9f7f3913 TS |
407 | |
408 | ||
409 | { # [perl #38293] chr(65535) should be allowed in regexes | |
410 | no warnings 'utf8'; # to allow non-characters | |
411 | ||
412 | $s = "\x{d800}\x{ffff}"; | |
413 | $s =~ tr/\0/A/; | |
414 | is($s, "\x{d800}\x{ffff}", "do_trans_simple"); | |
415 | ||
416 | $s = "\x{d800}\x{ffff}"; | |
417 | $i = $s =~ tr/\0//; | |
418 | is($i, 0, "do_trans_count"); | |
419 | ||
420 | $s = "\x{d800}\x{ffff}"; | |
421 | $s =~ tr/\0/A/s; | |
422 | is($s, "\x{d800}\x{ffff}", "do_trans_complex, SQUASH"); | |
423 | ||
424 | $s = "\x{d800}\x{ffff}"; | |
425 | $s =~ tr/\0/A/c; | |
426 | is($s, "AA", "do_trans_complex, COMPLEMENT"); | |
427 | ||
428 | $s = "A\x{ffff}B"; | |
429 | $s =~ tr/\x{ffff}/\x{1ffff}/; | |
430 | is($s, "A\x{1ffff}B", "utf8, SEARCHLIST"); | |
431 | ||
432 | $s = "\x{fffd}\x{fffe}\x{ffff}"; | |
433 | $s =~ tr/\x{fffd}-\x{ffff}/ABC/; | |
434 | is($s, "ABC", "utf8, SEARCHLIST range"); | |
435 | ||
436 | $s = "ABC"; | |
437 | $s =~ tr/ABC/\x{ffff}/; | |
438 | is($s, "\x{ffff}"x3, "utf8, REPLACEMENTLIST"); | |
439 | ||
440 | $s = "ABC"; | |
441 | $s =~ tr/ABC/\x{fffd}-\x{ffff}/; | |
442 | is($s, "\x{fffd}\x{fffe}\x{ffff}", "utf8, REPLACEMENTLIST range"); | |
443 | ||
444 | $s = "A\x{ffff}B\x{100}\0\x{fffe}\x{ffff}"; | |
445 | $i = $s =~ tr/\x{ffff}//; | |
446 | is($i, 2, "utf8, count"); | |
447 | ||
448 | $s = "A\x{ffff}\x{ffff}C"; | |
449 | $s =~ tr/\x{ffff}/\x{100}/s; | |
450 | is($s, "A\x{100}C", "utf8, SQUASH"); | |
451 | ||
452 | $s = "A\x{ffff}\x{ffff}\x{fffe}\x{fffe}\x{fffe}C"; | |
453 | $s =~ tr/\x{fffe}\x{ffff}//s; | |
454 | is($s, "A\x{ffff}\x{fffe}C", "utf8, SQUASH"); | |
455 | ||
456 | $s = "xAABBBy"; | |
457 | $s =~ tr/AB/\x{ffff}/s; | |
458 | is($s, "x\x{ffff}y", "utf8, SQUASH"); | |
459 | ||
460 | $s = "xAABBBy"; | |
461 | $s =~ tr/AB/\x{fffe}\x{ffff}/s; | |
462 | is($s, "x\x{fffe}\x{ffff}y", "utf8, SQUASH"); | |
463 | ||
464 | $s = "A\x{ffff}B\x{fffe}C"; | |
465 | $s =~ tr/\x{fffe}\x{ffff}/x/c; | |
466 | is($s, "x\x{ffff}x\x{fffe}x", "utf8, COMPLEMENT"); | |
467 | ||
468 | $s = "A\x{10000}B\x{2abcd}C"; | |
469 | $s =~ tr/\0-\x{ffff}/x/c; | |
470 | is($s, "AxBxC", "utf8, COMPLEMENT range"); | |
471 | ||
472 | $s = "A\x{fffe}B\x{ffff}C"; | |
473 | $s =~ tr/\x{fffe}\x{ffff}/x/d; | |
474 | is($s, "AxBC", "utf8, DELETE"); | |
475 | ||
476 | } # non-characters end | |
477 | ||
1749ea0d TS |
478 | { # related to [perl #27940] |
479 | my $c; | |
480 | ||
481 | ($c = "\x20\c@\x30\cA\x40\cZ\x50\c_\x60") =~ tr/\c@-\c_//d; | |
482 | is($c, "\x20\x30\x40\x50\x60", "tr/\\c\@-\\c_//d"); | |
483 | ||
484 | ($c = "\x20\x00\x30\x01\x40\x1A\x50\x1F\x60") =~ tr/\x00-\x1f//d; | |
485 | is($c, "\x20\x30\x40\x50\x60", "tr/\\x00-\\x1f//d"); | |
486 | } | |
487 | ||
3788ef8f | 488 | ($s) = keys %{{pie => 3}}; |
3e89ba19 | 489 | SKIP: { |
e3918bb7 FC |
490 | if (!eval { require XS::APItest }) { skip "no XS::APItest", 2 } |
491 | my $wasro = XS::APItest::SvIsCOW($s); | |
2203fb5a | 492 | ok $wasro, "have a COW"; |
3788ef8f | 493 | $s =~ tr/i//; |
e3918bb7 | 494 | ok( XS::APItest::SvIsCOW($s), |
3e89ba19 | 495 | "count-only tr doesn't deCOW COWs" ); |
3788ef8f | 496 | } |
a5446a64 DM |
497 | |
498 | # [ RT #61520 ] | |
499 | # | |
500 | # under threads, unicode tr within a cloned closure would SEGV or assert | |
501 | # fail, since the pointer in the pad to the swash was getting zeroed out | |
502 | # in the proto-CV | |
503 | ||
504 | { | |
505 | my $x = "\x{142}"; | |
506 | sub { | |
507 | $x =~ tr[\x{142}][\x{143}]; | |
508 | }->(); | |
509 | is($x,"\x{143}", "utf8 + closure"); | |
510 | } | |
511 | ||
9100eeb1 Z |
512 | # Freeing of trans ops prior to pmtrans() [perl #102858]. |
513 | eval q{ $a ~= tr/a/b/; }; | |
514 | ok 1; | |
515 | SKIP: { | |
55673181 | 516 | no warnings "deprecated"; |
9100eeb1 Z |
517 | skip "no encoding", 1 unless eval { require encoding; 1 }; |
518 | eval q{ use encoding "utf8"; $a ~= tr/a/b/; }; | |
519 | ok 1; | |
520 | } | |
a5446a64 | 521 | |
cb6d3474 KW |
522 | { # [perl #113584] |
523 | ||
524 | my $x = "Perlα"; | |
525 | $x =~ tr/αα/βγ/; | |
baacc348 | 526 | { no warnings 'utf8'; print "# $x\n"; } # No note() to avoid wide warning. |
cb6d3474 KW |
527 | is($x, "Perlβ", "Only first of multiple transliterations is used"); |
528 | } | |
529 | ||
d8b516a1 FC |
530 | # tr/a/b/ should fail even on zero-length read-only strings |
531 | use constant nullrocow => (keys%{{""=>undef}})[0]; | |
532 | for ("", nullrocow) { | |
533 | eval { $_ =~ y/a/b/ }; | |
534 | like $@, qr/^Modification of a read-only value attempted at /, | |
535 | 'tr/a/b/ fails on zero-length ro string'; | |
536 | } | |
537 | ||
9100eeb1 | 538 | 1; |