This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
warnings for perlio + others
[perl5.git] / ext / PerlIO / t / encoding.t
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     @INC = '../lib';
6     unless (find PerlIO::Layer 'perlio') {
7         print "1..0 # Skip: not perlio\n";
8         exit 0;
9     }
10 }
11
12 print "1..11\n";
13
14 my $grk = "grk$$";
15 my $utf = "utf$$";
16 my $fail1 = "fail$$";
17 my $russki = "koi8r$$";
18
19 if (open(GRK, ">$grk")) {
20     # alpha beta gamma in ISO 8859-7
21     print GRK "\xe1\xe2\xe3";
22     close GRK or die "Could not close: $!";
23 }
24
25 {
26     use Encode;
27     open(my $i,'<:encoding(iso-8859-7)',$grk);
28     print "ok 1\n";
29     open(my $o,'>:utf8',$utf);
30     print "ok 2\n";
31     print $o readline($i);
32     print "ok 3\n";
33     close($o) or die "Could not close: $!";
34     close($i);
35 }
36
37 if (open(UTF, "<$utf")) {
38     if (ord('A') == 193) { # EBCDIC
39         # alpha beta gamma in UTF-EBCDIC Unicode (0x3b1 0x3b2 0x3b3)
40         print "not " unless <UTF> eq "\xb4\x58\xb4\x59\xb4\x62";
41     } else {
42         # alpha beta gamma in UTF-8 Unicode (0x3b1 0x3b2 0x3b3)
43         print "not " unless <UTF> eq "\xce\xb1\xce\xb2\xce\xb3";
44     }
45     print "ok 4\n";
46     close UTF;
47 }
48
49 {
50     use Encode;
51     open(my $i,'<:utf8',$utf);
52     print "ok 5\n";
53     open(my $o,'>:encoding(iso-8859-7)',$grk);
54     print "ok 6\n";
55     print $o readline($i);
56     print "ok 7\n";
57     close($o) or die "Could not close: $!";
58     close($i);
59 }
60
61 if (open(GRK, "<$grk")) {
62     print "not " unless <GRK> eq "\xe1\xe2\xe3";
63     print "ok 8\n";
64     close GRK;
65 }
66
67 $SIG{__WARN__} = sub {$warn = $_[0]};
68
69 if (open(FAIL, ">:encoding(NoneSuch)", $fail1)) {
70     print "not ok 9 # Open should fail\n";
71 } else {
72     print "ok 9\n";
73 }
74 if (!defined $warn) {
75     print "not ok 10 # warning is undef\n";
76 } elsif ($warn =~ /^Cannot find encoding "NoneSuch" at/) {
77     print "ok 10\n";
78 } else {
79     print "not ok 10 # warning is '$warn'";
80 }
81
82 if (open(RUSSKI, ">$russki")) {
83     print RUSSKI "\x3c\x3f\x78";
84     close RUSSKI or die "Could not close: $!";
85     open(RUSSKI, "$russki");
86     binmode(RUSSKI, ":raw");
87     my $buf1;
88     read(RUSSKI, $buf1, 1);
89     eof(RUSSKI);
90     binmode(RUSSKI, ":encoding(koi8-r)");
91     my $buf2;
92     read(RUSSKI, $buf2, 1);
93     my $offset = tell(RUSSKI);
94     if (ord($buf1) == 0x3c &&
95         ord($buf2) == (ord('A') == 193) ? 0x6f : 0x3f &&
96         $offset == 2) {
97         print "ok 11\n";
98     } else {
99         printf "not ok 11 # [%s] [%s] %d\n",
100                join(" ", unpack("H*", $buf1)),
101                join(" ", unpack("H*", $buf2)), $offset;
102     }
103     close(RUSSKI);
104 } else {
105     print "not ok 11 # open failed: $!\n";
106 }
107
108 END {
109     unlink($grk, $utf, $fail1, $russki);
110 }