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