From 726ea1832d97e828b8b876350acab4bc0387050a Mon Sep 17 00:00:00 2001 From: Jarkko Hietaniemi Date: Mon, 15 Feb 1999 13:50:07 +0000 Subject: [PATCH] Enhance the packnative patch: use the packnative code only if required. Also added hefty testing (hopefully I didn't assume too much...). Tested on alpha, ix86, sparc. p4raw-id: //depot/cfgperl@2952 --- pod/perlfunc.pod | 18 ++++++---- pp.c | 101 ++++++++++++++++++++++++++++++++++++++++++++++--------- t/op/pack.t | 78 ++++++++++++++++++++++++++++++++++++++++-- 3 files changed, 173 insertions(+), 24 deletions(-) diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index 07e2361..1297e71 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -2592,19 +2592,25 @@ C<"P"> is C. =item * The integer types C<"s">, C<"S">, C<"l">, and C<"L"> may be -immediately followed by a C<"_"> to signify a native short or long--as +immediately followed by a C<"_"> to signify native shorts or longs--as you can see from above for example a bare C<"l"> does mean exactly 32 bits, the native C (as seen by the local C compiler) may be -larger. This is an issue mainly in 64-bit platforms. +larger. This is an issue mainly in 64-bit platforms. You can see +whether using C<"_"> makes any difference by + + print length(pack("s")), " ", length(pack("s_")), "\n"; + print length(pack("l")), " ", length(pack("l_")), "\n"; C<"i_"> and C<"I_"> also work but only because of completeness; they are identical to C<"i"> and C<"I">. -The actual size (in bytes) of native shorts, ints, and longs on -the platform where Perl was built are available from L: +The actual sizes (in bytes) of native shorts, ints, and longs on +the platform where Perl was built are available via L: use Config; print $Config{shortsize}, "\n"; + print $Config{intsize}, "\n"; + print $Config{longsize}, "\n"; =item * @@ -2632,8 +2638,8 @@ You can see your system's preference with print join(" ", map { sprintf "%#02x", $_ } unpack("C*",pack("L",0x12345678))), "\n"; -The actual byteorder on the platform where Perl was built are available -from L: +The actual byteorder on the platform where Perl was built is available +via L: use Config; print $Config{byteorder}, "\n"; diff --git a/pp.c b/pp.c index 985a3ed..d5b7081 100644 --- a/pp.c +++ b/pp.c @@ -78,6 +78,10 @@ typedef unsigned UBW; #define SIZE16 2 #define SIZE32 4 +#if SHORTSIZE != SIZE16 || LONGSIZE != SIZE32 +# define PERL_NATINT_PACK +#endif + #if BYTEORDER > 0xFFFF && defined(_CRAY) && !defined(_CRAYMPP) # if BYTEORDER == 0x12345678 # define OFF16(p) (char*)(p) @@ -3243,8 +3247,10 @@ PP(pp_unpack) register U32 culong; double cdouble; int commas = 0; +#ifdef PERL_NATINT_PACK int natint; /* native integer */ int unatint; /* unsigned native integer */ +#endif if (gimme != G_ARRAY) { /* arrange to do first one only */ /*SUPPRESS 530*/ @@ -3260,14 +3266,18 @@ PP(pp_unpack) while (pat < patend) { reparse: datumtype = *pat++ & 0xFF; +#ifdef PERL_NATINT_PACK natint = 0; +#endif if (isSPACE(datumtype)) continue; if (*pat == '_') { char *natstr = "sSiIlL"; if (strchr(natstr, datumtype)) { +#ifdef PERL_NATINT_PACK natint = 1; +#endif pat++; } else @@ -3517,10 +3527,15 @@ PP(pp_unpack) } break; case 's': +#if SHORTSIZE == SIZE16 + along = (strend - s) / SIZE16; +#else along = (strend - s) / (natint ? sizeof(short) : SIZE16); +#endif if (len > along) len = along; if (checksum) { +#if SHORTSIZE != SIZE16 if (natint) { while (len-- > 0) { COPYNN(s, &ashort, sizeof(short)); @@ -3529,7 +3544,9 @@ PP(pp_unpack) } } - else { + else +#endif + { while (len-- > 0) { COPY16(s, &ashort); s += SIZE16; @@ -3540,6 +3557,7 @@ PP(pp_unpack) else { EXTEND(SP, len); EXTEND_MORTAL(len); +#if SHORTSIZE != SIZE16 if (natint) { while (len-- > 0) { COPYNN(s, &ashort, sizeof(short)); @@ -3549,7 +3567,9 @@ PP(pp_unpack) PUSHs(sv_2mortal(sv)); } } - else { + else +#endif + { while (len-- > 0) { COPY16(s, &ashort); s += SIZE16; @@ -3563,11 +3583,16 @@ PP(pp_unpack) case 'v': case 'n': case 'S': +#if SHORTSIZE == SIZE16 + along = (strend - s) / SIZE16; +#else unatint = natint && datumtype == 'S'; along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16); +#endif if (len > along) len = along; if (checksum) { +#if SHORTSIZE != SIZE16 if (unatint) { while (len-- > 0) { COPYNN(s, &aushort, sizeof(unsigned short)); @@ -3575,7 +3600,9 @@ PP(pp_unpack) culong += aushort; } } - else { + else +#endif + { while (len-- > 0) { COPY16(s, &aushort); s += SIZE16; @@ -3594,16 +3621,19 @@ PP(pp_unpack) else { EXTEND(SP, len); EXTEND_MORTAL(len); +#if SHORTSIZE != SIZE16 if (unatint) { while (len-- > 0) { COPYNN(s, &aushort, sizeof(unsigned short)); s += sizeof(unsigned short); sv = NEWSV(39, 0); - sv_setiv(sv, (IV)aushort); + sv_setiv(sv, (UV)aushort); PUSHs(sv_2mortal(sv)); } } - else { + else +#endif + { while (len-- > 0) { COPY16(s, &aushort); s += SIZE16; @@ -3616,7 +3646,7 @@ PP(pp_unpack) if (datumtype == 'v') aushort = vtohs(aushort); #endif - sv_setiv(sv, (IV)aushort); + sv_setiv(sv, (UV)aushort); PUSHs(sv_2mortal(sv)); } } @@ -3693,10 +3723,15 @@ PP(pp_unpack) } break; case 'l': +#if LONGSIZE == SIZE32 + along = (strend - s) / SIZE32; +#else along = (strend - s) / (natint ? sizeof(long) : SIZE32); +#endif if (len > along) len = along; if (checksum) { +#if LONGSIZE != SIZE32 if (natint) { while (len-- > 0) { COPYNN(s, &along, sizeof(long)); @@ -3707,7 +3742,9 @@ PP(pp_unpack) culong += along; } } - else { + else +#endif + { while (len-- > 0) { COPY32(s, &along); s += SIZE32; @@ -3721,6 +3758,7 @@ PP(pp_unpack) else { EXTEND(SP, len); EXTEND_MORTAL(len); +#if LONGSIZE != SIZE32 if (natint) { while (len-- > 0) { COPYNN(s, &along, sizeof(long)); @@ -3730,7 +3768,9 @@ PP(pp_unpack) PUSHs(sv_2mortal(sv)); } } - else { + else +#endif + { while (len-- > 0) { COPY32(s, &along); s += SIZE32; @@ -3744,11 +3784,16 @@ PP(pp_unpack) case 'V': case 'N': case 'L': - unatint = natint && datumtype; +#if LONGSIZE == SIZE32 + along = (strend - s) / SIZE32; +#else + unatint = natint && datumtype == 'L'; along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32); +#endif if (len > along) len = along; if (checksum) { +#if LONGSIZE != SIZE32 if (unatint) { while (len-- > 0) { COPYNN(s, &aulong, sizeof(unsigned long)); @@ -3759,7 +3804,9 @@ PP(pp_unpack) culong += aulong; } } - else { + else +#endif + { while (len-- > 0) { COPY32(s, &aulong); s += SIZE32; @@ -3781,6 +3828,7 @@ PP(pp_unpack) else { EXTEND(SP, len); EXTEND_MORTAL(len); +#if LONGSIZE != SIZE32 if (unatint) { while (len-- > 0) { COPYNN(s, &aulong, sizeof(unsigned long)); @@ -3790,7 +3838,9 @@ PP(pp_unpack) PUSHs(sv_2mortal(sv)); } } - else { + else +#endif + { while (len-- > 0) { COPY32(s, &aulong); s += SIZE32; @@ -4210,7 +4260,9 @@ PP(pp_pack) float afloat; double adouble; int commas = 0; +#ifdef PERL_NATINT_PACK int natint; /* native integer */ +#endif items = SP - MARK; MARK++; @@ -4218,14 +4270,18 @@ PP(pp_pack) while (pat < patend) { #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no) datumtype = *pat++ & 0xFF; +#ifdef PERL_NATINT_PACK natint = 0; +#endif if (isSPACE(datumtype)) continue; if (*pat == '_') { char *natstr = "sSiIlL"; if (strchr(natstr, datumtype)) { +#ifdef PERL_NATINT_PACK natint = 1; +#endif pat++; } else @@ -4475,6 +4531,7 @@ PP(pp_pack) } break; case 'S': +#if SHORTSIZE != SIZE16 if (natint) { unsigned short aushort; @@ -4484,17 +4541,21 @@ PP(pp_pack) sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short)); } } - else { + else +#endif + { U16 aushort; while (len-- > 0) { fromstr = NEXTFROM; - aushort = (U16)SvIV(fromstr); + aushort = (U16)SvUV(fromstr); CAT16(cat, &aushort); } + } break; case 's': +#if SHORTSIZE != 2 if (natint) { while (len-- > 0) { fromstr = NEXTFROM; @@ -4502,7 +4563,9 @@ PP(pp_pack) sv_catpvn(cat, (char *)&ashort, sizeof(short)); } } - else { + else +#endif + { while (len-- > 0) { fromstr = NEXTFROM; ashort = (I16)SvIV(fromstr); @@ -4615,6 +4678,7 @@ PP(pp_pack) } break; case 'L': +#if LONGSIZE != SIZE32 if (natint) { while (len-- > 0) { fromstr = NEXTFROM; @@ -4622,7 +4686,9 @@ PP(pp_pack) sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long)); } } - else { + else +#endif + { while (len-- > 0) { fromstr = NEXTFROM; aulong = SvUV(fromstr); @@ -4631,6 +4697,7 @@ PP(pp_pack) } break; case 'l': +#if LONGSIZE != SIZE32 if (natint) { while (len-- > 0) { fromstr = NEXTFROM; @@ -4638,7 +4705,9 @@ PP(pp_pack) sv_catpvn(cat, (char *)&along, sizeof(long)); } } - else { + else +#endif + { while (len-- > 0) { fromstr = NEXTFROM; along = SvIV(fromstr); diff --git a/t/op/pack.t b/t/op/pack.t index 82f2b1c..3b8ee35 100755 --- a/t/op/pack.t +++ b/t/op/pack.t @@ -6,7 +6,7 @@ BEGIN { require Config; import Config; } -print "1..78\n"; +print "1..98\n"; $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 @@ -246,7 +246,7 @@ print "ok ", $test++, "\n"; print "not " unless unpack('Z8', "foo\0bar \0") eq "foo"; print "ok ", $test++, "\n"; -# 73..77: packing native shorts/ints/longs +# 73..78: packing native shorts/ints/longs print "not " unless length(pack("s_", 0)) == $Config{shortsize}; print "ok ", $test++, "\n"; @@ -266,3 +266,77 @@ print "ok ", $test++, "\n"; print "not " unless length(pack("i_", 0)) == length(pack("i", 0)); print "ok ", $test++, "\n"; +# 79..94: test the limits + +print "not " unless unpack("c", pack("c", 127)) == 127; +print "ok ", $test++, "\n"; + +print "not " unless unpack("c", pack("c", -128)) == -128; +print "ok ", $test++, "\n"; + +print "not " unless unpack("C", pack("C", 255)) == 255; +print "ok ", $test++, "\n"; + +print "not " unless unpack("s", pack("s", 32767)) == 32767; +print "ok ", $test++, "\n"; + +print "not " unless unpack("s", pack("s", -32768)) == -32768; +print "ok ", $test++, "\n"; + +print "not " unless unpack("S", pack("S", 65535)) == 65535; +print "ok ", $test++, "\n"; + +print "not " unless unpack("i", pack("i", 2147483647)) == 2147483647; +print "ok ", $test++, "\n"; + +print "not " unless unpack("i", pack("i", -2147483648)) == -2147483648; +print "ok ", $test++, "\n"; + +print "not " unless unpack("I", pack("I", 4294967295)) == 4294967295; +print "ok ", $test++, "\n"; + +print "not " unless unpack("l", pack("l", 2147483647)) == 2147483647; +print "ok ", $test++, "\n"; + +print "not " unless unpack("l", pack("l", -2147483648)) == -2147483648; +print "ok ", $test++, "\n"; + +print "not " unless unpack("L", pack("L", 4294967295)) == 4294967295; +print "ok ", $test++, "\n"; + +print "not " unless unpack("n", pack("n", 65535)) == 65535; +print "ok ", $test++, "\n"; + +print "not " unless unpack("n", pack("v", 65535)) == 65535; +print "ok ", $test++, "\n"; + +print "not " unless unpack("N", pack("N", 4294967295)) == 4294967295; +print "ok ", $test++, "\n"; + +print "not " unless unpack("V", pack("V", 4294967295)) == 4294967295; +print "ok ", $test++, "\n"; + +# 95..98 test the n/v/N/V byteorder + +if ($Config{byteorder} =~ /^1234(5678)?$/ || + $Config{byteorder} =~ /^(8765)?4321$/) { + +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"; + +print "not " unless pack("N", 0xdeadbeef) eq "\xde\xad\xbe\xef"; +print "ok ", $test++, "\n"; + +print "not " unless pack("V", 0xdeadbeef) eq "\xef\xbe\xad\xde"; +print "ok ", $test++, "\n"; + +} else { + # weird byteorders require more thought + foreach (95..98) { + print "ok ", $test++, " # skipped\n"; + } +} + -- 1.8.3.1