pack/unpack fixes from Wolfgang Laun:

- fix bug in UNICOS (where SIZE16 != sizeof(short))
- introduce and use new internal pack/unpack API
  (packlist, unpackstring)
  that does away with the unused arguments in the old API
  (pack_cat, unpack_str).

p4raw-id: //depot/perl@19416

1 files changed, 46 insertions, 6 deletions

diff --git a/pp_pack.c b/pp_pack.c
index 8bcc5707f8..7d7bd32736 100644
--- a/pp_pack.c
+++ b/pp_pack.c
@@ -494,7 +494,8 @@ S_next_symbol(pTHX_ register tempsym_t* symptr )
 /*
 =for apidoc unpack_str
 
-The engine implementing unpack() Perl function.
+The engine implementing unpack() Perl function. Note: parameters strbeg, new_s
+and ocnt are not used. This call should not be used, use unpackstring instead.
 
 =cut */
 
@@ -509,6 +510,24 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
     return unpack_rec(&sym, s, s, strend, NULL );
 }
 
+/*
+=for apidoc unpackstring
+
+The engine implementing unpack() Perl function.
+
+=cut */
+
+I32
+Perl_unpackstring(pTHX_ char *pat, register char *patend, register char *s, char *strend, U32 flags)
+{
+    tempsym_t sym = { 0 };
+    sym.patptr = pat;
+    sym.patend = patend;
+    sym.flags  = flags;
+
+    return unpack_rec(&sym, s, s, strend, NULL );
+}
+
 STATIC
 I32
 S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, char *strend, char **new_s )
@@ -933,7 +952,7 @@ S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, c
 	    break;
 	case 'S' | TYPE_IS_SHRIEKING:
 #if SHORTSIZE != SIZE16
-	    along = (strend - s) / SIZE16;
+	    along = (strend - s) / sizeof(unsigned short);
 	    if (len > along)
 		len = along;
 	    if (checksum) {
@@ -1705,7 +1724,7 @@ PP(pp_unpack)
     register I32 cnt;
 
     PUTBACK;
-    cnt = unpack_str(pat, patend, s, s, strend, NULL, 0,
+    cnt = unpackstring(pat, patend, s, strend,
 		     ((gimme == G_SCALAR) ? FLAG_UNPACK_ONLY_ONE : 0)
 		     | (DO_UTF8(right) ? FLAG_UNPACK_DO_UTF8 : 0));
 
@@ -1824,7 +1843,8 @@ S_div128(pTHX_ SV *pnum, bool *done)
 /*
 =for apidoc pack_cat
 
-The engine implementing pack() Perl function.
+The engine implementing pack() Perl function. Note: parameters next_in_list and
+flags are not used. This call should not be used; use packlist instead.
 
 =cut */
 
@@ -1835,7 +1855,27 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg
     tempsym_t sym = { 0 };
     sym.patptr = pat;
     sym.patend = patend;
-    sym.flags  = flags;
+    sym.flags  = FLAG_PACK;
+
+    (void)pack_rec( cat, &sym, beglist, endlist );
+}
+
+
+/*
+=for apidoc packlist
+
+The engine implementing pack() Perl function.
+
+=cut */
+
+
+void
+Perl_packlist(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist )
+{
+    tempsym_t sym = { 0 };
+    sym.patptr = pat;
+    sym.patend = patend;
+    sym.flags  = FLAG_PACK;
 
     (void)pack_rec( cat, &sym, beglist, endlist );
 }
@@ -2589,7 +2629,7 @@ PP(pp_pack)
     MARK++;
     sv_setpvn(cat, "", 0);
 
-    pack_cat(cat, pat, patend, MARK, SP + 1, NULL, FLAG_PACK);
+    packlist(cat, pat, patend, MARK, SP + 1);
 
     SvSETMAGIC(cat);
     SP = ORIGMARK;