=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<long> (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<Config>:
+The actual sizes (in bytes) of native shorts, ints, and longs on
+the platform where Perl was built are available via L<Config>:
use Config;
print $Config{shortsize}, "\n";
+ print $Config{intsize}, "\n";
+ print $Config{longsize}, "\n";
=item *
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<Config>:
+The actual byteorder on the platform where Perl was built is available
+via L<Config>:
use Config;
print $Config{byteorder}, "\n";
#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)
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*/
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
}
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));
}
}
- else {
+ else
+#endif
+ {
while (len-- > 0) {
COPY16(s, &ashort);
s += SIZE16;
else {
EXTEND(SP, len);
EXTEND_MORTAL(len);
+#if SHORTSIZE != SIZE16
if (natint) {
while (len-- > 0) {
COPYNN(s, &ashort, sizeof(short));
PUSHs(sv_2mortal(sv));
}
}
- else {
+ else
+#endif
+ {
while (len-- > 0) {
COPY16(s, &ashort);
s += SIZE16;
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));
culong += aushort;
}
}
- else {
+ else
+#endif
+ {
while (len-- > 0) {
COPY16(s, &aushort);
s += SIZE16;
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;
if (datumtype == 'v')
aushort = vtohs(aushort);
#endif
- sv_setiv(sv, (IV)aushort);
+ sv_setiv(sv, (UV)aushort);
PUSHs(sv_2mortal(sv));
}
}
}
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));
culong += along;
}
}
- else {
+ else
+#endif
+ {
while (len-- > 0) {
COPY32(s, &along);
s += SIZE32;
else {
EXTEND(SP, len);
EXTEND_MORTAL(len);
+#if LONGSIZE != SIZE32
if (natint) {
while (len-- > 0) {
COPYNN(s, &along, sizeof(long));
PUSHs(sv_2mortal(sv));
}
}
- else {
+ else
+#endif
+ {
while (len-- > 0) {
COPY32(s, &along);
s += SIZE32;
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));
culong += aulong;
}
}
- else {
+ else
+#endif
+ {
while (len-- > 0) {
COPY32(s, &aulong);
s += SIZE32;
else {
EXTEND(SP, len);
EXTEND_MORTAL(len);
+#if LONGSIZE != SIZE32
if (unatint) {
while (len-- > 0) {
COPYNN(s, &aulong, sizeof(unsigned long));
PUSHs(sv_2mortal(sv));
}
}
- else {
+ else
+#endif
+ {
while (len-- > 0) {
COPY32(s, &aulong);
s += SIZE32;
float afloat;
double adouble;
int commas = 0;
+#ifdef PERL_NATINT_PACK
int natint; /* native integer */
+#endif
items = SP - MARK;
MARK++;
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
}
break;
case 'S':
+#if SHORTSIZE != SIZE16
if (natint) {
unsigned short aushort;
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;
sv_catpvn(cat, (char *)&ashort, sizeof(short));
}
}
- else {
+ else
+#endif
+ {
while (len-- > 0) {
fromstr = NEXTFROM;
ashort = (I16)SvIV(fromstr);
}
break;
case 'L':
+#if LONGSIZE != SIZE32
if (natint) {
while (len-- > 0) {
fromstr = NEXTFROM;
sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
}
}
- else {
+ else
+#endif
+ {
while (len-- > 0) {
fromstr = NEXTFROM;
aulong = SvUV(fromstr);
}
break;
case 'l':
+#if LONGSIZE != SIZE32
if (natint) {
while (len-- > 0) {
fromstr = NEXTFROM;
sv_catpvn(cat, (char *)&along, sizeof(long));
}
}
- else {
+ else
+#endif
+ {
while (len-- > 0) {
fromstr = NEXTFROM;
along = SvIV(fromstr);
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
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";
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";
+ }
+}
+
projects / p5sagit/p5-mst-13.2.git / commitdiff