From: Jarkko Hietaniemi Date: Mon, 5 May 2003 05:33:43 +0000 (+0000) Subject: pack/unpack fixes from Wolfgang Laun: X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7accc089c4644f7a60f6877ea3a436c5f3cc9651;p=p5sagit%2Fp5-mst-13.2.git 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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);