1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = '../lib'; 6 require Config; import Config; 7 require './test.pl'; 8 require './charset_tools.pl'; 9} 10 11plan 23; 12 13# open::import expects 'open' as its first argument, but it clashes with open() 14sub import { 15 open::import( 'open', @_ ); 16} 17 18# can't use require_ok() here, with a name like 'open' 19ok( require 'open.pm', 'requiring open' ); 20 21# this should fail 22eval { import() }; 23like( $@, qr/needs explicit list of PerlIO layers/, 24 'import should fail without args' ); 25 26# prevent it from loading I18N::Langinfo, so we can test encoding failures 27my $warn; 28local $SIG{__WARN__} = sub { 29 $warn .= shift; 30}; 31 32# and it shouldn't be able to find this layer 33$warn = ''; 34eval q{ no warnings 'layer'; use open IN => ':macguffin' ; }; 35is( $warn, '', 36 'should not warn about unknown layer with bad layer provided' ); 37 38$warn = ''; 39eval q{ use warnings 'layer'; use open IN => ':macguffin' ; }; 40like( $warn, qr/Unknown PerlIO layer/, 41 'should warn about unknown layer with bad layer provided' ); 42 43# open :locale logic changed since open 1.04, new logic 44# difficult to test portably. 45 46# see if it sets the magic variables appropriately 47import( 'IN', ':crlf' ); 48is( $^H{'open_IN'}, 'crlf', 'should have set crlf layer' ); 49 50# it should reset them appropriately, too 51import( 'IN', ':raw' ); 52is( $^H{'open_IN'}, 'raw', 'should have reset to raw layer' ); 53 54# it dies if you don't set IN, OUT, or IO 55eval { import( 'sideways', ':raw' ) }; 56like( $@, qr/Unknown PerlIO layer class/, 'should croak with unknown class' ); 57 58# but it handles them all so well together 59import( 'IO', ':raw :crlf' ); 60is( ${^OPEN}, ":raw :crlf\0:raw :crlf", 61 'should set multi types, multi layer' ); 62is( $^H{'open_IO'}, 'crlf', 'should record last layer set in %^H' ); 63 64SKIP: { 65 skip("no perlio, no :utf8", 12) unless (find PerlIO::Layer 'perlio'); 66 67 eval <<EOE; 68 use open ':utf8'; 69 open(O, ">utf8"); 70 print O chr(0x100); 71 close O; 72 open(I, "<utf8"); 73 is(ord(<I>), 0x100, ":utf8 single wide character round-trip"); 74 close I; 75EOE 76 77 open F, ">a"; 78 @a = map { chr(1 << ($_ << 2)) } 0..5; # 0x1, 0x10, .., 0x100000 79 unshift @a, chr(0); # ... and a null byte in front just for fun 80 print F @a; 81 close F; 82 83 sub systell { 84 use Fcntl 'SEEK_CUR'; 85 sysseek($_[0], 0, SEEK_CUR); 86 } 87 88 require bytes; # not use 89 90 my $ok; 91 92 open F, "<:utf8", "a"; 93 $ok = $a = 0; 94 for (@a) { 95 unless ( 96 ($c = sysread(F, $b, 1)) == 1 && 97 length($b) == 1 && 98 ord($b) == ord($_) && 99 systell(F) == ($a += bytes::length($b)) 100 ) { 101 print '# ord($_) == ', ord($_), "\n"; 102 print '# ord($b) == ', ord($b), "\n"; 103 print '# length($b) == ', length($b), "\n"; 104 print '# bytes::length($b) == ', bytes::length($b), "\n"; 105 print '# systell(F) == ', systell(F), "\n"; 106 print '# $a == ', $a, "\n"; 107 print '# $c == ', $c, "\n"; 108 last; 109 } 110 $ok++; 111 } 112 close F; 113 ok($ok == @a, 114 "on :utf8 streams sysread() should work on characters, not bytes"); 115 116 sub diagnostics { 117 print '# ord($_) == ', ord($_), "\n"; 118 print '# bytes::length($_) == ', bytes::length($_), "\n"; 119 print '# systell(G) == ', systell(G), "\n"; 120 print '# $a == ', $a, "\n"; 121 print '# $c == ', $c, "\n"; 122 } 123 124 125 my %actions = ( 126 syswrite => sub { syswrite G, shift; }, 127 'syswrite len' => sub { syswrite G, shift, 1; }, 128 'syswrite len pad' => sub { 129 my $temp = shift() . "\243"; 130 syswrite G, $temp, 1; }, 131 'syswrite off' => sub { 132 my $temp = "\351" . shift(); 133 syswrite G, $temp, 1, 1; }, 134 'syswrite off pad' => sub { 135 my $temp = "\351" . shift() . "\243"; 136 syswrite G, $temp, 1, 1; }, 137 ); 138 139 foreach my $key (sort keys %actions) { 140 # syswrite() on should work on characters, not bytes 141 open G, ">:utf8", "b"; 142 143 print "# $key\n"; 144 $ok = $a = 0; 145 for (@a) { 146 unless ( 147 ($c = $actions{$key}($_)) == 1 && 148 systell(G) == ($a += bytes::length($_)) 149 ) { 150 diagnostics(); 151 last; 152 } 153 $ok++; 154 } 155 close G; 156 ok($ok == @a, 157 "on :utf8 streams syswrite() should work on characters, not bytes"); 158 159 open G, "<:utf8", "b"; 160 $ok = $a = 0; 161 for (@a) { 162 unless ( 163 ($c = sysread(G, $b, 1)) == 1 && 164 length($b) == 1 && 165 ord($b) == ord($_) && 166 systell(G) == ($a += bytes::length($_)) 167 ) { 168 print '# ord($_) == ', ord($_), "\n"; 169 print '# ord($b) == ', ord($b), "\n"; 170 print '# length($b) == ', length($b), "\n"; 171 print '# bytes::length($b) == ', bytes::length($b), "\n"; 172 print '# systell(G) == ', systell(G), "\n"; 173 print '# $a == ', $a, "\n"; 174 print '# $c == ', $c, "\n"; 175 last; 176 } 177 $ok++; 178 } 179 close G; 180 ok($ok == @a, 181 "checking syswrite() output on :utf8 streams by reading it back in"); 182 } 183} 184SKIP: { 185 skip("no perlio", 1) unless (find PerlIO::Layer 'perlio'); 186 skip("no Encode", 1) unless $Config{extensions} =~ m{\bEncode\b}; 187 skip("EBCDIC platform doesnt have 'use encoding' used by open ':locale'", 1) 188 if $::IS_EBCDIC; 189 190 eval q[use Encode::Alias;use open ":std", ":locale"]; 191 is($@, '', 'can use :std and :locale'); 192} 193 194{ 195 local $ENV{PERL_UNICODE}; 196 delete $ENV{PERL_UNICODE}; 197 local $TODO; 198 $TODO = "Encode not working on EBCDIC" if $::IS_EBCDIC; 199 is runperl( 200 progs => [ 201 'use open q\:encoding(UTF-8)\, q-:std-;', 202 'use open q\:encoding(UTF-8)\;', 203 'if(($_ = <STDIN>) eq qq-\x{100}\n-) { print qq-stdin ok\n- }', 204 'else { print qq-got -, join(q q q, map ord, split//), "\n" }', 205 'print STDOUT qq-\x{fe}\n-;', 206 'print STDERR qq-\x{fe}\n-;', 207 ], 208 stdin => byte_utf8a_to_utf8n("\xc4\x80") . "\n", 209 stderr => 1, 210 ), 211 "stdin ok\n" 212 . byte_utf8a_to_utf8n("\xc3\xbe") 213 . "\n" 214 . byte_utf8a_to_utf8n("\xc3\xbe") 215 . "\n", 216 "use open without :std does not affect standard handles", 217 ; 218} 219 220END { 221 1 while unlink "utf8"; 222 1 while unlink "a"; 223 1 while unlink "b"; 224} 225 226# the test cases beyond __DATA__ need to be executed separately 227 228__DATA__ 229$ENV{LC_ALL} = 'nonexistent.euc'; 230eval { open::_get_locale_encoding() }; 231like( $@, qr/too ambiguous/, 'should die with ambiguous locale encoding' ); 232%%% 233# the special :locale layer 234$ENV{LC_ALL} = $ENV{LANG} = 'ru_RU.KOI8-R'; 235# the :locale will probe the locale environment variables like LANG 236use open OUT => ':locale'; 237open(O, ">koi8"); 238print O chr(0x430); # Unicode CYRILLIC SMALL LETTER A = KOI8-R 0xc1 239close O; 240open(I, "<koi8"); 241printf "%#x\n", ord(<I>), "\n"; # this should print 0xc1 242close I; 243%%% 244