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
|
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require Config; import Config;
}
use Test::More tests => 16;
# 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 disciplines/,
'import should fail without args' );
# the hint bits shouldn't be set yet
is( $^H & $open::hint_bits, 0,
'hint bits should not be set in $^H before open import' );
# 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 discipline
$warn = '';
eval q{ no warnings 'layer'; use open IN => ':macguffin' ; };
is( $warn, '',
'should not warn about unknown discipline with bad discipline provided' );
$warn = '';
eval q{ use warnings 'layer'; use open IN => ':macguffin' ; };
like( $warn, qr/Unknown discipline layer/,
'should warn about unknown discipline with bad discipline provided' );
SKIP: {
skip("no perlio, no :utf8", 1) unless $Config{useperlio};
# now load a real-looking locale
$ENV{LC_ALL} = ' .utf8';
import( 'IN', 'locale' );
is( ${^OPEN}, ":utf8\0",
'should set a valid locale layer' );
}
# and see if it sets the magic variables appropriately
import( 'IN', ':crlf' );
ok( $^H & $open::hint_bits,
'hint bits should be set in $^H after open import' );
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 discipline 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 disciplines' );
is( $^H{'open_IO'}, 'crlf', 'should record last layer set in %^H' );
SKIP: {
skip("no perlio, no :utf8", 4) unless $Config{'useperlio'};
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");
# syswrite() on should work on characters, not bytes
open G, ">:utf8", "b";
$ok = $a = 0;
for (@a) {
unless (
($c = syswrite(G, $_, 1)) == 1 &&
systell(G) == ($a += bytes::length($_))
) {
print '# ord($_) == ', ord($_), "\n";
print '# bytes::length($_) == ', bytes::length($_), "\n";
print '# systell(G) == ', systell(G), "\n";
print '# $a == ', $a, "\n";
print '# $c == ', $c, "\n";
print "not ";
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");
}
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;
%%%
|
