From: Tony Cook <tony@develop-help.com>
Date: Fri, 23 Apr 2010 09:28:35 +0000 (+1000)
Subject: RT#73814 - unpack() didn't handle scalar context correctly for %32H and %32u
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=858fe5e170d95536de0f761c14ed083ad288eae8;p=p5sagit%2Fp5-mst-13.2.git

RT#73814 - unpack() didn't handle scalar context correctly for %32H and %32u

split() would crash because the third item on the stack wasn't the
regular expression it expected.  unpack("%2H", ...) would return both
the unpacked result and the checksum on the stack, similarly for
unpack("%2u", ...).
---

diff --git a/pp_pack.c b/pp_pack.c
index 0670548..0ae8afd 100644
--- a/pp_pack.c
+++ b/pp_pack.c
@@ -1562,9 +1562,11 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c
 	    /* Preliminary length estimate, acceptable for utf8 too */
 	    if (howlen == e_star || len > (strend - s) * 2)
 		len = (strend - s) * 2;
-	    sv = sv_2mortal(newSV(len ? len : 1));
-	    SvPOK_on(sv);
-	    str = SvPVX(sv);
+	    if (!checksum) {
+		sv = sv_2mortal(newSV(len ? len : 1));
+		SvPOK_on(sv);
+		str = SvPVX(sv);
+	    }
 	    if (datumtype == 'h') {
 		U8 bits = 0;
 		I32 ai32 = len;
@@ -1574,7 +1576,8 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c
 			if (s >= strend) break;
 			bits = uni_to_byte(aTHX_ &s, strend, datumtype);
 		    } else bits = * (U8 *) s++;
-		    *str++ = PL_hexdigit[bits & 15];
+		    if (!checksum)
+			*str++ = PL_hexdigit[bits & 15];
 		}
 	    } else {
 		U8 bits = 0;
@@ -1585,12 +1588,15 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c
 			if (s >= strend) break;
 			bits = uni_to_byte(aTHX_ &s, strend, datumtype);
 		    } else bits = *(U8 *) s++;
-		    *str++ = PL_hexdigit[(bits >> 4) & 15];
+		    if (!checksum)
+			*str++ = PL_hexdigit[(bits >> 4) & 15];
 		}
 	    }
-	    *str = '\0';
-	    SvCUR_set(sv, str - SvPVX_const(sv));
-	    XPUSHs(sv);
+	    if (!checksum) {
+		*str = '\0';
+		SvCUR_set(sv, str - SvPVX_const(sv));
+		XPUSHs(sv);
+	    }
 	    break;
 	}
 	case 'C':
@@ -2123,7 +2129,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c
 	    break;
 #endif
 	case 'u':
-	    {
+	    if (!checksum) {
                 const STRLEN l = (STRLEN) (strend - s) * 3 / 4;
 		sv = sv_2mortal(newSV(l));
 		if (l) SvPOK_on(sv);
@@ -2141,7 +2147,8 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c
 			hunk[0] = (char)((a << 2) | (b >> 4));
 			hunk[1] = (char)((b << 4) | (c >> 2));
 			hunk[2] = (char)((c << 6) | d);
-			sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
+			if (!checksum)
+			    sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
 			len -= 3;
 		    }
 		    if (s < strend) {
@@ -2182,7 +2189,8 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c
 			hunk[0] = (char)((a << 2) | (b >> 4));
 			hunk[1] = (char)((b << 4) | (c >> 2));
 			hunk[2] = (char)((c << 6) | d);
-			sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
+			if (!checksum)
+			    sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
 			len -= 3;
 		    }
 		    if (*s == '\n')
@@ -2192,7 +2200,8 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c
 			    s += 2;
 		}
 	    }
-	    XPUSHs(sv);
+	    if (!checksum)
+		XPUSHs(sv);
 	    break;
 	}
 
diff --git a/t/op/pack.t b/t/op/pack.t
index 4b5f9a5..5775caf 100644
--- a/t/op/pack.t
+++ b/t/op/pack.t
@@ -12,7 +12,7 @@ my $no_endianness = $] > 5.009 ? '' :
 my $no_signedness = $] > 5.009 ? '' :
   "Signed/unsigned pack modifiers not available on this perl";
 
-plan tests => 14697;
+plan tests => 14699;
 
 use strict;
 use warnings qw(FATAL all);
@@ -1985,3 +1985,11 @@ is(unpack('c'), 65, "one-arg unpack (change #18751)"); # defaulting to $_
     my ($v) = split //, unpack ('(B)*', 'ab');
     is($v, 0); # Doesn't SEGV :-)
 }
+{
+    #73814
+    my $x = runperl( prog => 'print split( /,/, unpack(q(%2H*), q(hello world))), qq(\n)' );
+    is($x, "0\n", "split /a/, unpack('%2H*'...) didn't crash");
+
+    my $y = runperl( prog => 'print split( /,/, unpack(q(%32u*), q(#,3,Q)), qq(\n)), qq(\n)' );
+    is($y, "0\n", "split /a/, unpack('%32u*'...) didn't crash");
+}