This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: [PATCH t/op/pack.t] Cleanup
[perl5.git] / t / op / pack.t
CommitLineData
d50dd4e4 1#!./perl -w
a687059c 2
a1a0e61e
TD
3BEGIN {
4 chdir 't' if -d 't';
20822f61 5 @INC = '../lib';
0b568b5f 6 require './test.pl';
b23b8711
MS
7}
8
0b568b5f
MS
9plan tests => 1470;
10
fa8ec7c1
NC
11use strict;
12use warnings;
b23b8711
MS
13use Config;
14
fa8ec7c1 15my $Is_EBCDIC = (defined $Config{ebcdic} && $Config{ebcdic} eq 'define');
0b568b5f 16my $Perl = which_perl();
c274e827 17
fa8ec7c1
NC
18sub encode {
19 my @result = @_;
b85d93de
NC
20 foreach (@result) {
21 s/([[:cntrl:]\177 ])/sprintf "\\%03o", ord $1/ge if defined;
22 }
fa8ec7c1
NC
23 @result;
24}
17639bde 25
b85d93de
NC
26sub encode_list {
27 my @result = @_;
28 foreach (@result) {
29 if (defined) {
30 s/([[:cntrl:]\177])/sprintf "\\%03o", ord $1/ge;
31 $_ = qq("$_");
32 } else {
33 $_ = 'undef';
34 }
35 }
36 if (@result == 1) {
37 return @result;
38 }
39 return '(' . join (', ', @result) . ')';
40}
41
a1a0e61e 42
b85d93de
NC
43sub list_eq ($$) {
44 my ($l, $r) = @_;
45 return unless @$l == @$r;
46 for my $i (0..$#$l) {
47 if (defined $l->[$i]) {
48 return unless defined ($r->[$i]) && $l->[$i] eq $r->[$i];
49 } else {
50 return if defined $r->[$i]
51 }
52 }
53 return 1;
54}
55
56##############################################################################
57#
58# Here starteth the tests
59#
60
fa8ec7c1 61{
0b568b5f
MS
62 my $format = "c2 x5 C C x s d i l a6";
63 # Need the expression in here to force ary[5] to be numeric. This avoids
64 # test2 failing because ary2 goes str->numeric->str and ary doesn't.
65 my @ary = (1,-100,127,128,32767,987.654321098 / 100.0,12345,123456,
66 "abcdef");
67 my $foo = pack($format,@ary);
68 my @ary2 = unpack($format,$foo);
69
70 is($#ary, $#ary2);
71
72 my $out1=join(':',@ary);
73 my $out2=join(':',@ary2);
74 # Using long double NVs may introduce greater accuracy than wanted.
75 $out1 =~ s/:9\.87654321097999\d*:/:9.87654321098:/;
76 $out2 =~ s/:9\.87654321097999\d*:/:9.87654321098:/;
77 is($out1, $out2);
78
79 like($foo, qr/def/);
fa8ec7c1 80}
79072805
LW
81# How about counting bits?
82
fa8ec7c1 83{
0b568b5f
MS
84 my $x;
85 is( ($x = unpack("%32B*", "\001\002\004\010\020\040\100\200\377")), 16 );
79072805 86
0b568b5f 87 is( ($x = unpack("%32b69", "\001\002\004\010\020\040\100\200\017")), 12 );
79072805 88
0b568b5f 89 is( ($x = unpack("%32B69", "\001\002\004\010\020\040\100\200\017")), 9 );
fa8ec7c1 90}
79072805 91
fa8ec7c1 92{
0b568b5f
MS
93 my $sum = 129; # ASCII
94 $sum = 103 if $Is_EBCDIC;
9d116dd7 95
0b568b5f
MS
96 my $x;
97 is( ($x = unpack("%32B*", "Now is the time for all good blurfl")), $sum );
79072805 98
0b568b5f
MS
99 my $foo;
100 open(BIN, $Perl) || die "Can't open $Perl: $!\n";
101 sysread BIN, $foo, 8192;
102 close BIN;
79072805 103
0b568b5f
MS
104 $sum = unpack("%32b*", $foo);
105 my $longway = unpack("b*", $foo);
106 is( $sum, $longway =~ tr/1/1/ );
fa8ec7c1 107}
73a1c01a 108
fa8ec7c1
NC
109{
110 my $x;
0b568b5f 111 is( ($x = unpack("I",pack("I", 0xFFFFFFFF))), 0xFFFFFFFF );
fa8ec7c1 112}
def98dd4 113
fa8ec7c1 114{
0b568b5f
MS
115 # check 'w'
116 my @x = (5,130,256,560,32000,3097152,268435455,1073741844, 2**33,
117 '4503599627365785','23728385234614992549757750638446');
118 my $x = pack('w*', @x);
119 my $y = pack 'H*', '0581028200843081fa0081bd8440ffffff7f8480808014A0808'.
120 '0800087ffffffffffdb19caefe8e1eeeea0c2e1e3e8ede1ee6e';
121
122 is($x, $y);
123
124 my @y = unpack('w*', $y);
125 my $a;
126 while ($a = pop @x) {
127 my $b = pop @y;
128 is($a, $b);
129 }
def98dd4 130
0b568b5f 131 @y = unpack('w2', $x);
def98dd4 132
0b568b5f
MS
133 is(scalar(@y), 2);
134 is($y[1], 130);
fa8ec7c1 135}
def98dd4 136
0b568b5f 137
fa8ec7c1
NC
138{
139 # test exeptions
140 my $x;
141 eval { $x = unpack 'w', pack 'C*', 0xff, 0xff};
0b568b5f 142 like($@, qr/^Unterminated compressed integer/);
def98dd4 143
fa8ec7c1 144 eval { $x = unpack 'w', pack 'C*', 0xff, 0xff, 0xff, 0xff};
0b568b5f 145 like($@, qr/^Unterminated compressed integer/);
def98dd4 146
fa8ec7c1 147 eval { $x = unpack 'w', pack 'C*', 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff};
0b568b5f 148 like($@, qr/^Unterminated compressed integer/);
fa8ec7c1 149}
def98dd4 150
84902520
TB
151#
152# test the "p" template
153
154# literals
0b568b5f 155is(unpack("p",pack("p","foo")), "foo");
84902520
TB
156
157# scalars
0b568b5f 158is(unpack("p",pack("p",239)), 239);
84902520
TB
159
160# temps
161sub foo { my $a = "a"; return $a . $a++ . $a++ }
162{
9f1b1f2d 163 use warnings;
0b568b5f 164 my $warning;
84902520 165 local $SIG{__WARN__} = sub {
0b568b5f 166 $warning = $_[0];
84902520
TB
167 };
168 my $junk = pack("p", &foo);
0b568b5f
MS
169
170 like($warning, qr/temporary val/);
84902520
TB
171}
172
173# undef should give null pointer
0b568b5f 174like(pack("p", undef), qr/^\0+/);
84902520 175
20408e3c
GS
176# Check for optimizer bug (e.g. Digital Unix GEM cc with -O4 on DU V4.0B gives
177# 4294967295 instead of -1)
178# see #ifdef __osf__ in pp.c pp_unpack
0b568b5f 179is((unpack("i",pack("i",-1))), -1);
20408e3c 180
0b568b5f
MS
181# test the pack lengths of s S i I l L
182# test the pack lengths of n N v V
fa8ec7c1
NC
183my @lengths = qw(s 2 S 2 i -4 I -4 l 4 L 4 n 2 N 4 v 2 V 4);
184while (my ($format, $expect) = splice @lengths, 0, 2) {
185 my $len = length(pack($format, 0));
186 if ($expect > 0) {
0b568b5f 187 is($expect, $len, "format '$format'");
fa8ec7c1
NC
188 } else {
189 $expect = -$expect;
0b568b5f
MS
190 ok ($len >= $expect, "format '$format'") ||
191 print "# format '$format' has length $len, expected >= $expect\n";
fa8ec7c1
NC
192 }
193}
d4217c7e 194
d4217c7e 195
0b568b5f
MS
196# test unpack-pack lengths
197my @templates = qw(c C i I s S l L n N v V f d q Q);
d4217c7e
JH
198
199foreach my $t (@templates) {
0b568b5f
MS
200 SKIP: {
201 my @t = eval { unpack("$t*", pack("$t*", 12, 34)) };
202
203 # quads not supported everywhere
204 skip "Quads not supported", 4 if $@ =~ /Invalid type in pack/;
205 is( $@, '' );
206
207 is(scalar @t, 2);
3020ec7a
MS
208
209 SKIP: {
210 skip "$t not expected to work for some reason", 2 if $t =~ /[nv]/i;
211
0b568b5f
MS
212 is($t[0], 12);
213 is($t[1], 34);
214 }
0b568b5f 215 }
d4217c7e 216}
9d116dd7 217
fa8ec7c1 218{
0b568b5f 219 # uuencode/decode
9d116dd7 220
0b568b5f
MS
221 # Note that first uuencoding known 'text' data and then checking the
222 # binary values of the uuencoded version would not be portable between
223 # character sets. Uuencoding is meant for encoding binary data, not
224 # text data.
c4d5f83a 225
0b568b5f 226 my $in = pack 'C*', 0 .. 255;
ba1ac976 227
0b568b5f
MS
228 # just to be anal, we do some random tr/`/ /
229 my $uu = <<'EOUU';
ba1ac976 230M` $"`P0%!@<("0H+# T.#Q`1$A,4%187&!D:&QP='A\@(2(C)"4F)R@I*BLL
9d116dd7
JH
231M+2XO,#$R,S0U-C<X.3H[/#T^/T!!0D-$149'2$E*2TQ-3D]045)35%565UA9
232M6EM<75Y?8&%B8V1E9F=H:6IK;&UN;W!Q<G-T=79W>'EZ>WQ]?G^`@8*#A(6&
233MAXB)BHN,C8Z/D)&2DY25EI>8F9J;G)V>GZ"AHJ.DI::GJ*FJJZRMKJ^PL;*S
234MM+6VM[BYNKN\O;Z_P,'"P\3%QL?(R<K+S,W.S]#1TM/4U=;7V-G:V]S=WM_@
ba1ac976 235?X>+CY.7FY^CIZNOL[>[O\/'R\_3U]O?X^?K[_/W^_P `
9d116dd7
JH
236EOUU
237
0b568b5f
MS
238 $_ = $uu;
239 tr/ /`/;
9d116dd7 240
0b568b5f 241 is(pack('u', $in), $_);
fa8ec7c1 242
0b568b5f 243 is(unpack('u', $uu), $in);
9d116dd7 244
0b568b5f
MS
245 $in = "\x1f\x8b\x08\x08\x58\xdc\xc4\x35\x02\x03\x4a\x41\x50\x55\x00\xf3\x2a\x2d\x2e\x51\x48\xcc\xcb\x2f\xc9\x48\x2d\x52\x08\x48\x2d\xca\x51\x28\x2d\x4d\xce\x4f\x49\x2d\xe2\x02\x00\x64\x66\x60\x5c\x1a\x00\x00\x00";
246 $uu = <<'EOUU';
eddc390b
JH
247M'XL("%C<Q#4"`TI!4%4`\RHM+E%(S,LOR4@M4@A(+<I1*"U-SD])+>("`&1F
248&8%P:````
249EOUU
250
0b568b5f 251 is(unpack('u', $uu), $in);
eddc390b 252
0b568b5f
MS
253# This is identical to the above except that backquotes have been
254# changed to spaces
eddc390b 255
0b568b5f 256 $uu = <<'EOUU';
eddc390b 257M'XL("%C<Q#4" TI!4%4 \RHM+E%(S,LOR4@M4@A(+<I1*"U-SD])+>(" &1F
c4d5f83a 258&8%P:
eddc390b
JH
259EOUU
260
0b568b5f
MS
261 # ' # Grr
262 is(unpack('u', $uu), $in);
ef54e1a4 263
d99ad34e 264}
726ea183 265
0b568b5f 266# test the ascii template types (A, a, Z)
726ea183 267
fa8ec7c1 268foreach (
0b568b5f 269['p', 'A*', "foo\0bar\0 ", "foo\0bar\0 "],
fa8ec7c1 270['p', 'A11', "foo\0bar\0 ", "foo\0bar\0 "],
0b568b5f
MS
271['u', 'A*', "foo\0bar \0", "foo\0bar"],
272['u', 'A8', "foo\0bar \0", "foo\0bar"],
273['p', 'a*', "foo\0bar\0 ", "foo\0bar\0 "],
fa8ec7c1 274['p', 'a11', "foo\0bar\0 ", "foo\0bar\0 \0\0"],
0b568b5f
MS
275['u', 'a*', "foo\0bar \0", "foo\0bar \0"],
276['u', 'a8', "foo\0bar \0", "foo\0bar "],
277['p', 'Z*', "foo\0bar\0 ", "foo\0bar\0 \0"],
fa8ec7c1 278['p', 'Z11', "foo\0bar\0 ", "foo\0bar\0 \0\0"],
0b568b5f
MS
279['p', 'Z3', "foo", "fo\0"],
280['u', 'Z*', "foo\0bar \0", "foo"],
281['u', 'Z8', "foo\0bar \0", "foo"],
282)
283{
284 my ($what, $template, $in, $out) = @$_;
285 my $got = $what eq 'u' ? (unpack $template, $in) : (pack $template, $in);
286 unless (is($got, $out)) {
287 ($in, $out, $got) = encode ($in, $out, $got);
288 my $un = $what eq 'u' ? 'un' : '';
289 print "# ${un}pack ('$template', \"$in\") gave $out not $got\n";
290 }
d99ad34e 291}
726ea183 292
0b568b5f 293# packing native shorts/ints/longs
726ea183 294
0b568b5f
MS
295is(length(pack("s!", 0)), $Config{shortsize});
296is(length(pack("i!", 0)), $Config{intsize});
297is(length(pack("l!", 0)), $Config{longsize});
298ok(length(pack("s!", 0)) <= length(pack("i!", 0)));
299ok(length(pack("i!", 0)) <= length(pack("l!", 0)));
300is(length(pack("i!", 0)), length(pack("i", 0)));
726ea183 301
fa8ec7c1
NC
302sub numbers {
303 my $format = shift;
304 return numbers_with_total ($format, undef, @_);
d99ad34e 305}
726ea183 306
fa8ec7c1
NC
307sub numbers_with_total {
308 my $format = shift;
309 my $total = shift;
310 if (!defined $total) {
311 foreach (@_) {
312 $total += $_;
313 }
314 }
315 foreach (@_) {
0b568b5f
MS
316 SKIP: {
317 my $out = eval {unpack($format, pack($format, $_))};
318 skip "cannot pack '$format' on this perl", 2 if
319 $@ =~ /Invalid type in pack: '$format'/;
320
321 is($@, '');
322 is($out, $_);
fa8ec7c1 323 }
fa8ec7c1 324 }
726ea183 325
fa8ec7c1
NC
326 my $skip_if_longer_than = ~0; # "Infinity"
327 if (~0 - 1 == ~0) {
328 # If we're running with -DNO_PERLPRESERVE_IVUV and NVs don't preserve all
329 # UVs (in which case ~0 is NV, ~0-1 will be the same NV) then we can't
330 # correctly in perl calculate UV totals for long checksums, as pp_unpack
331 # is using UV maths, and we've only got NVs.
332 $skip_if_longer_than = $Config{d_nv_preserves_uv_bits};
333 }
726ea183 334
fa8ec7c1 335 foreach ('', 1, 2, 3, 15, 16, 17, 31, 32, 33, 53, 54, 63, 64, 65) {
0b568b5f
MS
336 SKIP: {
337 my $sum = eval {unpack "%$_$format*", pack "$format*", @_};
338 skip "cannot pack '$format' on this perl", 3
339 if $@ =~ /Invalid type in pack: '$format'/;
340
341 is($@, '');
342 ok(defined $sum);
343
344 my $len = $_; # Copy, so that we can reassign ''
345 $len = 16 unless length $len;
346
347 SKIP: {
348 skip "cannot test checksums over $skip_if_longer_than bits", 1
349 if $len > $skip_if_longer_than;
350
351 # Our problem with testing this portably is that the checksum code in
352 # pp_unpack is able to cast signed to unsigned, and do modulo 2**n
353 # arithmetic in unsigned ints, which perl has no operators to do.
354 # (use integer; does signed ints, which won't wrap on UTS, which is just
355 # fine with ANSI, but not with most people's assumptions.
356 # This is why we need to supply the totals for 'Q' as there's no way in
357 # perl to calculate them, short of unpack '%0Q' (is that documented?)
358 # ** returns NVs; make sure it's IV.
359 my $max = 1 + 2 * (int (2 ** ($len-1))-1); # The max possible checksum
360 my $max_p1 = $max + 1;
361 my ($max_is_integer, $max_p1_is_integer);
362 $max_p1_is_integer = 1 unless $max_p1 + 1 == $max_p1;
363 $max_is_integer = 1 if $max - 1 < ~0;
364
365 my $calc_sum;
366 if (ref $total) {
367 $calc_sum = &$total($len);
368 } else {
369 $calc_sum = $total;
370 # Shift into range by some multiple of the total
371 my $mult = int ($total / $max_p1);
372 # Need this to make sure that -1 + (~0+1) is ~0 (ie still integer)
373 $calc_sum = $total - $mult;
374 $calc_sum -= $mult * $max;
375 if ($calc_sum < 0) {
376 $calc_sum += 1;
377 $calc_sum += $max;
378 }
379 }
380 if ($calc_sum == $calc_sum - 1 && $calc_sum == $max_p1) {
381 # we're into floating point (either by getting out of the range of
382 # UV arithmetic, or because we're doing a floating point checksum)
383 # and our calculation of the checksum has become rounded up to
384 # max_checksum + 1
385 $calc_sum = 0;
386 }
387
388 if (is( $calc_sum, $sum)) {
389 print "# unpack '%$_$format' gave $sum\n";
390 } else {
391 my $delta = 1.000001;
392 if ($format =~ tr /dDfF//
393 && ($calc_sum <= $sum * $delta && $calc_sum >= $sum / $delta)) {
394 pass;
395 print "# unpack '%$_$format' gave $sum, expected $calc_sum\n";
396 } else {
397 my $text = ref $total ? &$total($len) : $total;
398 fail;
399 print "# For list (" . join (", ", @_) . ") (total $text)"
400 . " packed with $format unpack '%$_$format' gave $sum,"
401 . " expected $calc_sum\n";
402 }
403 }
fa8ec7c1 404 }
0b568b5f 405 }
2e821511
NC
406 }
407}
408
fa8ec7c1
NC
409numbers ('c', -128, -1, 0, 1, 127);
410numbers ('C', 0, 1, 127, 128, 255);
411numbers ('s', -32768, -1, 0, 1, 32767);
412numbers ('S', 0, 1, 32767, 32768, 65535);
413numbers ('i', -2147483648, -1, 0, 1, 2147483647);
414numbers ('I', 0, 1, 2147483647, 2147483648, 4294967295);
415numbers ('l', -2147483648, -1, 0, 1, 2147483647);
416numbers ('L', 0, 1, 2147483647, 2147483648, 4294967295);
417numbers ('s!', -32768, -1, 0, 1, 32767);
418numbers ('S!', 0, 1, 32767, 32768, 65535);
419numbers ('i!', -2147483648, -1, 0, 1, 2147483647);
420numbers ('I!', 0, 1, 2147483647, 2147483648, 4294967295);
421numbers ('l!', -2147483648, -1, 0, 1, 2147483647);
422numbers ('L!', 0, 1, 2147483647, 2147483648, 4294967295);
423numbers ('n', 0, 1, 32767, 32768, 65535);
424numbers ('v', 0, 1, 32767, 32768, 65535);
425numbers ('N', 0, 1, 2147483647, 2147483648, 4294967295);
426numbers ('V', 0, 1, 2147483647, 2147483648, 4294967295);
427# All these should have exact binary representations:
428numbers ('f', -1, 0, 0.5, 42, 2**34);
b85d93de
NC
429numbers ('d', -(2**34), -1, 0, 1, 2**34);
430## These don't, but 'd' is NV. XXX wrong, it's double
431#numbers ('d', -1, 0, 1, 1-exp(-1), -exp(1));
fa8ec7c1
NC
432
433numbers_with_total ('q', -1,
434 -9223372036854775808, -1, 0, 1,9223372036854775807);
800e6488
JH
435# This total is icky, but the true total is 2**65-1, and need a way to generate
436# the epxected checksum on any system including those where NVs can preserve
437# 65 bits. (long double is 128 bits on sparc, so they certainly can)
438# or where rounding is down not up on binary conversion (crays)
439numbers_with_total ('Q', sub {
440 my $len = shift;
441 $len = 65 if $len > 65; # unmasked total is 2**65-1 here
442 my $total = 1 + 2 * (int (2**($len - 1)) - 1);
443 return 0 if $total == $total - 1; # Overflowed integers
444 return $total; # NVs still accurate to nearest integer
445 },
fa8ec7c1
NC
446 0, 1,9223372036854775807, 9223372036854775808,
447 18446744073709551615);
448
449# pack nvNV byteorders
450
0b568b5f
MS
451is(pack("n", 0xdead), "\xde\xad");
452is(pack("v", 0xdead), "\xad\xde");
453is(pack("N", 0xdeadbeef), "\xde\xad\xbe\xef");
454is(pack("V", 0xdeadbeef), "\xef\xbe\xad\xde");
43192e07 455
fa8ec7c1
NC
456{
457 # /
458
459 my ($x, $y, $z);
460 eval { ($x) = unpack '/a*','hello' };
0b568b5f
MS
461 like($@, qr!/ must follow a numeric type!);
462
fa8ec7c1 463 eval { ($z,$x,$y) = unpack 'a3/A C/a* C/Z', "003ok \003yes\004z\000abc" };
0b568b5f
MS
464 is($@, '');
465 is($z, 'ok');
466 is($x, 'yes');
467 is($y, 'z');
fa8ec7c1
NC
468
469 eval { ($x) = pack '/a*','hello' };
0b568b5f 470 like($@, qr!Invalid type in pack: '/'!);
fa8ec7c1
NC
471
472 $z = pack 'n/a* N/Z* w/A*','string','hi there ','etc';
473 my $expect = "\000\006string\0\0\0\012hi there \000\003etc";
0b568b5f 474 is($z, $expect);
4b5b2118 475
b85d93de
NC
476 $expect = 'hello world';
477 eval { ($x) = unpack ("w/a", chr (11) . "hello world!")};
0b568b5f
MS
478 is($x, $expect);
479 is($@, '');
480
b85d93de
NC
481 # Doing this in scalar context used to fail.
482 eval { $x = unpack ("w/a", chr (11) . "hello world!")};
0b568b5f
MS
483 is($@, '');
484 is($x, $expect);
b85d93de 485
fa8ec7c1 486 foreach (
0b568b5f
MS
487 ['a/a*/a*', '212ab345678901234567','ab3456789012'],
488 ['a/a*/a*', '3012ab345678901234567', 'ab3456789012'],
489 ['a/a*/b*', '212ab', $Is_EBCDIC ? '100000010100' : '100001100100'],
490 )
491 {
fa8ec7c1
NC
492 my ($pat, $in, $expect) = @$_;
493 eval { ($x) = unpack $pat, $in };
0b568b5f
MS
494 is($@, '');
495 is($x, $expect) ||
496 printf "# list unpack ('$pat', '$in') gave %s, expected '$expect'\n",
497 encode_list ($x);
498
b85d93de 499 eval { $x = unpack $pat, $in };
0b568b5f
MS
500 is($@, '');
501 is($x, $expect) ||
502 printf "# scalar unpack ('$pat', '$in') gave %s, expected '$expect'\n",
503 encode_list ($x);
fa8ec7c1 504 }
4b5b2118 505
0b568b5f 506 # / with #
17f4a12d 507
0b568b5f 508 eval { ($z,$x,$y) = unpack <<EOU, "003ok \003yes\004z\000abc" };
17f4a12d
IZ
509 a3/A # Count in ASCII
510 C/a* # Count in a C char
511 C/Z # Count in a C char but skip after \0
512EOU
17f4a12d 513
0b568b5f
MS
514 is($@, '');
515 is($z, 'ok');
516 is($x, 'yes');
517 is($y, 'z');
518
519 $z = pack <<EOP,'string','etc';
17f4a12d
IZ
520 n/a* # Count as network short
521 w/A* # Count a BER integer
522EOP
fa8ec7c1 523 $expect = "\000\006string\003etc";
0b568b5f
MS
524
525 is($z, $expect) ||
526 printf "# got '%s', expected '$expect'\n", encode $z;
fa8ec7c1
NC
527}
528
0b568b5f
MS
529is("1.20.300.4000", sprintf "%vd", pack("U*",1,20,300,4000));
530is("1.20.300.4000", sprintf "%vd", pack(" U*",1,20,300,4000));
531isnt(v1.20.300.4000, sprintf "%vd", pack("C0U*",1,20,300,4000));
fa8ec7c1 532
0b568b5f
MS
533my $rslt = $Is_EBCDIC ? "156 67" : "199 162";
534is(join(" ", unpack("C*", chr(0x1e2))), $rslt);
fa8ec7c1
NC
535
536# does pack U create Unicode?
0b568b5f 537is(ord(pack('U', 300)), 300);
fa8ec7c1
NC
538
539# does unpack U deref Unicode?
0b568b5f 540is((unpack('U', chr(300)))[0], 300);
fa8ec7c1
NC
541
542# is unpack U the reverse of pack U for Unicode string?
0b568b5f 543is("@{[unpack('U*', pack('U*', 100, 200, 300))]}", "100 200 300");
fa8ec7c1
NC
544
545# is unpack U the reverse of pack U for byte string?
0b568b5f
MS
546is("@{[unpack('U*', pack('U*', 100, 200))]}", "100 200");
547
548
549SKIP: {
550 skip "Not for EBCDIC", 4 if $Is_EBCDIC;
fa8ec7c1 551
7eed2ccc 552 # does unpack C unravel pack U?
0b568b5f 553 is("@{[unpack('C*', pack('U*', 100, 200))]}", "100 195 136");
fa8ec7c1 554
7eed2ccc 555 # does pack U0C create Unicode?
0b568b5f 556 is("@{[pack('U0C*', 100, 195, 136)]}", v100.v200);
fa8ec7c1 557
7eed2ccc 558 # does pack C0U create characters?
0b568b5f 559 is("@{[pack('C0U*', 100, 200)]}", pack("C*", 100, 195, 136));
fa8ec7c1 560
2dcec3fe
JH
561 # does unpack U0U on byte data warn?
562 {
563 local $SIG{__WARN__} = sub { $@ = "@_" };
564 my @null = unpack('U0U', chr(255));
0b568b5f 565 like($@, /^Malformed UTF-8 character /);
2dcec3fe 566 }
35bcd338
JH
567}
568
fa8ec7c1
NC
569{
570 my $p = pack 'i*', -2147483648, ~0, 0, 1, 2147483647;
571 my (@a);
572 # bug - % had to be at the start of the pattern, no leading whitespace or
573 # comments. %i! didn't work at all.
574 foreach my $pat ('%32i*', ' %32i*', "# Muhahahaha\n%32i*", '%32i* ',
575 '%32i!*', ' %32i!*', "\n#\n#\n\r \t\f%32i!*", '%32i!*#') {
576 @a = unpack $pat, $p;
0b568b5f 577 is($a[0], 0xFFFFFFFF) || print "# $pat\n";
fa8ec7c1 578 @a = scalar unpack $pat, $p;
0b568b5f 579 is($a[0], 0xFFFFFFFF) || print "# $pat\n";
fa8ec7c1
NC
580 }
581
582
583 $p = pack 'I*', 42, 12;
584 # Multiline patterns in scalar context failed.
585 foreach my $pat ('I', <<EOPOEMSNIPPET, 'I#I', 'I # I', 'I # !!!') {
586# On the Ning Nang Nong
587# Where the Cows go Bong!
588# And the Monkeys all say Boo!
589I
590EOPOEMSNIPPET
0b568b5f
MS
591 @a = unpack $pat, $p;
592 is(scalar @a, 1);
593 is($a[0], 42);
594 @a = scalar unpack $pat, $p;
595 is(scalar @a, 1);
596 is($a[0], 42);
597 }
fa8ec7c1
NC
598
599 # shorts (of all flavours) didn't calculate checksums > 32 bits with floating
600 # point, so a pathologically long pattern would wrap at 32 bits.
601 my $pat = "\xff\xff"x65538; # Start with it long, to save any copying.
602 foreach (4,3,2,1,0) {
603 my $len = 65534 + $_;
0b568b5f 604 is(unpack ("%33n$len", $pat), 65535 * $len);
fa8ec7c1
NC
605 }
606}
b85d93de
NC
607
608
609# pack x X @
610foreach (
0b568b5f
MS
611 ['x', "N", "\0"],
612 ['x4', "N", "\0"x4],
613 ['xX', "N", ""],
614 ['xXa*', "Nick", "Nick"],
615 ['a5Xa5', "cameL", "llama", "camellama"],
616 ['@4', 'N', "\0"x4],
617 ['a*@8a*', 'Camel', 'Dromedary', "Camel\0\0\0Dromedary"],
618 ['a*@4a', 'Perl rules', '!', 'Perl!'],
619)
620{
b85d93de
NC
621 my ($template, @in) = @$_;
622 my $out = pop @in;
623 my $got = eval {pack $template, @in};
0b568b5f
MS
624 is($@, '');
625 is($out, $got) ||
626 printf "# pack ('$template', %s) gave %s expected %s\n",
627 encode_list (@in), encode_list ($got), encode_list ($out);
b85d93de
NC
628}
629
630# unpack x X @
631foreach (
0b568b5f
MS
632 ['x', "N"],
633 ['xX', "N"],
634 ['xXa*', "Nick", "Nick"],
635 ['a5Xa5', "camellama", "camel", "llama"],
636 ['@3', "ice"],
637 ['@2a2', "water", "te"],
638 ['a*@1a3', "steam", "steam", "tea"],
639)
640{
b85d93de
NC
641 my ($template, $in, @out) = @$_;
642 my @got = eval {unpack $template, $in};
0b568b5f
MS
643 is($@, '');
644 list_eq (\@got, \@out) ||
645 printf "# list unpack ('$template', \"%s\") gave %s expected %s\n",
646 encode ($in), encode_list (@got), encode_list (@out);
b85d93de
NC
647
648 my $got = eval {unpack $template, $in};
0b568b5f
MS
649 is($@, '');
650 @out ? is( $got, $out[0] ) # 1 or more items; should get first
651 : ok( !defined $got ) # 0 items; should get undef
b85d93de 652 or printf "# scalar unpack ('$template', \"%s\") gave %s expected %s\n",
0b568b5f 653 encode ($in), encode_list ($got), encode_list ($out[0]);
b85d93de 654}
d50dd4e4
JH
655
656{
d50dd4e4
JH
657 my $t = 'Z*Z*';
658 my ($u, $v) = qw(foo xyzzy);
659 my $p = pack($t, $u, $v);
660 my @u = unpack($t, $p);
0b568b5f
MS
661 is(scalar @u, 2);
662 is($u[0], $u);
663 is($u[1], $v);
d50dd4e4 664}
bf80f5a2
JH
665
666{
0b568b5f 667 is((unpack("w/a*", "\x02abc"))[0], "ab");
bf80f5a2 668
0b568b5f 669 # "w/a*" should be seen as one unit
bf80f5a2 670
0b568b5f 671 is(scalar unpack("w/a*", "\x02abc"), "ab");
bf80f5a2 672}
b81060d6
WL
673
674{
b81060d6
WL
675 # from Wolfgang Laun: fix in change #13163
676
677 my $s = 'ABC' x 10;
678 my $x = 42;
679 my $buf = pack( 'Z*/A* C', $s, $x );
680 my $y;
681
682 my $h = $buf;
683 $h =~ s/[^[:print:]]/./g;
684 ( $s, $y ) = unpack( "Z*/A* C", $buf );
0b568b5f
MS
685 is($h, "30.ABCABCABCABCABCABCABCABCABCABC*");
686 is(length $buf, 34);
687 is($s, "ABCABCABCABCABCABCABCABCABCABC");
688 is($y, 42);
b81060d6 689}
3bf38418
WL
690
691{
b223308b 692 # from Wolfgang Laun: fix in change #13288
3bf38418 693
b223308b 694 eval { my $t=unpack("P*", "abc") };
0b568b5f 695 like($@, qr/P must have an explicit size/);
3bf38418 696}