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