Suppress a few compilation warnings in pp_hot.c.
[p5sagit/p5-mst-13.2.git] / t / op / tr.t
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" );