source: trunk/third/perl/t/op/tr.t @ 20075

Revision 20075, 9.3 KB checked in by zacheiss, 21 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r20074, which included commits to RCS files with non-trunk default branches.
  • Property svn:executable set to *
Line 
1# tr.t
2
3BEGIN {
4    chdir 't' if -d 't';
5    @INC = '../lib';
6    require './test.pl';
7}
8
9plan tests => 99;
10
11my $Is_EBCDIC = (ord('i') == 0x89 & ord('J') == 0xd1);
12
13$_ = "abcdefghijklmnopqrstuvwxyz";
14
15tr/a-z/A-Z/;
16
17is($_, "ABCDEFGHIJKLMNOPQRSTUVWXYZ",    'uc');
18
19tr/A-Z/a-z/;
20
21is($_, "abcdefghijklmnopqrstuvwxyz",    'lc');
22
23tr/b-y/B-Y/;
24is($_, "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/;
45is($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//;
52s/^(\s*)f/$1F/;
53is($_, '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})/;
59eval '$1 =~ tr/A-Z/A-Z/;';
60s/^(\s*)f/$1F/;
61is($_, 'Fred',  'harmless if implicitly not updating');
62is($@, '',      '    no error');
63
64
65# check tr handles UTF8 correctly
66($x = 256.65.258) =~ tr/a/b/;
67is($x, 256.65.258,  'handles UTF8');
68is(length $x, 3);
69
70$x =~ tr/A/B/;
71is(length $x, 3);
72if (ord("\t") == 9) { # ASCII
73    is($x, 256.66.258);
74}
75else {
76    is($x, 256.65.258);
77}
78
79# EBCDIC variants of the above tests
80($x = 256.193.258) =~ tr/a/b/;
81is(length $x, 3);
82is($x, 256.193.258);
83
84$x =~ tr/A/B/;
85is(length $x, 3);
86if (ord("\t") == 9) { # ASCII
87    is($x, 256.193.258);
88}
89else {
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";
132eval 'tr/a-z-9/ /';
133like($@, 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";
137tr/-a-m/./;
138is($_, '..r.rot9',  'hyphens, leading');
139
140$_ = "car-rot9";
141tr/a-m-/./;
142is($_, '..r.rot9',  '   trailing');
143
144$_ = "car-rot9";
145tr/-a-m-/./;
146is($_, '..r.rot9',  '   both');
147
148$_ = "abcdefghijklmnop";
149tr/ae-hn/./;
150is($_, '.bcd....ijklm.op');
151
152$_ = "abcdefghijklmnop";
153tr/a-cf-kn-p/./;
154is($_, '...de......lm...');
155
156$_ = "abcdefghijklmnop";
157tr/a-ceg-ikm-o/./;
158is($_, '...d.f...j.l...p');
159
160
161# 20000705 MJD
162eval "tr/m-d/ /";
163like($@, qr/^Invalid range "m-d" in transliteration operator/,
164              'reversed range check');
165
166eval '$1 =~ tr/x/y/';
167like($@, qr/^Modification of a read-only value attempted/,
168              'cannot update read-only var');
169
170'abcdef' =~ /(bcd)/;
171is(eval '$1 =~ tr/abcd//', 3,  'explicit read-only count');
172is($@, '',                      '    no error');
173
174'abcdef' =~ /(bcd)/;
175is(eval '$1 =~ tr/abcd/abcd/', 3,  'implicit read-only count');
176is($@, '',                      '    no error');
177
178is(eval '"123" =~ tr/12//', 2,     'LHS of non-updating tr');
179
180eval '"123" =~ tr/1/2/';
181like($@, 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/;
191is($a, v300.197.172.300.197.172,    'byte2byte transliteration');
192
193($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{c5}/;
194is($a, v300.197.172.300.197.172);
195
196($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\xc5/;
197is($a, v300.197.172.300.197.172);
198
199($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\x{c5}/;
200is($a, v300.197.172.300.197.172);
201
202
203($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/;
204is($a, v300.301.172.300.301.172,    'byte2wide transliteration');
205
206($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc3/;
207is($a, v195.196.172.195.196.172,    '   wide2byte');
208
209($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/;
210is($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/;
214is($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}/;
219is($a, v197.301.173.197.301.173.401.198.144,    'all together now!');
220
221
222is((($a = v300.196.172.300.196.172) =~ tr/\xc4/\xc5/), 2,
223                                     'transliterate and count');
224
225is((($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;
229is($a, v301.196.301.301.196.301,    'translit w/complement');
230
231($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc5/c;
232is($a, v300.197.197.300.197.197);
233
234
235($a = v300.196.172.300.196.172) =~ tr/\xc4//d;
236is($a, v300.172.300.172,            'translit w/deletion');
237
238($a = v300.196.172.300.196.172) =~ tr/\x{12c}//d;
239is($a, v196.172.196.172);
240
241
242($a = v196.196.172.300.300.196.172) =~ tr/\xc4/\xc5/s;
243is($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;
246is($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/;
251is(sprintf("%vd", $a), '196.172.200');
252
253($a = v196.172.200) =~ tr/\x{12c}/\x{12c}/;
254is(sprintf("%vd", $a), '196.172.200');
255
256($a = v196.172.200) =~ tr/\x{12c}//d;
257is(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/;
264is($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}/;
267is($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/;
273is($a, "X");
274
275($a = "\x{0100}") =~ tr/\x{0000}-\x{00ff}/X/c;
276is($a, "X");
277
278($a = "\x{0100}") =~ tr/\x{0000}-\x{00ff}\x{0101}/X/c;
279is($a, "X");
280 
281($a = v256) =~ tr/\x{0000}-\x{00ff}\x{0101}/X/c;
282is($a, "X");
283
284
285# UTF8 range tests from Inaba Hiroto
286
287($a = "\x{200}") =~ tr/\x00-\x{100}/X/c;
288is($a, "X");
289
290($a = "\x{200}") =~ tr/\x00-\x{100}/X/cs;
291is($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/;
300is($c, 8);
301is($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/;
305is($c, 8);
306is($a, "XXXXXXXX");
307
308
309SKIP: {   
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;
322is(ord($a), ord("X"));
323
324($a = "\x{100}") =~ tr/\x00-\xff/X/cs;
325is(ord($a), ord("X"));
326
327($a = "\x{100}\x{100}") =~ tr/\x{101}-\x{200}//c;
328is($a, "\x{100}\x{100}");
329
330($a = "\x{100}\x{100}") =~ tr/\x{101}-\x{200}//cs;
331is($a, "\x{100}");
332
333$a = "\xfe\xff"; $a =~ tr/\xfe\xff/\x{1ff}\x{1fe}/;
334is($a, "\x{1ff}\x{1fe}");
335
336
337# From David Dyck
338($a = "R0_001") =~ tr/R_//d;
339is(hex($a), 1);
340
341# From Inaba Hiroto
342@a = (1,2); map { y/1/./ for $_ } @a;
343is("@a", ". 2");
344
345@a = (1,2); map { y/1/./ for $_.'' } @a;
346is("@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;
351is($a, "XZY");
352
353
354# Used to fail with "Modification of a read-only value attempted"
355%a = (N=>1);
356foreach (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/';
364is($x, 2,   'implicit count on constant');
365is($@, '',  '   no error');
366
367
368my @foo = ();
369eval '$foo[-1] =~ tr/N/N/';
370is( $@, '',         'implicit count outside array bounds, index negative' );
371is( scalar @foo, 0, "    doesn't extend the array");
372
373eval '$foo[1] =~ tr/N/N/';
374is( $@, '',         'implicit count outside array bounds, index positive' );
375is( scalar @foo, 0, "    doesn't extend the array");
376
377
378my %foo = ();
379eval '$foo{bar} =~ tr/N/N/';
380is( $@, '',         'implicit count outside hash bounds' );
381is( scalar keys %foo, 0,   "    doesn't extend the hash");
382
383$x = \"foo";
384is( $x =~ tr/A/A/, 2, 'non-modifying tr/// on a scalar ref' );
385is( ref $x, 'SCALAR', "    doesn't stringify its argument" );
Note: See TracBrowser for help on using the repository browser.