1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
|
# tr.t
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
print "1..19\n";
$_ = "abcdefghijklmnopqrstuvwxyz";
tr/a-z/A-Z/;
print "not " unless $_ eq "ABCDEFGHIJKLMNOPQRSTUVWXYZ";
print "ok 1\n";
tr/A-Z/a-z/;
print "not " unless $_ eq "abcdefghijklmnopqrstuvwxyz";
print "ok 2\n";
tr/b-y/B-Y/;
print "not " unless $_ eq "aBCDEFGHIJKLMNOPQRSTUVWXYz";
print "ok 3\n";
# In EBCDIC 'I' is \xc9 and 'J' is \0xd1, 'i' is \x89 and 'j' is \x91.
# Yes, discontinuities. Regardless, the \xca in the below should stay
# untouched (and not became \x8a).
{
no utf8;
$_ = "I\xcaJ";
tr/I-J/i-j/;
print "not " unless $_ eq "i\xcaj";
print "ok 4\n";
}
#
# make sure that tr cancels IOK and NOK
($x = 12) =~ tr/1/3/;
(my $y = 12) =~ tr/1/3/;
($f = 1.5) =~ tr/1/3/;
(my $g = 1.5) =~ tr/1/3/;
print "not " unless $x + $y + $f + $g == 71;
print "ok 5\n";
# make sure tr is harmless if not updating - see [ID 20000511.005]
$_ = 'fred';
/([a-z]{2})/;
$1 =~ tr/A-Z//;
s/^(\s*)f/$1F/;
print "not " if $_ ne 'Fred';
print "ok 6\n";
# check tr handles UTF8 correctly
($x = 256.65.258) =~ tr/a/b/;
print "not " if $x ne 256.65.258 or length $x != 3;
print "ok 7\n";
$x =~ tr/A/B/;
if (ord("\t") == 9) { # ASCII
print "not " if $x ne 256.66.258 or length $x != 3;
}
else {
print "not " if $x ne 256.65.258 or length $x != 3;
}
print "ok 8\n";
{
if (ord("\t") == 9) { # ASCII
use utf8;
}
# 9 - changing UTF8 characters in a UTF8 string, same length.
$l = chr(300); $r = chr(400);
$x = 200.300.400;
$x =~ tr/\x{12c}/\x{190}/;
printf "not (%vd) ", $x if $x ne 200.400.400 or length $x != 3;
print "ok 9\n";
# 10 - changing UTF8 characters in UTF8 string, more bytes.
$x = 200.300.400;
$x =~ tr/\x{12c}/\x{be8}/;
printf "not (%vd) ", $x if $x ne 200.3048.400 or length $x != 3;
print "ok 10\n";
# 11 - introducing UTF8 characters to non-UTF8 string.
$x = 100.125.60;
$x =~ tr/\x{64}/\x{190}/;
printf "not (%vd) ", $x if $x ne 400.125.60 or length $x != 3;
print "ok 11\n";
# 12 - removing UTF8 characters from UTF8 string
$x = 400.125.60;
$x =~ tr/\x{190}/\x{64}/;
printf "not (%vd) ", $x if $x ne 100.125.60 or length $x != 3;
print "ok 12\n";
# 13 - counting UTF8 chars in UTF8 string
$x = 400.125.60.400;
$y = $x =~ tr/\x{190}/\x{190}/;
print "not " if $y != 2;
print "ok 13\n";
# 14 - counting non-UTF8 chars in UTF8 string
$x = 60.400.125.60.400;
$y = $x =~ tr/\x{3c}/\x{3c}/;
print "not " if $y != 2;
print "ok 14\n";
# 15 - counting UTF8 chars in non-UTF8 string
$x = 200.125.60;
$y = $x =~ tr/\x{190}/\x{190}/;
print "not " if $y != 0;
print "ok 15\n";
}
# 16: test cannot update if read-only
eval '$1 =~ tr/x/y/';
print (($@ =~ /^Modification of a read-only value attempted/) ? '' : 'not ',
"ok 16\n");
# 17: test can count read-only
'abcdef' =~ /(bcd)/;
print (( eval '$1 =~ tr/abcd//' == 3) ? '' : 'not ', "ok 17\n");
# 18: test lhs OK if not updating
print ((eval '"123" =~ tr/12//' == 2) ? '' : 'not ', "ok 18\n");
# 19: test lhs bad if updating
eval '"123" =~ tr/1/1/';
print (($@ =~ m|^Can't modify constant item in transliteration \(tr///\)|)
? '' : 'not ', "ok 19\n");
|
