# This file is encoded in US-ASCII.
die "This script is for perl only. You are using $^X.\n" if $^X =~ /jperl/i;

# Johab (code page 1361, KS X 1001:1992 annex 3) multibyte structure, verified
# directly through the runtime API. mb is loaded with require (no source
# filter), so this runs on every perl from 5.005_03 up. All multibyte bytes are
# written with \x escapes so the source stays US-ASCII.
#
# Johab is a two-octet encoding with a DISCONTINUOUS lead:
#   hangul  \x81-\xD3
#   symbols \xD8-\xDE
#   hanja   \xE0-\xF9
# (Microsoft CRT mbctype.c cp1361 lead table). There is NO single high octet:
# \x00-\x7F are the only one-octet units, and the inter-region gaps \xD4-\xD7
# and \xDF are not valid octets at all. The Johab trailing octet range covers
# \x31-\x7E and \x81-\xFE, which INCLUDES \x5C (backslash) and the US-ASCII
# letters, so a \x5C or a \x41 ("A") can sit INSIDE a character and must not be
# seen as a boundary or matched by [A-Z].
#
# Johab characters used here (all three lead regions, two with a buried \x5C):
#   A   US-ASCII single octet   "Z"          (\x5A)
#   C1  hangul  two octets      \x89\x5C      (U+ACA6; trailing \x5C -- buried backslash)
#   C2  hangul  two octets      \x89\x41      (U+AC8C; trailing "A" \x41 -- buried letter)
#   C3  symbol  two octets      \xD9\x31      (U+3000)
#   C4  hanja   two octets      \xE0\x5C      (U+5978; trailing \x5C -- buried backslash)

use strict;
use FindBin;
use lib "$FindBin::Bin/../lib";
require mb;
use vars qw(@test);

mb::set_script_encoding('johab');

my $A  = "\x5A";         # "Z"
my $C1 = "\x89\x5C";     # 2-octet, hangul, trailing \x5C (backslash)
my $C2 = "\x89\x41";     # 2-octet, hangul, trailing "A" (\x41)
my $C3 = "\xD9\x31";     # 2-octet, symbol region lead \xD8-\xDE
my $C4 = "\xE0\x5C";     # 2-octet, hanja region lead \xE0-\xF9, trailing \x5C
my $s  = $A . $C1 . $C2 . $C3 . $C4 . $A;  # 1+2+2+2+2+1 octets, 6 characters

BEGIN { open(GETCFH,">@{[__FILE__]}.getc.tmp") or die $!; binmode GETCFH; print GETCFH "\x5A\x89\x5C\x89\x41\xD9\x31\xE0\x5C\x5A"; close(GETCFH); }
END   { unlink("@{[__FILE__]}.getc.tmp") }

