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

diff --git a/embed.fnc b/embed.fnc
index 4547e1f..a67cd92 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -585,6 +585,7 @@ Ap  |void   |set_numeric_radix
 Ap     |void   |set_numeric_standard
 Apd    |void   |require_pv     |const char* pv
 Apd    |void   |pack_cat       |SV *cat|char *pat|char *patend|SV **beglist|SV **endlist|SV ***next_in_list|U32 flags
+Apd    |void   |packlist       |SV *cat|char *pat|char *patend|SV **beglist|SV **endlist
 p      |void   |pidgone        |Pid_t pid|int status
 Ap     |void   |pmflag         |U32* pmfl|int ch
 p      |OP*    |pmruntime      |OP* pm|OP* expr|OP* repl
@@ -807,6 +808,7 @@ Apd |UV     |to_utf8_fold   |U8 *p|U8* ustrp|STRLEN *lenp
 Ap     |I32    |unlnk          |char* f
 #endif
 Apd    |I32    |unpack_str     |char *pat|char *patend|char *s|char *strbeg|char *strend|char **new_s|I32 ocnt|U32 flags
+Apd    |I32    |unpackstring   |char *pat|char *patend|char *s|char *strend|U32 flags
 Ap     |void   |unsharepvn     |const char* sv|I32 len|U32 hash
 p      |void   |unshare_hek    |HEK* hek
 p      |void   |utilize        |int aver|I32 floor|OP* version|OP* idop|OP* arg

diff --git a/embed.h b/embed.h
index 489a552..031d4bb 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -808,6 +808,7 @@
 #define set_numeric_standard   Perl_set_numeric_standard
 #define require_pv             Perl_require_pv
 #define pack_cat               Perl_pack_cat
+#define packlist               Perl_packlist
 #ifdef PERL_CORE
 #define pidgone                        Perl_pidgone
 #endif
@@ -1069,6 +1070,7 @@
 #define unlnk                  Perl_unlnk
 #endif
 #define unpack_str             Perl_unpack_str
+#define unpackstring           Perl_unpackstring
 #define unsharepvn             Perl_unsharepvn
 #ifdef PERL_CORE
 #define unshare_hek            Perl_unshare_hek
@@ -3286,6 +3288,7 @@
 #define set_numeric_standard() Perl_set_numeric_standard(aTHX)
 #define require_pv(a)          Perl_require_pv(aTHX_ a)
 #define pack_cat(a,b,c,d,e,f,g)        Perl_pack_cat(aTHX_ a,b,c,d,e,f,g)
+#define packlist(a,b,c,d,e)    Perl_packlist(aTHX_ a,b,c,d,e)
 #ifdef PERL_CORE
 #define pidgone(a,b)           Perl_pidgone(aTHX_ a,b)
 #endif
@@ -3547,6 +3550,7 @@
 #define unlnk(a)               Perl_unlnk(aTHX_ a)
 #endif
 #define unpack_str(a,b,c,d,e,f,g,h)    Perl_unpack_str(aTHX_ a,b,c,d,e,f,g,h)
+#define unpackstring(a,b,c,d,e)        Perl_unpackstring(aTHX_ a,b,c,d,e)
 #define unsharepvn(a,b,c)      Perl_unsharepvn(aTHX_ a,b,c)
 #ifdef PERL_CORE
 #define unshare_hek(a)         Perl_unshare_hek(aTHX_ a)

diff --git a/global.sym b/global.sym
index e4908b6..4f77904 100644 (file)
--- a/global.sym
+++ b/global.sym
@@ -353,6 +353,7 @@ Perl_set_numeric_radix
 Perl_set_numeric_standard
 Perl_require_pv
 Perl_pack_cat
+Perl_packlist
 Perl_pmflag
 Perl_pop_scope
 Perl_push_scope
@@ -516,6 +517,7 @@ Perl_to_utf8_title
 Perl_to_utf8_fold
 Perl_unlnk
 Perl_unpack_str
+Perl_unpackstring
 Perl_unsharepvn
 Perl_utf16_to_utf8
 Perl_utf16_to_utf8_reversed

diff --git a/pod/perlapi.pod b/pod/perlapi.pod
index f646778..fa5381b 100644 (file)
--- a/pod/perlapi.pod
+++ b/pod/perlapi.pod
@@ -704,19 +704,39 @@ Found in file perl.c
 
 =over 8
 
-=item pack_cat
+=item packlist
 
 The engine implementing pack() Perl function.
 
+       void    packlist(SV *cat, char *pat, char *patend, SV **beglist, SV **endlist)
+
+=for hackers
+Found in file pp_pack.c
+
+=item pack_cat
+
+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.
+
        void    pack_cat(SV *cat, char *pat, char *patend, SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
 
 =for hackers
 Found in file pp_pack.c
 
-=item unpack_str
+=item unpackstring
 
 The engine implementing unpack() Perl function.
 
+       I32     unpackstring(char *pat, char *patend, char *s, char *strend, U32 flags)
+
+=for hackers
+Found in file pp_pack.c
+
+=item unpack_str
+
+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.
+
        I32     unpack_str(char *pat, char *patend, char *s, char *strbeg, char *strend, char **new_s, I32 ocnt, U32 flags)
 
 =for hackers

diff --git a/pp_pack.c b/pp_pack.c
index 8bcc570..7d7bd32 100644 (file)
--- 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;

diff --git a/proto.h b/proto.h
index a4077db..e37aaf4 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -623,6 +623,7 @@ PERL_CALLCONV void  Perl_set_numeric_radix(pTHX);
 PERL_CALLCONV void     Perl_set_numeric_standard(pTHX);
 PERL_CALLCONV void     Perl_require_pv(pTHX_ const char* pv);
 PERL_CALLCONV void     Perl_pack_cat(pTHX_ SV *cat, char *pat, char *patend, SV **beglist, SV **endlist, SV ***next_in_list, U32 flags);
+PERL_CALLCONV void     Perl_packlist(pTHX_ SV *cat, char *pat, char *patend, SV **beglist, SV **endlist);
 PERL_CALLCONV void     Perl_pidgone(pTHX_ Pid_t pid, int status);
 PERL_CALLCONV void     Perl_pmflag(pTHX_ U32* pmfl, int ch);
 PERL_CALLCONV OP*      Perl_pmruntime(pTHX_ OP* pm, OP* expr, OP* repl);
@@ -834,6 +835,7 @@ PERL_CALLCONV UV    Perl_to_utf8_fold(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp);
 PERL_CALLCONV I32      Perl_unlnk(pTHX_ char* f);
 #endif
 PERL_CALLCONV I32      Perl_unpack_str(pTHX_ char *pat, char *patend, char *s, char *strbeg, char *strend, char **new_s, I32 ocnt, U32 flags);
+PERL_CALLCONV I32      Perl_unpackstring(pTHX_ char *pat, char *patend, char *s, char *strend, U32 flags);
 PERL_CALLCONV void     Perl_unsharepvn(pTHX_ const char* sv, I32 len, U32 hash);
 PERL_CALLCONV void     Perl_unshare_hek(pTHX_ HEK* hek);
 PERL_CALLCONV void     Perl_utilize(pTHX_ int aver, I32 floor, OP* version, OP* idop, OP* arg);