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