Commit | Line | Data |
7d59b7e4 |
1 | #!./perl |
2 | |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
5 | @INC = '../lib'; |
6 | require Config; import Config; |
7 | unless ($Config{'useperlio'}) { |
8 | print "1..0 # Skip: not perlio\n"; |
9 | exit 0; |
10 | } |
11 | } |
12 | |
13 | $| = 1; |
360eb788 |
14 | print "1..25\n"; |
7d59b7e4 |
15 | |
16 | open(F,"+>:utf8",'a'); |
17 | print F chr(0x100).'£'; |
18 | print '#'.tell(F)."\n"; |
19 | print "not " unless tell(F) == 4; |
20 | print "ok 1\n"; |
21 | print F "\n"; |
22 | print '#'.tell(F)."\n"; |
23 | print "not " unless tell(F) >= 5; |
24 | print "ok 2\n"; |
25 | seek(F,0,0); |
26 | print "not " unless getc(F) eq chr(0x100); |
27 | print "ok 3\n"; |
28 | print "not " unless getc(F) eq "£"; |
29 | print "ok 4\n"; |
30 | print "not " unless getc(F) eq "\n"; |
31 | print "ok 5\n"; |
32 | seek(F,0,0); |
33 | binmode(F,":bytes"); |
34 | print "not " unless getc(F) eq chr(0xc4); |
35 | print "ok 6\n"; |
36 | print "not " unless getc(F) eq chr(0x80); |
37 | print "ok 7\n"; |
38 | print "not " unless getc(F) eq chr(0xc2); |
39 | print "ok 8\n"; |
40 | print "not " unless getc(F) eq chr(0xa3); |
41 | print "ok 9\n"; |
42 | print "not " unless getc(F) eq "\n"; |
43 | print "ok 10\n"; |
44 | seek(F,0,0); |
45 | binmode(F,":utf8"); |
46 | print "not " unless scalar(<F>) eq "\x{100}£\n"; |
47 | print "ok 11\n"; |
eb5c063a |
48 | seek(F,0,0); |
49 | $buf = chr(0x200); |
50 | $count = read(F,$buf,2,1); |
51 | print "not " unless $count == 2; |
52 | print "ok 12\n"; |
53 | print "not " unless $buf eq "\x{200}\x{100}£"; |
54 | print "ok 13\n"; |
7d59b7e4 |
55 | close(F); |
56 | |
360eb788 |
57 | { |
58 | $a = chr(300); # This *is* UTF-encoded |
59 | $b = chr(130); # This is not. |
60 | |
61 | open F, ">:utf8", 'a' or die $!; |
62 | print F $a,"\n"; |
63 | close F; |
64 | |
65 | open F, "<:utf8", 'a' or die $!; |
66 | $x = <F>; |
67 | chomp($x); |
68 | print "not " unless $x eq chr(300); |
69 | print "ok 14\n"; |
70 | |
71 | open F, "a" or die $!; # Not UTF |
72 | $x = <F>; |
73 | chomp($x); |
74 | print "not " unless $x eq chr(196).chr(172); |
75 | print "ok 15\n"; |
76 | close F; |
77 | |
78 | open F, ">:utf8", 'a' or die $!; |
79 | |
80 | print F $a; |
81 | my $y; |
82 | { my $x = tell(F); |
83 | { use bytes; $y = length($a);} |
84 | print "not " unless $x == $y; |
85 | print "ok 16\n"; |
86 | } |
87 | |
88 | { # Check byte length of $b |
89 | use bytes; my $y = length($b); |
90 | print "not " unless $y == 1; |
91 | print "ok 17\n"; |
92 | } |
93 | |
94 | print F $b,"\n"; # This upgrades $b! |
95 | |
96 | { # Check byte length of $b |
97 | use bytes; my $y = length($b); |
98 | print "not " unless $y == 2; |
99 | print "ok 18\n"; |
100 | } |
101 | |
102 | { my $x = tell(F); |
103 | { use bytes; $y += 3;} |
104 | print "not " unless $x == $y; |
105 | print "ok 19\n"; |
106 | } |
107 | |
108 | close F; |
109 | |
110 | open F, "a" or die $!; # Not UTF |
111 | $x = <F>; |
112 | chomp($x); |
113 | print "not " unless $x eq v196.172.194.130; |
114 | print "ok 20\n"; |
115 | |
116 | open F, "<:utf8", "a" or die $!; |
117 | $x = <F>; |
118 | chomp($x); |
119 | close F; |
120 | print "not " unless $x eq chr(300).chr(130); |
121 | print "ok 21\n"; |
122 | |
123 | # Now let's make it suffer. |
124 | open F, ">", "a" or die $!; |
125 | eval { print F $a; }; |
126 | print "not " unless $@ and $@ =~ /Wide character in print/i; |
127 | print "ok 22\n"; |
128 | } |
129 | |
130 | # Hm. Time to get more evil. |
131 | open F, ">:utf8", "a" or die $!; |
132 | print F $a; |
133 | binmode(F, ":bytes"); |
134 | print F chr(130)."\n"; |
135 | close F; |
136 | |
137 | open F, "<", "a" or die $!; |
138 | $x = <F>; chomp $x; |
139 | print "not " unless $x eq v196.172.130; |
140 | print "ok 23\n"; |
141 | |
142 | # Right. |
143 | open F, ">:utf8", "a" or die $!; |
144 | print F $a; |
145 | close F; |
146 | open F, ">>", "a" or die $!; |
147 | print F chr(130)."\n"; |
148 | close F; |
149 | |
150 | open F, "<", "a" or die $!; |
151 | $x = <F>; chomp $x; |
152 | print "not " unless $x eq v196.172.130; |
153 | print "ok 24\n"; |
154 | |
155 | # Now we have a deformed file. |
156 | open F, "<:utf8", "a" or die $!; |
157 | $x = <F>; chomp $x; |
158 | { local $SIG{__WARN__} = sub { print "ok 25\n"; }; |
159 | eval { sprintf "%vd\n", $x; } |
160 | } |
161 | |
162 | unlink('a'); |
7d59b7e4 |
163 | |