Commit | Line | Data |
bb7af5ca |
1 | #!./perl -w |
9ba8831b |
2 | |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
5 | @INC = '../lib'; |
bb7af5ca |
6 | no warnings; # Need global -w flag for later tests, but don't want this |
7 | # to warn here: |
e69a2255 |
8 | push @INC, "::lib:$MacPerl::Architecture:" if $^O eq 'MacOS'; |
9ba8831b |
9 | unless (find PerlIO::Layer 'perlio') { |
10 | print "1..0 # Skip: not perlio\n"; |
11 | exit 0; |
12 | } |
13 | } |
14 | |
bb7af5ca |
15 | print "1..13\n"; |
08efa405 |
16 | |
8e86646e |
17 | my $grk = "grk$$"; |
18 | my $utf = "utf$$"; |
92e410c2 |
19 | my $fail1 = "fa$$"; |
20 | my $fail2 = "fb$$"; |
ed53a2bb |
21 | my $russki = "koi8r$$"; |
8e86646e |
22 | |
2b18b92a |
23 | if (open(GRK, ">$grk")) { |
24 | binmode(GRK, ":bytes"); |
8e86646e |
25 | # alpha beta gamma in ISO 8859-7 |
26 | print GRK "\xe1\xe2\xe3"; |
d1e4d418 |
27 | close GRK or die "Could not close: $!"; |
8e86646e |
28 | } |
29 | |
30 | { |
31 | use Encode; |
32 | open(my $i,'<:encoding(iso-8859-7)',$grk); |
33 | print "ok 1\n"; |
34 | open(my $o,'>:utf8',$utf); |
35 | print "ok 2\n"; |
36 | print $o readline($i); |
37 | print "ok 3\n"; |
d1e4d418 |
38 | close($o) or die "Could not close: $!"; |
8e86646e |
39 | close($i); |
40 | } |
41 | |
2b18b92a |
42 | if (open(UTF, "<$utf")) { |
43 | binmode(UTF, ":bytes"); |
07229bbd |
44 | if (ord('A') == 193) { # EBCDIC |
45 | # alpha beta gamma in UTF-EBCDIC Unicode (0x3b1 0x3b2 0x3b3) |
46 | print "not " unless <UTF> eq "\xb4\x58\xb4\x59\xb4\x62"; |
47 | } else { |
48 | # alpha beta gamma in UTF-8 Unicode (0x3b1 0x3b2 0x3b3) |
49 | print "not " unless <UTF> eq "\xce\xb1\xce\xb2\xce\xb3"; |
50 | } |
8e86646e |
51 | print "ok 4\n"; |
206b12d5 |
52 | close UTF; |
8e86646e |
53 | } |
54 | |
55 | { |
56 | use Encode; |
57 | open(my $i,'<:utf8',$utf); |
58 | print "ok 5\n"; |
59 | open(my $o,'>:encoding(iso-8859-7)',$grk); |
60 | print "ok 6\n"; |
61 | print $o readline($i); |
62 | print "ok 7\n"; |
d1e4d418 |
63 | close($o) or die "Could not close: $!"; |
8e86646e |
64 | close($i); |
65 | } |
66 | |
2b18b92a |
67 | if (open(GRK, "<$grk")) { |
68 | binmode(GRK, ":bytes"); |
8e86646e |
69 | print "not " unless <GRK> eq "\xe1\xe2\xe3"; |
70 | print "ok 8\n"; |
206b12d5 |
71 | close GRK; |
8e86646e |
72 | } |
73 | |
bb7af5ca |
74 | $SIG{__WARN__} = sub {$warn .= $_[0]}; |
b26b1ab5 |
75 | |
76 | if (open(FAIL, ">:encoding(NoneSuch)", $fail1)) { |
77 | print "not ok 9 # Open should fail\n"; |
78 | } else { |
79 | print "ok 9\n"; |
80 | } |
81 | if (!defined $warn) { |
82 | print "not ok 10 # warning is undef\n"; |
83 | } elsif ($warn =~ /^Cannot find encoding "NoneSuch" at/) { |
84 | print "ok 10\n"; |
85 | } else { |
86 | print "not ok 10 # warning is '$warn'"; |
87 | } |
88 | |
ed53a2bb |
89 | if (open(RUSSKI, ">$russki")) { |
90 | print RUSSKI "\x3c\x3f\x78"; |
d1e4d418 |
91 | close RUSSKI or die "Could not close: $!"; |
ed53a2bb |
92 | open(RUSSKI, "$russki"); |
93 | binmode(RUSSKI, ":raw"); |
94 | my $buf1; |
95 | read(RUSSKI, $buf1, 1); |
bb7af5ca |
96 | # eof(RUSSKI); |
ed53a2bb |
97 | binmode(RUSSKI, ":encoding(koi8-r)"); |
98 | my $buf2; |
99 | read(RUSSKI, $buf2, 1); |
100 | my $offset = tell(RUSSKI); |
07229bbd |
101 | if (ord($buf1) == 0x3c && |
102 | ord($buf2) == (ord('A') == 193) ? 0x6f : 0x3f && |
103 | $offset == 2) { |
ed53a2bb |
104 | print "ok 11\n"; |
105 | } else { |
07229bbd |
106 | printf "not ok 11 # [%s] [%s] %d\n", |
107 | join(" ", unpack("H*", $buf1)), |
108 | join(" ", unpack("H*", $buf2)), $offset; |
ed53a2bb |
109 | } |
110 | close(RUSSKI); |
111 | } else { |
112 | print "not ok 11 # open failed: $!\n"; |
113 | } |
114 | |
bb7af5ca |
115 | undef $warn; |
116 | |
117 | # Check there is no Use of uninitialized value in concatenation (.) warning |
118 | # due to the way @latin2iso_num was used to make aliases. |
119 | if (open(FAIL, ">:encoding(latin42)", $fail2)) { |
120 | print "not ok 12 # Open should fail\n"; |
121 | } else { |
122 | print "ok 12\n"; |
123 | } |
124 | if (!defined $warn) { |
125 | print "not ok 13 # warning is undef\n"; |
126 | } elsif ($warn =~ /^Cannot find encoding "latin42" at.*line \d+\.$/) { |
127 | print "ok 13\n"; |
128 | } else { |
129 | print "not ok 13 # warning is: \n"; |
130 | $warn =~ s/^/# /mg; |
131 | print "$warn"; |
132 | } |
133 | |
8e86646e |
134 | END { |
92e410c2 |
135 | unlink($grk, $utf, $fail1, $fail2, $russki); |
8e86646e |
136 | } |