This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
S_utf16_textfilter() was not returning EOF correctly in some situations.
[perl5.git] / t / comp / utf.t
1 #!./perl -w
2
3 print "1..4016\n";
4 my $test = 0;
5
6 my %templates = (
7                  utf8 => 'C0U',
8                  utf16be => 'n',
9                  utf16le => 'v',
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;
16     my @chars = unpack "U*", $content;
17     if ($enc ne 'utf8') {
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;
33 }
34
35 sub test {
36     my ($enc, $write, $expect, $bom, $nl, $name) = @_;
37     open my $fh, ">", "utf$$.pl" or die "utf.pl: $!";
38     binmode $fh;
39     print $fh bytes_to_utf($enc, $write . ($nl ? "\n" : ''), $bom);
40     close $fh or die $!;
41     my $got = do "./utf$$.pl";
42     $test = $test + 1;
43     if (!defined $got) {
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";
47     } else {
48         print "ok $test # $enc $bom $nl $name\n";
49     }
50 }
51
52 for my $bom (0, 1) {
53     for my $enc (qw(utf16le utf16be utf8)) {
54         for my $nl (1, 0) {
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)");
60             }
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.
65
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
70                            ) {
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);
76             }
77
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);
90                 }
91             }
92         }
93     }
94 }
95
96 END {
97     1 while unlink "utf$$.pl";
98 }