From 1109a39207d99bf49cb02471368620d4a38731b2 Mon Sep 17 00:00:00 2001 From: Marcus Holland-Moritz Date: Wed, 21 Apr 2004 23:09:20 +0200 Subject: [PATCH] byte-order modifiers for (un)pack templates Message-Id: <20040421210920.3c467772@r2d2> p4raw-id: //depot/perl@22734 --- embed.fnc | 76 ++++++++++++++ embed.h | 246 +++++++++++++++++++++++++++++++++++++++++++ perl.h | 242 ++++++++++++++++++++++++++++++++++++++++++ pod/perldiag.pod | 31 +++++- pod/perlfunc.pod | 122 ++++++++++++++------- pod/perlport.pod | 4 + pp_pack.c | 314 +++++++++++++++++++++++++++++++++++++++++++++++-------- proto.h | 76 ++++++++++++++ t/op/pack.t | 289 ++++++++++++++++++++++++++++++++++++++++++-------- util.c | 213 +++++++++++++++++++++++++++++++++++-- 10 files changed, 1469 insertions(+), 144 deletions(-) diff --git a/embed.fnc b/embed.fnc index 49e6052..8e0b5ca 100644 --- a/embed.fnc +++ b/embed.fnc @@ -1404,4 +1404,80 @@ Apd |void |hv_clear_placeholders|HV* hb Apd |SV* |hv_scalar |HV* hv| p |SV* |magic_scalarpack|HV* hv|MAGIC* mg +#ifdef PERL_NEED_MY_HTOLE16 +np |U16 |my_htole16 |U16 n +#endif +#ifdef PERL_NEED_MY_LETOH16 +np |U16 |my_letoh16 |U16 n +#endif +#ifdef PERL_NEED_MY_HTOBE16 +np |U16 |my_htobe16 |U16 n +#endif +#ifdef PERL_NEED_MY_BETOH16 +np |U16 |my_betoh16 |U16 n +#endif +#ifdef PERL_NEED_MY_HTOLE32 +np |U32 |my_htole32 |U32 n +#endif +#ifdef PERL_NEED_MY_LETOH32 +np |U32 |my_letoh32 |U32 n +#endif +#ifdef PERL_NEED_MY_HTOBE32 +np |U32 |my_htobe32 |U32 n +#endif +#ifdef PERL_NEED_MY_BETOH32 +np |U32 |my_betoh32 |U32 n +#endif +#ifdef PERL_NEED_MY_HTOLE64 +np |U64 |my_htole64 |U64 n +#endif +#ifdef PERL_NEED_MY_LETOH64 +np |U64 |my_letoh64 |U64 n +#endif +#ifdef PERL_NEED_MY_HTOBE64 +np |U64 |my_htobe64 |U64 n +#endif +#ifdef PERL_NEED_MY_BETOH64 +np |U64 |my_betoh64 |U64 n +#endif + +#ifdef PERL_NEED_MY_HTOLES +np |short |my_htoles |short n +#endif +#ifdef PERL_NEED_MY_LETOHS +np |short |my_letohs |short n +#endif +#ifdef PERL_NEED_MY_HTOBES +np |short |my_htobes |short n +#endif +#ifdef PERL_NEED_MY_BETOHS +np |short |my_betohs |short n +#endif +#ifdef PERL_NEED_MY_HTOLEI +np |int |my_htolei |int n +#endif +#ifdef PERL_NEED_MY_LETOHI +np |int |my_letohi |int n +#endif +#ifdef PERL_NEED_MY_HTOBEI +np |int |my_htobei |int n +#endif +#ifdef PERL_NEED_MY_BETOHI +np |int |my_betohi |int n +#endif +#ifdef PERL_NEED_MY_HTOLEL +np |long |my_htolel |long n +#endif +#ifdef PERL_NEED_MY_LETOHL +np |long |my_letohl |long n +#endif +#ifdef PERL_NEED_MY_HTOBEL +np |long |my_htobel |long n +#endif +#ifdef PERL_NEED_MY_BETOHL +np |long |my_betohl |long n +#endif + +np |void |my_swabn |void* ptr|int n + END_EXTERN_C diff --git a/embed.h b/embed.h index 808e010..3de8118 100644 --- a/embed.h +++ b/embed.h @@ -2155,6 +2155,129 @@ #ifdef PERL_CORE #define magic_scalarpack Perl_magic_scalarpack #endif +#ifdef PERL_NEED_MY_HTOLE16 +#ifdef PERL_CORE +#define my_htole16 Perl_my_htole16 +#endif +#endif +#ifdef PERL_NEED_MY_LETOH16 +#ifdef PERL_CORE +#define my_letoh16 Perl_my_letoh16 +#endif +#endif +#ifdef PERL_NEED_MY_HTOBE16 +#ifdef PERL_CORE +#define my_htobe16 Perl_my_htobe16 +#endif +#endif +#ifdef PERL_NEED_MY_BETOH16 +#ifdef PERL_CORE +#define my_betoh16 Perl_my_betoh16 +#endif +#endif +#ifdef PERL_NEED_MY_HTOLE32 +#ifdef PERL_CORE +#define my_htole32 Perl_my_htole32 +#endif +#endif +#ifdef PERL_NEED_MY_LETOH32 +#ifdef PERL_CORE +#define my_letoh32 Perl_my_letoh32 +#endif +#endif +#ifdef PERL_NEED_MY_HTOBE32 +#ifdef PERL_CORE +#define my_htobe32 Perl_my_htobe32 +#endif +#endif +#ifdef PERL_NEED_MY_BETOH32 +#ifdef PERL_CORE +#define my_betoh32 Perl_my_betoh32 +#endif +#endif +#ifdef PERL_NEED_MY_HTOLE64 +#ifdef PERL_CORE +#define my_htole64 Perl_my_htole64 +#endif +#endif +#ifdef PERL_NEED_MY_LETOH64 +#ifdef PERL_CORE +#define my_letoh64 Perl_my_letoh64 +#endif +#endif +#ifdef PERL_NEED_MY_HTOBE64 +#ifdef PERL_CORE +#define my_htobe64 Perl_my_htobe64 +#endif +#endif +#ifdef PERL_NEED_MY_BETOH64 +#ifdef PERL_CORE +#define my_betoh64 Perl_my_betoh64 +#endif +#endif +#ifdef PERL_NEED_MY_HTOLES +#ifdef PERL_CORE +#define my_htoles Perl_my_htoles +#endif +#endif +#ifdef PERL_NEED_MY_LETOHS +#ifdef PERL_CORE +#define my_letohs Perl_my_letohs +#endif +#endif +#ifdef PERL_NEED_MY_HTOBES +#ifdef PERL_CORE +#define my_htobes Perl_my_htobes +#endif +#endif +#ifdef PERL_NEED_MY_BETOHS +#ifdef PERL_CORE +#define my_betohs Perl_my_betohs +#endif +#endif +#ifdef PERL_NEED_MY_HTOLEI +#ifdef PERL_CORE +#define my_htolei Perl_my_htolei +#endif +#endif +#ifdef PERL_NEED_MY_LETOHI +#ifdef PERL_CORE +#define my_letohi Perl_my_letohi +#endif +#endif +#ifdef PERL_NEED_MY_HTOBEI +#ifdef PERL_CORE +#define my_htobei Perl_my_htobei +#endif +#endif +#ifdef PERL_NEED_MY_BETOHI +#ifdef PERL_CORE +#define my_betohi Perl_my_betohi +#endif +#endif +#ifdef PERL_NEED_MY_HTOLEL +#ifdef PERL_CORE +#define my_htolel Perl_my_htolel +#endif +#endif +#ifdef PERL_NEED_MY_LETOHL +#ifdef PERL_CORE +#define my_letohl Perl_my_letohl +#endif +#endif +#ifdef PERL_NEED_MY_HTOBEL +#ifdef PERL_CORE +#define my_htobel Perl_my_htobel +#endif +#endif +#ifdef PERL_NEED_MY_BETOHL +#ifdef PERL_CORE +#define my_betohl Perl_my_betohl +#endif +#endif +#ifdef PERL_CORE +#define my_swabn Perl_my_swabn +#endif #define ck_anoncode Perl_ck_anoncode #define ck_bitop Perl_ck_bitop #define ck_concat Perl_ck_concat @@ -4647,6 +4770,129 @@ #ifdef PERL_CORE #define magic_scalarpack(a,b) Perl_magic_scalarpack(aTHX_ a,b) #endif +#ifdef PERL_NEED_MY_HTOLE16 +#ifdef PERL_CORE +#define my_htole16 Perl_my_htole16 +#endif +#endif +#ifdef PERL_NEED_MY_LETOH16 +#ifdef PERL_CORE +#define my_letoh16 Perl_my_letoh16 +#endif +#endif +#ifdef PERL_NEED_MY_HTOBE16 +#ifdef PERL_CORE +#define my_htobe16 Perl_my_htobe16 +#endif +#endif +#ifdef PERL_NEED_MY_BETOH16 +#ifdef PERL_CORE +#define my_betoh16 Perl_my_betoh16 +#endif +#endif +#ifdef PERL_NEED_MY_HTOLE32 +#ifdef PERL_CORE +#define my_htole32 Perl_my_htole32 +#endif +#endif +#ifdef PERL_NEED_MY_LETOH32 +#ifdef PERL_CORE +#define my_letoh32 Perl_my_letoh32 +#endif +#endif +#ifdef PERL_NEED_MY_HTOBE32 +#ifdef PERL_CORE +#define my_htobe32 Perl_my_htobe32 +#endif +#endif +#ifdef PERL_NEED_MY_BETOH32 +#ifdef PERL_CORE +#define my_betoh32 Perl_my_betoh32 +#endif +#endif +#ifdef PERL_NEED_MY_HTOLE64 +#ifdef PERL_CORE +#define my_htole64 Perl_my_htole64 +#endif +#endif +#ifdef PERL_NEED_MY_LETOH64 +#ifdef PERL_CORE +#define my_letoh64 Perl_my_letoh64 +#endif +#endif +#ifdef PERL_NEED_MY_HTOBE64 +#ifdef PERL_CORE +#define my_htobe64 Perl_my_htobe64 +#endif +#endif +#ifdef PERL_NEED_MY_BETOH64 +#ifdef PERL_CORE +#define my_betoh64 Perl_my_betoh64 +#endif +#endif +#ifdef PERL_NEED_MY_HTOLES +#ifdef PERL_CORE +#define my_htoles Perl_my_htoles +#endif +#endif +#ifdef PERL_NEED_MY_LETOHS +#ifdef PERL_CORE +#define my_letohs Perl_my_letohs +#endif +#endif +#ifdef PERL_NEED_MY_HTOBES +#ifdef PERL_CORE +#define my_htobes Perl_my_htobes +#endif +#endif +#ifdef PERL_NEED_MY_BETOHS +#ifdef PERL_CORE +#define my_betohs Perl_my_betohs +#endif +#endif +#ifdef PERL_NEED_MY_HTOLEI +#ifdef PERL_CORE +#define my_htolei Perl_my_htolei +#endif +#endif +#ifdef PERL_NEED_MY_LETOHI +#ifdef PERL_CORE +#define my_letohi Perl_my_letohi +#endif +#endif +#ifdef PERL_NEED_MY_HTOBEI +#ifdef PERL_CORE +#define my_htobei Perl_my_htobei +#endif +#endif +#ifdef PERL_NEED_MY_BETOHI +#ifdef PERL_CORE +#define my_betohi Perl_my_betohi +#endif +#endif +#ifdef PERL_NEED_MY_HTOLEL +#ifdef PERL_CORE +#define my_htolel Perl_my_htolel +#endif +#endif +#ifdef PERL_NEED_MY_LETOHL +#ifdef PERL_CORE +#define my_letohl Perl_my_letohl +#endif +#endif +#ifdef PERL_NEED_MY_HTOBEL +#ifdef PERL_CORE +#define my_htobel Perl_my_htobel +#endif +#endif +#ifdef PERL_NEED_MY_BETOHL +#ifdef PERL_CORE +#define my_betohl Perl_my_betohl +#endif +#endif +#ifdef PERL_CORE +#define my_swabn Perl_my_swabn +#endif #define ck_anoncode(a) Perl_ck_anoncode(aTHX_ a) #define ck_bitop(a) Perl_ck_bitop(aTHX_ a) #define ck_concat(a) Perl_ck_concat(aTHX_ a) diff --git a/perl.h b/perl.h index 3d86da4..7b9a51a 100644 --- a/perl.h +++ b/perl.h @@ -449,6 +449,241 @@ int usleep(unsigned int); # define MYSWAP #endif +#ifdef PERL_CORE + +/* macros for correct constant construction */ +# if INTSIZE >= 2 +# define U16_CONST(x) ((U16)x##U) +# else +# define U16_CONST(x) ((U16)x##UL) +# endif + +# if INTSIZE >= 4 +# define U32_CONST(x) ((U32)x##U) +# else +# define U32_CONST(x) ((U32)x##UL) +# endif + +# ifdef HAS_QUAD +# if INTSIZE >= 8 +# define U64_CONST(x) ((U64)x##U) +# elif LONGSIZE >= 8 +# define U64_CONST(x) ((U64)x##UL) +# elif QUADKIND == QUAD_IS_LONG_LONG +# define U64_CONST(x) ((U64)x##ULL) +# else /* best guess we can make */ +# define U64_CONST(x) ((U64)x##UL) +# endif +# endif + +/* byte-swapping functions for big-/little-endian conversion */ +# define _swab_16_(x) ((U16)( \ + (((U16)(x) & U16_CONST(0x00ff)) << 8) | \ + (((U16)(x) & U16_CONST(0xff00)) >> 8) )) + +# define _swab_32_(x) ((U32)( \ + (((U32)(x) & U32_CONST(0x000000ff)) << 24) | \ + (((U32)(x) & U32_CONST(0x0000ff00)) << 8) | \ + (((U32)(x) & U32_CONST(0x00ff0000)) >> 8) | \ + (((U32)(x) & U32_CONST(0xff000000)) >> 24) )) + +# ifdef HAS_QUAD +# define _swab_64_(x) ((U64)( \ + (((U64)(x) & U64_CONST(0x00000000000000ff)) << 56) | \ + (((U64)(x) & U64_CONST(0x000000000000ff00)) << 40) | \ + (((U64)(x) & U64_CONST(0x0000000000ff0000)) << 24) | \ + (((U64)(x) & U64_CONST(0x00000000ff000000)) << 8) | \ + (((U64)(x) & U64_CONST(0x000000ff00000000)) >> 8) | \ + (((U64)(x) & U64_CONST(0x0000ff0000000000)) >> 24) | \ + (((U64)(x) & U64_CONST(0x00ff000000000000)) >> 40) | \ + (((U64)(x) & U64_CONST(0xff00000000000000)) >> 56) )) +# endif + +/*----------------------------------------------------------------------------*/ +# if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 /* little-endian */ +/*----------------------------------------------------------------------------*/ +# define my_htole16(x) (x) +# define my_letoh16(x) (x) +# define my_htole32(x) (x) +# define my_letoh32(x) (x) +# define my_htobe16(x) _swab_16_(x) +# define my_betoh16(x) _swab_16_(x) +# define my_htobe32(x) _swab_32_(x) +# define my_betoh32(x) _swab_32_(x) +# ifdef HAS_QUAD +# define my_htole64(x) (x) +# define my_letoh64(x) (x) +# define my_htobe64(x) _swab_64_(x) +# define my_betoh64(x) _swab_64_(x) +# endif +# define my_htoles(x) (x) +# define my_letohs(x) (x) +# define my_htolei(x) (x) +# define my_letohi(x) (x) +# define my_htolel(x) (x) +# define my_letohl(x) (x) +# if SHORTSIZE == 1 +# define my_htobes(x) (x) +# define my_betohs(x) (x) +# elif SHORTSIZE == 2 +# define my_htobes(x) _swab_16_(x) +# define my_betohs(x) _swab_16_(x) +# elif SHORTSIZE == 4 +# define my_htobes(x) _swab_32_(x) +# define my_betohs(x) _swab_32_(x) +# elif SHORTSIZE == 8 +# define my_htobes(x) _swab_64_(x) +# define my_betohs(x) _swab_64_(x) +# else +# define PERL_NEED_MY_HTOBES +# define PERL_NEED_MY_BETOHS +# endif +# if INTSIZE == 1 +# define my_htobei(x) (x) +# define my_betohi(x) (x) +# elif INTSIZE == 2 +# define my_htobei(x) _swab_16_(x) +# define my_betohi(x) _swab_16_(x) +# elif INTSIZE == 4 +# define my_htobei(x) _swab_32_(x) +# define my_betohi(x) _swab_32_(x) +# elif INTSIZE == 8 +# define my_htobei(x) _swab_64_(x) +# define my_betohi(x) _swab_64_(x) +# else +# define PERL_NEED_MY_HTOBEI +# define PERL_NEED_MY_BETOHI +# endif +# if LONGSIZE == 1 +# define my_htobel(x) (x) +# define my_betohl(x) (x) +# elif LONGSIZE == 2 +# define my_htobel(x) _swab_16_(x) +# define my_betohl(x) _swab_16_(x) +# elif LONGSIZE == 4 +# define my_htobel(x) _swab_32_(x) +# define my_betohl(x) _swab_32_(x) +# elif LONGSIZE == 8 +# define my_htobel(x) _swab_64_(x) +# define my_betohl(x) _swab_64_(x) +# else +# define PERL_NEED_MY_HTOBEL +# define PERL_NEED_MY_BETOHL +# endif +# define my_htolen(p,n) NOOP +# define my_letohn(p,n) NOOP +# define my_htoben(p,n) my_swabn(p,n) +# define my_betohn(p,n) my_swabn(p,n) +/*----------------------------------------------------------------------------*/ +# elif BYTEORDER == 0x4321 || BYTEORDER == 0x87654321 /* big-endian */ +/*----------------------------------------------------------------------------*/ +# define my_htobe16(x) (x) +# define my_betoh16(x) (x) +# define my_htobe32(x) (x) +# define my_betoh32(x) (x) +# define my_htole16(x) _swab_16_(x) +# define my_letoh16(x) _swab_16_(x) +# define my_htole32(x) _swab_32_(x) +# define my_letoh32(x) _swab_32_(x) +# ifdef HAS_QUAD +# define my_htobe64(x) (x) +# define my_betoh64(x) (x) +# define my_htole64(x) _swab_64_(x) +# define my_letoh64(x) _swab_64_(x) +# endif +# define my_htobes(x) (x) +# define my_betohs(x) (x) +# define my_htobei(x) (x) +# define my_betohi(x) (x) +# define my_htobel(x) (x) +# define my_betohl(x) (x) +# if SHORTSIZE == 1 +# define my_htoles(x) (x) +# define my_letohs(x) (x) +# elif SHORTSIZE == 2 +# define my_htoles(x) _swab_16_(x) +# define my_letohs(x) _swab_16_(x) +# elif SHORTSIZE == 4 +# define my_htoles(x) _swab_32_(x) +# define my_letohs(x) _swab_32_(x) +# elif SHORTSIZE == 8 +# define my_htoles(x) _swab_64_(x) +# define my_letohs(x) _swab_64_(x) +# else +# define PERL_NEED_MY_HTOLES +# define PERL_NEED_MY_LETOHS +# endif +# if INTSIZE == 1 +# define my_htolei(x) (x) +# define my_letohi(x) (x) +# elif INTSIZE == 2 +# define my_htolei(x) _swab_16_(x) +# define my_letohi(x) _swab_16_(x) +# elif INTSIZE == 4 +# define my_htolei(x) _swab_32_(x) +# define my_letohi(x) _swab_32_(x) +# elif INTSIZE == 8 +# define my_htolei(x) _swab_64_(x) +# define my_letohi(x) _swab_64_(x) +# else +# define PERL_NEED_MY_HTOLEI +# define PERL_NEED_MY_LETOHI +# endif +# if LONGSIZE == 1 +# define my_htolel(x) (x) +# define my_letohl(x) (x) +# elif LONGSIZE == 2 +# define my_htolel(x) _swab_16_(x) +# define my_letohl(x) _swab_16_(x) +# elif LONGSIZE == 4 +# define my_htolel(x) _swab_32_(x) +# define my_letohl(x) _swab_32_(x) +# elif LONGSIZE == 8 +# define my_htolel(x) _swab_64_(x) +# define my_letohl(x) _swab_64_(x) +# else +# define PERL_NEED_MY_HTOLEL +# define PERL_NEED_MY_LETOHL +# endif +# define my_htolen(p,n) my_swabn(p,n) +# define my_letohn(p,n) my_swabn(p,n) +# define my_htoben(p,n) NOOP +# define my_betohn(p,n) NOOP +/*----------------------------------------------------------------------------*/ +# else /* all other byte-orders */ +/*----------------------------------------------------------------------------*/ +# define PERL_NEED_MY_HTOLE16 +# define PERL_NEED_MY_LETOH16 +# define PERL_NEED_MY_HTOBE16 +# define PERL_NEED_MY_BETOH16 +# define PERL_NEED_MY_HTOLE32 +# define PERL_NEED_MY_LETOH32 +# define PERL_NEED_MY_HTOBE32 +# define PERL_NEED_MY_BETOH32 +# ifdef HAS_QUAD +# define PERL_NEED_MY_HTOLE64 +# define PERL_NEED_MY_LETOH64 +# define PERL_NEED_MY_HTOBE64 +# define PERL_NEED_MY_BETOH64 +# endif +# define PERL_NEED_MY_HTOLES +# define PERL_NEED_MY_LETOHS +# define PERL_NEED_MY_HTOBES +# define PERL_NEED_MY_BETOHS +# define PERL_NEED_MY_HTOLEI +# define PERL_NEED_MY_LETOHI +# define PERL_NEED_MY_HTOBEI +# define PERL_NEED_MY_BETOHI +# define PERL_NEED_MY_HTOLEL +# define PERL_NEED_MY_LETOHL +# define PERL_NEED_MY_HTOBEL +# define PERL_NEED_MY_BETOHL +/*----------------------------------------------------------------------------*/ +# endif /* end of byte-order macros */ +/*----------------------------------------------------------------------------*/ + +#endif /* PERL_CORE */ + /* Cannot include embed.h here on Win32 as win32.h has not yet been included and defines some config variables e.g. HAVE_INTERP_INTERN */ @@ -1091,6 +1326,13 @@ typedef UVTYPE UV; # endif #endif +#ifndef HAS_QUAD +# undef PERL_NEED_MY_HTOLE64 +# undef PERL_NEED_MY_LETOH64 +# undef PERL_NEED_MY_HTOBE64 +# undef PERL_NEED_MY_BETOH64 +#endif + #if defined(uts) || defined(UTS) # undef UV_MAX # define UV_MAX (4294967295u) diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 3132242..94fc189 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -54,10 +54,10 @@ L. (X) You can't allocate more than 64K on an MS-DOS machine. -=item '!' allowed only after types %s +=item '%c' allowed only after types %s -(F) The '!' is allowed in pack() or unpack() only after certain types. -See L. +(F) The modifiers '!', '<' and '>' are allowed in pack() or unpack() only +after certain types. See L. =item Ambiguous call resolved as CORE::%s(), qualify as such or use & @@ -630,6 +630,13 @@ waitpid() without flags is emulated. point. For example, it'd be kind of silly to put a B<-x> on the #! line. +=item Can't %s %s-endian %ss on this platform + +(F) Your platform's byte-order is neither big-endian nor little-endian, +or it has a very strange pointer size. Packing and unpacking big- or +little-endian floating point values and pointers may not be possible. +See L. + =item Can't exec "%s": %s (W exec) A system(), exec(), or piped open call could not execute the @@ -1050,6 +1057,12 @@ references are disallowed. See L. Errno.pm module. The Errno module is expected to tie the %! hash to provide symbolic names for C<$!> errno values. +=item Can't use both '<' and '>' after type '%c' in %s + +(F) A type cannot be forced to have both big-endian and little-endian +byte-order at the same time, so this combination of modifiers is not +allowed. See L. + =item Can't use %s for loop variable (F) Only a simple scalar variable may be used as a loop variable on a @@ -1367,6 +1380,11 @@ qualifying it as C. Maybe it's a typo. See L. (S malloc) An internal routine called free() on something that had already been freed. +=item Duplicate modifier '%c' after '%c' in %s + +(W) You have applied the same modifier more than once after a type +in a pack template. See L. + =item elseif should be elsif (S syntax) There is no keyword "elseif" in Perl because Larry thinks it's @@ -2892,6 +2910,13 @@ that a method requires a package that has not been loaded. recent than the currently running version. How long has it been since you upgraded, anyway? See L. +=item Perl_my_%s() not available + +(F) Your platform has very uncommon byte-order and integer size, +so it was not possible to set up some or all fixed-width byte-order +conversion functions. This is only a problem when you're using the +'<' or '>' modifiers in (un)pack templates. See L. + =item PERL_SH_DIR too long (F) An error peculiar to OS/2. PERL_SH_DIR is the directory to find the diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index 61a5bb5..c7fb1f8 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -3272,38 +3272,14 @@ of values, as follows: h A hex string (low nybble first). H A hex string (high nybble first). - c A signed char value. + c A signed char (8-bit) value. C An unsigned char value. Only does bytes. See U for Unicode. - s A signed short value. + s A signed short (16-bit) value. S An unsigned short value. - (This 'short' is _exactly_ 16 bits, which may differ from - what a local C compiler calls 'short'. If you want - native-length shorts, use the '!' suffix.) - i A signed integer value. - I An unsigned integer value. - (This 'integer' is _at_least_ 32 bits wide. Its exact - size depends on what a local C compiler calls 'int', - and may even be larger than the 'long' described in - the next item.) - - l A signed long value. + l A signed long (32-bit) value. L An unsigned long value. - (This 'long' is _exactly_ 32 bits, which may differ from - what a local C compiler calls 'long'. If you want - native-length longs, use the '!' suffix.) - - n An unsigned short in "network" (big-endian) order. - N An unsigned long in "network" (big-endian) order. - v An unsigned short in "VAX" (little-endian) order. - V An unsigned long in "VAX" (little-endian) order. - (These 'shorts' and 'longs' are _exactly_ 16 bits and - _exactly_ 32 bits, respectively. If you want signed - types instead of unsigned ones, use the '!' suffix. - Note that this is _only_ safe if signed integers are - stored in the same format on all platforms using the - packed data.) q A signed quad (64-bit) value. Q An unsigned quad value. @@ -3311,14 +3287,23 @@ of values, as follows: integer values _and_ if Perl has been compiled to support those. Causes a fatal error otherwise.) - j A signed integer value (a Perl internal integer, IV). - J An unsigned integer value (a Perl internal unsigned integer, UV). + i A signed integer value. + I A unsigned integer value. + (This 'integer' is _at_least_ 32 bits wide. Its exact + size depends on what a local C compiler calls 'int'.) + + n An unsigned short (16-bit) in "network" (big-endian) order. + N An unsigned long (32-bit) in "network" (big-endian) order. + v An unsigned short (16-bit) in "VAX" (little-endian) order. + V An unsigned long (32-bit) in "VAX" (little-endian) order. + + j A Perl internal signed integer value (IV). + J A Perl internal unsigned integer value (UV). f A single-precision float in the native format. d A double-precision float in the native format. - F A floating point value in the native native format - (a Perl internal floating point value, NV). + F A Perl internal floating point value (NV) in the native format D A long double-precision float in the native format. (Long doubles are available only if your system supports long double values _and_ if Perl has been compiled to support those. @@ -3342,6 +3327,23 @@ of values, as follows: the innermost ()-group. ( Start of a ()-group. +Some letters in the TEMPLATE may optionally be followed by one or +more of these modifiers (the second column lists the letters for +which the modifier is valid): + + ! sSlLiI Forces native (short, long, int) sizes instead + of fixed (16-/32-bit) sizes. + + xX Make x and X act as alignment commands. + + nNvV Treat integers as signed instead of unsigned. + + > sSiIlLqQ Force big-endian byte-order on the type. + jJfFdDpP (The "big end" touches the construct.) + + < sSiIlLqQ Force little-endian byte-order on the type. + jJfFdDpP (The "little end" touches the construct.) + The following rules apply: =over 8 @@ -3446,6 +3448,11 @@ The C

