13 my ($enc, $content, $do_bom) = @_;
14 my $template = $templates{$enc};
15 die "Unsupported encoding $enc" unless $template;
16 my @chars = unpack "U*", $content;
18 # Make surrogate pairs
19 my @remember_that_utf_16_is_variable_length;
20 foreach my $ord (@chars) {
22 push @remember_that_utf_16_is_variable_length,
26 push @remember_that_utf_16_is_variable_length,
27 (0xD800 | ($ord >> 10)), (0xDC00 | ($ord & 0x3FF));
30 @chars = @remember_that_utf_16_is_variable_length;
32 return pack "$template*", ($do_bom ? 0xFEFF : ()), @chars;
36 my ($enc, $write, $expect, $bom, $nl, $name) = @_;
37 open my $fh, ">", "utf$$.pl" or die "utf.pl: $!";
39 print $fh bytes_to_utf($enc, $write . ($nl ? "\n" : ''), $bom);
41 my $got = do "./utf$$.pl";
44 print "not ok $test # $enc $bom $nl $name; got undef\n";
45 } elsif ($got ne $expect) {
46 print "not ok $test # $enc $bom $nl $name; got '$got'\n";
48 print "ok $test # $enc $bom $nl $name\n";
53 for my $enc (qw(utf16le utf16be utf8)) {
55 for my $value (123, 1234, 12345) {
56 test($enc, $value, $value, $bom, $nl, $value);
57 # This has the unfortunate side effect of causing an infinite
58 # loop without the bug fix it corresponds to:
59 test($enc, "($value)", $value, $bom, $nl, "($value)");
61 next if $enc eq 'utf8';
62 # Arguably a bug that currently string literals from UTF-8 file
63 # handles are not implicitly "use utf8", but don't FIXME that
64 # right now, as here we're testing the input filter itself.
66 for my $expect ("N", "\xFF", "\x{100}", "\x{010a}", "\x{0a23}",
67 "\x{10000}", "\x{64321}", "\x{10FFFD}",
68 "\x{1000a}", # 0xD800 0xDC0A
69 "\x{12800}", # 0xD80A 0xDC00
71 # A space so that the UTF-16 heuristic triggers - " '" gives two
72 # characters of ASCII.
73 my $write = " '$expect'";
74 my $name = 'chrs ' . join ', ', map {ord $_} split '', $expect;
75 test($enc, $write, $expect, $bom, $nl, $name);
78 # This is designed to try to trip over the end of the buffer,
79 # with similar results to U-1000A and U-12800 above.
80 for my $pad (2 .. 162) {
81 for my $chr ("\x{10000}", "\x{1000a}", "\x{12800}") {
82 my $padding = ' ' x $pad;
83 # Need 4 octets that were from 2 ASCII characters to trigger
84 # the heuristic that detects UTF-16 without a BOM. For
85 # UTF-16BE, one space and the newline will do, as the
86 # newline's high octet comes first. But for UTF-16LE, a
87 # newline is "\n\0", so it doesn't trigger it.
88 test($enc, " \n$padding'$chr'", $chr, $bom, $nl,
89 sprintf "'\\x{%x}' with $pad spaces before it", ord $chr);
97 1 while unlink "utf$$.pl";