X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_pack.c;h=0895c9bba9cdcf7781b068c0ccb1872c4fbfbe6d;hb=e7deb4af6a1bddab29db10b779d229aec81737e3;hp=7bf1ce1746e6e50c569cb57992f94487b7a00830;hpb=6e449a3ab1e3bd9d7e138ca681c733e57d4daa49;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/pp_pack.c b/pp_pack.c
index 7bf1ce1..0895c9b 100644
--- a/pp_pack.c
+++ b/pp_pack.c
@@ -1,7 +1,7 @@
 /*    pp_pack.c
  *
- *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- *    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others
+ *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
+ *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -14,6 +14,8 @@
  * wooden spoon, a short two-pronged fork and some skewers were stowed; and
  * hidden at the bottom of the pack in a flat wooden box a dwindling treasure,
  * some salt.
+ *
+ *     [p.653 of _The Lord of the Rings_, IV/iv: "Of Herbs and Stewed Rabbit"]
  */
 
 /* This file contains pp ("push/pop") functions that
@@ -177,6 +179,8 @@ S_mul128(pTHX_ SV *sv, U8 m)
   char           *s = SvPV(sv, len);
   char           *t;
 
+  PERL_ARGS_ASSERT_MUL128;
+
   if (!strnEQ(s, "0000", 4)) {  /* need to grow sv */
     SV * const tmpNew = newSVpvs("0000000000");
 
