(Version 2) Extending unpack to deal with counted strings

	Message-ID: <19990723233556.B2435@homer.diplex.co.uk>

p4raw-id: //depot/perl@3765

4 files changed, 95 insertions, 4 deletions

diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index b3265ffb74..e86bfbffbb 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -56,6 +56,31 @@ no useful value.  See L<perlmod>.
 (F) The '!' is allowed in pack() and unpack() only after certain types.
 See L<perlfunc/pack>.
 
+=item # cannot take a count
+
+(F) You had an unpack template indicating a counted-length string,
+but you have also specified an explicit size for the string.
+See L<perlfunc/pack>.
+
+=item # must be followed by a, A or Z
+
+(F) You had an unpack template indicating a counted-length string,
+which must be followed by one of the letters a, A or Z
+to indicate what sort of string is to be unpacked.
+See L<perlfunc/pack>.
+
+=item # must be followed by a*, A* or Z*
+
+(F) You had an pack template indicating a counted-length string,
+Currently the only things that can have their length counted are a*, A* or Z*.
+See L<perlfunc/pack>.
+
+=item # must follow a numeric type
+
+(F) You had an unpack template that contained a '#',
+but this did not follow some numeric unpack specification.
+See L<perlfunc/pack>.
+
 =item % may only be used in unpack
 
 (F) You can't pack a string by supplying a checksum, because the
diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod
index 3e791810db..efa7b58c12 100644
--- a/pod/perlfunc.pod
+++ b/pod/perlfunc.pod
@@ -2754,6 +2754,35 @@ C<"P"> is C<undef>.
 
 =item *
 
+The C<"#"> character allows packing and unpacking of strings where the
+packed structure contains a byte count followed by the string itself.
+You write I<length-item>C<#>I<string-item>.
+
+The I<length-item> can be any C<pack> template letter,
+and describes how the length value is packed.
+The ones likely to be of most use are integer-packing ones like
+C<"n"> (for Java strings), C<"w"> (for ASN.1 or SNMP)
+and C<"N"> (for Sun XDR).
+
+The I<string-item> must, at present, be C<"A*">, C<"a*"> or C<"Z*">.
+For C<unpack> the length of the string is obtained from the I<length-item>,
+but if you put in the '*' it will be ignored.
+
+    unpack 'C#a', "\04Gurusamy";        gives 'Guru'
+    unpack 'a3#A* A*', '007 Bond  J ';  gives (' Bond','J')
+    pack 'n#a* w#a*','hello,','world';  gives "\000\006hello,\005world"
+
+The I<length-item> is not returned explicitly from C<unpack>.
+
+Adding a count to the I<length-item> letter
+is unlikely to do anything useful,
+unless that letter is C<"A">, C<"a"> or C<"Z">.
+Packing with a I<length-item> of C<"a"> or C<"Z">
+may introduce C<"\000"> characters,
+which Perl does not regard as legal in numeric strings.
+
+=item *
+
 The integer types C<"s">, C<"S">, C<"l">, and C<"L"> may be
 immediately followed by a C<"!"> to signify native shorts or longs--as
 you can see from above for example a bare C<"l"> does mean exactly 32
diff --git a/pp.c b/pp.c
index c7fd585d54..69d3795ee4 100644
--- a/pp.c
+++ b/pp.c
@@ -900,7 +900,7 @@ PP(pp_postinc)
 PP(pp_postdec)
 {
     djSP; dTARGET;
-    if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
+    if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
 	Perl_croak(aTHX_ PL_no_modify);
     sv_setsv(TARG, TOPs);
     if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
@@ -3386,6 +3386,18 @@ PP(pp_unpack)
 		DIE(aTHX_ "x outside of string");
 	    s += len;
 	    break;
+	case '#':
+	    if (oldsp >= SP)
+		DIE(aTHX_ "# must follow a numeric type");
+	    if (*pat != 'a' && *pat != 'A' && *pat != 'Z')
+		DIE(aTHX_ "# must be followed by a, A or Z");
+	    datumtype = *pat++;
+	    if (*pat == '*')
+		pat++;		/* ignore '*' for compatibility with pack */
+	    if (isDIGIT(*pat))
+		DIE(aTHX_ "# cannot take a count" );
+	    len = POPi;
+	    /* drop through */
 	case 'A':
 	case 'Z':
 	case 'a':
@@ -4356,7 +4368,8 @@ PP(pp_pack)
     MARK++;
     sv_setpvn(cat, "", 0);
     while (pat < patend) {
-#define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
+	SV *lengthcode = Nullsv;
+#define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
 	datumtype = *pat++ & 0xFF;
 #ifdef PERL_NATINT_PACK
 	natint = 0;
@@ -4386,12 +4399,20 @@ PP(pp_pack)
 	}
 	else
 	    len = 1;
+	if (*pat == '#') {
+	    ++pat;
+	    if (*pat != 'a' && *pat != 'A' && *pat != 'Z' || pat[1] != '*')
+		DIE(aTHX_ "# must be followed by a*, A* or Z*");
+	    lengthcode = sv_2mortal(newSViv(sv_len(items > 0
+						   ? *MARK : &PL_sv_no)));
+	}
 	switch(datumtype) {
 	default:
 	    Perl_croak(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
 	case ',': /* grandfather in commas but with a warning */
 	    if (commas++ == 0 && ckWARN(WARN_UNSAFE))
-		Perl_warner(aTHX_ WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
+		Perl_warner(aTHX_ WARN_UNSAFE,
+			    "Invalid type in pack: '%c'", (int)datumtype);
 	    break;
 	case '%':
 	    DIE(aTHX_ "%% may only be used in unpack");
diff --git a/t/op/pack.t b/t/op/pack.t
index 5b727974a6..082b954756 100755
--- a/t/op/pack.t
+++ b/t/op/pack.t
@@ -6,7 +6,7 @@ BEGIN {
     require Config; import Config;
 }
 
-print "1..142\n";
+print "1..148\n";
 
 $format = "c2 x5 C C x s d i l a6";
 # Need the expression in here to force ary[5] to be numeric.  This avoids
@@ -353,3 +353,19 @@ print "ok ", $test++, "\n";
 
 print "not " unless pack("V", 0xdeadbeef) eq "\xef\xbe\xad\xde";
 print "ok ", $test++, "\n";
+
+# 143..148: # 
+
+my $z;
+eval { ($x) = unpack '#a*','hello' };
+print 'not ' unless $@; print "ok $test\n"; $test++;
+eval { ($z,$x,$y) = unpack 'a3#A C#a* C#Z', "003ok \003yes\004z\000abc" };
+print $@ eq '' && $z eq 'ok' ? "ok $test\n" : "not ok $test\n"; $test++;
+print $@ eq '' && $x eq 'yes' ? "ok $test\n" : "not ok $test\n"; $test++;
+print $@ eq '' && $y eq 'z' ? "ok $test\n" : "not ok $test\n"; $test++;
+
+eval { ($x) = pack '#a*','hello' };
+print 'not ' unless $@; print "ok $test\n"; $test++;
+$z = pack 'n#a* w#A*','string','etc';
+print 'not ' unless $z eq "\000\006string\003etc"; print "ok $test\n"; $test++;
+