-#!./perl
-
-BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
- unless (find PerlIO::Layer 'perlio') {
- print "1..0 # Skip: not perlio\n";
- exit 0;
- }
- if ($ENV{PERL_CORE_MINITEST}) {
- print "1..0 # Skip: no dynamic loading on miniperl, no threads\n";
- exit 0;
- }
- require Config; import Config;
- if ($Config{'extensions'} !~ /\bEncode\b/) {
- print "1..0 # Skip: Encode was not built\n";
- exit 0;
- }
-}
+#!./perl -w
-BEGIN { require "./test.pl"; }
+print "1..3980\n";
+my $test = 0;
-plan(tests => 18);
+my %templates = (
+ utf8 => 'C0U',
+ utf16be => 'n',
+ utf16le => 'v',
+ );
-my $BOM = chr(0xFEFF);
+sub bytes_to_utf {
+ my ($enc, $content, $do_bom) = @_;
+ my $template = $templates{$enc};
+ die "Unsupported encoding $enc" unless $template;
+ my @chars = unpack "U*", $content;
+ if ($enc ne 'utf8') {
+ # Make surrogate pairs
+ my @remember_that_utf_16_is_variable_length;
+ foreach my $ord (@chars) {
+ if ($ord < 0x10000) {
+ push @remember_that_utf_16_is_variable_length,
+ $ord;
+ } else {
+ $ord -= 0x10000;
+ push @remember_that_utf_16_is_variable_length,
+ (0xD800 | ($ord >> 10)), (0xDC00 | ($ord & 0x3FF));
+ }
+ }
+ @chars = @remember_that_utf_16_is_variable_length;
+ }
+ return pack "$template*", ($do_bom ? 0xFEFF : ()), @chars;
+}
sub test {
- my ($enc, $tag, $bom) = @_;
- open(UTF_PL, ">:raw:encoding($enc)", "utf$$.pl")
- or die "utf.pl($enc,$tag,$bom): $!";
- print UTF_PL $BOM if $bom;
- print UTF_PL "$tag\n";
- close(UTF_PL);
+ my ($enc, $write, $expect, $bom, $nl, $name) = @_;
+ open my $fh, ">", "utf$$.pl" or die "utf.pl: $!";
+ binmode $fh;
+ print $fh bytes_to_utf($enc, $write . ($nl ? "\n" : ''), $bom);
+ close $fh or die $!;
my $got = do "./utf$$.pl";
- is($got, $tag);
+ $test = $test + 1;
+ if (!defined $got) {
+ print "not ok $test # $enc $bom $nl $name; got undef\n";
+ } elsif ($got ne $expect) {
+ print "not ok $test # $enc $bom $nl $name; got '$got'\n";
+ } else {
+ print "ok $test # $enc $bom $nl $name\n";
+ }
}
-test("utf16le", 123, 1);
-test("utf16le", 1234, 1);
-test("utf16le", 12345, 1);
-test("utf16be", 123, 1);
-test("utf16be", 1234, 1);
-test("utf16be", 12345, 1);
-test("utf8", 123, 1);
-test("utf8", 1234, 1);
-test("utf8", 12345, 1);
-
-test("utf16le", 123, 0);
-test("utf16le", 1234, 0);
-test("utf16le", 12345, 0);
-test("utf16be", 123, 0);
-test("utf16be", 1234, 0);
-test("utf16be", 12345, 0);
-test("utf8", 123, 0);
-test("utf8", 1234, 0);
-test("utf8", 12345, 0);
+for my $bom (0, 1) {
+ for my $enc (qw(utf16le utf16be utf8)) {
+ for my $nl (1, 0) {
+ for my $value (123, 1234, 12345) {
+ test($enc, $value, $value, $bom, $nl, $value);
+ }
+ next if $enc eq 'utf8';
+ # Arguably a bug that currently string literals from UTF-8 file
+ # handles are not implicitly "use utf8", but don't FIXME that
+ # right now, as here we're testing the input filter itself.
+
+ for my $expect ("N", "\xFF", "\x{100}", "\x{010a}", "\x{0a23}",
+ "\x{10000}", "\x{64321}", "\x{10FFFD}",
+ "\x{1000a}", # 0xD800 0xDC0A
+ "\x{12800}", # 0xD80A 0xDC00
+ ) {
+ # A space so that the UTF-16 heuristic triggers - " '" gives two
+ # characters of ASCII.
+ my $write = " '$expect'";
+ my $name = 'chrs ' . join ', ', map {ord $_} split '', $expect;
+ test($enc, $write, $expect, $bom, $nl, $name);
+ }
+
+ # This is designed to try to trip over the end of the buffer,
+ # with similar results to U-1000A and U-12800 above.
+ for my $pad (2 .. 162) {
+ for my $chr ("\x{10000}", "\x{1000a}", "\x{12800}") {
+ my $padding = ' ' x $pad;
+ # Need 4 octets that were from 2 ASCII characters to trigger
+ # the heuristic that detects UTF-16 without a BOM. For
+ # UTF-16BE, one space and the newline will do, as the
+ # newline's high octet comes first. But for UTF-16LE, a
+ # newline is "\n\0", so it doesn't trigger it.
+ test($enc, " \n$padding'$chr'", $chr, $bom, $nl,
+ sprintf "'\\x{%x}' with $pad spaces before it", ord $chr);
+ }
+ }
+ }
+ }
+}
END {
1 while unlink "utf$$.pl";