From: Nicholas Clark Date: Thu, 20 Sep 2001 14:27:08 +0000 (+0100) Subject: Re: n questions (was Re: 4 questions about pack/unpack) X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=fa8ec7c13dcb82551b3b5da77efcc0da9b1b45f5;p=p5sagit%2Fp5-mst-13.2.git Re: n questions (was Re: 4 questions about pack/unpack) Message-ID: <20010920142708.X4971@plum.flirble.org> p4raw-id: //depot/perl@12092 --- diff --git a/pp_pack.c b/pp_pack.c index 54ed0b7..1075143 100644 --- a/pp_pack.c +++ b/pp_pack.c @@ -159,8 +159,9 @@ PP(pp_unpack) float afloat; double adouble; I32 checksum = 0; - register U32 culong = 0; + UV culong = 0; NV cdouble = 0.0; + const int bits_in_uv = 8 * sizeof(culong); int commas = 0; int star; #ifdef PERL_NATINT_PACK @@ -171,14 +172,30 @@ PP(pp_unpack) if (gimme != G_ARRAY) { /* arrange to do first one only */ /*SUPPRESS 530*/ - for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ; - if (strchr("aAZbBhHP", *patend) || *pat == '%') { - patend++; - while (isDIGIT(*patend) || *patend == '*') - patend++; - } - else - patend++; + /* Skipping spaces will be useful later on. */ + while (isSPACE(*pat)) + pat++; + /* Give up on optimisation of only doing first if the pattern + is getting too complex to parse. */ + if (*pat != '#') { + /* This pre-parser will let through certain invalid patterns + such as rows of !s, but the nothing that would cause multiple + conversions to be attempted. */ + char *here = pat; + bool seen_percent = FALSE; + if (*here == '%') + seen_percent = TRUE; + while (!isALPHA(*here) || *here == 'x') + here++; + if (strchr("aAZbBhHP", *here) || seen_percent) { + here++; + while (isDIGIT(*here) || *here == '*' || *here == '!') + here++; + } + else + here++; + patend = here; + } } while (pat < patend) { reparse: @@ -206,7 +223,7 @@ PP(pp_unpack) DIE(aTHX_ "'!' allowed only after types %s", natstr); } star = 0; - if (pat > patend) + if (pat >= patend) len = 1; else if (*pat == '*') { len = strend - strbeg; /* long enough */ @@ -400,7 +417,10 @@ PP(pp_unpack) aint = *s++; if (aint >= 128) /* fake up signed chars */ aint -= 256; - culong += aint; + if (checksum > bits_in_uv) + cdouble += (NV)aint; + else + culong += aint; } } else { @@ -457,7 +477,7 @@ PP(pp_unpack) auint = utf8n_to_uvchr((U8*)s, strend - s, &alen, 0); along = alen; s += along; - if (checksum > 32) + if (checksum > bits_in_uv) cdouble += (NV)auint; else culong += auint; @@ -492,7 +512,10 @@ PP(pp_unpack) while (len-- > 0) { COPYNN(s, &ashort, sizeof(short)); s += sizeof(short); - culong += ashort; + if (checksum > bits_in_uv) + cdouble += (NV)ashort; + else + culong += ashort; } } @@ -506,7 +529,10 @@ PP(pp_unpack) ashort -= 65536; #endif s += SIZE16; - culong += ashort; + if (checksum > bits_in_uv) + cdouble += (NV)ashort; + else + culong += ashort; } } } @@ -559,7 +585,10 @@ PP(pp_unpack) while (len-- > 0) { COPYNN(s, &aushort, sizeof(unsigned short)); s += sizeof(unsigned short); - culong += aushort; + if (checksum > bits_in_uv) + cdouble += (NV)aushort; + else + culong += aushort; } } else @@ -576,7 +605,10 @@ PP(pp_unpack) if (datumtype == 'v') aushort = vtohs(aushort); #endif - culong += aushort; + if (checksum > bits_in_uv) + cdouble += (NV)aushort; + else + culong += aushort; } } } @@ -623,7 +655,7 @@ PP(pp_unpack) while (len-- > 0) { Copy(s, &aint, 1, int); s += sizeof(int); - if (checksum > 32) + if (checksum > bits_in_uv) cdouble += (NV)aint; else culong += aint; @@ -674,7 +706,7 @@ PP(pp_unpack) while (len-- > 0) { Copy(s, &auint, 1, unsigned int); s += sizeof(unsigned int); - if (checksum > 32) + if (checksum > bits_in_uv) cdouble += (NV)auint; else culong += auint; @@ -713,7 +745,7 @@ PP(pp_unpack) while (len-- > 0) { COPYNN(s, &along, sizeof(long)); s += sizeof(long); - if (checksum > 32) + if (checksum > bits_in_uv) cdouble += (NV)along; else culong += along; @@ -732,7 +764,7 @@ PP(pp_unpack) along -= 4294967296; #endif s += SIZE32; - if (checksum > 32) + if (checksum > bits_in_uv) cdouble += (NV)along; else culong += along; @@ -790,7 +822,7 @@ PP(pp_unpack) while (len-- > 0) { COPYNN(s, &aulong, sizeof(unsigned long)); s += sizeof(unsigned long); - if (checksum > 32) + if (checksum > bits_in_uv) cdouble += (NV)aulong; else culong += aulong; @@ -810,7 +842,7 @@ PP(pp_unpack) if (datumtype == 'V') aulong = vtohl(aulong); #endif - if (checksum > 32) + if (checksum > bits_in_uv) cdouble += (NV)aulong; else culong += aulong; @@ -932,43 +964,67 @@ PP(pp_unpack) along = (strend - s) / sizeof(Quad_t); if (len > along) len = along; - EXTEND(SP, len); - EXTEND_MORTAL(len); - while (len-- > 0) { - if (s + sizeof(Quad_t) > strend) - aquad = 0; - else { + if (checksum) { + while (len-- > 0) { Copy(s, &aquad, 1, Quad_t); s += sizeof(Quad_t); + if (checksum > bits_in_uv) + cdouble += (NV)aquad; + else + culong += aquad; } - sv = NEWSV(42, 0); - if (aquad >= IV_MIN && aquad <= IV_MAX) - sv_setiv(sv, (IV)aquad); - else - sv_setnv(sv, (NV)aquad); - PUSHs(sv_2mortal(sv)); } + else { + EXTEND(SP, len); + EXTEND_MORTAL(len); + while (len-- > 0) { + if (s + sizeof(Quad_t) > strend) + aquad = 0; + else { + Copy(s, &aquad, 1, Quad_t); + s += sizeof(Quad_t); + } + sv = NEWSV(42, 0); + if (aquad >= IV_MIN && aquad <= IV_MAX) + sv_setiv(sv, (IV)aquad); + else + sv_setnv(sv, (NV)aquad); + PUSHs(sv_2mortal(sv)); + } + } break; case 'Q': along = (strend - s) / sizeof(Quad_t); if (len > along) len = along; - EXTEND(SP, len); - EXTEND_MORTAL(len); - while (len-- > 0) { - if (s + sizeof(Uquad_t) > strend) - auquad = 0; - else { + if (checksum) { + while (len-- > 0) { Copy(s, &auquad, 1, Uquad_t); s += sizeof(Uquad_t); - } - sv = NEWSV(43, 0); - if (auquad <= UV_MAX) - sv_setuv(sv, (UV)auquad); - else + if (checksum > bits_in_uv) + cdouble += (NV)auquad; + else + culong += auquad; + } + } + else { + EXTEND(SP, len); + EXTEND_MORTAL(len); + while (len-- > 0) { + if (s + sizeof(Uquad_t) > strend) + auquad = 0; + else { + Copy(s, &auquad, 1, Uquad_t); + s += sizeof(Uquad_t); + } + sv = NEWSV(43, 0); + if (auquad <= UV_MAX) + sv_setuv(sv, (UV)auquad); + else sv_setnv(sv, (NV)auquad); - PUSHs(sv_2mortal(sv)); - } + PUSHs(sv_2mortal(sv)); + } + } break; #endif /* float and double added gnb@melba.bby.oz.au 22/11/89 */ @@ -1082,30 +1138,23 @@ PP(pp_unpack) if (checksum) { sv = NEWSV(42, 0); if (strchr("fFdD", datumtype) || - (checksum > 32 && strchr("iIlLNU", datumtype)) ) { + (checksum > bits_in_uv && strchr("csSiIlLnNUvVqQ", datumtype)) ) { NV trouble; - adouble = 1.0; + adouble = (NV) (1 << (checksum & 15)); while (checksum >= 16) { checksum -= 16; adouble *= 65536.0; } - while (checksum >= 4) { - checksum -= 4; - adouble *= 16.0; - } - while (checksum--) - adouble *= 2.0; - along = (1 << checksum) - 1; while (cdouble < 0.0) cdouble += adouble; cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble; sv_setnv(sv, cdouble); } else { - if (checksum < 32) { - aulong = (1 << checksum) - 1; - culong &= aulong; + if (checksum < bits_in_uv) { + UV mask = ((UV)1 << checksum) - 1; + culong &= mask; } sv_setuv(sv, (UV)culong); } diff --git a/t/op/pack.t b/t/op/pack.t index 8d32746..cb1270a 100755 --- a/t/op/pack.t +++ b/t/op/pack.t @@ -1,122 +1,145 @@ #!./perl -Tw +print "1..581\n"; + BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } +use strict; +use warnings; use Config; -$Is_EBCDIC = (defined $Config{ebcdic} && $Config{ebcdic} eq 'define'); +my $Is_EBCDIC = (defined $Config{ebcdic} && $Config{ebcdic} eq 'define'); my $test = 1; -sub ok { - my($ok) = @_; - - # You have to do it this way or VMS will get confused. - my $out = ''; - $out = "not " unless $ok; - $out .= "ok $test\n"; - print $out; +# Using Test considered bad plan in op/*.t ? - printf "# Failed test at line %d\n", (caller)[2] unless $ok; +sub encode { + my @result = @_; + s/([[:cntrl:]\177 ])/sprintf "\\%03o", ord $1/ge foreach @result; + @result; +} +sub ok { + my ($pass, $wrong, $err) = @_; + if ($pass) { + print "ok $test\n"; $test++; - return $ok; + return 1; + } else { + if ($err) { + chomp $err; + print "not ok $test # \$\@ = $err\n"; + } else { + if (defined $wrong) { + $wrong = ", got $wrong"; + } else { + $wrong = ''; + } + printf "not ok $test # line %d$wrong\n", (caller)[2]; + } + } + $test++; + return; } - -print "1..169\n"; - -# Note: All test numbers in comments are off by 1 after the comment below.. - -$format = "c2 x5 C C x s d i l a6"; +{ +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 # test2 failing because ary2 goes str->numeric->str and ary doesn't. -@ary = (1,-100,127,128,32767,987.654321098 / 100.0,12345,123456,"abcdef"); -$foo = pack($format,@ary); -@ary2 = unpack($format,$foo); +my @ary = (1,-100,127,128,32767,987.654321098 / 100.0,12345,123456,"abcdef"); +my $foo = pack($format,@ary); +my @ary2 = unpack($format,$foo); ok($#ary == $#ary2); -$out1=join(':',@ary); -$out2=join(':',@ary2); +my $out1=join(':',@ary); +my $out2=join(':',@ary2); # Using long double NVs may introduce greater accuracy than wanted. $out1 =~ s/:9\.87654321097999\d*:/:9.87654321098:/; $out2 =~ s/:9\.87654321097999\d*:/:9.87654321098:/; ok($out1 eq $out2); ok($foo =~ /def/); - +} # How about counting bits? +{ +my $x; ok( ($x = unpack("%32B*", "\001\002\004\010\020\040\100\200\377")) == 16 ); ok( ($x = unpack("%32b69", "\001\002\004\010\020\040\100\200\017")) == 12 ); ok( ($x = unpack("%32B69", "\001\002\004\010\020\040\100\200\017")) == 9 ); +} +{ my $sum = 129; # ASCII $sum = 103 if $Is_EBCDIC; +my $x; ok( ($x = unpack("%32B*", "Now is the time for all good blurfl")) == $sum ); +my $foo; open(BIN, "./perl") || open(BIN, "./perl.exe") || open(BIN, $^X) || die "Can't open ../perl or ../perl.exe: $!\n"; sysread BIN, $foo, 8192; close BIN; $sum = unpack("%32b*", $foo); -$longway = unpack("b*", $foo); +my $longway = unpack("b*", $foo); ok( $sum == $longway =~ tr/1/1/ ); +} -ok( ($x = unpack("I",pack("I", 0xFFFFFFFF))) == 0xFFFFFFFF ); +{ + my $x; + ok( ($x = unpack("I",pack("I", 0xFFFFFFFF))) == 0xFFFFFFFF ); +} +{ # check 'w' my @x = (5,130,256,560,32000,3097152,268435455,1073741844, 2**33, '4503599627365785','23728385234614992549757750638446'); my $x = pack('w*', @x); my $y = pack 'H*', '0581028200843081fa0081bd8440ffffff7f8480808014A08080800087ffffffffffdb19caefe8e1eeeea0c2e1e3e8ede1ee6e'; -if ($x eq $y) { - print "ok $test\n"; -} else { - printf "not ok $test # %s\n", unpack 'H*', $x; -} -$test++; - -@y = unpack('w*', $y); +ok ($x eq $y, unpack 'H*', $x); +my @y = unpack('w*', $y); my $a; while ($a = pop @x) { my $b = pop @y; - print $a eq $b ? "ok $test\n" : "not ok $test\n$a\n$b\n"; $test++; + ok ($a eq $b, "\$a='$a' \$b='$b'"); } -# XXX All test numbers in comments are off by 1 after this point. - @y = unpack('w2', $x); -print scalar(@y) == 2 ? "ok $test\n" : "not ok $test\n"; $test++; -print $y[1] == 130 ? "ok $test\n" : "not ok $test # $y[1]\n"; $test++; +ok (scalar(@y) == 2); +ok ($y[1] == 130, $y[1]); +} -# test exeptions -eval { $x = unpack 'w', pack 'C*', 0xff, 0xff}; -print $@ ne '' ? "ok $test\n" : "not ok $test\n"; $test++; +{ + # test exeptions + my $x; + eval { $x = unpack 'w', pack 'C*', 0xff, 0xff}; + ok ($@ =~ /^Unterminated compressed integer/, undef, $@); -eval { $x = unpack 'w', pack 'C*', 0xff, 0xff, 0xff, 0xff}; -print $@ ne '' ? "ok $test\n" : "not ok $test\n"; $test++; + eval { $x = unpack 'w', pack 'C*', 0xff, 0xff, 0xff, 0xff}; + ok ($@ =~ /^Unterminated compressed integer/, undef, $@); -eval { $x = unpack 'w', pack 'C*', 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff}; -print $@ ne '' ? "ok $test\n" : "not ok $test\n"; $test++; + eval { $x = unpack 'w', pack 'C*', 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff}; + ok ($@ =~ /^Unterminated compressed integer/, undef, $@); +} # # test the "p" template # literals -print((unpack("p",pack("p","foo")) eq "foo" ? "ok " : "not ok "),$test++,"\n"); +ok(unpack("p",pack("p","foo")) eq "foo"); # scalars -print((unpack("p",pack("p",$test)) == $test ? "ok " : "not ok "),$test++,"\n"); +ok(unpack("p",pack("p",$test)) == $test); # temps sub foo { my $a = "a"; return $a . $a++ . $a++ } @@ -131,46 +154,27 @@ sub foo { my $a = "a"; return $a . $a++ . $a++ } } # undef should give null pointer -print((pack("p", undef) =~ /^\0+/ ? "ok " : "not ok "),$test++,"\n"); +ok (pack("p", undef) =~ /^\0+/); # Check for optimizer bug (e.g. Digital Unix GEM cc with -O4 on DU V4.0B gives # 4294967295 instead of -1) # see #ifdef __osf__ in pp.c pp_unpack # Test 30: -print( ((unpack("i",pack("i",-1))) == -1 ? "ok " : "not ok "),$test++,"\n"); +ok((unpack("i",pack("i",-1))) == -1, "__osf__ like bug seems to exist"); # 31..36: test the pack lengths of s S i I l L -print "not " unless length(pack("s", 0)) == 2; -print "ok ", $test++, "\n"; - -print "not " unless length(pack("S", 0)) == 2; -print "ok ", $test++, "\n"; - -print "not " unless length(pack("i", 0)) >= 4; -print "ok ", $test++, "\n"; - -print "not " unless length(pack("I", 0)) >= 4; -print "ok ", $test++, "\n"; - -print "not " unless length(pack("l", 0)) == 4; -print "ok ", $test++, "\n"; - -print "not " unless length(pack("L", 0)) == 4; -print "ok ", $test++, "\n"; - # 37..40: test the pack lengths of n N v V - -print "not " unless length(pack("n", 0)) == 2; -print "ok ", $test++, "\n"; - -print "not " unless length(pack("N", 0)) == 4; -print "ok ", $test++, "\n"; - -print "not " unless length(pack("v", 0)) == 2; -print "ok ", $test++, "\n"; - -print "not " unless length(pack("V", 0)) == 4; -print "ok ", $test++, "\n"; +my @lengths = qw(s 2 S 2 i -4 I -4 l 4 L 4 n 2 N 4 v 2 V 4); +while (my ($format, $expect) = splice @lengths, 0, 2) { + my $len = length(pack($format, 0)); + if ($expect > 0) { + ok ($expect == $len, "format '$format' has length $len, expected $expect"); + } else { + $expect = -$expect; + ok ($len >= $expect, + "format '$format' has length $len, expected >= $expect"); + } +} # 41..56: test unpack-pack lengths @@ -183,11 +187,11 @@ push @templates, $@ !~ /Invalid type in pack/ ? qw(q Q) : qw(f d); foreach my $t (@templates) { my @t = unpack("$t*", pack("$t*", 12, 34)); - print "not " - unless @t == 2 and (($t[0] == 12 and $t[1] == 34) or ($t =~ /[nv]/i)); - print "ok ", $test++, "\n"; + ok ((@t == 2 and (($t[0] == 12 and $t[1] == 34) or ($t =~ /[nv]/i))), + "unpack-pack length for '$t' failed; \@t=@t"); } +{ # 57..60: uuencode/decode # Note that first uuencoding known 'text' data and then checking the @@ -195,10 +199,10 @@ foreach my $t (@templates) { # character sets. Uuencoding is meant for encoding binary data, not # text data. -$in = pack 'C*', 0 .. 255; +my $in = pack 'C*', 0 .. 255; # just to be anal, we do some random tr/`/ / -$uu = <<'EOUU'; +my $uu = <<'EOUU'; M` $"`P0%!@<("0H+# T.#Q`1$A,4%187&!D:&QP='A\@(2(C)"4F)R@I*BLL M+2XO,#$R,S0U-C'EZ>WQ]?G^`@8*#A(6& @@ -209,11 +213,10 @@ EOUU $_ = $uu; tr/ /`/; -print "not " unless pack('u', $in) eq $_; -print "ok ", $test++, "\n"; -print "not " unless unpack('u', $uu) eq $in; -print "ok ", $test++, "\n"; +ok (pack('u', $in) eq $_); + +ok (unpack('u', $uu) eq $in); $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"; $uu = <<'EOUU'; @@ -221,8 +224,7 @@ M'XL("%C("`&1F &8%P:```` EOUU -print "not " unless unpack('u', $uu) eq $in; -print "ok ", $test++, "\n"; +ok unless unpack('u', $uu); # 60 identical to 59 except that backquotes have been changed to spaces @@ -231,272 +233,321 @@ M'XL("%C(" &1F &8%P: EOUU -print "not " unless unpack('u', $uu) eq $in; -print "ok ", $test++, "\n"; - -# 61..73: test the ascii template types (A, a, Z) - -print "not " unless pack('A*', "foo\0bar\0 ") eq "foo\0bar\0 "; -print "ok ", $test++, "\n"; - -print "not " unless pack('A11', "foo\0bar\0 ") eq "foo\0bar\0 "; -print "ok ", $test++, "\n"; - -print "not " unless unpack('A*', "foo\0bar \0") eq "foo\0bar"; -print "ok ", $test++, "\n"; - -print "not " unless unpack('A8', "foo\0bar \0") eq "foo\0bar"; -print "ok ", $test++, "\n"; - -print "not " unless pack('a*', "foo\0bar\0 ") eq "foo\0bar\0 "; -print "ok ", $test++, "\n"; - -print "not " unless pack('a11', "foo\0bar\0 ") eq "foo\0bar\0 \0\0"; -print "ok ", $test++, "\n"; - -print "not " unless unpack('a*', "foo\0bar \0") eq "foo\0bar \0"; -print "ok ", $test++, "\n"; - -print "not " unless unpack('a8', "foo\0bar \0") eq "foo\0bar "; -print "ok ", $test++, "\n"; - -print "not " unless pack('Z*', "foo\0bar\0 ") eq "foo\0bar\0 \0"; -print "ok ", $test++, "\n"; - -print "not " unless pack('Z11', "foo\0bar\0 ") eq "foo\0bar\0 \0\0"; -print "ok ", $test++, "\n"; - -print "not " unless pack('Z3', "foo") eq "fo\0"; -print "ok ", $test++, "\n"; - -print "not " unless unpack('Z*', "foo\0bar \0") eq "foo"; -print "ok ", $test++, "\n"; - -print "not " unless unpack('Z8', "foo\0bar \0") eq "foo"; -print "ok ", $test++, "\n"; - -# 74..79: packing native shorts/ints/longs - -print "not " unless length(pack("s!", 0)) == $Config{shortsize}; -print "ok ", $test++, "\n"; - -print "not " unless length(pack("i!", 0)) == $Config{intsize}; -print "ok ", $test++, "\n"; - -print "not " unless length(pack("l!", 0)) == $Config{longsize}; -print "ok ", $test++, "\n"; +# ' # Grr +ok (unpack('u', $uu) eq $in); -print "not " unless length(pack("s!", 0)) <= length(pack("i!", 0)); -print "ok ", $test++, "\n"; - -print "not " unless length(pack("i!", 0)) <= length(pack("l!", 0)); -print "ok ", $test++, "\n"; - -print "not " unless length(pack("i!", 0)) == length(pack("i", 0)); -print "ok ", $test++, "\n"; - -# 80..139: pack <-> unpack bijectionism - -# 80.. 84 c -foreach my $c (-128, -1, 0, 1, 127) { - print "not " unless unpack("c", pack("c", $c)) == $c; - print "ok ", $test++, "\n"; -} - -# 85.. 89: C -foreach my $C (0, 1, 127, 128, 255) { - print "not " unless unpack("C", pack("C", $C)) == $C; - print "ok ", $test++, "\n"; -} - -# 90.. 94: s -foreach my $s (-32768, -1, 0, 1, 32767) { - print "not " unless unpack("s", pack("s", $s)) == $s; - print "ok ", $test++, "\n"; -} - -# 95.. 99: S -foreach my $S (0, 1, 32767, 32768, 65535) { - print "not " unless unpack("S", pack("S", $S)) == $S; - print "ok ", $test++, "\n"; -} - -# 100..104: i -foreach my $i (-2147483648, -1, 0, 1, 2147483647) { - print "not " unless unpack("i", pack("i", $i)) == $i; - print "ok ", $test++, "\n"; -} - -# 105..109: I -foreach my $I (0, 1, 2147483647, 2147483648, 4294967295) { - print "not " unless unpack("I", pack("I", $I)) == $I; - print "ok ", $test++, "\n"; } -# 110..114: l -foreach my $l (-2147483648, -1, 0, 1, 2147483647) { - print "not " unless unpack("l", pack("l", $l)) == $l; - print "ok ", $test++, "\n"; -} - -# 115..119: L -foreach my $L (0, 1, 2147483647, 2147483648, 4294967295) { - print "not " unless unpack("L", pack("L", $L)) == $L; - print "ok ", $test++, "\n"; -} +# 61..73: test the ascii template types (A, a, Z) -# 120..124: n -foreach my $n (0, 1, 32767, 32768, 65535) { - print "not " unless unpack("n", pack("n", $n)) == $n; - print "ok ", $test++, "\n"; +foreach ( +['p', 'A*', "foo\0bar\0 ", "foo\0bar\0 "], +['p', 'A11', "foo\0bar\0 ", "foo\0bar\0 "], +['u', 'A*', "foo\0bar \0", "foo\0bar"], +['u', 'A8', "foo\0bar \0", "foo\0bar"], +['p', 'a*', "foo\0bar\0 ", "foo\0bar\0 "], +['p', 'a11', "foo\0bar\0 ", "foo\0bar\0 \0\0"], +['u', 'a*', "foo\0bar \0", "foo\0bar \0"], +['u', 'a8', "foo\0bar \0", "foo\0bar "], +['p', 'Z*', "foo\0bar\0 ", "foo\0bar\0 \0"], +['p', 'Z11', "foo\0bar\0 ", "foo\0bar\0 \0\0"], +['p', 'Z3', "foo", "fo\0"], +['u', 'Z*', "foo\0bar \0", "foo"], +['u', 'Z8', "foo\0bar \0", "foo"], +) { + my ($what, $template, $in, $out) = @$_; + my $got = $what eq 'u' ? (unpack $template, $in) : (pack $template, $in); + unless (ok ($got eq $out)) { + ($in, $out, $got) = encode ($in, $out, $got); + my $un = $what eq 'u' ? 'un' : ''; + print "# ${un}pack ('$template', \"$in\") gave $out not $got\n"; + } } -# 125..129: v -foreach my $v (0, 1, 32767, 32768, 65535) { - print "not " unless unpack("v", pack("v", $v)) == $v; - print "ok ", $test++, "\n"; -} +# 74..79: packing native shorts/ints/longs -# 130..134: N -foreach my $N (0, 1, 2147483647, 2147483648, 4294967295) { - print "not " unless unpack("N", pack("N", $N)) == $N; - print "ok ", $test++, "\n"; -} +ok (length(pack("s!", 0)) == $Config{shortsize}); +ok (length(pack("i!", 0)) == $Config{intsize}); +ok (length(pack("l!", 0)) == $Config{longsize}); +ok (length(pack("s!", 0)) <= length(pack("i!", 0))); +ok (length(pack("i!", 0)) <= length(pack("l!", 0))); +ok (length(pack("i!", 0)) == length(pack("i", 0))); -# 135..139: V -foreach my $V (0, 1, 2147483647, 2147483648, 4294967295) { - print "not " unless unpack("V", pack("V", $V)) == $V; - print "ok ", $test++, "\n"; +sub numbers { + my $format = shift; + return numbers_with_total ($format, undef, @_); } -# 140..143: pack nvNV byteorders - -print "not " unless pack("n", 0xdead) eq "\xde\xad"; -print "ok ", $test++, "\n"; - -print "not " unless pack("v", 0xdead) eq "\xad\xde"; -print "ok ", $test++, "\n"; +sub numbers_with_total { + my $format = shift; + my $total = shift; + if (!defined $total) { + foreach (@_) { + $total += $_; + } + } + foreach (@_) { + my $out = eval {unpack($format, pack($format, $_))}; + if ($@ =~ /Invalid type in pack: '$format'/) { + print "ok $test # skip cannot pack '$format' on this perl\n"; + } elsif ($out == $_) { + print "ok $test\n"; + } else { + print "not ok $test # unpack '$format', pack '$format', $_ gives $out\n"; + print "# \$\@='$@'\n" if $@; + } + $test++; + } -print "not " unless pack("N", 0xdeadbeef) eq "\xde\xad\xbe\xef"; -print "ok ", $test++, "\n"; + my $skip_if_longer_than = ~0; # "Infinity" + if (~0 - 1 == ~0) { + # If we're running with -DNO_PERLPRESERVE_IVUV and NVs don't preserve all + # 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}; + } -print "not " unless pack("V", 0xdeadbeef) eq "\xef\xbe\xad\xde"; -print "ok ", $test++, "\n"; + foreach ('', 1, 2, 3, 15, 16, 17, 31, 32, 33, 53, 54, 63, 64, 65) { + my $sum = eval {unpack "%$_$format*", pack "$format*", @_}; + if (!defined $sum) { + if ($@ =~ /Invalid type in pack: '$format'/) { + print "ok $test # skip cannot pack '$format' on this perl\n"; + } else { + print "not ok $test # \$\@='$@'\n" if $@; + } + next; + } + my $len = $_; # Copy, so that we can reassign '' + $len = 16 unless length $len; -# 144..152: / + if ($len > $skip_if_longer_than) { + print "ok $test # skip cannot test checksums over $skip_if_longer_than " + ."bits for this perl (compiled with -DNO_PERLPRESERVE_IVUV)\n"; + next; + } -# Using Test considered bad plan in op/*.t ? + # Our problem with testing this portably is that the checksum code in + # pp_unpack is able to cast signed to unsigned, and do modulo 2**n + # arithmetic in unsigned ints, which perl has no operators to do. + # (use integer; does signed ints, which won't wrap on UTS, which is just + # fine with ANSI, but not with most people's assumptions. + # This is why we need to supply the totals for 'Q' as there's no way in + # perl to calculate them, short of unpack '%0Q' (is that documented?) + # ** returns NVs; make sure it's IV. + my $max = 1 + 2 * (int (2 ** ($len-1))-1); # The maximum possible checksum + my $max_p1 = $max + 1; + my ($max_is_integer, $max_p1_is_integer); + $max_p1_is_integer = 1 unless $max_p1 + 1 == $max_p1; + $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"; + } else { + $calc_sum = $total; + # Shift into range by some multiple of the total + my $mult = int ($total / $max_p1); + # Need this to make sure that -1 + (~0+1) is ~0 (ie still integer) + $calc_sum = $total - $mult; + $calc_sum -= $mult * $max; + if ($calc_sum < 0) { + $calc_sum += 1; + $calc_sum += $max; + } + } + if ($calc_sum == $calc_sum - 1 && $calc_sum == $max_p1) { + # we're into floating point (either by getting out of the range of + # UV arithmetic, or because we're doing a floating point checksum) and + # our calculation of the checksum has become rounded up to + # max_checksum + 1 + $calc_sum = 0; + } -sub report { - my ($pass, $test, $err, $wrong) = @_; - if ($pass) { - print "ok $test\n" - } else { - if ($err) { - chomp $err; - print "not ok $test # \$\@ = $err\n"; + if ($calc_sum == $sum) { + print "ok $test # unpack '%$_$format' gave $sum\n"; } else { - $wrong =~ s/([[:cntrl:]\177 ])/sprintf "\\%03o", ord $1/ge; - print "not ok $test # got $wrong\n"; + my $delta = 1.000001; + if ($format =~ tr /dDfF// + && ($calc_sum <= $sum * $delta && $calc_sum >= $sum / $delta)) { + print "ok $test # unpack '%$_$format' gave $sum," + . " expected $calc_sum\n"; + } else { + print "not ok $test # For list (" . join (", ", @_) . ") (total $total)" + . " packed with $format unpack '%$_$format' gave $sum," + . " expected $calc_sum\n"; + } } + } continue { + $test++; } } -my $z; -eval { ($x) = unpack '/a*','hello' }; -print 'not ' unless $@; print "ok $test\n"; $test++; -eval { ($z,$x,$y) = unpack 'a3/A C/a* C/Z', "003ok \003yes\004z\000abc" }; -print $@ eq '' && $z eq 'ok' ? "ok $test\n" : "not ok $test\n"; $test++; -print $@ eq '' && $x eq 'yes' ? "ok $test\n" : "not ok $test\n"; $test++; -print $@ eq '' && $y eq 'z' ? "ok $test\n" : "not ok $test\n"; $test++; - -eval { ($x) = pack '/a*','hello' }; -print 'not ' unless $@; print "ok $test\n"; $test++; -$z = pack 'n/a* N/Z* w/A*','string','hi there ','etc'; -my $expect = "\000\006string\0\0\0\012hi there \000\003etc"; -report ($z eq $expect, $test++, '', $z); +numbers ('c', -128, -1, 0, 1, 127); +numbers ('C', 0, 1, 127, 128, 255); +numbers ('s', -32768, -1, 0, 1, 32767); +numbers ('S', 0, 1, 32767, 32768, 65535); +numbers ('i', -2147483648, -1, 0, 1, 2147483647); +numbers ('I', 0, 1, 2147483647, 2147483648, 4294967295); +numbers ('l', -2147483648, -1, 0, 1, 2147483647); +numbers ('L', 0, 1, 2147483647, 2147483648, 4294967295); +numbers ('s!', -32768, -1, 0, 1, 32767); +numbers ('S!', 0, 1, 32767, 32768, 65535); +numbers ('i!', -2147483648, -1, 0, 1, 2147483647); +numbers ('I!', 0, 1, 2147483647, 2147483648, 4294967295); +numbers ('l!', -2147483648, -1, 0, 1, 2147483647); +numbers ('L!', 0, 1, 2147483647, 2147483648, 4294967295); +numbers ('n', 0, 1, 32767, 32768, 65535); +numbers ('v', 0, 1, 32767, 32768, 65535); +numbers ('N', 0, 1, 2147483647, 2147483648, 4294967295); +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_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, + 0, 1,9223372036854775807, 9223372036854775808, + 18446744073709551615); + +# pack nvNV byteorders + +ok (pack("n", 0xdead) eq "\xde\xad"); +ok (pack("v", 0xdead) eq "\xad\xde"); +ok (pack("N", 0xdeadbeef) eq "\xde\xad\xbe\xef"); +ok (pack("V", 0xdeadbeef) eq "\xef\xbe\xad\xde"); -eval { ($x) = unpack 'a/a*/a*', '212ab345678901234567' }; -print $@ eq '' && $x eq 'ab3456789012' ? "ok $test\n" : "#$x,$@\nnot ok $test\n"; -$test++; - -eval { ($x) = unpack 'a/a*/a*', '3012ab345678901234567' }; -print $@ eq '' && $x eq 'ab3456789012' ? "ok $test\n" : "not ok $test\n"; -$test++; +{ + # / + + my ($x, $y, $z); + eval { ($x) = unpack '/a*','hello' }; + ok ($@ =~ m!/ must follow a numeric type!, undef, $@); + eval { ($z,$x,$y) = unpack 'a3/A C/a* C/Z', "003ok \003yes\004z\000abc" }; + ok ($z eq 'ok'); + ok ($x eq 'yes'); + ok ($y eq 'z'); + ok ($@ eq '', undef, $@); + + eval { ($x) = pack '/a*','hello' }; + ok ($@ =~ m!Invalid type in pack: '/'!, undef, $@); + + $z = pack 'n/a* N/Z* w/A*','string','hi there ','etc'; + my $expect = "\000\006string\0\0\0\012hi there \000\003etc"; + unless (ok ($z eq $expect)) { + printf "# got '%s'\n", encode $z; + } -eval { ($x) = unpack 'a/a*/b*', '212ab' }; -my $expected_x = '100001100100'; -if ($Is_EBCDIC) { $expected_x = '100000010100'; } -print $@ eq '' && $x eq $expected_x ? "ok $test\n" : "#$x,$@\nnot ok $test\n"; -$test++; + foreach ( +['a/a*/a*', '212ab345678901234567','ab3456789012'], +['a/a*/a*', '3012ab345678901234567', 'ab3456789012'], +['a/a*/b*', '212ab', $Is_EBCDIC ? '100000010100' : '100001100100'], +) { + 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"; + } + } -# 153..156: / with # +# / with # eval { ($z,$x,$y) = unpack < 32 bits with floating + # point, so a pathologically long pattern would wrap at 32 bits. + my $pat = "\xff\xff"x65538; # Start with it long, to save any copying. + foreach (4,3,2,1,0) { + my $len = 65534 + $_; + ok (unpack ("%33n$len", $pat) == 65535 * $len); + } +}