This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
2dee60d132239cefd59e898475e3a2067db592ca
[perl5.git] / cpan / Encode / t / perlio.t
1 BEGIN {
2     if ( $ENV{'PERL_CORE'} && $] >= 5.011) {
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     }
15     unless (PerlIO::Layer->find('perlio')){
16         print "1..0 # Skip: PerlIO required\n";
17         exit 0;
18     }
19     $| = 1;
20 }
21
22 use strict;
23 use File::Basename;
24 use File::Spec;
25 use File::Compare qw(compare_text);
26 use File::Copy;
27 use FileHandle;
28
29 #use Test::More qw(no_plan);
30 use Test::More tests => 38;
31
32 our $DEBUG = 0;
33
34 use Encode (":all");
35 {
36     no warnings;
37     @ARGV and $DEBUG = shift;
38     #require Encode::JP::JIS7;
39     #require Encode::KR::2022_KR;
40     #$Encode::JP::JIS7::DEBUG = $DEBUG;
41 }
42
43 my $seq = 0;
44 my $dir = dirname(__FILE__);
45
46 my %e = 
47     (
48      jisx0208 => [ qw/euc-jp shiftjis 7bit-jis iso-2022-jp iso-2022-jp-1/],
49      ksc5601  => [ qw/euc-kr/],
50      gb2312   => [ qw/euc-cn hz/],
51     );
52
53 $/ = "\x0a"; # may fix VMS problem for test #28 and #29
54
55 for my $src (sort keys %e) {
56     my $ufile = File::Spec->catfile($dir,"$src.utf");
57     open my $fh, "<:utf8", $ufile or die "$ufile : $!";
58     my @uline = <$fh>;
59     my $utext = join('' => @uline);
60     close $fh;
61
62     for my $e (@{$e{$src}}){
63     my $sfile = File::Spec->catfile($dir,"$$.sio");
64     my $pfile = File::Spec->catfile($dir,"$$.pio");
65     
66     # first create a file without perlio
67     dump2file($sfile, &encode($e, $utext, 0));
68     
69     # then create a file via perlio without autoflush
70
71     SKIP:{
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     }
125      if ( ! $DEBUG ) {
126             1 while unlink ($sfile);
127             1 while unlink ($pfile);
128         }
129     }
130 }
131
132 # BOM Test
133
134 SKIP:{
135     my $pev = PerlIO::encoding->VERSION;
136     skip "PerlIO::encoding->VERSION = $pev <= 0.07 ", 6
137     unless ($pev >= 0.07 or $DEBUG);
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 = (
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           );
149     # reading
150     for my $utf (sort keys %bom){
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++;
161     }
162     # writing
163     for my $utf_nobom (qw/UTF-16 UTF-32/){
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++;
176     }
177 }
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 }