t/comp/utf.t

   1 #!./perl -w
   2
   3 print "1..4016\n";
   4 my $test = 0;
   5
   6 my %templates = (
   7                  'UTF-8'    => 'C0U',
   8                  'UTF-16BE' => 'n',
   9                  'UTF-16LE' => '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 'UTF-8') {
  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         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         }
  49     } elsif ($got ne $expect) {
  50         print "not ok $test # $enc $bom $nl $name; got '$got'\n";
  51     } else {
  52         print "ok $test # $enc $bom $nl $name\n";
  53     }
  54 }
  55
  56 for my $bom (0, 1) {
  57     for my $enc (qw(UTF-16LE UTF-16BE UTF-8)) {
  58         for my $nl (1, 0) {
  59             for my $value (123, 1234, 12345) {
  60                 test($enc, $value, $value, $bom, $nl, $value);
  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)");
  64             }
  65             next if $enc eq 'UTF-8';
  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
  70             for my $expect ("N", "\xFF", "\x{100}", "\x{010a}", "\x{0a23}",
  71                             "\x{10000}", "\x{64321}", "\x{10FFFD}",
  72                             "\x{1000a}", # 0xD800 0xDC0A
  73                             "\x{12800}", # 0xD80A 0xDC00
  74                            ) {
  75                 # A space so that the UTF-16 heuristic triggers - " '" gives two
  76                 # characters of ASCII.
  77                 my $write = " '$expect'";
  78                 my $name = 'chrs ' . join ', ', map {ord $_} split '', $expect;
  79                 test($enc, $write, $expect, $bom, $nl, $name);
  80             }
  81
  82             # This is designed to try to trip over the end of the buffer,
  83             # with similar results to U-1000A and U-12800 above.
  84             for my $pad (2 .. 162) {
  85                 for my $chr ("\x{10000}", "\x{1000a}", "\x{12800}") {
  86                     my $padding = ' ' x $pad;
  87                     # Need 4 octets that were from 2 ASCII characters to trigger
  88                     # the heuristic that detects UTF-16 without a BOM. For
  89                     # UTF-16BE, one space and the newline will do, as the
  90                     # newline's high octet comes first. But for UTF-16LE, a
  91                     # newline is "\n\0", so it doesn't trigger it.
  92                     test($enc, "  \n$padding'$chr'", $chr, $bom, $nl,
  93                          sprintf "'\\x{%x}' with $pad spaces before it", ord $chr);
  94                 }
  95             }
  96         }
  97     }
  98 }
  99
 100 END {
 101     1 while unlink "utf$$.pl";
 102 }