require './test.pl';
}
-plan tests => 1470;
+plan tests => 5619;
use strict;
use warnings;
my $Is_EBCDIC = (defined $Config{ebcdic} && $Config{ebcdic} eq 'define');
my $Perl = which_perl();
-sub encode {
- my @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';
- }
- }
+ my @result = map {_qq($_)} @_;
if (@result == 1) {
return @result;
}
is(scalar(@y), 2);
is($y[1], 130);
+ $x = pack('w*', 5000000000); $y = '';
+ eval {
+ use Math::BigInt;
+ $y = pack('w*', Math::BigInt::->new(5000000000));
+ };
+ is($x, $y);
}
is( $@, '' );
is(scalar @t, 2);
- if( $t =~ /[nv]/i ) {
+
+ SKIP: {
+ skip "$t not expected to work for some reason", 2 if $t =~ /[nv]/i;
+
is($t[0], 12);
is($t[1], 34);
}
- else {
- pass() for 1..2;
- }
}
}
my ($what, $template, $in, $out) = @$_;
my $got = $what eq 'u' ? (unpack $template, $in) : (pack $template, $in);
unless (is($got, $out)) {
- ($in, $out, $got) = encode ($in, $out, $got);
my $un = $what eq 'u' ? 'un' : '';
- print "# ${un}pack ('$template', \"$in\") gave $out not $got\n";
+ print "# ${un}pack ('$template', "._qq($in).') gave '._qq($out).
+ ' not '._qq($got)."\n";
}
}
$calc_sum = 0;
}
- if (is( $calc_sum, $sum)) {
- print "# unpack '%$_$format' gave $sum\n";
+ if ($calc_sum == $sum) { # HAS to be ==, not eq (so no is()).
+ ok ("unpack '%$_$format' gave $sum");
} else {
my $delta = 1.000001;
if ($format =~ tr /dDfF//
&& ($calc_sum <= $sum * $delta && $calc_sum >= $sum / $delta)) {
- pass;
- print "# unpack '%$_$format' gave $sum, expected $calc_sum\n";
+ pass ("unpack '%$_$format' gave $sum, expected $calc_sum");
} else {
my $text = ref $total ? &$total($len) : $total;
fail;
my ($x, $y, $z);
eval { ($x) = unpack '/a*','hello' };
like($@, qr!/ must follow a numeric type!);
+ undef $x;
+ eval { $x = unpack '/a*','hello' };
+ like($@, qr!/ must follow a numeric type!);
+ undef $x;
eval { ($z,$x,$y) = unpack 'a3/A C/a* C/Z', "003ok \003yes\004z\000abc" };
is($@, '');
is($z, 'ok');
is($x, 'yes');
is($y, 'z');
+ undef $z;
+ eval { $z = unpack 'a3/A C/a* C/Z', "003ok \003yes\004z\000abc" };
+ is($@, '');
+ is($z, 'ok');
+
+ undef $x;
eval { ($x) = pack '/a*','hello' };
like($@, qr!Invalid type in pack: '/'!);
+ undef $x;
+ eval { $x = pack '/a*','hello' };
+ like($@, qr!Invalid type in pack: '/'!);
$z = pack 'n/a* N/Z* w/A*','string','hi there ','etc';
my $expect = "\000\006string\0\0\0\012hi there \000\003etc";
is($z, $expect);
+ undef $x;
$expect = 'hello world';
eval { ($x) = unpack ("w/a", chr (11) . "hello world!")};
is($x, $expect);
is($@, '');
+ undef $x;
# Doing this in scalar context used to fail.
eval { $x = unpack ("w/a", chr (11) . "hello world!")};
is($@, '');
)
{
my ($pat, $in, $expect) = @$_;
+ undef $x;
eval { ($x) = unpack $pat, $in };
is($@, '');
is($x, $expect) ||
printf "# list unpack ('$pat', '$in') gave %s, expected '$expect'\n",
encode_list ($x);
+ undef $x;
eval { $x = unpack $pat, $in };
is($@, '');
is($x, $expect) ||
# / with #
- eval { ($z,$x,$y) = unpack <<EOU, "003ok \003yes\004z\000abc" };
+ my $pattern = <<'EOU';
a3/A # Count in ASCII
C/a* # Count in a C char
C/Z # Count in a C char but skip after \0
EOU
+ $x = $y = $z =undef;
+ eval { ($z,$x,$y) = unpack $pattern, "003ok \003yes\004z\000abc" };
is($@, '');
is($z, 'ok');
is($x, 'yes');
is($y, 'z');
+ undef $x;
+ eval { $z = unpack $pattern, "003ok \003yes\004z\000abc" };
+ is($@, '');
+ is($z, 'ok');
- $z = pack <<EOP,'string','etc';
+ $pattern = <<'EOP';
n/a* # Count as network short
w/A* # Count a BER integer
EOP
$expect = "\000\006string\003etc";
-
- is($z, $expect) ||
- printf "# got '%s', expected '$expect'\n", encode $z;
+ $z = pack $pattern,'string','etc';
+ is($z, $expect);
}
-is("1.20.300.4000", sprintf "%vd", pack("U*",1,20,300,4000));
-is("1.20.300.4000", sprintf "%vd", pack(" U*",1,20,300,4000));
+
+SKIP: {
+ skip("(EBCDIC and) version strings are bad idea", 2) if $Is_EBCDIC;
+
+ is("1.20.300.4000", sprintf "%vd", pack("U*",1,20,300,4000));
+ is("1.20.300.4000", sprintf "%vd", pack(" U*",1,20,300,4000));
+}
isnt(v1.20.300.4000, sprintf "%vd", pack("C0U*",1,20,300,4000));
my $rslt = $Is_EBCDIC ? "156 67" : "199 162";
my @got = eval {unpack $template, $in};
is($@, '');
list_eq (\@got, \@out) ||
- printf "# list unpack ('$template', \"%s\") gave %s expected %s\n",
- encode ($in), encode_list (@got), encode_list (@out);
+ printf "# list unpack ('$template', %s) gave %s expected %s\n",
+ _qq($in), encode_list (@got), encode_list (@out);
my $got = eval {unpack $template, $in};
is($@, '');
@out ? is( $got, $out[0] ) # 1 or more items; should get first
: ok( !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]);
+ or printf "# scalar unpack ('$template', %s) gave %s expected %s\n",
+ _qq($in), encode_list ($got), encode_list ($out[0]);
}
{
# from Wolfgang Laun: fix in change #13163
my $s = 'ABC' x 10;
- my $x = 42;
+ my $t = '*';
+ my $x = ord($t);
my $buf = pack( 'Z*/A* C', $s, $x );
my $y;
my $h = $buf;
$h =~ s/[^[:print:]]/./g;
( $s, $y ) = unpack( "Z*/A* C", $buf );
- is($h, "30.ABCABCABCABCABCABCABCABCABCABC*");
+ is($h, "30.ABCABCABCABCABCABCABCABCABCABC$t");
is(length $buf, 34);
is($s, "ABCABCABCABCABCABCABCABCABCABC");
- is($y, 42);
+ is($y, $x);
}
{
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);
+ 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);
+ 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);
+}
+