@test = (

# get/set round trip
    sub { mb::get_script_encoding() eq 'johab' },

# octet vs character count
    sub { CORE::length($s) == 10 },
    sub { mb::length($s)   == 6 },

# substr walks by character, keeping each multibyte char whole across all three
# lead regions; the trailing \x5C and \x41 stay inside their characters
    sub { mb::substr($s, 0, 1) eq $A  },
    sub { mb::substr($s, 1, 1) eq $C1 },   # trailing \x5C kept inside the char
    sub { mb::substr($s, 2, 1) eq $C2 },   # trailing \x41 kept inside the char
    sub { mb::substr($s, 3, 1) eq $C3 },   # symbol region
    sub { mb::substr($s, 4, 1) eq $C4 },   # hanja region, trailing \x5C
    sub { mb::substr($s, 5, 1) eq $A  },
    sub { mb::substr($s, -1, 1) eq $A },
    sub { mb::substr($s, 1, 4) eq ($C1 . $C2 . $C3 . $C4) },

# index / rindex return character offsets, not octet offsets
    sub { mb::index($s, $C1) == 1 },
    sub { mb::index($s, $C2) == 2 },
    sub { mb::index($s, $C3) == 3 },
    sub { mb::index($s, $C4) == 4 },
    sub { mb::rindex($s, $A) == 5 },
    sub { mb::index($s, $A)  == 0 },

# the ASCII octet \x41 ("A") buried inside C2 is not findable as a character
    sub { mb::index($s, "\x41") == -1 },

# the octet \x5C (backslash) buried inside C1 and C4 is not findable as a char
    sub { mb::index($s, "\x5C") == -1 },

# reverse keeps each character whole, only reorders them
    sub { mb::reverse($s) eq ($A . $C4 . $C3 . $C2 . $C1 . $A) },

# chop removes one whole character from the end
    sub { my $c = $s; my $ch = mb::chop($c);
          ($ch eq $A) and (mb::length($c) == 5) },

# chop a string whose last character has a trailing \x5C (buried backslash)
    sub { my $c = $A . $C4; my $ch = mb::chop($c);
          ($ch eq $C4) and (mb::length($c) == 1) and ($c eq $A) },

# the multibyte anchor: /./ (transpiled) steps one character at a time
    sub { my $code = mb::parse(q{my @c = $s =~ /(.)/g; scalar(@c)});
          (eval $code) == 6 },
    sub { my $code = mb::parse(q{my @c = $s =~ /(.)/g; $c[1]});
          (eval $code) eq $C1 },
    sub { my $code = mb::parse(q{my @c = $s =~ /(.)/g; $c[4]});
          (eval $code) eq $C4 },

# US-ASCII class [A-Z] matches only the two real "Z" chars, never the \x41
# ("A") buried inside C2
    sub { my $code = mb::parse(q{my $n = () = $s =~ /([A-Z])/g; $n});
          (eval $code) == 2 },

# getc-style lead dispatch: the three discontinuous lead regions imply 2 octets;
# the inter-region gaps \xD4-\xD7 and \xDF, plus \x80 and \xFA-\xFF, do not
    sub { ("\x81" =~ /\A [\x81-\xD3\xD8-\xDE\xE0-\xF9] \z/x) ? 1 : 0 },  # hangul lead
    sub { ("\xD3" =~ /\A [\x81-\xD3\xD8-\xDE\xE0-\xF9] \z/x) ? 1 : 0 },  # hangul lead max
    sub { ("\xD8" =~ /\A [\x81-\xD3\xD8-\xDE\xE0-\xF9] \z/x) ? 1 : 0 },  # symbol lead
    sub { ("\xDE" =~ /\A [\x81-\xD3\xD8-\xDE\xE0-\xF9] \z/x) ? 1 : 0 },  # symbol lead max
    sub { ("\xE0" =~ /\A [\x81-\xD3\xD8-\xDE\xE0-\xF9] \z/x) ? 1 : 0 },  # hanja lead
    sub { ("\xF9" =~ /\A [\x81-\xD3\xD8-\xDE\xE0-\xF9] \z/x) ? 1 : 0 },  # hanja lead max
    sub { ("\x80" =~ /\A [\x81-\xD3\xD8-\xDE\xE0-\xF9] \z/x) ? 0 : 1 },  # below hangul
    sub { ("\xD4" =~ /\A [\x81-\xD3\xD8-\xDE\xE0-\xF9] \z/x) ? 0 : 1 },  # gap D4-D7
    sub { ("\xDF" =~ /\A [\x81-\xD3\xD8-\xDE\xE0-\xF9] \z/x) ? 0 : 1 },  # gap DF
    sub { ("\xFA" =~ /\A [\x81-\xD3\xD8-\xDE\xE0-\xF9] \z/x) ? 0 : 1 },  # above hanja

# mb::getc reads one whole character at a time from a real filehandle, across
# all three lead regions, keeping the buried \x5C and \x41 octets inside
    sub { open(GETCFH,"@{[__FILE__]}.getc.tmp") or die $!; binmode GETCFH;
          my $c1 = mb::getc(*GETCFH); my $c2 = mb::getc(*GETCFH);
          my $c3 = mb::getc(*GETCFH); my $c4 = mb::getc(*GETCFH);
          my $c5 = mb::getc(*GETCFH); my $c6 = mb::getc(*GETCFH);
          my $c7 = mb::getc(*GETCFH);
          close(GETCFH);
          ($c1 eq $A) and ($c2 eq $C1) and ($c3 eq $C2) and
          ($c4 eq $C3) and ($c5 eq $C4) and ($c6 eq $A) and (not defined $c7) },

# truncated input: a file that ends in the MIDDLE of a 2-octet character. For
# each of the three lead regions, mb::getc must read the single lead octet that
# is present, return it, and MUST NOT warn "uninitialized value" when the
# trailing octet hits EOF. The next mb::getc then returns undef. Warnings are
# forced on with local $^W and captured with $SIG{__WARN__} so this stays a
# real guard even under `perl` (no -w). $w must stay empty.

# hangul lead \x89 truncated after 1 of 2 octets
    sub { open(TRUNCFH,">@{[__FILE__]}.trunc.tmp") or die $!;
          binmode TRUNCFH; print TRUNCFH "\x89"; close(TRUNCFH);
          my $w = ''; local $^W = 1; local $SIG{__WARN__} = sub { $w .= $_[0] };
          open(TRUNCFH,"@{[__FILE__]}.trunc.tmp") or die $!; binmode TRUNCFH;
          my $c1 = mb::getc(*TRUNCFH); my $c2 = mb::getc(*TRUNCFH);
          close(TRUNCFH); unlink("@{[__FILE__]}.trunc.tmp");
          ($c1 eq "\x89") and (not defined $c2) and ($w eq '') },

# symbol lead \xD9 truncated after 1 of 2 octets
    sub { open(TRUNCFH,">@{[__FILE__]}.trunc.tmp") or die $!;
          binmode TRUNCFH; print TRUNCFH "\xD9"; close(TRUNCFH);
          my $w = ''; local $^W = 1; local $SIG{__WARN__} = sub { $w .= $_[0] };
          open(TRUNCFH,"@{[__FILE__]}.trunc.tmp") or die $!; binmode TRUNCFH;
          my $c1 = mb::getc(*TRUNCFH); my $c2 = mb::getc(*TRUNCFH);
          close(TRUNCFH); unlink("@{[__FILE__]}.trunc.tmp");
          ($c1 eq "\xD9") and (not defined $c2) and ($w eq '') },

# hanja lead \xE0 truncated after 1 of 2 octets
    sub { open(TRUNCFH,">@{[__FILE__]}.trunc.tmp") or die $!;
          binmode TRUNCFH; print TRUNCFH "\xE0"; close(TRUNCFH);
          my $w = ''; local $^W = 1; local $SIG{__WARN__} = sub { $w .= $_[0] };
          open(TRUNCFH,"@{[__FILE__]}.trunc.tmp") or die $!; binmode TRUNCFH;
          my $c1 = mb::getc(*TRUNCFH); my $c2 = mb::getc(*TRUNCFH);
          close(TRUNCFH); unlink("@{[__FILE__]}.trunc.tmp");
          ($c1 eq "\xE0") and (not defined $c2) and ($w eq '') },

# strict validity: the well-formed sample is valid; the inter-region gap octets
# \xD4 and \xDF are not valid Johab
    sub { mb::valid($s) == 1 },
    sub { mb::valid($A . $C1 . $C4 . $A) == 1 },
    sub { mb::valid("\xD4") == 0 },
    sub { mb::valid("\xDF") == 0 },
    sub { mb::valid("\x89") == 0 },   # lone hangul lead, no trailing octet
);

$|=1; print "1..",scalar(@test),"\n"; my $testno=1; sub ok { print $_[0]?'ok ':'not ok ',$testno++,$_[1]?" - $_[1]\n":"\n" } ok($_->()) for @test;

__END__
