Commit | Line | Data |
f96ec2a2 |
1 | #!./perl |
2 | |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
20822f61 |
5 | @INC = '../lib'; |
8ae6c9f9 |
6 | require './test.pl'; |
f96ec2a2 |
7 | } |
8 | |
4765795a |
9 | # NOTE! |
10 | # |
11 | # Think carefully before adding tests here. In general this should be |
12 | # used only for about three categories of tests: |
13 | # |
14 | # (1) tests that absolutely require 'use utf8', and since that in general |
15 | # shouldn't be needed as the utf8 is being obsoleted, this should |
16 | # have rather few tests. If you want to test Unicode and regexes, |
17 | # you probably want to go to op/regexp or op/pat; if you want to test |
18 | # split, go to op/split; pack, op/pack; appending or joining, |
19 | # op/append or op/join, and so forth |
20 | # |
21 | # (2) tests that have to do with Unicode tokenizing (though it's likely |
22 | # that all the other Unicode tests sprinkled around the t/**/*.t are |
23 | # going to catch that) |
24 | # |
25 | # (3) complicated tests that simultaneously stress so many Unicode features |
26 | # that deciding into which other test script the tests should go to |
27 | # is hard -- maybe consider breaking up the complicated test |
28 | # |
29 | # |
30 | |
4c26891c |
31 | plan tests => 94; |
31067593 |
32 | |
7bbb0251 |
33 | { |
da450f52 |
34 | # bug id 20001009.001 |
35 | |
89491803 |
36 | my ($a, $b); |
37 | |
38 | { use bytes; $a = "\xc3\xa4" } |
4765795a |
39 | { use utf8; $b = "\xe4" } |
89491803 |
40 | |
4765795a |
41 | my $test = 68; |
31067593 |
42 | |
4765795a |
43 | ok($a ne $b); |
da450f52 |
44 | |
4765795a |
45 | { use utf8; ok($a ne $b) } |
da450f52 |
46 | } |
47 | |
60ff4832 |
48 | |
49 | { |
50 | # bug id 20000730.004 |
51 | |
60ff4832 |
52 | my $smiley = "\x{263a}"; |
53 | |
4765795a |
54 | for my $s ("\x{263a}", |
55 | $smiley, |
60ff4832 |
56 | |
4765795a |
57 | "" . $smiley, |
58 | "" . "\x{263a}", |
60ff4832 |
59 | |
4765795a |
60 | $smiley . "", |
61 | "\x{263a}" . "", |
60ff4832 |
62 | ) { |
63 | my $length_chars = length($s); |
64 | my $length_bytes; |
65 | { use bytes; $length_bytes = length($s) } |
66 | my @regex_chars = $s =~ m/(.)/g; |
67 | my $regex_chars = @regex_chars; |
68 | my @split_chars = split //, $s; |
69 | my $split_chars = @split_chars; |
4765795a |
70 | ok("$length_chars/$regex_chars/$split_chars/$length_bytes" eq |
71 | "1/1/1/3"); |
60ff4832 |
72 | } |
73 | |
4765795a |
74 | for my $s ("\x{263a}" . "\x{263a}", |
75 | $smiley . $smiley, |
60ff4832 |
76 | |
4765795a |
77 | "\x{263a}\x{263a}", |
78 | "$smiley$smiley", |
60ff4832 |
79 | |
4765795a |
80 | "\x{263a}" x 2, |
81 | $smiley x 2, |
60ff4832 |
82 | ) { |
83 | my $length_chars = length($s); |
84 | my $length_bytes; |
85 | { use bytes; $length_bytes = length($s) } |
86 | my @regex_chars = $s =~ m/(.)/g; |
87 | my $regex_chars = @regex_chars; |
88 | my @split_chars = split //, $s; |
89 | my $split_chars = @split_chars; |
4765795a |
90 | ok("$length_chars/$regex_chars/$split_chars/$length_bytes" eq |
91 | "2/2/2/6"); |
60ff4832 |
92 | } |
93 | } |
ffc61ed2 |
94 | |
ffc61ed2 |
95 | |
96 | { |
f9a63242 |
97 | my $w = 0; |
98 | local $SIG{__WARN__} = sub { print "#($_[0])\n"; $w++ }; |
99 | my $x = eval q/"\\/ . "\x{100}" . q/"/;; |
100 | |
4765795a |
101 | ok($w == 0 && $x eq "\x{100}"); |
f9a63242 |
102 | } |
103 | |
8ae6c9f9 |
104 | { |
435e7af6 |
105 | use warnings; |
4c26891c |
106 | use strict; |
107 | |
108 | my $show = q( |
109 | sub show { |
110 | my $result; |
111 | $result .= '>' . join (',', map {ord} split //, $_) . '<' |
112 | foreach @_; |
113 | $result; |
114 | } |
115 | 1; |
116 | ); |
117 | eval $show or die $@; # We don't expect this sub definition to fail. |
8ae6c9f9 |
118 | my $progfile = 'utf' . $$; |
435e7af6 |
119 | END {unlink_all $progfile} |
120 | |
121 | # If I'm right 60 is '>' in ASCII, ' ' in EBCDIC |
122 | # 173 is not punctuation in either ASCII or EBCDIC |
123 | my (@char); |
124 | foreach (60, 173, 257, 65532) { |
125 | my $char = chr $_; |
126 | utf8::encode($char); |
127 | # I don't want to use map {ord} and I've no need to hardcode the UTF |
128 | # version |
129 | my $charsubst = $char; |
130 | $charsubst =~ s/(.)/ord ($1) . ','/ge; |
131 | chop $charsubst; |
4c26891c |
132 | # Not testing this one against map {ord} |
133 | my $char_as_ord |
134 | = join " . ", map {sprintf 'chr (%d)', ord $_} split //, $char; |
135 | push @char, [$_, $char, $charsubst, $char_as_ord]; |
435e7af6 |
136 | } |
4c26891c |
137 | # Now we've done all the UTF8 munching hopefully we're safe |
138 | my @tests = ( |
435e7af6 |
139 | ['check our detection program works', |
4c26891c |
140 | 'my @a = ("'.chr(60).'\x2A", ""); $b = show @a', qr/^>60,42<><$/], |
435e7af6 |
141 | ['check literal 8 bit input', |
4c26891c |
142 | '$a = "' . chr (173) . '"; $b = show $a', qr/^>173<$/], |
435e7af6 |
143 | ['check no utf8; makes no change', |
4c26891c |
144 | 'no utf8; $a = "' . chr (173) . '"; $b = show $a', qr/^>173<$/], |
435e7af6 |
145 | # Now we do the real byte sequences that are valid UTF8 |
146 | (map { |
147 | ["the utf8 sequence for chr $_->[0]", |
347a2837 |
148 | qq{\$a = "$_->[1]"; \$b = show \$a}, qr/^>$_->[2]<$/], |
435e7af6 |
149 | ["no utf8; for the utf8 sequence for chr $_->[0]", |
4c26891c |
150 | qq(no utf8; \$a = "$_->[1]"; \$b = show \$a), qr/^>$_->[2]<$/], |
435e7af6 |
151 | ["use utf8; for the utf8 sequence for chr $_->[0]", |
4c26891c |
152 | qq(use utf8; \$a = "$_->[1]"; \$b = show \$a), qr/^>$_->[0]<$/], |
435e7af6 |
153 | } @char), |
154 | # Interpolation of hex characters needs to take place now, as we're |
155 | # testing feeding malformed utf8 into perl. Bug now fixed was an |
156 | # "out of memory" error. We really need the "" [rather than qq() |
157 | # or q()] to get the best explosion. |
158 | ["!Feed malformed utf8 into perl.", <<"BANG", |
8ae6c9f9 |
159 | use utf8; %a = ("\xE1\xA0"=>"sterling"); |
435e7af6 |
160 | print 'start'; printf '%x,', ord \$_ foreach keys %a; print "end\n"; |
8ae6c9f9 |
161 | BANG |
097fb8e2 |
162 | qr/^Malformed UTF-8 character \(2 bytes, need 3.+\).*start\d+,end$/s |
435e7af6 |
163 | ], |
4c26891c |
164 | ); |
165 | foreach (@tests) { |
435e7af6 |
166 | my ($why, $prog, $expect) = @$_; |
167 | open P, ">$progfile" or die "Can't open '$progfile': $!"; |
347a2837 |
168 | binmode(P, ":bytes"); |
4c26891c |
169 | print P $show, $prog, '; print $b' |
170 | or die "Print to 'progfile' failed: $!"; |
435e7af6 |
171 | close P or die "Can't close '$progfile': $!"; |
172 | if ($why =~ s/^!//) { |
173 | print "# Possible delay...\n"; |
174 | } else { |
175 | print "# $prog\n"; |
176 | } |
177 | my $result = runperl ( stderr => 1, progfile => $progfile ); |
178 | like ($result, $expect, $why); |
179 | } |
4c26891c |
180 | print |
181 | "# Again! Again! [but this time as eval, and not the explosive one]\n"; |
182 | # and now we've safely done them all as separate files, check that the |
183 | # evals do the same thing. Hopefully doing it later sucessfully decouples |
184 | # the previous tests from anything messy that may go wrong with the evals. |
185 | foreach (@tests) { |
186 | my ($why, $prog, $expect) = @$_; |
187 | next if $why =~ m/^!/; # Goes bang. |
188 | my $result = eval $prog; |
189 | if ($@) { |
190 | print "# prog is $prog\n"; |
191 | print "# \$\@=", _qq($@), "\n"; |
192 | } |
193 | like ($result, $expect, $why); |
194 | } |
195 | |
196 | # See what the tokeniser does with hash keys. |
197 | print "# What does the tokeniser do with utf8 hash keys?\n"; |
198 | @tests = (map { |
199 | # This is the control - I don't expect it to fail |
200 | ["assign utf8 for chr $_->[0] to a hash", |
201 | qq(my \$a = "$_->[1]"; my %h; \$h{\$a} = 1; |
202 | my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b), |
203 | qr/^>$_->[2]<$/], |
204 | ["no utf8; assign utf8 for chr $_->[0] to a hash", |
205 | qq(no utf8; my \$a = "$_->[1]"; my %h; \$h{\$a} = 1; |
206 | my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b), |
207 | qr/^>$_->[2]<$/], |
208 | ["use utf8; assign utf8 for chr $_->[0] to a hash", |
209 | qq(use utf8; my \$a = "$_->[1]"; my %h; \$h{\$a} = 1; |
210 | my \$b = show keys %h; \$b .= 'F' unless \$h{chr $_->[0]}; \$b), |
211 | qr/^>$_->[0]<$/], |
212 | # Now check literal $h{"x"} constructions. |
213 | ["\$h{\"x\"} construction, where x is utf8 for chr $_->[0]", |
214 | qq(my \$a = "$_->[1]"; my %h; \$h{"$_->[1]"} = 1; |
215 | my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b), |
216 | qr/^>$_->[2]<$/], |
217 | ["no utf8; \$h{\"x\"} construction, where x is utf8 for chr $_->[0]", |
218 | qq(no utf8; my \$a = "$_->[1]"; my %h; \$h{"$_->[1]"} = 1; |
219 | my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b), |
220 | qr/^>$_->[2]<$/], |
221 | ["use utf8; \$h{\"x\"} construction, where x is utf8 for chr $_->[0]", |
222 | qq(use utf8; my \$a = "$_->[1]"; my %h; \$h{"$_->[1]"} = 1; |
223 | my \$b = show keys %h; \$b .= 'F' unless \$h{chr $_->[0]}; \$b), |
224 | qr/^>$_->[0]<$/], |
225 | # Now check "x" => constructions. |
226 | ["assign \"x\"=>1 to a hash, where x is utf8 for chr $_->[0]", |
227 | qq(my \$a = "$_->[1]"; my %h; %h = ("$_->[1]" => 1); |
228 | my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b), |
229 | qr/^>$_->[2]<$/], |
230 | ["no utf8; assign \"x\"=>1 to a hash, where x is utf8 for chr $_->[0]", |
231 | qq(no utf8; my \$a = "$_->[1]"; my %h; %h = ("$_->[1]" => 1); |
232 | my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b), |
233 | qr/^>$_->[2]<$/], |
234 | ["use utf8; assign \"x\"=>1 to a hash, where x is utf8 for chr $_->[0]", |
235 | qq(use utf8; my \$a = "$_->[1]"; my %h; %h = ("$_->[1]" => 1); |
236 | my \$b = show keys %h; \$b .= 'F' unless \$h{chr $_->[0]}; \$b), |
237 | qr/^>$_->[0]<$/], |
238 | # Check copies of hashes made from literal utf8 keys |
239 | ["assign utf8 for chr $_->[0] to a hash, then copy it", |
240 | qq(my \$a = "$_->[1]"; my %i; \$i{\$a} = 1; my %h = %i; |
241 | my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b), |
242 | qr/^>$_->[2]<$/], |
243 | ["no utf8; assign utf8 for chr $_->[0] to a hash, then copy it", |
244 | qq(no utf8; my \$a = "$_->[1]"; my %i; \$i{\$a} = 1;; my %h = %i; |
245 | my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b), |
246 | qr/^>$_->[2]<$/], |
247 | ["use utf8; assign utf8 for chr $_->[0] to a hash, then copy it", |
248 | qq(use utf8; my \$a = "$_->[1]"; my %i; \$i{\$a} = 1; my %h = %i; |
249 | my \$b = show keys %h; \$b .= 'F' unless \$h{chr $_->[0]}; \$b), |
250 | qr/^>$_->[0]<$/], |
251 | } @char); |
252 | foreach (@tests) { |
253 | my ($why, $prog, $expect) = @$_; |
254 | # print "# $prog\n"; |
255 | my $result = eval $prog; |
256 | like ($result, $expect, $why); |
257 | } |
8ae6c9f9 |
258 | } |