Commit | Line | Data |
---|---|---|
61ad1ccd | 1 | #!./perl -w |
7aa207d6 | 2 | |
d52b8576 | 3 | print "1..4216\n"; |
61ad1ccd | 4 | my $test = 0; |
7aa207d6 | 5 | |
5c7da53c | 6 | my %templates = ( |
ee6ba15d EB |
7 | 'UTF-8' => 'C0U', |
8 | 'UTF-16BE' => 'n', | |
9 | 'UTF-16LE' => 'v', | |
5c7da53c NC |
10 | ); |
11 | ||
12 | sub bytes_to_utf { | |
13 | my ($enc, $content, $do_bom) = @_; | |
14 | my $template = $templates{$enc}; | |
15 | die "Unsupported encoding $enc" unless $template; | |
b3766b12 | 16 | my @chars = unpack "U*", $content; |
ee6ba15d | 17 | if ($enc ne 'UTF-8') { |
b3766b12 NC |
18 | # Make surrogate pairs |
19 | my @remember_that_utf_16_is_variable_length; | |
20 | foreach my $ord (@chars) { | |
21 | if ($ord < 0x10000) { | |
22 | push @remember_that_utf_16_is_variable_length, | |
23 | $ord; | |
24 | } else { | |
25 | $ord -= 0x10000; | |
26 | push @remember_that_utf_16_is_variable_length, | |
27 | (0xD800 | ($ord >> 10)), (0xDC00 | ($ord & 0x3FF)); | |
28 | } | |
29 | } | |
30 | @chars = @remember_that_utf_16_is_variable_length; | |
31 | } | |
32 | return pack "$template*", ($do_bom ? 0xFEFF : ()), @chars; | |
5c7da53c | 33 | } |
7aa207d6 JH |
34 | |
35 | sub test { | |
02512a66 | 36 | my ($enc, $write, $expect, $bom, $nl, $name) = @_; |
5c7da53c NC |
37 | open my $fh, ">", "utf$$.pl" or die "utf.pl: $!"; |
38 | binmode $fh; | |
02512a66 | 39 | print $fh bytes_to_utf($enc, $write . ($nl ? "\n" : ''), $bom); |
5c7da53c | 40 | close $fh or die $!; |
2d90ac95 | 41 | my $got = do "./utf$$.pl"; |
61ad1ccd NC |
42 | $test = $test + 1; |
43 | if (!defined $got) { | |
ee6ba15d EB |
44 | if ($@ =~ /^(Unsupported script encoding \Q$enc\E)/) { |
45 | print "ok $test # skip $1\n"; | |
46 | } else { | |
47 | print "not ok $test # $enc $bom $nl $name; got undef\n"; | |
48 | } | |
02512a66 NC |
49 | } elsif ($got ne $expect) { |
50 | print "not ok $test # $enc $bom $nl $name; got '$got'\n"; | |
61ad1ccd | 51 | } else { |
02512a66 | 52 | print "ok $test # $enc $bom $nl $name\n"; |
61ad1ccd | 53 | } |
7aa207d6 JH |
54 | } |
55 | ||
386ac4df | 56 | for my $bom (0, 1) { |
ee6ba15d | 57 | for my $enc (qw(UTF-16LE UTF-16BE UTF-8)) { |
02512a66 NC |
58 | for my $nl (1, 0) { |
59 | for my $value (123, 1234, 12345) { | |
60 | test($enc, $value, $value, $bom, $nl, $value); | |
d2d1d4de NC |
61 | # This has the unfortunate side effect of causing an infinite |
62 | # loop without the bug fix it corresponds to: | |
63 | test($enc, "($value)", $value, $bom, $nl, "($value)"); | |
02512a66 | 64 | } |
ee6ba15d | 65 | next if $enc eq 'UTF-8'; |
02512a66 NC |
66 | # Arguably a bug that currently string literals from UTF-8 file |
67 | # handles are not implicitly "use utf8", but don't FIXME that | |
68 | # right now, as here we're testing the input filter itself. | |
69 | ||
d52b8576 HS |
70 | for my $expect ( |
71 | "N", "\x{010a}", "\x{0a23}", "\x{64321}", "\x{10FFFD}", | |
72 | "\x{1000a}", # 0xD800 0xDC0A | |
73 | "\x{12800}", # 0xD80A 0xDC00 | |
74 | # explore a bunch of bit-width boundaries | |
75 | map { chr((1 << $_) - 1), chr(1 << $_) } 7 .. 20 | |
76 | ) { | |
b3766b12 | 77 | # A space so that the UTF-16 heuristic triggers - " '" gives two |
02512a66 NC |
78 | # characters of ASCII. |
79 | my $write = " '$expect'"; | |
d52b8576 | 80 | my $name = 'chrs ' . join ', ', map {sprintf "%#x", ord $_} split '', $expect; |
02512a66 | 81 | test($enc, $write, $expect, $bom, $nl, $name); |
c28d6105 | 82 | } |
ba77e4cc NC |
83 | |
84 | # This is designed to try to trip over the end of the buffer, | |
85 | # with similar results to U-1000A and U-12800 above. | |
86 | for my $pad (2 .. 162) { | |
87 | for my $chr ("\x{10000}", "\x{1000a}", "\x{12800}") { | |
88 | my $padding = ' ' x $pad; | |
89 | # Need 4 octets that were from 2 ASCII characters to trigger | |
90 | # the heuristic that detects UTF-16 without a BOM. For | |
91 | # UTF-16BE, one space and the newline will do, as the | |
92 | # newline's high octet comes first. But for UTF-16LE, a | |
93 | # newline is "\n\0", so it doesn't trigger it. | |
94 | test($enc, " \n$padding'$chr'", $chr, $bom, $nl, | |
95 | sprintf "'\\x{%x}' with $pad spaces before it", ord $chr); | |
96 | } | |
97 | } | |
386ac4df NC |
98 | } |
99 | } | |
100 | } | |
7aa207d6 JH |
101 | |
102 | END { | |
2d90ac95 | 103 | 1 while unlink "utf$$.pl"; |
7aa207d6 | 104 | } |