type packs a pointer to a structure of the size indicated by the length. A NULL pointer is created if the corresponding value for C

or C

is C, similarly for unpack(). +If your system has a strange pointer size (i.e. a pointer is neither as +big as an int nor as big as a long), it may not be possible to pack or +unpack pointers in big- or little-endian byte order. Attempting to do +so will result in a fatal error. + =item * The C template character allows packing and unpacking of strings where @@ -3477,7 +3484,7 @@ which Perl does not regard as legal in numeric strings. =item * The integer types C, C, C, and C may be -immediately followed by a C suffix to signify native shorts or +followed by a C modifier to signify native shorts or longs--as you can see from above for example a bare C 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. You can @@ -3543,12 +3550,39 @@ via L: Byteorders C<'1234'> and C<'12345678'> are little-endian, C<'4321'> and C<'87654321'> are big-endian. -If you want portable packed integers use the formats C, C, -C, and C, their byte endianness and size are known. +If you want portable packed integers you can either use the formats +C, C, C, and C, or you can use the C> and C> +modifiers. These modifiers are only available as of perl 5.8.5. See also L. =item * +All integer and floating point formats as well as C

and C

may +be followed by the C> or C> modifiers to force big- or +little- endian byte-order, respectively. This is especially useful, +since C, C, C and C don't cover signed integers, 64-bit +integers and floating point values. However, there are some things +to keep in mind. + +Exchanging signed integers between different platforms only works +if all platforms store them in the same format. Most platforms store +signed integers in two's complement, so usually this is not an issue. + +The C> or C> modifiers can only be used on floating point +formats on big- or little-endian machines. Otherwise, attempting to +do so will result in a fatal error. + +Forcing big- or little-endian byte-order on floating point values for +data exchange can only work if all platforms are using the same +binary representation (e.g. IEEE floating point format). Even if all +platforms are using IEEE, there may be subtle differences. Being able +to use C> or C> on floating point values can be very useful, +but also very dangerous if you don't know exactly what you're doing. +It is definetely not a general way to portably store floating point +values. + +=item * + Real numbers (floats and doubles) are in the native machine format only; due to the multiplicity of floating formats around, and the lack of a standard "network" representation, no facility for interchange has been @@ -3557,10 +3591,13 @@ may not be readable on another - even if both use IEEE floating point arithmetic (as the endian-ness of the memory representation is not part of the IEEE spec). See also L. -Note that Perl uses doubles internally for all numeric calculation, and -converting from double into float and thence back to double again will -lose precision (i.e., C) will not in general -equal $foo). +If you know exactly what you're doing, you can use the C> or C> +modifiers to force big- or little-endian byte-order on floating point values. + +Note that Perl uses doubles (or long doubles, if configured) internally for +all numeric calculation, and converting from double into float and thence back +to double again will lose precision (i.e., C) +will not in general equal $foo). =item * @@ -3616,7 +3653,7 @@ using two's complement representation). A comment in a TEMPLATE starts with C<#> and goes to the end of line. White space may be used to separate pack codes from each other, but -a C modifier and a repeat count must follow immediately. +modifiers and a repeat count must follow immediately. =item * @@ -3676,6 +3713,13 @@ Examples: # short 12, zero fill to position 4, long 34 # $foo eq $bar + $foo = pack('nN', 42, 4711); + # pack big-endian 16- and 32-bit unsigned integers + $foo = pack('S>L>', 42, 4711); + # exactly the same + $foo = pack('s and C formats C and C, the "network" orders. These are guaranteed to be portable. +As of perl 5.8.5, you can also use the C> and C> modifiers +to force big- or little-endian byte-order. This is useful if you want +to store signed integers or 64-bit integers, for example. + You can explore the endianness of your platform by unpacking a data structure packed in native format such as: diff --git a/pp_pack.c b/pp_pack.c index e51a2b9..d484e6a 100644 --- a/pp_pack.c +++ b/pp_pack.c @@ -55,16 +55,12 @@ static double UV_MAX_cxux = ((double)UV_MAX); /* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack(). --jhi Feb 1999 */ -#if SHORTSIZE != SIZE16 || LONGSIZE != SIZE32 -# define PERL_NATINT_PACK -#endif - -#if LONGSIZE > 4 && defined(_CRAY) -# if BYTEORDER == 0x12345678 +#if U16SIZE > SIZE16 || U32SIZE > SIZE32 +# if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 /* little-endian */ # define OFF16(p) (char*)(p) # define OFF32(p) (char*)(p) # else -# if BYTEORDER == 0x87654321 +# if BYTEORDER == 0x4321 || BYTEORDER == 0x87654321 /* big-endian */ # define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16)) # define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32)) # else @@ -135,6 +131,108 @@ S_mul128(pTHX_ SV *sv, U8 m) #endif #define TYPE_IS_SHRIEKING 0x100 +#define TYPE_IS_BIG_ENDIAN 0x200 +#define TYPE_IS_LITTLE_ENDIAN 0x400 +#define TYPE_ENDIANNESS_MASK (TYPE_IS_BIG_ENDIAN|TYPE_IS_LITTLE_ENDIAN) +#define TYPE_NO_ENDIANNESS(t) ((t) & ~TYPE_ENDIANNESS_MASK) +#define TYPE_NO_MODIFIERS(t) ((t) & 0xFF) + +#define DO_BO_UNPACK(var, type) \ + STMT_START { \ + switch (datumtype & TYPE_ENDIANNESS_MASK) { \ + case TYPE_IS_BIG_ENDIAN: var = my_betoh ## type (var); break; \ + case TYPE_IS_LITTLE_ENDIAN: var = my_letoh ## type (var); break; \ + default: break; \ + } \ + } STMT_END + +#define DO_BO_PACK(var, type) \ + STMT_START { \ + switch (datumtype & TYPE_ENDIANNESS_MASK) { \ + case TYPE_IS_BIG_ENDIAN: var = my_htobe ## type (var); break; \ + case TYPE_IS_LITTLE_ENDIAN: var = my_htole ## type (var); break; \ + default: break; \ + } \ + } STMT_END + +#define DO_BO_UNPACK_PTR(var, type, pre_cast) \ + STMT_START { \ + switch (datumtype & TYPE_ENDIANNESS_MASK) { \ + case TYPE_IS_BIG_ENDIAN: \ + var = (void *) my_betoh ## type ((pre_cast) var); \ + break; \ + case TYPE_IS_LITTLE_ENDIAN: \ + var = (void *) my_letoh ## type ((pre_cast) var); \ + break; \ + default: \ + break; \ + } \ + } STMT_END + +#define DO_BO_PACK_PTR(var, type, pre_cast) \ + STMT_START { \ + switch (datumtype & TYPE_ENDIANNESS_MASK) { \ + case TYPE_IS_BIG_ENDIAN: \ + var = (void *) my_htobe ## type ((pre_cast) var); \ + break; \ + case TYPE_IS_LITTLE_ENDIAN: \ + var = (void *) my_htole ## type ((pre_cast) var); \ + break; \ + default: \ + break; \ + } \ + } STMT_END + +#define BO_CANT_DOIT(action, type) \ + STMT_START { \ + switch (datumtype & TYPE_ENDIANNESS_MASK) { \ + case TYPE_IS_BIG_ENDIAN: \ + Perl_croak(aTHX_ "Can't %s big-endian %ss on this " \ + "platform", #action, #type); \ + break; \ + case TYPE_IS_LITTLE_ENDIAN: \ + Perl_croak(aTHX_ "Can't %s little-endian %ss on this " \ + "platform", #action, #type); \ + break; \ + default: \ + break; \ + } \ + } STMT_END + +#if PTRSIZE == INTSIZE +# define DO_BO_UNPACK_P(var) DO_BO_UNPACK_PTR(var, i, int) +# define DO_BO_PACK_P(var) DO_BO_PACK_PTR(var, i, int) +#elif PTRSIZE == LONGSIZE +# define DO_BO_UNPACK_P(var) DO_BO_UNPACK_PTR(var, l, long) +# define DO_BO_PACK_P(var) DO_BO_PACK_PTR(var, l, long) +#else +# define DO_BO_UNPACK_P(var) BO_CANT_DOIT(unpack, pointer) +# define DO_BO_PACK_P(var) BO_CANT_DOIT(pack, pointer) +#endif + +#if defined(my_htolen) && defined(my_letohn) && \ + defined(my_htoben) && defined(my_betohn) +# define DO_BO_UNPACK_N(var, type) \ + STMT_START { \ + switch (datumtype & TYPE_ENDIANNESS_MASK) { \ + case TYPE_IS_BIG_ENDIAN: my_betohn(&var, sizeof(type)); break;\ + case TYPE_IS_LITTLE_ENDIAN: my_letohn(&var, sizeof(type)); break;\ + default: break; \ + } \ + } STMT_END + +# define DO_BO_PACK_N(var, type) \ + STMT_START { \ + switch (datumtype & TYPE_ENDIANNESS_MASK) { \ + case TYPE_IS_BIG_ENDIAN: my_htoben(&var, sizeof(type)); break;\ + case TYPE_IS_LITTLE_ENDIAN: my_htolen(&var, sizeof(type)); break;\ + default: break; \ + } \ + } STMT_END +#else +# define DO_BO_UNPACK_N(var, type) BO_CANT_DOIT(unpack, type) +# define DO_BO_PACK_N(var, type) BO_CANT_DOIT(pack, type) +#endif /* Returns the sizeof() struct described by pat */ STATIC I32 @@ -159,10 +257,11 @@ S_measure_struct(pTHX_ register tempsym_t* symptr) break; } - switch(symptr->code) { + /* endianness doesn't influence the size of a type */ + switch(TYPE_NO_ENDIANNESS(symptr->code)) { default: - Perl_croak(aTHX_ "Invalid type '%c' in %s", - (int)symptr->code, + Perl_croak(aTHX_ "Invalid type '%c' in %s", + (int)TYPE_NO_MODIFIERS(symptr->code), symptr->flags & FLAG_PACK ? "pack" : "unpack" ); case '@': case '/': @@ -415,15 +514,44 @@ S_next_symbol(pTHX_ register tempsym_t* symptr ) symptr->flags & FLAG_PACK ? "pack" : "unpack" ); } - /* test for '!' modifier */ - if (patptr < patend && *patptr == '!') { - static const char natstr[] = "sSiIlLxXnNvV"; - patptr++; - if (strchr(natstr, code)) - code |= TYPE_IS_SHRIEKING; - else - Perl_croak(aTHX_ "'!' allowed only after types %s in %s", - natstr, symptr->flags & FLAG_PACK ? "pack" : "unpack" ); + /* look for modifiers */ + while (patptr < patend) { + const char *allowed; + I32 modifier = 0; + switch (*patptr) { + case '!': + modifier = TYPE_IS_SHRIEKING; + allowed = "sSiIlLxXnNvV"; + break; + case '>': + modifier = TYPE_IS_BIG_ENDIAN; + allowed = "sSiIlLqQjJfFdDpP"; + break; + case '<': + modifier = TYPE_IS_LITTLE_ENDIAN; + allowed = "sSiIlLqQjJfFdDpP"; + break; + default: + break; + } + if (modifier == 0) + break; + if (!strchr(allowed, TYPE_NO_MODIFIERS(code))) + Perl_croak(aTHX_ "'%c' allowed only after types %s in %s", *patptr, + allowed, symptr->flags & FLAG_PACK ? "pack" : "unpack" ); + if ((code | modifier) == (code | TYPE_IS_BIG_ENDIAN | TYPE_IS_LITTLE_ENDIAN)) + Perl_croak(aTHX_ "Can't use both '<' and '>' after type '%c' in %s", + (int) TYPE_NO_MODIFIERS(code), + symptr->flags & FLAG_PACK ? "pack" : "unpack" ); + if (ckWARN(WARN_UNPACK)) { + if (code & modifier) + Perl_warner(aTHX_ packWARN(WARN_UNPACK), + "Duplicate modifier '%c' after '%c' in %s", + *patptr, (int) TYPE_NO_MODIFIERS(code), + symptr->flags & FLAG_PACK ? "pack" : "unpack" ); + } + code |= modifier; + patptr++; } /* look for count and/or / */ @@ -548,7 +676,6 @@ S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, c howlen_t howlen; /* These must not be in registers: */ - short ashort; int aint; long along; #ifdef HAS_QUAD @@ -602,9 +729,9 @@ S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, c redo_switch: beyond = s >= strend; - switch(datumtype) { + switch(TYPE_NO_ENDIANNESS(datumtype)) { default: - Perl_croak(aTHX_ "Invalid type '%c' in unpack", (int)datumtype ); + Perl_croak(aTHX_ "Invalid type '%c' in unpack", (int)TYPE_NO_MODIFIERS(datumtype) ); case '%': if (howlen == e_no_len) @@ -894,13 +1021,13 @@ S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, c if (checksum) { short ashort; while (len-- > 0) { - COPYNN(s, &ashort, sizeof(short)); - s += sizeof(short); - if (checksum > bits_in_uv) - cdouble += (NV)ashort; - else - cuv += ashort; - + COPYNN(s, &ashort, sizeof(short)); + DO_BO_UNPACK(ashort, s); + s += sizeof(short); + if (checksum > bits_in_uv) + cdouble += (NV)ashort; + else + cuv += ashort; } } else { @@ -911,6 +1038,7 @@ S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, c EXTEND_MORTAL(len); while (len-- > 0) { COPYNN(s, &ashort, sizeof(short)); + DO_BO_UNPACK(ashort, s); s += sizeof(short); sv = NEWSV(38, 0); sv_setiv(sv, (IV)ashort); @@ -927,16 +1055,17 @@ S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, c len = along; if (checksum) { while (len-- > 0) { - COPY16(s, &ashort); -#if SHORTSIZE > SIZE16 - if (ashort > 32767) - ashort -= 65536; + COPY16(s, &asshort); + DO_BO_UNPACK(asshort, 16); +#if U16SIZE > SIZE16 + if (asshort > 32767) + asshort -= 65536; #endif s += SIZE16; if (checksum > bits_in_uv) - cdouble += (NV)ashort; + cdouble += (NV)asshort; else - cuv += ashort; + cuv += asshort; } } else { @@ -946,14 +1075,15 @@ S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, c EXTEND_MORTAL(len); while (len-- > 0) { - COPY16(s, &ashort); -#if SHORTSIZE > SIZE16 - if (ashort > 32767) - ashort -= 65536; + COPY16(s, &asshort); + DO_BO_UNPACK(asshort, 16); +#if U16SIZE > SIZE16 + if (asshort > 32767) + asshort -= 65536; #endif s += SIZE16; sv = NEWSV(38, 0); - sv_setiv(sv, (IV)ashort); + sv_setiv(sv, (IV)asshort); PUSHs(sv_2mortal(sv)); } } @@ -967,6 +1097,7 @@ S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, c unsigned short aushort; while (len-- > 0) { COPYNN(s, &aushort, sizeof(unsigned short)); + DO_BO_UNPACK(aushort, s); s += sizeof(unsigned short); if (checksum > bits_in_uv) cdouble += (NV)aushort; @@ -982,6 +1113,7 @@ S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, c while (len-- > 0) { unsigned short aushort; COPYNN(s, &aushort, sizeof(unsigned short)); + DO_BO_UNPACK(aushort, s); s += sizeof(unsigned short); sv = NEWSV(39, 0); sv_setiv(sv, (UV)aushort); @@ -1001,6 +1133,7 @@ S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, c if (checksum) { while (len-- > 0) { COPY16(s, &aushort); + DO_BO_UNPACK(aushort, 16); s += SIZE16; #ifdef HAS_NTOHS if (datumtype == 'n') @@ -1023,6 +1156,7 @@ S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, c EXTEND_MORTAL(len); while (len-- > 0) { COPY16(s, &aushort); + DO_BO_UNPACK(aushort, 16); s += SIZE16; sv = NEWSV(39, 0); #ifdef HAS_NTOHS @@ -1091,6 +1225,7 @@ S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, c if (checksum) { while (len-- > 0) { Copy(s, &aint, 1, int); + DO_BO_UNPACK(aint, i); s += sizeof(int); if (checksum > bits_in_uv) cdouble += (NV)aint; @@ -1105,6 +1240,7 @@ S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, c EXTEND_MORTAL(len); while (len-- > 0) { Copy(s, &aint, 1, int); + DO_BO_UNPACK(aint, i); s += sizeof(int); sv = NEWSV(40, 0); #ifdef __osf__ @@ -1145,6 +1281,7 @@ S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, c if (checksum) { while (len-- > 0) { Copy(s, &auint, 1, unsigned int); + DO_BO_UNPACK(auint, i); s += sizeof(unsigned int); if (checksum > bits_in_uv) cdouble += (NV)auint; @@ -1159,6 +1296,7 @@ S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, c EXTEND_MORTAL(len); while (len-- > 0) { Copy(s, &auint, 1, unsigned int); + DO_BO_UNPACK(auint, i); s += sizeof(unsigned int); sv = NEWSV(41, 0); #ifdef __osf__ @@ -1180,6 +1318,13 @@ S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, c if (checksum) { while (len-- > 0) { Copy(s, &aiv, 1, IV); +#if IVSIZE == INTSIZE + DO_BO_UNPACK(aiv, i); +#elif IVSIZE == LONGSIZE + DO_BO_UNPACK(aiv, l); +#elif defined(HAS_QUAD) && IVSIZE == U64SIZE + DO_BO_UNPACK(aiv, 64); +#endif s += IVSIZE; if (checksum > bits_in_uv) cdouble += (NV)aiv; @@ -1194,6 +1339,13 @@ S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, c EXTEND_MORTAL(len); while (len-- > 0) { Copy(s, &aiv, 1, IV); +#if IVSIZE == INTSIZE + DO_BO_UNPACK(aiv, i); +#elif IVSIZE == LONGSIZE + DO_BO_UNPACK(aiv, l); +#elif defined(HAS_QUAD) && IVSIZE == U64SIZE + DO_BO_UNPACK(aiv, 64); +#endif s += IVSIZE; sv = NEWSV(40, 0); sv_setiv(sv, aiv); @@ -1208,6 +1360,13 @@ S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, c if (checksum) { while (len-- > 0) { Copy(s, &auv, 1, UV); +#if UVSIZE == INTSIZE + DO_BO_UNPACK(auv, i); +#elif UVSIZE == LONGSIZE + DO_BO_UNPACK(auv, l); +#elif defined(HAS_QUAD) && UVSIZE == U64SIZE + DO_BO_UNPACK(auv, 64); +#endif s += UVSIZE; if (checksum > bits_in_uv) cdouble += (NV)auv; @@ -1222,6 +1381,13 @@ S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, c EXTEND_MORTAL(len); while (len-- > 0) { Copy(s, &auv, 1, UV); +#if UVSIZE == INTSIZE + DO_BO_UNPACK(auv, i); +#elif UVSIZE == LONGSIZE + DO_BO_UNPACK(auv, l); +#elif defined(HAS_QUAD) && UVSIZE == U64SIZE + DO_BO_UNPACK(auv, 64); +#endif s += UVSIZE; sv = NEWSV(41, 0); sv_setuv(sv, auv); @@ -1237,6 +1403,7 @@ S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, c if (checksum) { while (len-- > 0) { COPYNN(s, &along, sizeof(long)); + DO_BO_UNPACK(along, l); s += sizeof(long); if (checksum > bits_in_uv) cdouble += (NV)along; @@ -1251,6 +1418,7 @@ S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, c EXTEND_MORTAL(len); while (len-- > 0) { COPYNN(s, &along, sizeof(long)); + DO_BO_UNPACK(along, l); s += sizeof(long); sv = NEWSV(42, 0); sv_setiv(sv, (IV)along); @@ -1271,6 +1439,7 @@ S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, c I32 along; #endif COPY32(s, &along); + DO_BO_UNPACK(along, 32); #if LONGSIZE > SIZE32 if (along > 2147483647) along -= 4294967296; @@ -1292,6 +1461,7 @@ S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, c I32 along; #endif COPY32(s, &along); + DO_BO_UNPACK(along, 32); #if LONGSIZE > SIZE32 if (along > 2147483647) along -= 4294967296; @@ -1312,6 +1482,7 @@ S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, c while (len-- > 0) { unsigned long aulong; COPYNN(s, &aulong, sizeof(unsigned long)); + DO_BO_UNPACK(aulong, l); s += sizeof(unsigned long); if (checksum > bits_in_uv) cdouble += (NV)aulong; @@ -1327,6 +1498,7 @@ S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, c while (len-- > 0) { unsigned long aulong; COPYNN(s, &aulong, sizeof(unsigned long)); + DO_BO_UNPACK(aulong, l); s += sizeof(unsigned long); sv = NEWSV(43, 0); sv_setuv(sv, (UV)aulong); @@ -1346,6 +1518,7 @@ S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, c if (checksum) { while (len-- > 0) { COPY32(s, &aulong); + DO_BO_UNPACK(aulong, 32); s += SIZE32; #ifdef HAS_NTOHL if (datumtype == 'N') @@ -1368,6 +1541,7 @@ S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, c EXTEND_MORTAL(len); while (len-- > 0) { COPY32(s, &aulong); + DO_BO_UNPACK(aulong, 32); s += SIZE32; #ifdef HAS_NTOHL if (datumtype == 'N') @@ -1439,6 +1613,7 @@ S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, c break; else { Copy(s, &aptr, 1, char*); + DO_BO_UNPACK_P(aptr); s += sizeof(char*); } sv = NEWSV(44, 0); @@ -1500,6 +1675,7 @@ S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, c break; else { Copy(s, &aptr, 1, char*); + DO_BO_UNPACK_P(aptr); s += sizeof(char*); } sv = NEWSV(44, 0); @@ -1515,6 +1691,7 @@ S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, c if (checksum) { while (len-- > 0) { Copy(s, &aquad, 1, Quad_t); + DO_BO_UNPACK(aquad, 64); s += sizeof(Quad_t); if (checksum > bits_in_uv) cdouble += (NV)aquad; @@ -1532,6 +1709,7 @@ S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, c aquad = 0; else { Copy(s, &aquad, 1, Quad_t); + DO_BO_UNPACK(aquad, 64); s += sizeof(Quad_t); } sv = NEWSV(42, 0); @@ -1550,6 +1728,7 @@ S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, c if (checksum) { while (len-- > 0) { Copy(s, &auquad, 1, Uquad_t); + DO_BO_UNPACK(auquad, 64); s += sizeof(Uquad_t); if (checksum > bits_in_uv) cdouble += (NV)auquad; @@ -1567,6 +1746,7 @@ S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, c auquad = 0; else { Copy(s, &auquad, 1, Uquad_t); + DO_BO_UNPACK(auquad, 64); s += sizeof(Uquad_t); } sv = NEWSV(43, 0); @@ -1587,6 +1767,7 @@ S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, c if (checksum) { while (len-- > 0) { Copy(s, &afloat, 1, float); + DO_BO_UNPACK_N(afloat, float); s += sizeof(float); cdouble += afloat; } @@ -1598,6 +1779,7 @@ S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, c EXTEND_MORTAL(len); while (len-- > 0) { Copy(s, &afloat, 1, float); + DO_BO_UNPACK_N(afloat, float); s += sizeof(float); sv = NEWSV(47, 0); sv_setnv(sv, (NV)afloat); @@ -1612,6 +1794,7 @@ S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, c if (checksum) { while (len-- > 0) { Copy(s, &adouble, 1, double); + DO_BO_UNPACK_N(adouble, double); s += sizeof(double); cdouble += adouble; } @@ -1623,6 +1806,7 @@ S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, c EXTEND_MORTAL(len); while (len-- > 0) { Copy(s, &adouble, 1, double); + DO_BO_UNPACK_N(adouble, double); s += sizeof(double); sv = NEWSV(48, 0); sv_setnv(sv, (NV)adouble); @@ -1637,6 +1821,7 @@ S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, c if (checksum) { while (len-- > 0) { Copy(s, &anv, 1, NV); + DO_BO_UNPACK_N(anv, NV); s += NVSIZE; cdouble += anv; } @@ -1648,6 +1833,7 @@ S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, c EXTEND_MORTAL(len); while (len-- > 0) { Copy(s, &anv, 1, NV); + DO_BO_UNPACK_N(anv, NV); s += NVSIZE; sv = NEWSV(48, 0); sv_setnv(sv, anv); @@ -1663,6 +1849,7 @@ S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, c if (checksum) { while (len-- > 0) { Copy(s, &aldouble, 1, long double); + DO_BO_UNPACK_N(aldouble, long double); s += LONG_DOUBLESIZE; cdouble += aldouble; } @@ -1674,6 +1861,7 @@ S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, c EXTEND_MORTAL(len); while (len-- > 0) { Copy(s, &aldouble, 1, long double); + DO_BO_UNPACK_N(aldouble, long double); s += LONG_DOUBLESIZE; sv = NEWSV(48, 0); sv_setnv(sv, (NV)aldouble); @@ -1745,9 +1933,9 @@ S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, c if (checksum) { sv = NEWSV(42, 0); - if (strchr("fFdD", datumtype) || + if (strchr("fFdD", TYPE_NO_MODIFIERS(datumtype)) || (checksum > bits_in_uv && - strchr("csSiIlLnNUvVqQjJ", datumtype&0xFF)) ) { + strchr("csSiIlLnNUvVqQjJ", TYPE_NO_MODIFIERS(datumtype))) ) { NV trouble; adouble = (NV) (1 << (checksum & 15)); @@ -2036,7 +2224,7 @@ S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV len = symptr->length; break; case e_star: - len = strchr("@Xxu", datumtype) ? 0 : items; + len = strchr("@Xxu", TYPE_NO_MODIFIERS(datumtype)) ? 0 : items; break; } @@ -2056,9 +2244,9 @@ S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV } } - switch(datumtype) { + switch(TYPE_NO_ENDIANNESS(datumtype)) { default: - Perl_croak(aTHX_ "Invalid type '%c' in pack", (int)datumtype); + Perl_croak(aTHX_ "Invalid type '%c' in pack", (int)TYPE_NO_MODIFIERS(datumtype)); case '%': Perl_croak(aTHX_ "'%%' may not be used in pack"); case '@': @@ -2264,7 +2452,7 @@ S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV case 'c': while (len-- > 0) { fromstr = NEXTFROM; - switch (datumtype) { + switch (TYPE_NO_MODIFIERS(datumtype)) { case 'C': aint = SvIV(fromstr); if ((aint < 0 || aint > 255) && @@ -2330,6 +2518,7 @@ S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV afloat = (float)SvNV(fromstr); # endif #endif + DO_BO_PACK_N(afloat, float); sv_catpvn(cat, (char *)&afloat, sizeof (float)); } break; @@ -2362,21 +2551,27 @@ S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV adouble = (double)SvNV(fromstr); # endif #endif + DO_BO_PACK_N(adouble, double); sv_catpvn(cat, (char *)&adouble, sizeof (double)); } break; case 'F': + Zero(&anv, 1, NV); /* can be long double with unused bits */ while (len-- > 0) { fromstr = NEXTFROM; anv = SvNV(fromstr); + DO_BO_PACK_N(anv, NV); sv_catpvn(cat, (char *)&anv, NVSIZE); } break; #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE) case 'D': + /* long doubles can have unused bits, which may be nonzero */ + Zero(&aldouble, 1, long double); while (len-- > 0) { fromstr = NEXTFROM; aldouble = (long double)SvNV(fromstr); + DO_BO_PACK_N(aldouble, long double); sv_catpvn(cat, (char *)&aldouble, LONG_DOUBLESIZE); } break; @@ -2411,6 +2606,7 @@ S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV while (len-- > 0) { fromstr = NEXTFROM; aushort = SvUV(fromstr); + DO_BO_PACK(aushort, s); sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short)); } } @@ -2425,6 +2621,7 @@ S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV while (len-- > 0) { fromstr = NEXTFROM; aushort = (U16)SvUV(fromstr); + DO_BO_PACK(aushort, 16); CAT16(cat, &aushort); } @@ -2438,6 +2635,7 @@ S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV while (len-- > 0) { fromstr = NEXTFROM; ashort = SvIV(fromstr); + DO_BO_PACK(ashort, s); sv_catpvn(cat, (char *)&ashort, sizeof(short)); } } @@ -2449,6 +2647,7 @@ S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV while (len-- > 0) { fromstr = NEXTFROM; ashort = (I16)SvIV(fromstr); + DO_BO_PACK(ashort, 16); CAT16(cat, &ashort); } break; @@ -2457,6 +2656,7 @@ S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV while (len-- > 0) { fromstr = NEXTFROM; auint = SvUV(fromstr); + DO_BO_PACK(auint, i); sv_catpvn(cat, (char*)&auint, sizeof(unsigned int)); } break; @@ -2464,6 +2664,13 @@ S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV while (len-- > 0) { fromstr = NEXTFROM; aiv = SvIV(fromstr); +#if IVSIZE == INTSIZE + DO_BO_PACK(aiv, i); +#elif IVSIZE == LONGSIZE + DO_BO_PACK(aiv, l); +#elif defined(HAS_QUAD) && IVSIZE == U64SIZE + DO_BO_PACK(aiv, 64); +#endif sv_catpvn(cat, (char*)&aiv, IVSIZE); } break; @@ -2471,6 +2678,13 @@ S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV while (len-- > 0) { fromstr = NEXTFROM; auv = SvUV(fromstr); +#if UVSIZE == INTSIZE + DO_BO_PACK(auv, i); +#elif UVSIZE == LONGSIZE + DO_BO_PACK(auv, l); +#elif defined(HAS_QUAD) && UVSIZE == U64SIZE + DO_BO_PACK(auv, 64); +#endif sv_catpvn(cat, (char*)&auv, UVSIZE); } break; @@ -2580,6 +2794,7 @@ S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV while (len-- > 0) { fromstr = NEXTFROM; aint = SvIV(fromstr); + DO_BO_PACK(aint, i); sv_catpvn(cat, (char*)&aint, sizeof(int)); } break; @@ -2613,6 +2828,7 @@ S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV while (len-- > 0) { fromstr = NEXTFROM; aulong = SvUV(fromstr); + DO_BO_PACK(aulong, l); sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long)); } } @@ -2625,6 +2841,7 @@ S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV while (len-- > 0) { fromstr = NEXTFROM; aulong = SvUV(fromstr); + DO_BO_PACK(aulong, 32); CAT32(cat, &aulong); } } @@ -2637,6 +2854,7 @@ S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV while (len-- > 0) { fromstr = NEXTFROM; along = SvIV(fromstr); + DO_BO_PACK(along, l); sv_catpvn(cat, (char *)&along, sizeof(long)); } } @@ -2648,6 +2866,7 @@ S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV while (len-- > 0) { fromstr = NEXTFROM; along = SvIV(fromstr); + DO_BO_PACK(along, 32); CAT32(cat, &along); } break; @@ -2656,6 +2875,7 @@ S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV while (len-- > 0) { fromstr = NEXTFROM; auquad = (Uquad_t)SvUV(fromstr); + DO_BO_PACK(auquad, 64); sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t)); } break; @@ -2663,6 +2883,7 @@ S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV while (len-- > 0) { fromstr = NEXTFROM; aquad = (Quad_t)SvIV(fromstr); + DO_BO_PACK(aquad, 64); sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t)); } break; @@ -2694,6 +2915,7 @@ S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV else aptr = SvPV_force(fromstr,n_a); } + DO_BO_PACK_P(aptr); sv_catpvn(cat, (char*)&aptr, sizeof(char*)); } break; diff --git a/proto.h b/proto.h index 86b32a0..b72fede 100644 --- a/proto.h +++ b/proto.h @@ -1345,4 +1345,80 @@ PERL_CALLCONV void Perl_hv_clear_placeholders(pTHX_ HV* hb); PERL_CALLCONV SV* Perl_hv_scalar(pTHX_ HV* hv); PERL_CALLCONV SV* Perl_magic_scalarpack(pTHX_ HV* hv, MAGIC* mg); +#ifdef PERL_NEED_MY_HTOLE16 +PERL_CALLCONV U16 Perl_my_htole16(U16 n); +#endif +#ifdef PERL_NEED_MY_LETOH16 +PERL_CALLCONV U16 Perl_my_letoh16(U16 n); +#endif +#ifdef PERL_NEED_MY_HTOBE16 +PERL_CALLCONV U16 Perl_my_htobe16(U16 n); +#endif +#ifdef PERL_NEED_MY_BETOH16 +PERL_CALLCONV U16 Perl_my_betoh16(U16 n); +#endif +#ifdef PERL_NEED_MY_HTOLE32 +PERL_CALLCONV U32 Perl_my_htole32(U32 n); +#endif +#ifdef PERL_NEED_MY_LETOH32 +PERL_CALLCONV U32 Perl_my_letoh32(U32 n); +#endif +#ifdef PERL_NEED_MY_HTOBE32 +PERL_CALLCONV U32 Perl_my_htobe32(U32 n); +#endif +#ifdef PERL_NEED_MY_BETOH32 +PERL_CALLCONV U32 Perl_my_betoh32(U32 n); +#endif +#ifdef PERL_NEED_MY_HTOLE64 +PERL_CALLCONV U64 Perl_my_htole64(U64 n); +#endif +#ifdef PERL_NEED_MY_LETOH64 +PERL_CALLCONV U64 Perl_my_letoh64(U64 n); +#endif +#ifdef PERL_NEED_MY_HTOBE64 +PERL_CALLCONV U64 Perl_my_htobe64(U64 n); +#endif +#ifdef PERL_NEED_MY_BETOH64 +PERL_CALLCONV U64 Perl_my_betoh64(U64 n); +#endif + +#ifdef PERL_NEED_MY_HTOLES +PERL_CALLCONV short Perl_my_htoles(short n); +#endif +#ifdef PERL_NEED_MY_LETOHS +PERL_CALLCONV short Perl_my_letohs(short n); +#endif +#ifdef PERL_NEED_MY_HTOBES +PERL_CALLCONV short Perl_my_htobes(short n); +#endif +#ifdef PERL_NEED_MY_BETOHS +PERL_CALLCONV short Perl_my_betohs(short n); +#endif +#ifdef PERL_NEED_MY_HTOLEI +PERL_CALLCONV int Perl_my_htolei(int n); +#endif +#ifdef PERL_NEED_MY_LETOHI +PERL_CALLCONV int Perl_my_letohi(int n); +#endif +#ifdef PERL_NEED_MY_HTOBEI +PERL_CALLCONV int Perl_my_htobei(int n); +#endif +#ifdef PERL_NEED_MY_BETOHI +PERL_CALLCONV int Perl_my_betohi(int n); +#endif +#ifdef PERL_NEED_MY_HTOLEL +PERL_CALLCONV long Perl_my_htolel(long n); +#endif +#ifdef PERL_NEED_MY_LETOHL +PERL_CALLCONV long Perl_my_letohl(long n); +#endif +#ifdef PERL_NEED_MY_HTOBEL +PERL_CALLCONV long Perl_my_htobel(long n); +#endif +#ifdef PERL_NEED_MY_BETOHL +PERL_CALLCONV long Perl_my_betohl(long n); +#endif + +PERL_CALLCONV void Perl_my_swabn(void* ptr, int n); + END_EXTERN_C diff --git a/t/op/pack.t b/t/op/pack.t index a4c8e91..d7a4137 100755 --- a/t/op/pack.t +++ b/t/op/pack.t @@ -6,7 +6,7 @@ BEGIN { require './test.pl'; } -plan tests => 6076; +plan tests => 13576; use strict; use warnings; @@ -14,6 +14,41 @@ use Config; my $Is_EBCDIC = (defined $Config{ebcdic} && $Config{ebcdic} eq 'define'); my $Perl = which_perl(); +my @valid_errors = (qr/^Invalid type '\w'/); + +my $ByteOrder = 'unknown'; +my $maybe_not_avail = '(?:hto[bl]e|[bl]etoh)'; +if ($Config{byteorder} =~ /^1234(?:5678)?$/) { + $ByteOrder = 'little'; + $maybe_not_avail = '(?:htobe|betoh)'; +} +elsif ($Config{byteorder} =~ /^(?:8765)?4321$/) { + $ByteOrder = 'big'; + $maybe_not_avail = '(?:htole|letoh)'; +} +else { + push @valid_errors, qr/^Can't (?:un)?pack (?:big|little)-endian .*? on this platform/; +} + +for my $size ( 16, 32, 64 ) { + if (exists $Config{"u${size}size"} and $Config{"u${size}size"} != ($size >> 3)) { + push @valid_errors, qr/^Perl_my_$maybe_not_avail$size\(\) not available/; + } +} + +my $IsTwosComplement = pack('i', -1) eq "\xFF" x $Config{intsize}; +print "# \$IsTwosComplement = $IsTwosComplement\n"; + +sub is_valid_error +{ + my $err = shift; + + for my $e (@valid_errors) { + $err =~ $e and return 1; + } + + return 0; +} sub encode_list { my @result = map {_qq($_)} @_; @@ -177,6 +212,22 @@ sub list_eq ($$) { eval { $x = pack 'w', '1'x(1 + length ~0) . 'e0' }; like ($@, qr/^Can only compress unsigned integers/); + for my $mod (qw( ! < > )) { + eval { $x = pack "a$mod", 42 }; + like ($@, qr/^'$mod' allowed only after types \w+ in pack/); + + eval { $x = unpack "a$mod", 'x'x8 }; + like ($@, qr/^'$mod' allowed only after types \w+ in unpack/); + } + + for my $mod (qw( <> >< !<> !>< >!< <>! >' after type 'I' in pack/); + + eval { $x = unpack "sI${mod}s", 'x'x16 }; + like ($@, qr/^Can't use both '<' and '>' after type 'I' in unpack/); + } + SKIP: { # Is this a stupid thing to do on VMS, VOS and other unusual platforms? @@ -192,7 +243,7 @@ sub list_eq ($$) { ($^O =~ /^svr4/ && -f "/etc/issue" && -f "/etc/.relid") # NCR MP-RAS ); - my $inf = eval '2**10000'; + my $inf = eval '2**1000000'; skip("Couldn't generate infinity - got error '$@'", 1) unless defined $inf and $inf == $inf / 2 and $inf + 1 == $inf; @@ -229,7 +280,7 @@ sub list_eq ($$) { # 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%)"); + "Round trip pack, unpack 'w' of $big is within 1% ($quotient%)"); } } @@ -238,9 +289,13 @@ print "# test the 'p' template\n"; # literals is(unpack("p",pack("p","foo")), "foo"); +is(unpack("p<",pack("p<","foo")), "foo"); +is(unpack("p>",pack("p>","foo")), "foo"); # scalars is(unpack("p",pack("p",239)), 239); +is(unpack("p<",pack("p<",239)), 239); +is(unpack("p>",pack("p>",239)), 239); # temps sub foo { my $a = "a"; return $a . $a++ . $a++ } @@ -256,24 +311,36 @@ sub foo { my $a = "a"; return $a . $a++ . $a++ } } # undef should give null pointer -like(pack("p", undef), qr/^\0+/); +like(pack("p", undef), qr/^\0+$/); +like(pack("p<", undef), qr/^\0+$/); +like(pack("p>", undef), qr/^\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 is((unpack("i",pack("i",-1))), -1); -print "# test the pack lengths of s S i I l L n N v V\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) { - is($expect, $len, "format '$format'"); - } else { - $expect = -$expect; - ok ($len >= $expect, "format '$format'") || - print "# format '$format' has length $len, expected >= $expect\n"; +print "# test the pack lengths of s S i I l L n N v V + modifiers\n"; + +my @lengths = ( + qw(s 2 S 2 i -4 I -4 l 4 L 4 n 2 N 4 v 2 V 4 n! 2 N! 4 v! 2 V! 4), + 's!' => $Config{shortsize}, 'S!' => $Config{shortsize}, + 'i!' => $Config{intsize}, 'I!' => $Config{intsize}, + 'l!' => $Config{longsize}, 'L!' => $Config{longsize}, +); + +while (my ($base, $expect) = splice @lengths, 0, 2) { + my @formats = ($base); + $base =~ /^[nv]/i or push @formats, "$base>", "$base<"; + for my $format (@formats) { + my $len = length(pack($format, 0)); + if ($expect > 0) { + is($expect, $len, "format '$format'"); + } else { + $expect = -$expect; + ok ($len >= $expect, "format '$format'") || + print "# format '$format' has length $len, expected >= $expect\n"; + } } } @@ -282,18 +349,18 @@ print "# test unpack-pack lengths\n"; my @templates = qw(c C i I s S l L n N v V f d q Q); -foreach my $t (@templates) { - SKIP: { - my @t = eval { unpack("$t*", pack("$t*", 12, 34)) }; - - # quads not supported everywhere - skip "Quads not supported", 4 if $@ =~ /Invalid type/; - is( $@, '' ); +foreach my $base (@templates) { + my @tmpl = ($base); + $base =~ /^[cnv]/i or push @tmpl, "$base>", "$base<"; + foreach my $t (@tmpl) { + SKIP: { + my @t = eval { unpack("$t*", pack("$t*", 12, 34)) }; - is(scalar @t, 2); + skip "cannot pack '$t' on this perl", 4 + if is_valid_error($@); - SKIP: { - skip "$t not expected to work for some reason", 2 if $t =~ /[nv]/i; + is( $@, '' ); + is(scalar @t, 2); is($t[0], 12); is($t[1], 34); @@ -386,8 +453,12 @@ ok(length(pack("i!", 0)) <= length(pack("l!", 0))); is(length(pack("i!", 0)), length(pack("i", 0))); sub numbers { - my $format = shift; - return numbers_with_total ($format, undef, @_); + my $base = shift; + my @formats = ($base); + $base =~ /^[silqjfdp]/i and push @formats, "$base>", "$base<"; + for my $format (@formats) { + numbers_with_total ($format, undef, @_); + } } sub numbers_with_total { @@ -402,8 +473,8 @@ sub numbers_with_total { foreach (@_) { SKIP: { my $out = eval {unpack($format, pack($format, $_))}; - skip "cannot pack '$format' on this perl", 2 if - $@ =~ /Invalid type '$format'/; + skip "cannot pack '$format' on this perl", 2 + if is_valid_error($@); is($@, ''); is($out, $_); @@ -423,7 +494,7 @@ sub numbers_with_total { SKIP: { my $sum = eval {unpack "%$_$format*", pack "$format*", @_}; skip "cannot pack '$format' on this perl", 3 - if $@ =~ /Invalid type '$format'/; + if is_valid_error($@); is($@, ''); ok(defined $sum); @@ -548,6 +619,117 @@ is(pack("v!", 0xdead), "\xad\xde"); is(pack("N!", 0xdeadbeef), "\xde\xad\xbe\xef"); is(pack("V!", 0xdeadbeef), "\xef\xbe\xad\xde"); +print "# test big-/little-endian conversion\n"; + +sub byteorder +{ + my $format = shift; + print "# byteorder test for $format\n"; + for my $value (@_) { + SKIP: { + my($nat,$be,$le) = eval { map { pack $format.$_, $value } '', '>', '<' }; + skip "cannot pack '$format' on this perl", 5 + if is_valid_error($@); + + print "# [$value][$nat][$be][$le][$@]\n"; + + SKIP: { + skip "cannot compare native byteorder with big-/little-endian", 1 + if $ByteOrder eq 'unknown'; + + is($nat, $ByteOrder eq 'big' ? $be : $le); + } + is($be, reverse($le)); + my @x = eval { unpack "$format$format>$format<", $nat.$be.$le }; + + print "# [$value][", join('][', @x), "][$@]\n"; + + is($@, ''); + is($x[0], $x[1]); + is($x[0], $x[2]); + } + } +} + +byteorder('s', -32768, -1, 0, 1, 32767); +byteorder('S', 0, 1, 32767, 32768, 65535); +byteorder('i', -2147483648, -1, 0, 1, 2147483647); +byteorder('I', 0, 1, 2147483647, 2147483648, 4294967295); +byteorder('l', -2147483648, -1, 0, 1, 2147483647); +byteorder('L', 0, 1, 2147483647, 2147483648, 4294967295); +byteorder('j', -2147483648, -1, 0, 1, 2147483647); +byteorder('J', 0, 1, 2147483647, 2147483648, 4294967295); +byteorder('s!', -32768, -1, 0, 1, 32767); +byteorder('S!', 0, 1, 32767, 32768, 65535); +byteorder('i!', -2147483648, -1, 0, 1, 2147483647); +byteorder('I!', 0, 1, 2147483647, 2147483648, 4294967295); +byteorder('l!', -2147483648, -1, 0, 1, 2147483647); +byteorder('L!', 0, 1, 2147483647, 2147483648, 4294967295); +byteorder('q', -9223372036854775808, -1, 0, 1, 9223372036854775807); +byteorder('Q', 0, 1, 9223372036854775807, 9223372036854775808, 18446744073709551615); +byteorder('f', -1, 0, 0.5, 42, 2**34); +byteorder('F', -1, 0, 0.5, 42, 2**34); +byteorder('d', -(2**34), -1, 0, 1, 2**34); +byteorder('D', -(2**34), -1, 0, 1, 2**34); + +print "# test negative numbers\n"; + +SKIP: { + skip "platform is not using two's complement for negative integers", 120 + unless $IsTwosComplement; + + for my $format (qw(s i l j s! i! l! q)) { + SKIP: { + my($nat,$be,$le) = eval { map { pack $format.$_, -1 } '', '>', '<' }; + skip "cannot pack '$format' on this perl", 15 + if is_valid_error($@); + + my $len = length $nat; + is($_, "\xFF"x$len) for $nat, $be, $le; + + my(@val,@ref); + if ($len >= 8) { + @val = (-2, -81985529216486896, -9223372036854775808); + @ref = ("\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFE", + "\xFE\xDC\xBA\x98\x76\x54\x32\x10", + "\x80\x00\x00\x00\x00\x00\x00\x00"); + } + elsif ($len >= 4) { + @val = (-2, -19088744, -2147483648); + @ref = ("\xFF\xFF\xFF\xFE", + "\xFE\xDC\xBA\x98", + "\x80\x00\x00\x00"); + } + else { + @val = (-2, -292, -32768); + @ref = ("\xFF\xFE", + "\xFE\xDC", + "\x80\x00"); + } + for my $x (@ref) { + if ($len > length $x) { + $x = $x . "\xFF" x ($len - length $x); + } + } + + for my $i (0 .. $#val) { + my($nat,$be,$le) = eval { map { pack $format.$_, $val[$i] } '', '>', '<' }; + is($@, ''); + + SKIP: { + skip "cannot compare native byteorder with big-/little-endian", 1 + if $ByteOrder eq 'unknown'; + + is($nat, $ByteOrder eq 'big' ? $be : $le); + } + + is($be, $ref[$i]); + is($be, reverse($le)); + } + } + } +} + { # / @@ -684,7 +866,7 @@ SKIP: { { local $SIG{__WARN__} = sub { $@ = "@_" }; my @null = unpack('U0U', chr(255)); - like($@, /^Malformed UTF-8 character /); + like($@, qr/^Malformed UTF-8 character /); } } @@ -953,6 +1135,16 @@ foreach ( eval { my @a = unpack( "C/", "\3" ); }; like( $@, qr{Code missing after '/'} ); + # modifier warnings + @warning = (); + $x = pack "I>>s!!", 47, 11; + ($x) = unpack "I<!>", 'x'x20; + is(scalar @warning, 5); + like($warning[0], qr/Duplicate modifier '>' after 'I' in pack/); + like($warning[1], qr/Duplicate modifier '!' after 's' in pack/); + like($warning[2], qr/Duplicate modifier '<' after 'I' in unpack/); + like($warning[3], qr/Duplicate modifier '!' after 'l' in unpack/); + like($warning[4], qr/Duplicate modifier '>' after 'l' in unpack/); } { # Repeat count [SUBEXPR] @@ -962,7 +1154,7 @@ foreach ( if (eval { pack 'q', 1 } ) { push @codes, qw(q Q); } else { - push @codes, qw(c C); # Keep the count the same + push @codes, qw(s S); # Keep the count the same } if (eval { pack 'D', 1 } ) { push @codes, 'D'; @@ -970,6 +1162,8 @@ foreach ( push @codes, 'd'; # Keep the count the same } + push @codes, map { /^[silqjfdp]/i ? ("$_<", "$_>") : () } @codes; + my %val; @val{@codes} = map { / [Xx] (?{ undef }) | [AZa] (?{ 'something' }) @@ -998,18 +1192,23 @@ foreach ( $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]"); - } + SKIP: { + my $junk1 = "$groupbegin $type$count $groupend"; + # print "# junk1=$junk1\n"; + my $p = eval { pack $junk1, @list2 }; + skip "cannot pack '$type' on this perl", 12 + if is_valid_error($@); + + 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]"); + } + } } } } @@ -1072,7 +1271,7 @@ 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/; + skip "Long doubles not in use", 166 if $@ =~ /Invalid type/; is(length(pack("D", 0)), $Config{longdblsize}); numbers ('D', -(2**34), -1, 0, 1, 2**34); diff --git a/util.c b/util.c index 9c12c12..d145262 100644 --- a/util.c +++ b/util.c @@ -1746,7 +1746,7 @@ Perl_my_ntohl(pTHX_ long l) * -DWS */ -#define HTOV(name,type) \ +#define HTOLE(name,type) \ type \ name (register type n) \ { \ @@ -1755,14 +1755,14 @@ Perl_my_ntohl(pTHX_ long l) char c[sizeof(type)]; \ } u; \ register I32 i; \ - register I32 s; \ - for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \ + register I32 s = 0; \ + for (i = 0; i < sizeof(u.c); i++, s += 8) { \ u.c[i] = (n >> s) & 0xFF; \ } \ return u.value; \ } -#define VTOH(name,type) \ +#define LETOH(name,type) \ type \ name (register type n) \ { \ @@ -1771,27 +1771,218 @@ Perl_my_ntohl(pTHX_ long l) char c[sizeof(type)]; \ } u; \ register I32 i; \ - register I32 s; \ + register I32 s = 0; \ u.value = n; \ n = 0; \ - for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \ - n += (u.c[i] & 0xFF) << s; \ + for (i = 0; i < sizeof(u.c); i++, s += 8) { \ + n |= ((type)(u.c[i] & 0xFF)) << s; \ } \ return n; \ } +/* + * Big-endian byte order functions. + */ + +#define HTOBE(name,type) \ + type \ + name (register type n) \ + { \ + union { \ + type value; \ + char c[sizeof(type)]; \ + } u; \ + register I32 i; \ + register I32 s = 8*(sizeof(u.c)-1); \ + for (i = 0; i < sizeof(u.c); i++, s -= 8) { \ + u.c[i] = (n >> s) & 0xFF; \ + } \ + return u.value; \ + } + +#define BETOH(name,type) \ + type \ + name (register type n) \ + { \ + union { \ + type value; \ + char c[sizeof(type)]; \ + } u; \ + register I32 i; \ + register I32 s = 8*(sizeof(u.c)-1); \ + u.value = n; \ + n = 0; \ + for (i = 0; i < sizeof(u.c); i++, s -= 8) { \ + n |= ((type)(u.c[i] & 0xFF)) << s; \ + } \ + return n; \ + } + +/* + * If we just can't do it... + */ + +#define NOT_AVAIL(name,type) \ + type \ + name (register type n) \ + { \ + Perl_croak_nocontext(#name "() not available"); \ + return n; /* not reached */ \ + } + + #if defined(HAS_HTOVS) && !defined(htovs) -HTOV(htovs,short) +HTOLE(htovs,short) #endif #if defined(HAS_HTOVL) && !defined(htovl) -HTOV(htovl,long) +HTOLE(htovl,long) #endif #if defined(HAS_VTOHS) && !defined(vtohs) -VTOH(vtohs,short) +LETOH(vtohs,short) #endif #if defined(HAS_VTOHL) && !defined(vtohl) -VTOH(vtohl,long) +LETOH(vtohl,long) +#endif + +#ifdef PERL_NEED_MY_HTOLE16 +# if U16SIZE == 2 +HTOLE(Perl_my_htole16,U16) +# else +NOT_AVAIL(Perl_my_htole16,U16) +# endif +#endif +#ifdef PERL_NEED_MY_LETOH16 +# if U16SIZE == 2 +LETOH(Perl_my_letoh16,U16) +# else +NOT_AVAIL(Perl_my_letoh16,U16) +# endif +#endif +#ifdef PERL_NEED_MY_HTOBE16 +# if U16SIZE == 2 +HTOBE(Perl_my_htobe16,U16) +# else +NOT_AVAIL(Perl_my_htobe16,U16) +# endif +#endif +#ifdef PERL_NEED_MY_BETOH16 +# if U16SIZE == 2 +BETOH(Perl_my_betoh16,U16) +# else +NOT_AVAIL(Perl_my_betoh16,U16) +# endif +#endif + +#ifdef PERL_NEED_MY_HTOLE32 +# if U32SIZE == 4 +HTOLE(Perl_my_htole32,U32) +# else +NOT_AVAIL(Perl_my_htole32,U32) +# endif +#endif +#ifdef PERL_NEED_MY_LETOH32 +# if U32SIZE == 4 +LETOH(Perl_my_letoh32,U32) +# else +NOT_AVAIL(Perl_my_letoh32,U32) +# endif +#endif +#ifdef PERL_NEED_MY_HTOBE32 +# if U32SIZE == 4 +HTOBE(Perl_my_htobe32,U32) +# else +NOT_AVAIL(Perl_my_htobe32,U32) +# endif +#endif +#ifdef PERL_NEED_MY_BETOH32 +# if U32SIZE == 4 +BETOH(Perl_my_betoh32,U32) +# else +NOT_AVAIL(Perl_my_betoh32,U32) +# endif +#endif + +#ifdef PERL_NEED_MY_HTOLE64 +# if U64SIZE == 8 +HTOLE(Perl_my_htole64,U64) +# else +NOT_AVAIL(Perl_my_htole64,U64) +# endif +#endif +#ifdef PERL_NEED_MY_LETOH64 +# if U64SIZE == 8 +LETOH(Perl_my_letoh64,U64) +# else +NOT_AVAIL(Perl_my_letoh64,U64) +# endif +#endif +#ifdef PERL_NEED_MY_HTOBE64 +# if U64SIZE == 8 +HTOBE(Perl_my_htobe64,U64) +# else +NOT_AVAIL(Perl_my_htobe64,U64) +# endif #endif +#ifdef PERL_NEED_MY_BETOH64 +# if U64SIZE == 8 +BETOH(Perl_my_betoh64,U64) +# else +NOT_AVAIL(Perl_my_betoh64,U64) +# endif +#endif + +#ifdef PERL_NEED_MY_HTOLES +HTOLE(Perl_my_htoles,short) +#endif +#ifdef PERL_NEED_MY_LETOHS +LETOH(Perl_my_letohs,short) +#endif +#ifdef PERL_NEED_MY_HTOBES +HTOBE(Perl_my_htobes,short) +#endif +#ifdef PERL_NEED_MY_BETOHS +BETOH(Perl_my_betohs,short) +#endif + +#ifdef PERL_NEED_MY_HTOLEI +HTOLE(Perl_my_htolei,int) +#endif +#ifdef PERL_NEED_MY_LETOHI +LETOH(Perl_my_letohi,int) +#endif +#ifdef PERL_NEED_MY_HTOBEI +HTOBE(Perl_my_htobei,int) +#endif +#ifdef PERL_NEED_MY_BETOHI +BETOH(Perl_my_betohi,int) +#endif + +#ifdef PERL_NEED_MY_HTOLEL +HTOLE(Perl_my_htolel,long) +#endif +#ifdef PERL_NEED_MY_LETOHL +LETOH(Perl_my_letohl,long) +#endif +#ifdef PERL_NEED_MY_HTOBEL +HTOBE(Perl_my_htobel,long) +#endif +#ifdef PERL_NEED_MY_BETOHL +BETOH(Perl_my_betohl,long) +#endif + +void +Perl_my_swabn(void *ptr, int n) +{ + register char *s = (char *)ptr; + register char *e = s + (n-1); + register char tc; + + for (n /= 2; n > 0; s++, e--, n--) { + tc = *s; + *s = *e; + *e = tc; + } +} PerlIO * Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) -- 2.7.4