Uncomment and fix up tests at the end of Storable's blessed.t

[perl5.git] / t / comp / utf.t

diff --git a/t/comp/utf.t b/t/comp/utf.t
index 90a9e5e..f5190f9 100644 (file)
--- a/t/comp/utf.t
+++ b/t/comp/utf.t
@@ -1,57 +1,102 @@
-#!./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
 
-require "./test.pl";
+print "1..4016\n";
+my $test = 0;
 
-plan(tests => 15);
+my %templates = (
+                'UTF-8'    => 'C0U',
+                'UTF-16BE' => 'n',
+                'UTF-16LE' => '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 'UTF-8') {
+       # 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 $got = do "./utf.pl";
-    is($got, $tag);
+    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";
+    $test = $test + 1;
+    if (!defined $got) {
+       if ($@ =~ /^(Unsupported script encoding \Q$enc\E)/) {
+           print "ok $test # skip $1\n";
+        } else {
+           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);
+for my $bom (0, 1) {
+    for my $enc (qw(UTF-16LE UTF-16BE UTF-8)) {
+       for my $nl (1, 0) {
+           for my $value (123, 1234, 12345) {
+               test($enc, $value, $value, $bom, $nl, $value);
+               # This has the unfortunate side effect of causing an infinite
+               # loop without the bug fix it corresponds to:
+               test($enc, "($value)", $value, $bom, $nl, "($value)");
+           }
+           next if $enc eq 'UTF-8';
+           # 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";
+    1 while unlink "utf$$.pl";
 }