This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Tweak for 8.3 compat.
[perl5.git] / lib / utf8.t
CommitLineData
f96ec2a2
GS
1#!./perl
2
3BEGIN {
4 chdir 't' if -d 't';
20822f61 5 @INC = '../lib';
8ae6c9f9 6 require './test.pl';
f96ec2a2
GS
7}
8
4765795a
JH
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 31plan tests => 94;
31067593 32
7bbb0251 33{
da450f52
JH
34 # bug id 20001009.001
35
89491803
SC
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
JH
46}
47
60ff4832
JH
48
49{
50 # bug id 20000730.004
51
60ff4832
JH
52 my $smiley = "\x{263a}";
53
4765795a
JH
54 for my $s ("\x{263a}",
55 $smiley,
60ff4832 56
4765795a
JH
57 "" . $smiley,
58 "" . "\x{263a}",
60ff4832 59
4765795a
JH
60 $smiley . "",
61 "\x{263a}" . "",
60ff4832
JH
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
JH
70 ok("$length_chars/$regex_chars/$split_chars/$length_bytes" eq
71 "1/1/1/3");
60ff4832
JH
72 }
73
4765795a
JH
74 for my $s ("\x{263a}" . "\x{263a}",
75 $smiley . $smiley,
60ff4832 76
4765795a
JH
77 "\x{263a}\x{263a}",
78 "$smiley$smiley",
60ff4832 79
4765795a
JH
80 "\x{263a}" x 2,
81 $smiley x 2,
60ff4832
JH
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
JH
90 ok("$length_chars/$regex_chars/$split_chars/$length_bytes" eq
91 "2/2/2/6");
60ff4832
JH
92 }
93}
ffc61ed2 94
ffc61ed2
JH
95
96{
f9a63242
JH
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
JH
102}
103
8ae6c9f9 104{
435e7af6 105 use warnings;
4c26891c
NC
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
NC
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
NC
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
NC
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
NC
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
NC
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 161BANG
097fb8e2 162 qr/^Malformed UTF-8 character \(2 bytes, need 3.+\).*start\d+,end$/s
435e7af6 163 ],
4c26891c
NC
164 );
165 foreach (@tests) {
435e7af6
NC
166 my ($why, $prog, $expect) = @$_;
167 open P, ">$progfile" or die "Can't open '$progfile': $!";
347a2837 168 binmode(P, ":bytes");
4c26891c
NC
169 print P $show, $prog, '; print $b'
170 or die "Print to 'progfile' failed: $!";
435e7af6
NC
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
NC
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}