1#!./perl -w
2
3print "1..4216\n";
4my $test = 0;
5
6my %templates = (
7		 'UTF-8'    => 'C0U',
8		 'UTF-16BE' => 'n',
9		 'UTF-16LE' => 'v',
10		);
11
12sub 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
35sub test {
36    my ($enc, $write, $expect, $bom, $nl, $name) = @_;
37    open my $fh, ">", "tmputf$$.pl" or die "tmputf$$.pl: $!";
38    binmode $fh;
39    print $fh bytes_to_utf($enc, $write . ($nl ? "\n" : ''), $bom);
40    close $fh or die $!;
41    my $got = do "./tmputf$$.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
56for 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 (
71		"N", "\x{010a}", "\x{0a23}", "\x{64321}", "\x{10FFFD}",
72		"\x{1000a}", # 0xD800 0xDC0A
73		"\x{12800}", # 0xD80A 0xDC00
74		# explore a bunch of bit-width boundaries
75		map { chr((1 << $_) - 1), chr(1 << $_) } 7 .. 20
76	    ) {
77		# A space so that the UTF-16 heuristic triggers - " '" gives two
78		# characters of ASCII.
79		my $write = " '$expect'";
80		my $name = 'chrs ' . join ', ', map {sprintf "%#x", ord $_} split '', $expect;
81		test($enc, $write, $expect, $bom, $nl, $name);
82	    }
83
84	    # This is designed to try to trip over the end of the buffer,
85	    # with similar results to U-1000A and U-12800 above.
86	    for my $pad (2 .. 162) {
87		for my $chr ("\x{10000}", "\x{1000a}", "\x{12800}") {
88		    my $padding = ' ' x $pad;
89		    # Need 4 octets that were from 2 ASCII characters to trigger
90		    # the heuristic that detects UTF-16 without a BOM. For
91		    # UTF-16BE, one space and the newline will do, as the
92		    # newline's high octet comes first. But for UTF-16LE, a
93		    # newline is "\n\0", so it doesn't trigger it.
94		    test($enc, "  \n$padding'$chr'", $chr, $bom, $nl,
95			 sprintf "'\\x{%x}' with $pad spaces before it", ord $chr);
96		}
97	    }
98	}
99    }
100}
101
102END {
103    1 while unlink "tmputf$$.pl";
104}
105