t/op/pack.t

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