1BEGIN {
2    if ( $] < 5.009 ) {
3        print "1..0 # Skip: Perl <= 5.9 or later required\n";
4        exit 0;
5    }
6}
7use strict;
8use warnings;
9
10my $script = quotemeta $0;
11
12use Encode;
13use Test::More tests => 38;
14
15my $valid   = "\x61\x00\x00\x00";
16my $invalid = "\x78\x56\x34\x12";
17
18our $warn;
19$SIG{__WARN__} = sub { $warn = $_[0] };
20
21my $enc = find_encoding("UTF32-LE");
22
23{
24    local $warn;
25    my $ret = $enc->encode( "a", Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
26    is($warn, undef, "Calling encode on UTF32-LE encode object with valid string produces no warnings");
27    is($ret, $valid, "Calling encode on UTF32-LE encode object with valid string returns correct output");
28}
29
30
31{
32    local $warn;
33    $enc->encode( "\x{D800}", Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
34    like($warn, qr/UTF-16 surrogate.* at $script line /, "Calling encode on UTF32-LE encode object with invalid string warns");
35}
36
37{
38    local $warn;
39    no warnings 'utf8';
40    $enc->encode( "\x{D800}", Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
41    is($warn, undef, "Warning from encode method of UTF32-LE encode object can be silenced via no warnings 'utf8'");
42}
43
44{
45    local $warn;
46    no warnings;
47    $enc->encode( "\x{D800}", Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
48    is($warn, undef, "Warning from encode method of UTF32-LE encode object can be silenced via no warnings");
49}
50
51{
52    local $warn;
53    no warnings 'utf8';
54    $enc->encode( "\x{D800}", Encode::WARN_ON_ERR | Encode::LEAVE_SRC );
55    like($warn, qr/UTF-16 surrogate.* at $script line /, "Warning from encode method of UTF32-LE encode object cannot be silenced via no warnings 'utf8' when ONLY_PRAGMA_WARNINGS is not used");
56}
57
58{
59    local $warn;
60    no warnings;
61    $enc->encode( "\x{D800}", Encode::WARN_ON_ERR | Encode::LEAVE_SRC );
62    like($warn, qr/UTF-16 surrogate.* at $script line /, "Warning from encode method of UTF32-LE encode object cannot be silenced via no warnings when ONLY_PRAGMA_WARNINGS is not used");
63}
64
65
66{
67    local $warn;
68    my $ret = Encode::encode( $enc, "a", Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
69    is($warn, undef, "Calling Encode::encode for UTF32-LE with valid string produces no warnings");
70    is($ret, $valid, "Calling Encode::encode for UTF32-LE with valid string returns correct output");
71}
72
73
74{
75    local $warn;
76    Encode::encode( $enc, "\x{D800}", Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
77    like($warn, qr/UTF-16 surrogate.* at $script line /, "Calling Encode::encode for UTF32-LE with invalid string warns");
78}
79
80
81{
82    local $warn;
83    no warnings 'utf8';
84    Encode::encode( $enc, "\x{D800}", Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
85    is($warn, undef, "Warning from Encode::encode for UTF32-LE can be silenced via no warnings 'utf8'");
86}
87
88{
89    local $warn;
90    no warnings;
91    Encode::encode( $enc, "\x{D800}", Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
92    is($warn, undef, "Warning from Encode::encode for UTF32-LE can be silenced via no warnings");
93}
94
95{
96    local $warn;
97    no warnings 'utf8';
98    Encode::encode( $enc, "\x{D800}", Encode::WARN_ON_ERR | Encode::LEAVE_SRC );
99    like($warn, qr/UTF-16 surrogate.* at $script line /, "Warning from Encode::encode for UTF32-LE cannot be silenced via no warnings 'utf8' when ONLY_PRAGMA_WARNINGS is not used");
100}
101
102{
103    local $warn;
104    no warnings;
105    Encode::encode( $enc, "\x{D800}", Encode::WARN_ON_ERR | Encode::LEAVE_SRC );
106    like($warn, qr/UTF-16 surrogate.* at $script line /, "Warning from Encode::encode for UTF32-LE cannot be silenced via no warnings when ONLY_PRAGMA_WARNINGS is not used");
107}
108
109
110{
111    local $warn;
112    my $ret = $enc->decode( $valid, Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
113    is($warn, undef, "Calling decode on UTF32-LE encode object with valid string produces no warnings");
114    is($ret, "a", "Calling decode on UTF32-LE encode object with valid string returns correct output");
115}
116
117
118{
119    local $warn;
120    $enc->decode( $invalid, Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
121    like($warn, qr/may not be portable.* at $script line /, "Calling decode on UTF32-LE encode object with invalid string warns");
122}
123
124{
125    local $warn;
126    no warnings 'utf8';
127    $enc->decode( $invalid, Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
128    is($warn, undef, "Warning from decode method of UTF32-LE encode object can be silenced via no warnings 'utf8'");
129}
130
131{
132    local $warn;
133    no warnings;
134    $enc->decode( $invalid, Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
135    is($warn, undef, "Warning from decode method of UTF32-LE encode object can be silenced via no warnings");
136}
137
138{
139    local $warn;
140    no warnings 'utf8';
141    $enc->decode( $invalid, Encode::WARN_ON_ERR | Encode::LEAVE_SRC );
142    like($warn, qr/may not be portable.* at $script line /, "Warning from decode method of UTF32-LE encode object cannot be silenced via no warnings 'utf8' when ONLY_PRAGMA_WARNINGS is not used");
143}
144
145{
146    local $warn;
147    no warnings;
148    $enc->decode( $invalid, Encode::WARN_ON_ERR | Encode::LEAVE_SRC );
149    like($warn, qr/may not be portable.* at $script line /, "Warning from decode method of UTF32-LE encode object cannot be silenced via no warnings when ONLY_PRAGMA_WARNINGS is not used");
150}
151
152
153{
154    local $warn;
155    my $ret = Encode::decode( $enc, $valid, Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
156    is($warn, undef, "Calling Encode::decode for UTF32-LE with valid string produces no warnings");
157    is($ret, "a", "Calling Encode::decode for UTF32-LE with valid string returns correct output");
158}
159
160
161{
162    local $warn;
163    Encode::decode( $enc, $invalid, Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
164    like($warn, qr/may not be portable.* at $script line /, "Calling Encode::decode for UTF32-LE with invalid string warns");
165}
166
167{
168    local $warn;
169    no warnings 'utf8';
170    Encode::decode( $enc, $invalid, Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
171    is($warn, undef, "Warning from Encode::decode for UTF32-LE can be silenced via no warnings 'utf8'");
172}
173
174{
175    local $warn;
176    no warnings;
177    Encode::decode( $enc, $invalid, Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
178    is($warn, undef, "Warning from Encode::decode for UTF32-LE can be silenced via no warnings");
179}
180
181{
182    local $warn;
183    no warnings 'utf8';
184    Encode::decode( $enc, $invalid, Encode::WARN_ON_ERR | Encode::LEAVE_SRC );
185    like($warn, qr/may not be portable.* at $script line /, "Warning from Encode::decode for UTF32-LE cannot be silenced via no warnings 'utf8' when ONLY_PRAGMA_WARNINGS is not used");
186}
187
188{
189    local $warn;
190    no warnings;
191    Encode::decode( $enc, $invalid, Encode::WARN_ON_ERR | Encode::LEAVE_SRC );
192    like($warn, qr/may not be portable.* at $script line /, "Warning from Encode::decode for UTF32-LE cannot be silenced via no warnings when ONLY_PRAGMA_WARNINGS is not used");
193}
194
195
196use PerlIO::encoding;
197$PerlIO::encoding::fallback |= Encode::ONLY_PRAGMA_WARNINGS;
198
199{
200    local $warn;
201    my $tmp = $valid;
202    $tmp .= ''; # de-COW
203    open my $fh, '<:encoding(UTF32-LE)', \$tmp or die;
204    my $str = <$fh>;
205    close $fh;
206    is($warn, undef, "Calling PerlIO :encoding on valid string produces no warnings");
207    is($str, "a", "PerlIO decodes string correctly");
208}
209
210
211{
212    local $warn;
213    my $tmp = $invalid;
214    use Devel::Peek;
215    $tmp .= ''; # de-COW
216    open my $fh, '<:encoding(UTF32-LE)', \$tmp or die;
217    my $str = <$fh>;
218    close $fh;
219    like($warn, qr/may not be portable.* at $script line /, "Calling PerlIO :encoding on invalid string warns");
220}
221
222{
223    local $warn;
224    my $tmp = $invalid;
225    $tmp .= ''; # de-COW
226    no warnings 'utf8';
227    open my $fh, '<:encoding(UTF32-LE)', \$tmp or die;
228    my $str = <$fh>;
229    close $fh;
230    is($warn, undef, "Warning from PerlIO :encoding can be silenced via no warnings 'utf8'");
231}
232
233{
234    local $warn;
235    my $tmp = $invalid;
236    $tmp .= ''; # de-COW
237    no warnings;
238    open my $fh, '<:encoding(UTF32-LE)', \$tmp or die;
239    my $str = <$fh>;
240    close $fh;
241    is($warn, undef, "Warning from PerlIO :encoding can be silenced via no warnings");
242}
243
244
245{
246    local $warn;
247    my $str;
248    open my $fh, '>:encoding(UTF32-LE)', \$str or die;
249    print $fh "a";
250    close $fh;
251    is($warn, undef, "Calling PerlIO :encoding on valid string produces no warnings");
252    is($str, $valid, "PerlIO encodes string correctly");
253}
254
255
256{
257    local $warn;
258    my $str;
259    open my $fh, '>:encoding(UTF32-LE)', \$str or die;
260    print $fh "\x{D800}";
261    close $fh;
262    like($warn, qr/UTF-16 surrogate.* at $script line /, "Calling PerlIO :encoding on invalid string warns");
263}
264
265{
266    local $warn;
267    my $str;
268    no warnings 'utf8';
269    open my $fh, '>:encoding(UTF32-LE)', \$str or die;
270    print $fh "\x{D800}";
271    close $fh;
272    is($warn, undef, "Warning from PerlIO :encoding can be silenced via no warnings 'utf8'");
273}
274
275{
276    local $warn;
277    my $str;
278    no warnings;
279    open my $fh, '>:encoding(UTF32-LE)', \$str or die;
280    print $fh "\x{D800}";
281    close $fh;
282    is($warn, undef, "Warning from PerlIO :encoding can be silenced via no warnings");
283}
284