@@ -705,6 +709,8 @@ STATIC char *
 S_bytes_to_uni(const U8 *start, STRLEN len, char *dest) {
     const U8 * const end = start + len;
 
+    PERL_ARGS_ASSERT_BYTES_TO_UNI;
+
     while (start < end) {
 	const UV uv = NATIVE_TO_ASCII(*start);
 	if (UNI_IS_INVARIANT(uv))
@@ -784,6 +790,8 @@ S_measure_struct(pTHX_ tempsym_t* symptr)
 {
     I32 total = 0;
 
+    PERL_ARGS_ASSERT_MEASURE_STRUCT;
+
     while (next_symbol(symptr)) {
 	I32 len;
 	int size;
@@ -893,6 +901,8 @@ S_measure_struct(pTHX_ tempsym_t* symptr)
 STATIC const char *
 S_group_end(pTHX_ register const char *patptr, register const char *patend, char ender)
 {
+    PERL_ARGS_ASSERT_GROUP_END;
+
     while (patptr < patend) {
 	const char c = *patptr++;
 
@@ -923,6 +933,9 @@ STATIC const char *
 S_get_num(pTHX_ register const char *patptr, I32 *lenptr )
 {
   I32 len = *patptr++ - '0';
+
+  PERL_ARGS_ASSERT_GET_NUM;
+
   while (isDIGIT(*patptr)) {
     if (len >= 0x7FFFFFFF/10)
       Perl_croak(aTHX_ "pack/unpack repeat count overflow");
@@ -941,6 +954,8 @@ S_next_symbol(pTHX_ tempsym_t* symptr )
   const char* patptr = symptr->patptr;
   const char* const patend = symptr->patend;
 
+  PERL_ARGS_ASSERT_NEXT_SYMBOL;
+
   symptr->flags &= ~FLAG_SLASH;
 
   while (patptr < patend) {
@@ -1120,6 +1135,9 @@ STATIC bool
 need_utf8(const char *pat, const char *patend)
 {
     bool first = TRUE;
+
+    PERL_ARGS_ASSERT_NEED_UTF8;
+
     while (pat < patend) {
 	if (pat[0] == '#') {
 	    pat++;
@@ -1135,6 +1153,8 @@ need_utf8(const char *pat, const char *patend)
 
 STATIC char
 first_symbol(const char *pat, const char *patend) {
+    PERL_ARGS_ASSERT_FIRST_SYMBOL;
+
     while (pat < patend) {
 	if (pat[0] != '#') return pat[0];
 	pat++;
@@ -1159,6 +1179,8 @@ Perl_unpackstring(pTHX_ const char *pat, const char *patend, const char *s, cons
 {
     tempsym_t sym;
 
+    PERL_ARGS_ASSERT_UNPACKSTRING;
+
     if (flags & FLAG_DO_UTF8) flags |= FLAG_WAS_UTF8;
     else if (need_utf8(pat, patend)) {
 	/* We probably should try to avoid this in case a scalar context call
@@ -1185,7 +1207,6 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c
     SV *sv;
     const I32 start_sp_offset = SP - PL_stack_base;
     howlen_t howlen;
-
     I32 checksum = 0;
     UV cuv = 0;
     NV cdouble = 0.0;
@@ -1194,6 +1215,9 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c
     bool explicit_length;
     const bool unpack_only_one = (symptr->flags & FLAG_UNPACK_ONLY_ONE) != 0;
     bool utf8 = (symptr->flags & FLAG_PARSE_UTF8) ? 1 : 0;
+
+    PERL_ARGS_ASSERT_UNPACK_REC;
+
     symptr->strbeg = s - strbeg;
 
     while (next_symbol(symptr)) {
@@ -1258,6 +1282,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c
 	    symptr->previous = &savsym;
             symptr->level++;
 	    PUTBACK;
+	    if (len && unpack_only_one) len = 1;
 	    while (len--) {
   	        symptr->patptr = savsym.grpbeg;
 		if (utf8) symptr->flags |=  FLAG_PARSE_UTF8;
@@ -2278,6 +2303,8 @@ S_is_an_int(pTHX_ const char *s, STRLEN l)
   bool skip = 1;
   bool ignore = 0;
 
+  PERL_ARGS_ASSERT_IS_AN_INT;
+
   while (*s) {
     switch (*s) {
     case ' ':
@@ -2326,6 +2353,8 @@ S_div128(pTHX_ SV *pnum, bool *done)
     char *t = s;
     int m = 0;
 
+    PERL_ARGS_ASSERT_DIV128;
+
     *done = 1;
     while (*t) {
 	const int i = m * 10 + (*t - '0');
@@ -2355,6 +2384,8 @@ Perl_packlist(pTHX_ SV *cat, const char *pat, const char *patend, register SV **
     dVAR;
     tempsym_t sym;
 
+    PERL_ARGS_ASSERT_PACKLIST;
+
     TEMPSYM_INIT(&sym, pat, patend, FLAG_PACK);
 
     /* We're going to do changes through SvPVX(cat). Make sure it's valid.
@@ -2439,6 +2470,9 @@ S_sv_exp_grow(pTHX_ SV *sv, STRLEN needed) {
     const STRLEN cur = SvCUR(sv);
     const STRLEN len = SvLEN(sv);
     STRLEN extend;
+
+    PERL_ARGS_ASSERT_SV_EXP_GROW;
+
     if (len - cur > needed) return SvPVX(sv);
     extend = needed > len ? needed : len;
     return SvGROW(sv, len+extend+1);
@@ -2455,6 +2489,8 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist )
     bool utf8 = (symptr->flags & FLAG_PARSE_UTF8) ? 1 : 0;
     bool warn_utf8 = ckWARN(WARN_UTF8);
 
+    PERL_ARGS_ASSERT_PACK_REC;
+
     if (symptr->level == 0 && found && symptr->code == 'U') {
 	marked_upgrade(aTHX_ cat, symptr);
 	symptr->flags |= FLAG_DO_UTF8;
@@ -3064,11 +3100,14 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist )
 		   any OS that needs it, or removed if and when VOS implements
 		   posix-976 (suggestion to support mapping to infinity).
 		   Paul.Green@stratus.com 02-04-02.  */
+{
+extern const float _float_constants[];
 		if (anv > FLT_MAX)
 		    afloat = _float_constants[0];   /* single prec. inf. */
 		else if (anv < -FLT_MAX)
 		    afloat = _float_constants[0];   /* single prec. inf. */
 		else afloat = (float) anv;
+}
 #else /* __VOS__ */
 # if defined(VMS) && !defined(__IEEE_FP)
 		/* IEEE fp overflow shenanigans are unavailable on VAX and optional
@@ -3100,11 +3139,14 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist )
 		   for any OS that needs it, or removed if and when VOS
 		   implements posix-976 (suggestion to support mapping to
 		   infinity).  Paul.Green@stratus.com 02-04-02.  */
+{
+extern const double _double_constants[];
 		if (anv > DBL_MAX)
 		    adouble = _double_constants[0];   /* double prec. inf. */
 		else if (anv < -DBL_MAX)
 		    adouble = _double_constants[0];   /* double prec. inf. */
 		else adouble = (double) anv;
+}
 #else /* __VOS__ */
 # if defined(VMS) && !defined(__IEEE_FP)
 		/* IEEE fp overflow shenanigans are unavailable on VAX and optional
@@ -3552,7 +3594,7 @@ PP(pp_pack)
     register const char *patend = pat + fromlen;
 
     MARK++;
-    sv_setpvn(cat, "", 0);
+    sv_setpvs(cat, "");
     SvUTF8_off(cat);
 
     packlist(cat, pat, patend, MARK, SP + 1);