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