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