-#!./perl -Tw
+#!./perl -w
-print "1..581\n";
+print "1..615\n";
BEGIN {
chdir 't' if -d 't';
sub encode {
my @result = @_;
- s/([[:cntrl:]\177 ])/sprintf "\\%03o", ord $1/ge foreach @result;
+ foreach (@result) {
+ s/([[:cntrl:]\177 ])/sprintf "\\%03o", ord $1/ge if defined;
+ }
@result;
}
+sub encode_list {
+ my @result = @_;
+ foreach (@result) {
+ if (defined) {
+ s/([[:cntrl:]\177])/sprintf "\\%03o", ord $1/ge;
+ $_ = qq("$_");
+ } else {
+ $_ = 'undef';
+ }
+ }
+ if (@result == 1) {
+ return @result;
+ }
+ return '(' . join (', ', @result) . ')';
+}
+
sub ok {
my ($pass, $wrong, $err) = @_;
if ($pass) {
} else {
if ($err) {
chomp $err;
- print "not ok $test # \$\@ = $err\n";
+ print "not ok $test # $err\n";
} else {
if (defined $wrong) {
$wrong = ", got $wrong";
return;
}
+sub list_eq ($$) {
+ my ($l, $r) = @_;
+ return unless @$l == @$r;
+ for my $i (0..$#$l) {
+ if (defined $l->[$i]) {
+ return unless defined ($r->[$i]) && $l->[$i] eq $r->[$i];
+ } else {
+ return if defined $r->[$i]
+ }
+ }
+ return 1;
+}
+
+##############################################################################
+#
+# Here starteth the tests
+#
+
{
my $format = "c2 x5 C C x s d i l a6";
# Need the expression in here to force ary[5] to be numeric. This avoids
$max_is_integer = 1 if $max - 1 < ~0;
my $calc_sum;
- if ($total =~ /^0b[01]*?([01]{1,$len})/) {
- no warnings qw(overflow portable);
- $calc_sum = oct "0b$1";
+ if (ref $total) {
+ $calc_sum = &$total($len);
} else {
$calc_sum = $total;
# Shift into range by some multiple of the total
print "ok $test # unpack '%$_$format' gave $sum,"
. " expected $calc_sum\n";
} else {
- print "not ok $test # For list (" . join (", ", @_) . ") (total $total)"
+ my $text = ref $total ? &$total($len) : $total;
+ print "not ok $test # For list (" . join (", ", @_) . ") (total $text)"
. " packed with $format unpack '%$_$format' gave $sum,"
. " expected $calc_sum\n";
}
numbers ('V', 0, 1, 2147483647, 2147483648, 4294967295);
# All these should have exact binary representations:
numbers ('f', -1, 0, 0.5, 42, 2**34);
-# These don't, but 'd' is NV.
-numbers ('d', -1, 0, 1, 1-exp(-1), -exp(1));
+numbers ('d', -(2**34), -1, 0, 1, 2**34);
+## These don't, but 'd' is NV. XXX wrong, it's double
+#numbers ('d', -1, 0, 1, 1-exp(-1), -exp(1));
numbers_with_total ('q', -1,
-9223372036854775808, -1, 0, 1,9223372036854775807);
-# This total is icky, but need a way to express 2**65-1 that is going to
-# work independant of whether NVs can preserve 65 bits.
-# (long double is 128 bits on sparc, so they certianly can)
-numbers_with_total ('Q', "0b" . "1" x 65,
+# This total is icky, but the true total is 2**65-1, and need a way to generate
+# the epxected checksum on any system including those where NVs can preserve
+# 65 bits. (long double is 128 bits on sparc, so they certainly can)
+# or where rounding is down not up on binary conversion (crays)
+numbers_with_total ('Q', sub {
+ my $len = shift;
+ $len = 65 if $len > 65; # unmasked total is 2**65-1 here
+ my $total = 1 + 2 * (int (2**($len - 1)) - 1);
+ return 0 if $total == $total - 1; # Overflowed integers
+ return $total; # NVs still accurate to nearest integer
+ },
0, 1,9223372036854775807, 9223372036854775808,
18446744073709551615);
printf "# got '%s'\n", encode $z;
}
+ $expect = 'hello world';
+ eval { ($x) = unpack ("w/a", chr (11) . "hello world!")};
+ ok ($x eq $expect);
+ ok ($@ eq '', undef, $@);
+ # Doing this in scalar context used to fail.
+ eval { $x = unpack ("w/a", chr (11) . "hello world!")};
+ unless (ok ($x eq $expect, undef, $@)) {
+ printf "# expected '$expect' got '%s'\n", encode $x;
+ }
+ ok ($@ eq '', undef, $@);
+
foreach (
['a/a*/a*', '212ab345678901234567','ab3456789012'],
['a/a*/a*', '3012ab345678901234567', 'ab3456789012'],
) {
my ($pat, $in, $expect) = @$_;
eval { ($x) = unpack $pat, $in };
- unless (ok ($x eq $expect)) {
- $x = encode $x;
- print "# pack ('$pat', '$in') gave '$x', expected '$expect'\n";
- }
+ ok ($@ eq '' && $x eq $expect, undef, $@)
+ or printf "# list unpack ('$pat', '$in') gave %s, expected '$expect'\n",
+ encode_list ($x);
+ eval { $x = unpack $pat, $in };
+ ok ($@ eq '' && $x eq $expect, undef, $@)
+ or printf "# scalar unpack ('$pat', '$in') gave %s, expected '$expect'\n",
+ encode_list ($x);
}
# / with #
# is unpack U the reverse of pack U for byte string?
ok ("@{[unpack('U*', pack('U*', 100, 200))]}" eq "100 200");
-# does unpack C unravel pack U?
-ok ("@{[unpack('C*', pack('U*', 100, 200))]}" eq "100 195 136");
+if (ord('A') == 193) {
+ ok(1, undef, "skipped") for 1..4; # EBCDIC
+} else {
+ # does unpack C unravel pack U?
+ ok ("@{[unpack('C*', pack('U*', 100, 200))]}" eq "100 195 136");
-# does pack U0C create Unicode?
-ok ("@{[pack('U0C*', 100, 195, 136)]}" eq v100.v200);
+ # does pack U0C create Unicode?
+ ok ("@{[pack('U0C*', 100, 195, 136)]}" eq v100.v200);
-# does pack C0U create characters?
-ok ("@{[pack('C0U*', 100, 200)]}" eq pack("C*", 100, 195, 136));
+ # does pack C0U create characters?
+ ok ("@{[pack('C0U*', 100, 200)]}" eq pack("C*", 100, 195, 136));
-# does unpack U0U on byte data warn?
-{
- local $SIG{__WARN__} = sub { $@ = "@_" };
- my @null = unpack('U0U', chr(255));
- ok ($@ =~ /^Malformed UTF-8 character /, undef, $@);
+ # does unpack U0U on byte data warn?
+ {
+ local $SIG{__WARN__} = sub { $@ = "@_" };
+ my @null = unpack('U0U', chr(255));
+ ok ($@ =~ /^Malformed UTF-8 character /, undef, $@);
+ }
}
{
ok (unpack ("%33n$len", $pat) == 65535 * $len);
}
}
+
+
+# pack x X @
+foreach (
+['x', "N", "\0"],
+['x4', "N", "\0"x4],
+['xX', "N", ""],
+['xXa*', "Nick", "Nick"],
+['a5Xa5', "cameL", "llama", "camellama"],
+['@4', 'N', "\0"x4],
+['a*@8a*', 'Camel', 'Dromedary', "Camel\0\0\0Dromedary"],
+['a*@4a', 'Perl rules', '!', 'Perl!'],
+) {
+ my ($template, @in) = @$_;
+ my $out = pop @in;
+ my $got = eval {pack $template, @in};
+ ok ($@ eq '' and $out eq $got, '', $@)
+ or printf "# pack ('$template', %s) gave %s expected %s\n",
+ encode_list (@in), encode_list ($got), encode_list ($out);
+}
+
+# unpack x X @
+foreach (
+['x', "N"],
+['xX', "N"],
+['xXa*', "Nick", "Nick"],
+['a5Xa5', "camellama", "camel", "llama"],
+['@3', "ice"],
+['@2a2', "water", "te"],
+['a*@1a3', "steam", "steam", "tea"],
+) {
+ my ($template, $in, @out) = @$_;
+ my @got = eval {unpack $template, $in};
+ ok (($@ eq '' and list_eq (\@got, \@out)), undef, $@)
+ or printf "# list unpack ('$template', \"%s\") gave %s expected %s\n",
+ encode ($in), encode_list (@got), encode_list (@out);
+
+ my $got = eval {unpack $template, $in};
+ ok (($@ eq '' and @out ? $got eq $out[0] # 1 or more items; should get first
+ : !defined $got) # 0 items; should get undef
+ , "", $@)
+ or printf "# scalar unpack ('$template', \"%s\") gave %s expected %s\n",
+ encode ($in), encode_list ($got), encode_list ($out[0]);
+}
+
+{
+ # 611
+ my $t = 'Z*Z*';
+ my ($u, $v) = qw(foo xyzzy);
+ my $p = pack($t, $u, $v);
+ my @u = unpack($t, $p);
+ ok(@u == 2 && $u[0] eq $u && $u[1] eq $v);
+}
+
+{
+ # 612
+
+ ok((unpack("w/a*", "\x02abc"))[0] eq "ab");
+
+ # 613: "w/a*" should be seen as one unit
+
+ ok(scalar unpack("w/a*", "\x02abc") eq "ab");
+}
+
+{
+ # 614
+
+ # from Wolfgang Laun: fix in change #13163
+
+ my $s = 'ABC' x 10;
+ my $x = 42;
+ my $buf = pack( 'Z*/A* C', $s, $x );
+ my $y;
+
+ my $h = $buf;
+ $h =~ s/[^[:print:]]/./g;
+ ( $s, $y ) = unpack( "Z*/A* C", $buf );
+ ok($h eq "30.ABCABCABCABCABCABCABCABCABCABC*" &&
+ length $buf == 34 &&
+ $s eq "ABCABCABCABCABCABCABCABCABCABC" &
+ $y == 42);
+}
+
+{
+ # 615
+
+ # from Wolfgang Laun: fix in change #13288
+
+ eval { my $t=unpack("P*", "abc") };
+ ok($@ =~ /P must have an explicit size/);
+}
projects / p5sagit/p5-mst-13.2.git / blobdiff