[perl5.git] / cpan / Encode / t / utf32warnings.t

BEGIN {
    if ( $] < 5.009 ) {
        print "1..0 # Skip: Perl <= 5.9 or later required\n";
        exit 0;
    }
}
use strict;
use warnings;

my $script = quotemeta $0;

use Encode;
use Test::More tests => 38;

my $valid   = "\x61\x00\x00\x00";
my $invalid = "\x78\x56\x34\x12";

our $warn;
$SIG{__WARN__} = sub { $warn = $_[0] };

my $enc = find_encoding("UTF32-LE");

{
    local $warn;
    my $ret = $enc->encode( "a", Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
    is($warn, undef, "Calling encode on UTF32-LE encode object with valid string produces no warnings");
    is($ret, $valid, "Calling encode on UTF32-LE encode object with valid string returns correct output");
}


{
    local $warn;
    $enc->encode( "\x{D800}", Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
    like($warn, qr/UTF-16 surrogate.* at $script line /, "Calling encode on UTF32-LE encode object with invalid string warns");
}

{
    local $warn;
    no warnings 'utf8';
    $enc->encode( "\x{D800}", Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
    is($warn, undef, "Warning from encode method of UTF32-LE encode object can be silenced via no warnings 'utf8'");
}

{
    local $warn;
    no warnings;
    $enc->encode( "\x{D800}", Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
    is($warn, undef, "Warning from encode method of UTF32-LE encode object can be silenced via no warnings");
}

{
    local $warn;
    no warnings 'utf8';
    $enc->encode( "\x{D800}", Encode::WARN_ON_ERR | Encode::LEAVE_SRC );
    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");
}

{
    local $warn;
    no warnings;
    $enc->encode( "\x{D800}", Encode::WARN_ON_ERR | Encode::LEAVE_SRC );
    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");
}


{
    local $warn;
    my $ret = Encode::encode( $enc, "a", Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
    is($warn, undef, "Calling Encode::encode for UTF32-LE with valid string produces no warnings");
    is($ret, $valid, "Calling Encode::encode for UTF32-LE with valid string returns correct output");
}


{
    local $warn;
    Encode::encode( $enc, "\x{D800}", Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
    like($warn, qr/UTF-16 surrogate.* at $script line /, "Calling Encode::encode for UTF32-LE with invalid string warns");
}


{
    local $warn;
    no warnings 'utf8';
    Encode::encode( $enc, "\x{D800}", Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
    is($warn, undef, "Warning from Encode::encode for UTF32-LE can be silenced via no warnings 'utf8'");
}

{
    local $warn;
    no warnings;
    Encode::encode( $enc, "\x{D800}", Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
    is($warn, undef, "Warning from Encode::encode for UTF32-LE can be silenced via no warnings");
}

{
    local $warn;
    no warnings 'utf8';
    Encode::encode( $enc, "\x{D800}", Encode::WARN_ON_ERR | Encode::LEAVE_SRC );
    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");
}

{
    local $warn;
    no warnings;
    Encode::encode( $enc, "\x{D800}", Encode::WARN_ON_ERR | Encode::LEAVE_SRC );
    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");
}


{
    local $warn;
    my $ret = $enc->decode( $valid, Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
    is($warn, undef, "Calling decode on UTF32-LE encode object with valid string produces no warnings");
    is($ret, "a", "Calling decode on UTF32-LE encode object with valid string returns correct output");
}


{
    local $warn;
    $enc->decode( $invalid, Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
    like($warn, qr/may not be portable.* at $script line /, "Calling decode on UTF32-LE encode object with invalid string warns");
}

{
    local $warn;
    no warnings 'utf8';
    $enc->decode( $invalid, Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
    is($warn, undef, "Warning from decode method of UTF32-LE encode object can be silenced via no warnings 'utf8'");
}

{
    local $warn;
    no warnings;
    $enc->decode( $invalid, Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
    is($warn, undef, "Warning from decode method of UTF32-LE encode object can be silenced via no warnings");
}

{
    local $warn;
    no warnings 'utf8';
    $enc->decode( $invalid, Encode::WARN_ON_ERR | Encode::LEAVE_SRC );
    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");
}

{
    local $warn;
    no warnings;
    $enc->decode( $invalid, Encode::WARN_ON_ERR | Encode::LEAVE_SRC );
    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");
}


{
    local $warn;
    my $ret = Encode::decode( $enc, $valid, Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
    is($warn, undef, "Calling Encode::decode for UTF32-LE with valid string produces no warnings");
    is($ret, "a", "Calling Encode::decode for UTF32-LE with valid string returns correct output");
}


{
    local $warn;
    Encode::decode( $enc, $invalid, Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
    like($warn, qr/may not be portable.* at $script line /, "Calling Encode::decode for UTF32-LE with invalid string warns");
}

{
    local $warn;
    no warnings 'utf8';
    Encode::decode( $enc, $invalid, Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
    is($warn, undef, "Warning from Encode::decode for UTF32-LE can be silenced via no warnings 'utf8'");
}

{
    local $warn;
    no warnings;
    Encode::decode( $enc, $invalid, Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
    is($warn, undef, "Warning from Encode::decode for UTF32-LE can be silenced via no warnings");
}

{
    local $warn;
    no warnings 'utf8';
    Encode::decode( $enc, $invalid, Encode::WARN_ON_ERR | Encode::LEAVE_SRC );
    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");
}

{
    local $warn;
    no warnings;
    Encode::decode( $enc, $invalid, Encode::WARN_ON_ERR | Encode::LEAVE_SRC );
    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");
}


use PerlIO::encoding;
$PerlIO::encoding::fallback |= Encode::ONLY_PRAGMA_WARNINGS;

{
    local $warn;
    my $tmp = $valid;
    $tmp .= ''; # de-COW
    open my $fh, '<:encoding(UTF32-LE)', \$tmp or die;
    my $str = <$fh>;
    close $fh;
    is($warn, undef, "Calling PerlIO :encoding on valid string produces no warnings");
    is($str, "a", "PerlIO decodes string correctly");
}


{
    local $warn;
    my $tmp = $invalid;
    use Devel::Peek;
    $tmp .= ''; # de-COW
    open my $fh, '<:encoding(UTF32-LE)', \$tmp or die;
    my $str = <$fh>;
    close $fh;
    like($warn, qr/may not be portable.* at $script line /, "Calling PerlIO :encoding on invalid string warns");
}

{
    local $warn;
    my $tmp = $invalid;
    $tmp .= ''; # de-COW
    no warnings 'utf8';
    open my $fh, '<:encoding(UTF32-LE)', \$tmp or die;
    my $str = <$fh>;
    close $fh;
    is($warn, undef, "Warning from PerlIO :encoding can be silenced via no warnings 'utf8'");
}

{
    local $warn;
    my $tmp = $invalid;
    $tmp .= ''; # de-COW
    no warnings;
    open my $fh, '<:encoding(UTF32-LE)', \$tmp or die;
    my $str = <$fh>;
    close $fh;
    is($warn, undef, "Warning from PerlIO :encoding can be silenced via no warnings");
}


{
    local $warn;
    my $str;
    open my $fh, '>:encoding(UTF32-LE)', \$str or die;
    print $fh "a";
    close $fh;
    is($warn, undef, "Calling PerlIO :encoding on valid string produces no warnings");
    is($str, $valid, "PerlIO encodes string correctly");
}


{
    local $warn;
    my $str;
    open my $fh, '>:encoding(UTF32-LE)', \$str or die;
    print $fh "\x{D800}";
    close $fh;
    like($warn, qr/UTF-16 surrogate.* at $script line /, "Calling PerlIO :encoding on invalid string warns");
}

{
    local $warn;
    my $str;
    no warnings 'utf8';
    open my $fh, '>:encoding(UTF32-LE)', \$str or die;
    print $fh "\x{D800}";
    close $fh;
    is($warn, undef, "Warning from PerlIO :encoding can be silenced via no warnings 'utf8'");
}

{
    local $warn;
    my $str;
    no warnings;
    open my $fh, '>:encoding(UTF32-LE)', \$str or die;
    print $fh "\x{D800}";
    close $fh;
    is($warn, undef, "Warning from PerlIO :encoding can be silenced via no warnings");
}
Commit	Line	Data
d26b5e1d DK	1	BEGIN {
	2	if ( $] < 5.009 ) {
	3	print "1..0 # Skip: Perl <= 5.9 or later required\n";
	4	exit 0;
	5	}
	6	}
ab5cf2ea YO	7	use strict;
	8	use warnings;
	9
	10	my $script = quotemeta $0;
	11
	12	use Encode;
	13	use Test::More tests => 38;
	14
	15	my $valid = "\x61\x00\x00\x00";
	16	my $invalid = "\x78\x56\x34\x12";
	17
	18	our $warn;
	19	$SIG{__WARN__} = sub { $warn = $_[0] };
	20
	21	my $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
196	use 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	}