Commit | Line | Data |
85982a32 |
1 | BEGIN { |
85982a32 |
2 | require Config; import Config; |
3 | if ($Config{'extensions'} !~ /\bEncode\b/) { |
4 | print "1..0 # Skip: Encode was not built\n"; |
5 | exit 0; |
6 | } |
7 | if (ord("A") == 193) { |
d1256cb1 |
8 | print "1..0 # Skip: EBCDIC\n"; |
9 | exit 0; |
85982a32 |
10 | } |
011b2d2f |
11 | unless (PerlIO::Layer->find('perlio')){ |
12 | print "1..0 # Skip: PerlIO required\n"; |
13 | exit 0; |
14 | } |
85982a32 |
15 | $| = 1; |
16 | } |
17 | |
18 | use strict; |
19 | use File::Basename; |
20 | use File::Spec; |
0ab8f81e |
21 | use File::Compare qw(compare_text); |
6d1c0808 |
22 | use File::Copy; |
85982a32 |
23 | use FileHandle; |
24 | |
25 | #use Test::More qw(no_plan); |
47dd3999 |
26 | use Test::More tests => 38; |
85982a32 |
27 | |
28 | our $DEBUG = 0; |
29 | |
0ab8f81e |
30 | use Encode (":all"); |
85982a32 |
31 | { |
32 | no warnings; |
33 | @ARGV and $DEBUG = shift; |
0ab8f81e |
34 | #require Encode::JP::JIS7; |
35 | #require Encode::KR::2022_KR; |
36 | #$Encode::JP::JIS7::DEBUG = $DEBUG; |
85982a32 |
37 | } |
38 | |
6d1c0808 |
39 | my $seq = 0; |
0ab8f81e |
40 | my $dir = dirname(__FILE__); |
85982a32 |
41 | |
0ab8f81e |
42 | my %e = |
43 | ( |
44 | jisx0208 => [ qw/euc-jp shiftjis 7bit-jis iso-2022-jp iso-2022-jp-1/], |
0ab8f81e |
45 | ksc5601 => [ qw/euc-kr/], |
47dd3999 |
46 | gb2312 => [ qw/euc-cn hz/], |
0ab8f81e |
47 | ); |
85982a32 |
48 | |
f74b3917 |
49 | $/ = "\x0a"; # may fix VMS problem for test #28 and #29 |
c00aecee |
50 | |
47dd3999 |
51 | for my $src (sort keys %e) { |
ef175861 |
52 | my $ufile = File::Spec->catfile($dir,"$src.utf"); |
0ab8f81e |
53 | open my $fh, "<:utf8", $ufile or die "$ufile : $!"; |
54 | my @uline = <$fh>; |
55 | my $utext = join('' => @uline); |
85982a32 |
56 | close $fh; |
85982a32 |
57 | |
0ab8f81e |
58 | for my $e (@{$e{$src}}){ |
d1256cb1 |
59 | my $sfile = File::Spec->catfile($dir,"$$.sio"); |
60 | my $pfile = File::Spec->catfile($dir,"$$.pio"); |
0ab8f81e |
61 | |
d1256cb1 |
62 | # first create a file without perlio |
63 | dump2file($sfile, &encode($e, $utext, 0)); |
0ab8f81e |
64 | |
d1256cb1 |
65 | # then create a file via perlio without autoflush |
0ab8f81e |
66 | |
47dd3999 |
67 | SKIP:{ |
d1256cb1 |
68 | skip "$e: !perlio_ok", 4 unless (perlio_ok($e) or $DEBUG); |
69 | no warnings 'uninitialized'; |
70 | open $fh, ">:encoding($e)", $pfile or die "$sfile : $!"; |
71 | $fh->autoflush(0); |
72 | print $fh $utext; |
73 | close $fh; |
74 | $seq++; |
75 | is(compare_text($sfile, $pfile), 0 => ">:encoding($e)"); |
76 | if ($DEBUG){ |
77 | copy $sfile, "$sfile.$seq"; |
78 | copy $pfile, "$pfile.$seq"; |
79 | } |
80 | |
81 | # this time print line by line. |
82 | # works even for ISO-2022 but not ISO-2022-KR |
83 | open $fh, ">:encoding($e)", $pfile or die "$sfile : $!"; |
84 | $fh->autoflush(1); |
85 | for my $l (@uline) { |
86 | print $fh $l; |
87 | } |
88 | close $fh; |
89 | $seq++; |
90 | is(compare_text($sfile, $pfile), 0 => ">:encoding($e) by lines"); |
91 | if ($DEBUG){ |
92 | copy $sfile, "$sfile.$seq"; |
93 | copy $pfile, "$pfile.$seq"; |
94 | } |
95 | my $dtext; |
96 | open $fh, "<:encoding($e)", $pfile or die "$pfile : $!"; |
97 | $fh->autoflush(0); |
98 | $dtext = join('' => <$fh>); |
99 | close $fh; |
100 | $seq++; |
101 | ok($utext eq $dtext, "<:encoding($e)"); |
102 | if ($DEBUG){ |
103 | dump2file("$sfile.$seq", $utext); |
104 | dump2file("$pfile.$seq", $dtext); |
105 | } |
106 | if (perlio_ok($e) or $DEBUG){ |
107 | $dtext = ''; |
108 | open $fh, "<:encoding($e)", $pfile or die "$pfile : $!"; |
109 | while(defined(my $l = <$fh>)) { |
110 | $dtext .= $l; |
111 | } |
112 | close $fh; |
113 | } |
114 | $seq++; |
115 | ok($utext eq $dtext, "<:encoding($e) by lines"); |
116 | if ($DEBUG){ |
117 | dump2file("$sfile.$seq", $utext); |
118 | dump2file("$pfile.$seq", $dtext); |
119 | } |
120 | } |
f9674d83 |
121 | if ( ! $DEBUG ) { |
122 | 1 while unlink ($sfile); |
123 | 1 while unlink ($pfile); |
124 | } |
6d1c0808 |
125 | } |
85982a32 |
126 | } |
127 | |
47dd3999 |
128 | # BOM Test |
129 | |
130 | SKIP:{ |
131 | my $pev = PerlIO::encoding->VERSION; |
132 | skip "PerlIO::encoding->VERSION = $pev <= 0.07 ", 6 |
d1256cb1 |
133 | unless ($pev >= 0.07 or $DEBUG); |
47dd3999 |
134 | |
135 | my $file = File::Spec->catfile($dir,"jisx0208.utf"); |
136 | open my $fh, "<:utf8", $file or die "$file : $!"; |
137 | my $str = join('' => <$fh>); |
138 | close $fh; |
139 | my %bom = ( |
d1256cb1 |
140 | 'UTF-16BE' => pack('n', 0xFeFF), |
141 | 'UTF-16LE' => pack('v', 0xFeFF), |
142 | 'UTF-32BE' => pack('N', 0xFeFF), |
143 | 'UTF-32LE' => pack('V', 0xFeFF), |
144 | ); |
47dd3999 |
145 | # reading |
146 | for my $utf (sort keys %bom){ |
d1256cb1 |
147 | my $bomed = $bom{$utf} . encode($utf, $str); |
148 | my $sfile = File::Spec->catfile($dir,".${utf}_${seq}_$$"); |
149 | dump2file($sfile, $bomed); |
150 | my $utf_nobom = $utf; $utf_nobom =~ s/(LE|BE)$//o; |
151 | # reading |
152 | open $fh, "<:encoding($utf_nobom)", $sfile or die "$sfile : $!"; |
153 | my $cmp = join '' => <$fh>; |
154 | close $fh; |
155 | is($str, $cmp, "<:encoding($utf_nobom) eq $utf"); |
156 | unlink $sfile; $seq++; |
47dd3999 |
157 | } |
158 | # writing |
159 | for my $utf_nobom (qw/UTF-16 UTF-32/){ |
d1256cb1 |
160 | my $utf = $utf_nobom . 'BE'; |
161 | my $sfile = File::Spec->catfile($dir,".${utf_nobom}_${seq}_$$"); |
162 | my $bomed = $bom{$utf} . encode($utf, $str); |
163 | open $fh, ">:encoding($utf_nobom)", $sfile or die "$sfile : $!"; |
164 | print $fh $str; |
165 | close $fh; |
166 | open my $fh, "<:bytes", $sfile or die "$sfile : $!"; |
167 | read $fh, my $cmp, -s $sfile; |
168 | close $fh; |
169 | use bytes (); |
170 | ok($bomed eq $cmp, ">:encoding($utf_nobom) eq $utf"); |
171 | unlink $sfile; $seq++; |
47dd3999 |
172 | } |
173 | } |
6d1c0808 |
174 | sub dump2file{ |
175 | no warnings; |
176 | open my $fh, ">", $_[0] or die "$_[0]: $!"; |
177 | binmode $fh; |
178 | print $fh $_[1]; |
179 | close $fh; |
180 | } |