1#!./perl -w 2 3BEGIN { 4 unless (find PerlIO::Layer 'perlio') { 5 print "1..0 # Skip: not perlio\n"; 6 exit 0; 7 } 8 unless (eval { require Encode } ) { 9 print "1..0 # Skip: not Encode\n"; 10 exit 0; 11 } 12} 13 14use Test::More tests => 18; 15 16my $grk = "grk$$"; 17my $utf = "utf$$"; 18my $fail1 = "fa$$"; 19my $fail2 = "fb$$"; 20my $russki = "koi8r$$"; 21my $threebyte = "3byte$$"; 22 23if (open(GRK, ">$grk")) { 24 binmode(GRK, ":bytes"); 25 # alpha beta gamma in ISO 8859-7 26 print GRK "\xe1\xe2\xe3"; 27 close GRK or die "Could not close: $!"; 28} 29 30{ 31 is(open(my $i,'<:encoding(iso-8859-7)',$grk), 1); 32 is(open(my $o,'>:utf8',$utf), 1); 33 is((print $o readline $i), 1); 34 close($o) or die "Could not close: $!"; 35 close($i); 36} 37 38if (open(UTF, "<$utf")) { 39 binmode(UTF, ":bytes"); 40 if (ord('A') == 193) { # EBCDIC 41 # alpha beta gamma in UTF-EBCDIC Unicode (0x3b1 0x3b2 0x3b3) 42 is(scalar <UTF>, "\xb4\x58\xb4\x59\xb4\x62"); 43 } else { 44 # alpha beta gamma in UTF-8 Unicode (0x3b1 0x3b2 0x3b3) 45 is(scalar <UTF>, "\xce\xb1\xce\xb2\xce\xb3"); 46 } 47 close UTF; 48} 49 50{ 51 use Encode; 52 is (open(my $i,'<:utf8',$utf), 1); 53 is (open(my $o,'>:encoding(iso-8859-7)',$grk), 1); 54 is ((scalar print $o readline $i), 1); 55 close($o) or die "Could not close: $!"; 56 close($i); 57} 58 59if (open(GRK, "<$grk")) { 60 binmode(GRK, ":bytes"); 61 is(scalar <GRK>, "\xe1\xe2\xe3"); 62 close GRK; 63} 64 65$SIG{__WARN__} = sub {$warn .= $_[0]}; 66 67is (open(FAIL, ">:encoding(NoneSuch)", $fail1), undef, 'Open should fail'); 68like($warn, qr/^Cannot find encoding "NoneSuch" at/); 69 70is(open(RUSSKI, ">$russki"), 1); 71print RUSSKI "\x3c\x3f\x78"; 72close RUSSKI or die "Could not close: $!"; 73open(RUSSKI, "$russki"); 74binmode(RUSSKI, ":raw"); 75my $buf1; 76read(RUSSKI, $buf1, 1); 77# eof(RUSSKI); 78binmode(RUSSKI, ":encoding(koi8-r)"); 79my $buf2; 80read(RUSSKI, $buf2, 1); 81my $offset = tell(RUSSKI); 82is(ord $buf1, 0x3c); 83is(ord $buf2, (ord('A') == 193) ? 0x6f : 0x3f); 84is($offset, 2); 85close RUSSKI; 86 87undef $warn; 88 89# Check there is no Use of uninitialized value in concatenation (.) warning 90# due to the way @latin2iso_num was used to make aliases. 91is(open(FAIL, ">:encoding(latin42)", $fail2), undef, 'Open should fail'); 92 93like($warn, qr/^Cannot find encoding "latin42" at.*line \d+\.$/); 94 95# Create a string of chars that are 3 bytes in UTF-8 96my $str = "\x{1f80}" x 2048; 97 98# Write them to a file 99open(F,'>:utf8',$threebyte) || die "Cannot open $threebyte:$!"; 100print F $str; 101close(F); 102 103# Read file back as UTF-8 104open(F,'<:encoding(utf-8)',$threebyte) || die "Cannot open $threebyte:$!"; 105my $dstr = <F>; 106close(F); 107is($dstr, $str); 108 109# Try decoding some bad stuff 110open(F,'>:raw',$threebyte) || die "Cannot open $threebyte:$!"; 111if (ord('A') == 193) { # EBCDIC 112 print F "foo\x8c\x80\x80\x80bar\n\x80foo\n"; 113} else { 114 print F "foo\xF0\x80\x80\x80bar\n\x80foo\n"; 115} 116close(F); 117 118open(F,'<:encoding(utf-8)',$threebyte) || die "Cannot open $threebyte:$!"; 119$dstr = join(":", <F>); 120close(F); 121if (ord('A') == 193) { # EBCDIC 122 is($dstr, "foo\\x8C\\x80\\x80\\x80bar\n:\\x80foo\n"); 123} else { 124 is($dstr, "foo\\xF0\\x80\\x80\\x80bar\n:\\x80foo\n"); 125} 126 127END { 128 1 while unlink($grk, $utf, $fail1, $fail2, $russki, $threebyte); 129} 130