Time::Local in blead has diverged from CPAN. Update the version number to a dev release
[perl.git] / lib / open.t
1 #!./perl
2
3 BEGIN {
4         chdir 't' if -d 't';
5         @INC = '../lib';
6         require Config; import Config;
7 }
8
9 use Test::More tests => 23;
10
11 # open::import expects 'open' as its first argument, but it clashes with open()
12 sub import {
13         open::import( 'open', @_ );
14 }
15
16 # can't use require_ok() here, with a name like 'open'
17 ok( require 'open.pm', 'requiring open' );
18
19 # this should fail
20 eval { import() };
21 like( $@, 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
25 my $warn;
26 local $SIG{__WARN__} = sub {
27         $warn .= shift;
28 };
29
30 # and it shouldn't be able to find this layer
31 $warn = '';
32 eval q{ no warnings 'layer'; use open IN => ':macguffin' ; };
33 is( $warn, '',
34         'should not warn about unknown layer with bad layer provided' );
35
36 $warn = '';
37 eval q{ use warnings 'layer'; use open IN => ':macguffin' ; };
38 like( $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
45 import( 'IN', ':crlf' );
46 is( $^H{'open_IN'}, 'crlf', 'should have set crlf layer' );
47
48 # it should reset them appropriately, too
49 import( 'IN', ':raw' );
50 is( $^H{'open_IN'}, 'raw', 'should have reset to raw layer' );
51
52 # it dies if you don't set IN, OUT, or IO
53 eval { import( 'sideways', ':raw' ) };
54 like( $@, qr/Unknown PerlIO layer class/, 'should croak with unknown class' );
55
56 # but it handles them all so well together
57 import( 'IO', ':raw :crlf' );
58 is( ${^OPEN}, ":raw :crlf\0:raw :crlf",
59         'should set multi types, multi layer' );
60 is( $^H{'open_IO'}, 'crlf', 'should record last layer set in %^H' );
61
62 SKIP: {
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;
73 EOE
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 }
182 SKIP: {
183     skip("no perlio", 2) unless (find PerlIO::Layer 'perlio');
184
185     eval q[use Encode::Alias;use open ":std", ":locale"];
186     is($@, '', 'can use :std and :locale');
187
188     use open IN => ':non-existent';
189     eval {
190         require Symbol; # Anything that exists but we havn't loaded
191     };
192     like($@, qr/Can't locate Symbol|Recursive call/i,
193          "test for an endless loop in PerlIO_find_layer");
194 }
195
196 END {
197     1 while unlink "utf8";
198     1 while unlink "a";
199     1 while unlink "b";
200 }
201
202 # the test cases beyond __DATA__ need to be executed separately
203
204 __DATA__
205 $ENV{LC_ALL} = 'nonexistent.euc';
206 eval { open::_get_locale_encoding() };
207 like( $@, qr/too ambiguous/, 'should die with ambiguous locale encoding' );
208 %%%
209 # the special :locale layer
210 $ENV{LC_ALL} = $ENV{LANG} = 'ru_RU.KOI8-R';
211 # the :locale will probe the locale environment variables like LANG
212 use open OUT => ':locale';
213 open(O, ">koi8");
214 print O chr(0x430); # Unicode CYRILLIC SMALL LETTER A = KOI8-R 0xc1
215 close O;
216 open(I, "<koi8");
217 printf "%#x\n", ord(<I>), "\n"; # this should print 0xc1
218 close I;
219 %%%