1N/A#!./perl -w
1N/A
1N/ABEGIN {
1N/A chdir 't' if -d 't';
1N/A @INC = '../lib';
1N/A no warnings; # Need global -w flag for later tests, but don't want this
1N/A # to warn here:
1N/A push @INC, "::lib:$MacPerl::Architecture:" if $^O eq 'MacOS';
1N/A unless (find PerlIO::Layer 'perlio') {
1N/A print "1..0 # Skip: not perlio\n";
1N/A exit 0;
1N/A }
1N/A unless (eval { require Encode } ) {
1N/A print "1..0 # Skip: not Encode\n";
1N/A exit 0;
1N/A }
1N/A}
1N/A
1N/Aprint "1..14\n";
1N/A
1N/Amy $grk = "grk$$";
1N/Amy $utf = "utf$$";
1N/Amy $fail1 = "fa$$";
1N/Amy $fail2 = "fb$$";
1N/Amy $russki = "koi8r$$";
1N/Amy $threebyte = "3byte$$";
1N/A
1N/Aif (open(GRK, ">$grk")) {
1N/A binmode(GRK, ":bytes");
1N/A # alpha beta gamma in ISO 8859-7
1N/A print GRK "\xe1\xe2\xe3";
1N/A close GRK or die "Could not close: $!";
1N/A}
1N/A
1N/A{
1N/A open(my $i,'<:encoding(iso-8859-7)',$grk);
1N/A print "ok 1\n";
1N/A open(my $o,'>:utf8',$utf);
1N/A print "ok 2\n";
1N/A print $o readline($i);
1N/A print "ok 3\n";
1N/A close($o) or die "Could not close: $!";
1N/A close($i);
1N/A}
1N/A
1N/Aif (open(UTF, "<$utf")) {
1N/A binmode(UTF, ":bytes");
1N/A if (ord('A') == 193) { # EBCDIC
1N/A # alpha beta gamma in UTF-EBCDIC Unicode (0x3b1 0x3b2 0x3b3)
1N/A print "not " unless <UTF> eq "\xb4\x58\xb4\x59\xb4\x62";
1N/A } else {
1N/A # alpha beta gamma in UTF-8 Unicode (0x3b1 0x3b2 0x3b3)
1N/A print "not " unless <UTF> eq "\xce\xb1\xce\xb2\xce\xb3";
1N/A }
1N/A print "ok 4\n";
1N/A close UTF;
1N/A}
1N/A
1N/A{
1N/A use Encode;
1N/A open(my $i,'<:utf8',$utf);
1N/A print "ok 5\n";
1N/A open(my $o,'>:encoding(iso-8859-7)',$grk);
1N/A print "ok 6\n";
1N/A print $o readline($i);
1N/A print "ok 7\n";
1N/A close($o) or die "Could not close: $!";
1N/A close($i);
1N/A}
1N/A
1N/Aif (open(GRK, "<$grk")) {
1N/A binmode(GRK, ":bytes");
1N/A print "not " unless <GRK> eq "\xe1\xe2\xe3";
1N/A print "ok 8\n";
1N/A close GRK;
1N/A}
1N/A
1N/A$SIG{__WARN__} = sub {$warn .= $_[0]};
1N/A
1N/Aif (open(FAIL, ">:encoding(NoneSuch)", $fail1)) {
1N/A print "not ok 9 # Open should fail\n";
1N/A} else {
1N/A print "ok 9\n";
1N/A}
1N/Aif (!defined $warn) {
1N/A print "not ok 10 # warning is undef\n";
1N/A} elsif ($warn =~ /^Cannot find encoding "NoneSuch" at/) {
1N/A print "ok 10\n";
1N/A} else {
1N/A print "not ok 10 # warning is '$warn'";
1N/A}
1N/A
1N/Aif (open(RUSSKI, ">$russki")) {
1N/A print RUSSKI "\x3c\x3f\x78";
1N/A close RUSSKI or die "Could not close: $!";
1N/A open(RUSSKI, "$russki");
1N/A binmode(RUSSKI, ":raw");
1N/A my $buf1;
1N/A read(RUSSKI, $buf1, 1);
1N/A # eof(RUSSKI);
1N/A binmode(RUSSKI, ":encoding(koi8-r)");
1N/A my $buf2;
1N/A read(RUSSKI, $buf2, 1);
1N/A my $offset = tell(RUSSKI);
1N/A if (ord($buf1) == 0x3c &&
1N/A ord($buf2) == (ord('A') == 193) ? 0x6f : 0x3f &&
1N/A $offset == 2) {
1N/A print "ok 11\n";
1N/A } else {
1N/A printf "not ok 11 # [%s] [%s] %d\n",
1N/A join(" ", unpack("H*", $buf1)),
1N/A join(" ", unpack("H*", $buf2)), $offset;
1N/A }
1N/A close(RUSSKI);
1N/A} else {
1N/A print "not ok 11 # open failed: $!\n";
1N/A}
1N/A
1N/Aundef $warn;
1N/A
1N/A# Check there is no Use of uninitialized value in concatenation (.) warning
1N/A# due to the way @latin2iso_num was used to make aliases.
1N/Aif (open(FAIL, ">:encoding(latin42)", $fail2)) {
1N/A print "not ok 12 # Open should fail\n";
1N/A} else {
1N/A print "ok 12\n";
1N/A}
1N/Aif (!defined $warn) {
1N/A print "not ok 13 # warning is undef\n";
1N/A} elsif ($warn =~ /^Cannot find encoding "latin42" at.*line \d+\.$/) {
1N/A print "ok 13\n";
1N/A} else {
1N/A print "not ok 13 # warning is: \n";
1N/A $warn =~ s/^/# /mg;
1N/A print "$warn";
1N/A}
1N/A
1N/A# Create a string of chars that are 3 bytes in UTF-8
1N/Amy $str = "\x{1f80}" x 2048;
1N/A
1N/A# Write them to a file
1N/Aopen(F,'>:utf8',$threebyte) || die "Cannot open $threebyte:$!";
1N/Aprint F $str;
1N/Aclose(F);
1N/A
1N/A# Read file back as UTF-8
1N/Aopen(F,'<:encoding(utf-8)',$threebyte) || die "Cannot open $threebyte:$!";
1N/Amy $dstr = <F>;
1N/Aclose(F);
1N/Aprint "not " unless ($dstr eq $str);
1N/Aprint "ok 14\n";
1N/A
1N/AEND {
1N/A 1 while unlink($grk, $utf, $fail1, $fail2, $russki, $threebyte);
1N/A}