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) { |
12 | print "1..0 # Skip: EBCDIC\n"; |
13 | exit 0; |
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); |
0ab8f81e |
30 | use Test::More tests => 28; |
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 | |
85982a32 |
43 | |
0ab8f81e |
44 | |
6d1c0808 |
45 | my $seq = 0; |
0ab8f81e |
46 | my $dir = dirname(__FILE__); |
85982a32 |
47 | |
0ab8f81e |
48 | my %e = |
49 | ( |
50 | jisx0208 => [ qw/euc-jp shiftjis 7bit-jis iso-2022-jp iso-2022-jp-1/], |
51 | #ksc5601 => [ qw/euc-kr iso-2022-kr/], |
52 | ksc5601 => [ qw/euc-kr/], |
53 | #gb2312 => [ qw/euc-cn hz/], |
54 | gb2312 => [ qw/euc-cn/], |
55 | ); |
85982a32 |
56 | |
c00aecee |
57 | |
0ab8f81e |
58 | for my $src(sort keys %e) { |
59 | my $ufile = File::Spec->catfile($dir,"$src.ref"); |
60 | open my $fh, "<:utf8", $ufile or die "$ufile : $!"; |
61 | my @uline = <$fh>; |
62 | my $utext = join('' => @uline); |
85982a32 |
63 | close $fh; |
85982a32 |
64 | |
0ab8f81e |
65 | for my $e (@{$e{$src}}){ |
66 | my $sfile = File::Spec->catfile($dir,"$$.sio"); |
67 | my $pfile = File::Spec->catfile($dir,"$$.pio"); |
68 | |
69 | # first create a file without perlio |
70 | dump2file($sfile, &encode($e, $utext, 0)); |
71 | |
72 | # then create a file via perlio without autoflush |
73 | |
74 | TODO:{ |
75 | #local $TODO = "$e: !perlio_ok" unless (perlio_ok($e) or $DEBUG); |
76 | todo_skip "$e: !perlio_ok", 4 unless (perlio_ok($e) or $DEBUG); |
77 | no warnings 'uninitialized'; |
78 | open $fh, ">:encoding($e)", $pfile or die "$sfile : $!"; |
79 | $fh->autoflush(0); |
80 | print $fh $utext; |
81 | close $fh; |
82 | $seq++; |
83 | is(compare_text($sfile, $pfile), 0 => ">:encoding($e)"); |
84 | if ($DEBUG){ |
85 | copy $sfile, "$sfile.$seq"; |
86 | copy $pfile, "$pfile.$seq"; |
87 | } |
88 | |
89 | # this time print line by line. |
90 | # works even for ISO-2022 but not ISO-2022-KR |
91 | open $fh, ">:encoding($e)", $pfile or die "$sfile : $!"; |
92 | $fh->autoflush(1); |
93 | for my $l (@uline) { |
94 | print $fh $l; |
95 | } |
96 | close $fh; |
97 | $seq++; |
98 | is(compare_text($sfile, $pfile), 0 => ">:encoding($e) by lines"); |
99 | if ($DEBUG){ |
100 | copy $sfile, "$sfile.$seq"; |
101 | copy $pfile, "$pfile.$seq"; |
102 | } |
103 | my $dtext; |
104 | open $fh, "<:encoding($e)", $pfile or die "$pfile : $!"; |
105 | $fh->autoflush(0); |
106 | $dtext = join('' => <$fh>); |
107 | close $fh; |
108 | $seq++; |
109 | ok($utext eq $dtext, "<:encoding($e)"); |
110 | if ($DEBUG){ |
111 | dump2file("$sfile.$seq", $utext); |
112 | dump2file("$pfile.$seq", $dtext); |
113 | } |
114 | if (perlio_ok($e) or $DEBUG){ |
115 | $dtext = ''; |
116 | open $fh, "<:encoding($e)", $pfile or die "$pfile : $!"; |
117 | while(defined(my $l = <$fh>)) { |
118 | $dtext .= $l; |
119 | } |
120 | close $fh; |
121 | } |
122 | $seq++; |
123 | ok($utext eq $dtext, "<:encoding($e) by lines"); |
124 | if ($DEBUG){ |
125 | dump2file("$sfile.$seq", $utext); |
126 | dump2file("$pfile.$seq", $dtext); |
127 | } |
6d1c0808 |
128 | } |
0ab8f81e |
129 | $DEBUG or unlink ($sfile, $pfile); |
6d1c0808 |
130 | } |
85982a32 |
131 | } |
0ab8f81e |
132 | |
85982a32 |
133 | |
6d1c0808 |
134 | sub dump2file{ |
135 | no warnings; |
136 | open my $fh, ">", $_[0] or die "$_[0]: $!"; |
137 | binmode $fh; |
138 | print $fh $_[1]; |
139 | close $fh; |
140 | } |