Integrate mainline

p4raw-id: //depot/perlio@15801

4 files changed, 174 insertions, 8 deletions

diff --git a/ext/Encode/t/Aliases.t b/ext/Encode/t/Aliases.t
index 846884ed34..4c6570fc30 100644
--- a/ext/Encode/t/Aliases.t
+++ b/ext/Encode/t/Aliases.t
@@ -22,9 +22,16 @@ sub init_a2c{
     %a2c = (
 	    'US-ascii' => 'ascii',
 	    'UTF-8'    => 'utf8',
-	    'UTF-16BE' => 'UCS-2',
-	    'ucs-2le'  => 'UTF-16LE',
-	    'ucs2-le'  => 'UTF-16LE',
+	    'UCS-2'    => 'UCS-2BE',
+	    'UCS2'     => 'UCS-2BE',
+	    'iso-10646-1' => 'UCS-2BE',
+	    'ucs2-le'  => 'UCS-2LE',
+	    'utf16'    => 'UTF-16',
+	    'utf32'    => 'UTF-32',
+	    'utf16-be'  => 'UTF-16BE',
+	    'utf32-be'  => 'UTF-32BE',
+	    'utf16-le'  => 'UTF-16LE',
+	    'utf32-le'  => 'UTF-32LE',
 	    'cyrillic' => 'iso-8859-5',
 	    'arabic'   => 'iso-8859-6',
 	    'greek'    => 'iso-8859-7',
@@ -54,11 +61,15 @@ sub init_a2c{
 	    'zh_TW.Big5'    => $ON_EBCDIC ? '' : 'big5',
 	    'big5-hk'	    => $ON_EBCDIC ? '' : 'big5-hkscs',
 	    'GB_2312-80'    => $ON_EBCDIC ? '' : 'euc-cn',
-	    'gb2312-raw'    => $ON_EBCDIC ? '' : 'gb2312-raw',
-	    'gb12345-raw'   => $ON_EBCDIC ? '' : 'gb12345-raw',
 	    'KS_C_5601-1987'    => $ON_EBCDIC ? '' : 'cp949',
-	    'ksc5601-raw'       => $ON_EBCDIC ? '' : 'ksc5601-raw',
-	    );
+	    #
+	    'gb12345-raw'   => $ON_EBCDIC ? '' : 'gb12345-raw',
+	    'gb2312-raw'    => $ON_EBCDIC ? '' : 'gb2312-raw',
+	    'jis0201-raw'   => $ON_EBCDIC ? '' : 'jis0201-raw',
+	    'jis0208-raw'   => $ON_EBCDIC ? '' : 'jis0208-raw',
+	    'jis0212-raw'   => $ON_EBCDIC ? '' : 'jis0212-raw',
+	    'ksc5601-raw'   => $ON_EBCDIC ? '' : 'ksc5601-raw',
+	   );
 
     for my $i (1..11,13..16){
 	$a2c{"ISO 8859 $i"} = "iso-8859-$i";
diff --git a/ext/Encode/t/Unicode.t b/ext/Encode/t/Unicode.t
new file mode 100644
index 0000000000..75486ad5b8
--- /dev/null
+++ b/ext/Encode/t/Unicode.t
@@ -0,0 +1,92 @@
+#
+# $Id: Unicode.t,v 1.2 2002/04/07 17:22:31 dankogai Exp dankogai $
+#
+# This script is written entirely in ASCII, even though quoted literals
+# do include non-BMP unicode characters -- Are you happy, jhi?
+#
+
+BEGIN {
+     require Config; import Config;
+     if ($Config{'extensions'} !~ /\bEncode\b/) {
+       print "1..0 # Skip: Encode was not built\n";
+       exit 0;
+     }
+# should work without perlio
+#     unless (find PerlIO::Layer 'perlio') {
+#       print "1..0 # Skip: PerlIO was not built\n";
+#       exit 0;
+#     }
+# should work on EBCDIC
+#    if (ord("A") == 193) {
+#       print "1..0 # Skip: EBCDIC\n";
+#       exit 0;
+#    }
+     $| = 1;
+}
+
+use strict;
+#use Test::More 'no_plan';
+use Test::More tests => 22;
+use Encode qw(encode decode);
+
+#
+# see
+# http://www.unicode.org/unicode/reports/tr19/
+#
+
+my $nasty      = "\x{004D}\x{0061}\x{1abcd}";
+my $fallback   = "\x{004D}\x{0061}\x{fffd}";
+
+#hi: (0x1abcd - 0x10000) / 0x400 + 0xD800 = 0xd82a
+#lo: (0x1abcd - 0x10000) % 0x400 + 0xDC00 = 0xdfcd
+
+my $n_16be =
+     pack("C*", map {hex($_)} qw<00 4D 00 61 d8 2a df cd>);
+my $n_16le =
+     pack("C*", map {hex($_)} qw<4D 00 61 00 2a d8 cd df>);
+my $f_16be =
+     pack("C*", map {hex($_)} qw<00 4D 00 61 ff fd>);
+my $f_16le =
+     pack("C*", map {hex($_)} qw<4D 00 61 00 fd ff>);
+my $n_32be =
+     pack("C*", map {hex($_)} qw<00 00 00 4D 00 00 00 61 00 01 ab cd>);
+my $n_32le =
+     pack("C*", map {hex($_)} qw<4D 00 00 00 61 00 00 00 cd ab 01 00>);
+
+my $n_16bb = pack('n', Encode::Unicode::BOM_BE)  . $n_16be;
+my $n_16lb = pack('n', Encode::Unicode::BOM16LE) . $n_16le;
+my $n_32bb = pack('N', Encode::Unicode::BOM_BE ) . $n_32be;
+my $n_32lb = pack('N', Encode::Unicode::BOM32LE) . $n_32le;
+
+is($n_16be, encode('UTF-16BE', $nasty),  qq{encode UTF-16BE});
+is($n_16le, encode('UTF-16LE', $nasty),  qq{encode UTF-16LE});
+is($n_32be, encode('UTF-32BE', $nasty),  qq{encode UTF-32BE});
+is($n_32le, encode('UTF-32LE', $nasty),  qq{encode UTF-16LE});
+
+is($nasty,  decode('UTF-16BE', $n_16be), qq{decode UTF-16BE});
+is($nasty,  decode('UTF-16LE', $n_16le), qq{decode UTF-16LE});
+is($nasty,  decode('UTF-32BE', $n_32be), qq{decode UTF-32BE});
+is($nasty,  decode('UTF-32LE', $n_32le), qq{decode UTF-32LE});
+
+is($n_16bb, encode('UTF-16',   $nasty),  qq{encode UTF-16});
+is($n_32bb, encode('UTF-32',   $nasty),  qq{encode UTF-32});
+is($nasty,  decode('UTF-16',   $n_16bb), qq{decode UTF-16, bom=be});
+is($nasty,  decode('UTF-16',   $n_16lb), qq{decode UTF-16, bom=le});
+is($nasty,  decode('UTF-32',   $n_32bb), qq{decode UTF-32, bom=be});
+is($nasty,  decode('UTF-32',   $n_32lb), qq{decode UTF-32, bom=le});
+
+is(decode('UCS-2BE', $n_16be), $fallback, "decode UCS-2BE: fallback");
+is(decode('UCS-2LE', $n_16le), $fallback, "decode UCS-2LE: fallback");
+eval { decode('UCS-2BE', $n_16be, 1) };
+ok($@=~/^UCS-2BE:/, "decode UCS-2BE: exception");
+eval { decode('UCS-2LE', $n_16le, 1) };
+ok($@=~/^UCS-2LE:/, "decode UCS-2LE: exception");
+is(encode('UCS-2BE', $nasty), $f_16be, "encode UCS-2BE: fallback");
+is(encode('UCS-2LE', $nasty), $f_16le, "encode UCS-2LE: fallback");
+eval { encode('UCS-2BE', $nasty, 1) };
+ok($@=~/^UCS-2BE:/, "encode UCS-2BE: exception");
+eval { encode('UCS-2LE', $nasty, 1) };
+ok($@=~/^UCS-2LE:/, "encode UCS-2LE: exception");
+
+1;
+__END__
diff --git a/ext/Encode/t/jperl.t b/ext/Encode/t/jperl.t
index 48999054f1..a43a6debe8 100644
--- a/ext/Encode/t/jperl.t
+++ b/ext/Encode/t/jperl.t
@@ -1,5 +1,5 @@
 #
-# $Id: jperl.t,v 1.20 2002/04/04 19:50:52 dankogai Exp dankogai $
+# $Id: jperl.t,v 1.20 2002/04/04 19:50:52 dankogai Exp $
 #
 # This script is written in euc-jp
 
diff --git a/ext/Encode/t/unibench.pl b/ext/Encode/t/unibench.pl
new file mode 100644
index 0000000000..0d8dbf08bc
--- /dev/null
+++ b/ext/Encode/t/unibench.pl
@@ -0,0 +1,63 @@
+#!./perl
+
+use strict;
+use Encode;
+use Benchmark qw(:all);
+
+my $Count = shift @ARGV;
+$Count ||= 16;
+my @sizes = @ARGV || (1, 4, 16);
+
+my %utf8_seed;
+for my $i (0x00..0xff){
+    my $c = chr($i);
+    $utf8_seed{BMP} .= ($c =~ /^\p{IsPrint}/o) ? $c : " ";
+}
+utf8::upgrade($utf8_seed{BMP});
+
+for my $i (0x00..0xff){
+    my $c = chr(0x10000+$i);
+    $utf8_seed{HIGH} .= ($c =~ /^\p{IsPrint}/o) ? $c : " ";
+}
+utf8::upgrade($utf8_seed{HIGH});
+
+my %S;
+for my $i (@sizes){
+    my $sz = 256 * $i;
+    for my $cp (qw(BMP HIGH)){
+	$S{utf8}{$sz}{$cp}  = $utf8_seed{$cp} x $i;
+	$S{utf16}{$sz}{$cp} = encode('UTF-16BE', $S{utf8}{$sz}{$cp});
+    }
+}
+
+for my $i (@sizes){
+    my $sz = $i * 256;
+    my $count = $Count * int(256/$i);
+    for my $cp (qw(BMP HIGH)){
+	for my $op (qw(encode decode)){
+	    my ($meth, $from, $to) = ($op eq 'encode') ?
+		(\&encode, 'utf8', 'utf16') : (\&decode, 'utf16', 'utf8');
+	    my $modern = sub {
+		Encode::Unicode::set_transcoder("modern");  
+		$meth->('UTF-16BE', $S{$from}{$sz}{$cp})
+		     eq $S{$to}{$sz}{$cp} 
+			 or die "$op,$from,$to,$sz,$cp";
+	    };
+	    my $classic = sub {
+		Encode::Unicode::set_transcoder("classic");  
+		$meth->('UTF-16BE', $S{$from}{$sz}{$cp})
+		     eq $S{$to}{$sz}{$cp} or 
+			 die "$op,$from,$to,$sz,$cp";
+	    };
+	    print "---- $op length=$sz/range=$cp ----\n";
+	    my $r = timethese($count,
+		     {
+		      "Modern" => $modern,
+		      "Classic" => $classic,
+		     },
+		     'none',
+		    );
+	    cmpthese($r);
+	}
+    }
+}