require './test.pl';
}
-plan tests => 1477;
+plan tests => 5826;
use strict;
use warnings;
sub list_eq ($$) {
my ($l, $r) = @_;
- return unless @$l == @$r;
+ return 0 unless @$l == @$r;
for my $i (0..$#$l) {
if (defined $l->[$i]) {
- return unless defined ($r->[$i]) && $l->[$i] eq $r->[$i];
+ return 0 unless defined ($r->[$i]) && $l->[$i] eq $r->[$i];
} else {
- return if defined $r->[$i]
+ return 0 if defined $r->[$i]
}
}
return 1;
$y = pack('w*', Math::BigInt::->new(5000000000));
};
is($x, $y);
+
+ $x = pack 'w', ~0;
+ $y = pack 'w', (~0).'';
+ is($x, $y);
+ is(unpack ('w',$x), ~0);
+ is(unpack ('w',$y), ~0);
+
+ $x = pack 'w', ~0 - 1;
+ $y = pack 'w', (~0) - 2;
+
+ if (~0 - 1 == (~0) - 2) {
+ is($x, $y, "NV arithmetic");
+ } else {
+ isnt($x, $y, "IV/NV arithmetic");
+ }
+ cmp_ok(unpack ('w',$x), '==', ~0 - 1);
+ cmp_ok(unpack ('w',$y), '==', ~0 - 2);
+
+ # These should spot that pack 'w' is using NV, not double, on platforms
+ # where IVs are smaller than doubles, and harmlessly pass elsewhere.
+ # (tests for change 16861)
+ my $x0 = 2**54+3;
+ my $y0 = 2**54-2;
+
+ $x = pack 'w', $x0;
+ $y = pack 'w', $y0;
+
+ if ($x0 == $y0) {
+ is($x, $y, "NV arithmetic");
+ } else {
+ isnt($x, $y, "IV/NV arithmetic");
+ }
+ cmp_ok(unpack ('w',$x), '==', $x0);
+ cmp_ok(unpack ('w',$y), '==', $y0);
}
{
- # test exeptions
+ # test exceptions
my $x;
eval { $x = unpack 'w', pack 'C*', 0xff, 0xff};
like($@, qr/^Unterminated compressed integer/);
eval { $x = unpack 'w', pack 'C*', 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff};
like($@, qr/^Unterminated compressed integer/);
+
+ eval { $x = pack 'w', -1 };
+ like ($@, qr/^Cannot compress negative numbers/);
+
+ eval { $x = pack 'w', '1'x(1 + length ~0) . 'e0' };
+ like ($@, qr/^Can only compress unsigned integers/);
+
+ SKIP: {
+ # Is this a stupid thing to do on VMS, VOS and other unusual platforms?
+ my $inf = eval '2**10000';
+
+ skip "Couldn't generate infinity - got error '$@'"
+ unless defined $inf and $inf == $inf / 2 and $inf + 1 == $inf;
+
+ eval { $x = pack 'w', $inf };
+ like ($@, qr/^Cannot compress integer/);
+ }
+
+ SKIP: {
+ # This should be about the biggest thing possible on an IEEE double
+ my $big = eval '2**1023';
+
+ skip "Couldn't generate 2**1023 - got error '$@'", 3
+ unless defined $big and $big != $big / 2;
+
+ eval { $x = pack 'w', $big };
+ is ($@, '', "Should be able to pack 'w', $big # 2**1023");
+
+ my $y = eval {unpack 'w', $x};
+ is ($@, '',
+ "Should be able to unpack 'w' the result of pack 'w', $big # 2**1023");
+
+ # I'm getting about 1e-16 on FreeBSD
+ my $quotient = int (100 * ($y - $big) / $big);
+ ok($quotient < 2 && $quotient > -2,
+ "Round trip pack, unpack 'w' of $big is withing 1% ($quotient%)");
+ }
+
}
#
# UVs (in which case ~0 is NV, ~0-1 will be the same NV) then we can't
# correctly in perl calculate UV totals for long checksums, as pp_unpack
# is using UV maths, and we've only got NVs.
- $skip_if_longer_than = $Config{d_nv_preserves_uv_bits};
+ $skip_if_longer_than = $Config{nv_preserves_uv_bits};
}
foreach ('', 1, 2, 3, 15, 16, 17, 31, 32, 33, 53, 54, 63, 64, 65) {
my ($template, $in, @out) = @$_;
my @got = eval {unpack $template, $in};
is($@, '');
- list_eq (\@got, \@out) ||
+ ok (list_eq (\@got, \@out)) ||
printf "# list unpack ('$template', %s) gave %s expected %s\n",
_qq($in), encode_list (@got), encode_list (@out);
eval { my $t=unpack("P*", "abc") };
like($@, qr/P must have an explicit size/);
}
+
+{ # Grouping constructs
+ my (@a, @b);
+ @a = unpack '(SL)', pack 'SLSLSL', 67..90;
+ is("@a", "67 68");
+ @a = unpack '(SL)3', pack 'SLSLSL', 67..90;
+ @b = (67..72);
+ is("@a", "@b");
+ @a = unpack '(SL)3', pack 'SLSLSLSL', 67..90;
+ is("@a", "@b");
+ @a = unpack '(SL)[3]', pack 'SLSLSLSL', 67..90;
+ is("@a", "@b");
+ @a = unpack '(SL)[2] SL', pack 'SLSLSLSL', 67..90;
+ is("@a", "@b");
+ @a = unpack 'A/(SL)', pack 'ASLSLSLSL', 3, 67..90;
+ is("@a", "@b");
+ @a = unpack 'A/(SL)SL', pack 'ASLSLSLSL', 2, 67..90;
+ is("@a", "@b");
+ @a = unpack '(SL)*', pack 'SLSLSLSL', 67..90;
+ @b = (67..74);
+ is("@a", "@b");
+ @a = unpack '(SL)*SL', pack 'SLSLSLSL', 67..90;
+ is("@a", "@b");
+ eval { @a = unpack '(*SL)', '' };
+ like($@, qr/\(\)-group starts with a count/);
+ eval { @a = unpack '(3SL)', '' };
+ like($@, qr/\(\)-group starts with a count/);
+ eval { @a = unpack '([3]SL)', '' };
+ like($@, qr/\(\)-group starts with a count/);
+ eval { @a = pack '(*SL)' };
+ like($@, qr/\(\)-group starts with a count/);
+ @a = unpack '(SL)3 SL', pack '(SL)4', 67..74;
+ is("@a", "@b");
+ @a = unpack '(SL)3 SL', pack '(SL)[4]', 67..74;
+ is("@a", "@b");
+ @a = unpack '(SL)3 SL', pack '(SL)*', 67..74;
+ is("@a", "@b");
+}
+
+{ # Repeat count [SUBEXPR]
+ my @codes = qw( x A Z a c C B b H h s v n S i I l V N L p P f F d
+ s! S! i! I! l! L! j J);
+ my $G;
+ if (eval { pack 'q', 1 } ) {
+ push @codes, qw(q Q);
+ } else {
+ push @codes, qw(c C); # Keep the count the same
+ }
+ if (eval { pack 'D', 1 } ) {
+ push @codes, 'D';
+ } else {
+ push @codes, 'd'; # Keep the count the same
+ }
+
+ my %val;
+ @val{@codes} = map { / [Xx] (?{ undef })
+ | [AZa] (?{ 'something' })
+ | C (?{ 214 })
+ | c (?{ 114 })
+ | [Bb] (?{ '101' })
+ | [Hh] (?{ 'b8' })
+ | [svnSiIlVNLqQjJ] (?{ 10111 })
+ | [FfDd] (?{ 1.36514538e67 })
+ | [pP] (?{ "try this buffer" })
+ /x; $^R } @codes;
+ my @end = (0x12345678, 0x23456781, 0x35465768, 0x15263748);
+ my $end = "N4";
+
+ for my $type (@codes) {
+ my @list = $val{$type};
+ @list = () unless defined $list[0];
+ for my $count ('', '3', '[11]') {
+ my $c = 1;
+ $c = $1 if $count =~ /(\d+)/;
+ my @list1 = @list;
+ @list1 = (@list1) x $c unless $type =~ /[XxAaZBbHhP]/;
+ for my $groupend ('', ')2', ')[8]') {
+ my $groupbegin = ($groupend ? '(' : '');
+ $c = 1;
+ $c = $1 if $groupend =~ /(\d+)/;
+ my @list2 = (@list1) x $c;
+
+ my $junk1 = "$groupbegin $type$count $groupend";
+ # print "# junk1=$junk1\n";
+ my $p = pack $junk1, @list2;
+ my $half = int( (length $p)/2 );
+ for my $move ('', "X$half", "X!$half", 'x1', 'x!8', "x$half") {
+ my $junk = "$junk1 $move";
+ # print "# junk='$junk', list=(@list2)\n";
+ $p = pack "$junk $end", @list2, @end;
+ my @l = unpack "x[$junk] $end", $p;
+ is(scalar @l, scalar @end);
+ is("@l", "@end", "skipping x[$junk]");
+ }
+ }
+ }
+ }
+}
+
+# / is recognized after spaces in scalar context
+# XXXX no spaces are allowed in pack... In pack only before the slash...
+is(scalar unpack('A /A Z20', pack 'A/A* Z20', 'bcde', 'xxxxx'), 'bcde');
+is(scalar unpack('A /A /A Z20', '3004bcde'), 'bcde');
+
+{ # X! and x!
+ my $t = 'C[3] x!8 C[2]';
+ my @a = (0x73..0x77);
+ my $p = pack($t, @a);
+ is($p, "\x73\x74\x75\0\0\0\0\0\x76\x77");
+ my @b = unpack $t, $p;
+ is(scalar @b, scalar @a);
+ is("@b", "@a", 'x!8');
+ $t = 'x[5] C[6] X!8 C[2]';
+ @a = (0x73..0x7a);
+ $p = pack($t, @a);
+ is($p, "\0\0\0\0\0\x73\x74\x75\x79\x7a");
+ @b = unpack $t, $p;
+ @a = (0x73..0x75, 0x79, 0x7a, 0x79, 0x7a);
+ is(scalar @b, scalar @a);
+ is("@b", "@a");
+}
+
+{ # struct {char c1; double d; char cc[2];}
+ my $t = 'C x![d] d C[2]';
+ my @a = (173, 1.283476517e-45, 42, 215);
+ my $p = pack $t, @a;
+ ok( length $p);
+ my @b = unpack "$t X[$t] $t", $p; # Extract, step back, extract again
+ is(scalar @b, 2 * scalar @a);
+ $b = "@b";
+ $b =~ s/(?:17000+|16999+)\d+(e-45) /17$1 /gi; # stringification is gamble
+ is($b, "@a @a");
+
+ my $warning;
+ local $SIG{__WARN__} = sub {
+ $warning = $_[0];
+ };
+ @b = unpack "x[C] x[$t] X[$t] X[C] $t", "$p\0";
+
+ is($warning, undef);
+ is(scalar @b, scalar @a);
+ $b = "@b";
+ $b =~ s/(?:17000+|16999+)\d+(e-45) /17$1 /gi; # stringification is gamble
+ is($b, "@a");
+}
+
+is(length(pack("j", 0)), $Config{ivsize});
+is(length(pack("J", 0)), $Config{uvsize});
+is(length(pack("F", 0)), $Config{nvsize});
+
+numbers ('j', -2147483648, -1, 0, 1, 2147483647);
+numbers ('J', 0, 1, 2147483647, 2147483648, 4294967295);
+numbers ('F', -(2**34), -1, 0, 1, 2**34);
+SKIP: {
+ my $t = eval { unpack("D*", pack("D", 12.34)) };
+
+ skip "Long doubles not in use", 56 if $@ =~ /Invalid type in pack/;
+
+ is(length(pack("D", 0)), $Config{longdblsize});
+ numbers ('D', -(2**34), -1, 0, 1, 2**34);
+}
+
+# Maybe this knowledge needs to be "global" for all of pack.t
+# Or a "can checksum" which would effectively be all the number types"
+my %cant_checksum = map {$_=> 1} qw(A Z u w);
+# not a b B h H
+foreach my $template (qw(A Z c C s S i I l L n N v V q Q j J f d F D u U w)) {
+ SKIP: {
+ my $packed = eval {pack "${template}4", 1, 4, 9, 16};
+ if ($@) {
+ die unless $@ =~ /Invalid type in pack: '$template'/;
+ skip ("$template not supported on this perl",
+ $cant_checksum{$template} ? 4 : 8);
+ }
+ my @unpack4 = unpack "${template}4", $packed;
+ my @unpack = unpack "${template}*", $packed;
+ my @unpack1 = unpack "${template}", $packed;
+ my @unpack1s = scalar unpack "${template}", $packed;
+ my @unpack4s = scalar unpack "${template}4", $packed;
+ my @unpacks = scalar unpack "${template}*", $packed;
+
+ my @tests = ( ["${template}4 vs ${template}*", \@unpack4, \@unpack],
+ ["scalar ${template} ${template}", \@unpack1s, \@unpack1],
+ ["scalar ${template}4 vs ${template}", \@unpack4s, \@unpack1],
+ ["scalar ${template}* vs ${template}", \@unpacks, \@unpack1],
+ );
+
+ unless ($cant_checksum{$template}) {
+ my @unpack4_c = unpack "\%${template}4", $packed;
+ my @unpack_c = unpack "\%${template}*", $packed;
+ my @unpack1_c = unpack "\%${template}", $packed;
+ my @unpack1s_c = scalar unpack "\%${template}", $packed;
+ my @unpack4s_c = scalar unpack "\%${template}4", $packed;
+ my @unpacks_c = scalar unpack "\%${template}*", $packed;
+
+ push @tests,
+ ( ["% ${template}4 vs ${template}*", \@unpack4_c, \@unpack_c],
+ ["% scalar ${template} ${template}", \@unpack1s_c, \@unpack1_c],
+ ["% scalar ${template}4 vs ${template}*", \@unpack4s_c, \@unpack_c],
+ ["% scalar ${template}* vs ${template}*", \@unpacks_c, \@unpack_c],
+ );
+ }
+ foreach my $test (@tests) {
+ ok (list_eq ($test->[1], $test->[2]), $test->[0]) ||
+ printf "# unpack gave %s expected %s\n",
+ encode_list (@{$test->[1]}), encode_list (@{$test->[2]});
+ }
+ }
+}
+
+ok(pack('u2', 'AA'), "[perl #8026]"); # used to hang and eat RAM in perl 5.7.2
+
projects / p5sagit/p5-mst-13.2.git / blobdiff