integrate change #2846 from mainline

a modified version of suggested patch for pack template 'Z'; added docs
	Message-ID: <%lOHpzIuGV@snark.ptc.spbu.ru>
	Subject: lack of pack/unpack letter with useful symmetry for C null delimited strings

p4raw-link: @2846 on //depot/perl: 5a929a98cca1fca196d5fd6d9350568e529e8825

p4raw-id: //depot/maint-5.005/perl@3185
p4raw-integrated: from //depot/perl@3184 'merge in' t/op/pack.t
	(@3023..)

4 files changed, 121 insertions, 34 deletions

diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index 0ed844c920..a0af1e16dd 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -491,6 +491,11 @@ If C<$/> is a referenence to an integer, or a scalar that holds an integer,
 E<lt>E<gt> will read in records instead of lines. For more info, see
 L<perlvar/$/>.
 
+=head2 pack() format 'Z' supported
+
+The new format type 'Z' is useful for packing and unpacking null-terminated
+strings.  See L<perlfunc/"pack">.
+
 =head1 Significant bug fixes
 
 =head2 E<lt>HANDLEE<gt> on empty files
diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod
index 6ed1f5b433..f40e991dec 100644
--- a/pod/perlfunc.pod
+++ b/pod/perlfunc.pod
@@ -2590,6 +2590,8 @@ follows:
 
     a	A string with arbitrary binary data, will be null padded.
     A	An ascii string, will be space padded.
+    Z	A null terminated (asciz) string, will be null padded.
+
     b	A bit string (ascending bit order, like vec()).
     B	A bit string (descending bit order).
     h	A hex string (low nybble first).
@@ -2652,17 +2654,17 @@ The following rules apply:
 =item *
 
 Each letter may optionally be followed by a number giving a repeat
-count.  With all types except C<"a">, C<"A">, C<"b">, C<"B">, C<"h">,
+count.  With all types except C<"a">, C<"A">, C<"Z">, C<"b">, C<"B">, C<"h">,
 C<"H">, and C<"P"> the pack function will gobble up that many values from
 the LIST.  A C<*> for the repeat count means to use however many items are
 left.
 
 =item *
 
-The C<"a"> and C<"A"> types gobble just one value, but pack it as a
-string of length count, padding with nulls or spaces as necessary.
-When unpacking, C<"A"> strips trailing spaces and nulls, and C<"a">
-returns data verbatim.
+The C<"a">, C<"A">, and C<"Z"> types gobble just one value, but pack it as a
+string of length count, padding with nulls or spaces as necessary.  When
+unpacking, C<"A"> strips trailing spaces and nulls, C<"Z"> strips everything
+after the first null, and C<"a"> returns data verbatim.
 
 =item *
 
@@ -2767,6 +2769,13 @@ Examples:
     $foo = pack("i9pl", gmtime);
     # a real struct tm (on my system anyway)
 
+    $utmp_template = "Z8 Z8 Z16 L";
+    $utmp = pack($utmp_template, @utmp1);
+    # a struct utmp (BSDish)
+
+    @utmp2 = unpack($utmp_template, $utmp);
+    # "@utmp1" eq "@utmp2"
+
     sub bintodec {
 	unpack("N", pack("B32", substr("0" x 32 . shift, -32)));
     }
diff --git a/pp.c b/pp.c
index f083fabed5..1f628867b1 100644
--- a/pp.c
+++ b/pp.c
@@ -3013,7 +3013,7 @@ PP(pp_unpack)
     if (gimme != G_ARRAY) {		/* arrange to do first one only */
 	/*SUPPRESS 530*/
 	for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
-	if (strchr("aAbBhHP", *patend) || *pat == '%') {
+	if (strchr("aAZbBhHP", *patend) || *pat == '%') {
 	    patend++;
 	    while (isDIGIT(*patend) || *patend == '*')
 		patend++;
@@ -3071,6 +3071,7 @@ PP(pp_unpack)
 	    s += len;
 	    break;
 	case 'A':
+	case 'Z':
 	case 'a':
 	    if (len > strend - s)
 		len = strend - s;
@@ -3079,12 +3080,19 @@ PP(pp_unpack)
 	    sv = NEWSV(35, len);
 	    sv_setpvn(sv, s, len);
 	    s += len;
-	    if (datumtype == 'A') {
+	    if (datumtype == 'A' || datumtype == 'Z') {
 		aptr = s;	/* borrow register */
-		s = SvPVX(sv) + len - 1;
-		while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
-		    s--;
-		*++s = '\0';
+		if (datumtype == 'Z') {	/* 'Z' strips stuff after first null */
+		    s = SvPVX(sv);
+		    while (*s)
+			s++;
+		}
+		else {		/* 'A' strips both nulls and spaces */
+		    s = SvPVX(sv) + len - 1;
+		    while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
+			s--;
+		    *++s = '\0';
+		}
 		SvCUR_set(sv, s - SvPVX(sv));
 		s = aptr;	/* unborrow register */
 	    }
@@ -3910,6 +3918,7 @@ PP(pp_pack)
 	    sv_catpvn(cat, null10, len);
 	    break;
 	case 'A':
+	case 'Z':
 	case 'a':
 	    fromstr = NEXTFROM;
 	    aptr = SvPV(fromstr, fromlen);
diff --git a/t/op/pack.t b/t/op/pack.t
index cd4d69bf5c..902fc28af0 100755
--- a/t/op/pack.t
+++ b/t/op/pack.t
@@ -1,8 +1,12 @@
 #!./perl
 
-# $RCSfile: pack.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:11 $
+BEGIN {
+    chdir 't' if -d 't';
+    unshift @INC, '../lib' if -d '../lib';
+    require Config; import Config;
+}
 
-print "1..124\n";
+print "1..142\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
@@ -31,7 +35,7 @@ print +($x = unpack("%32B69", "\001\002\004\010\020\040\100\200\017")) == 9
 	? "ok 6\n" : "not ok 6 $x\n";
 
 my $sum = 129; # ASCII
-$sum = 103 if ($^O eq 'os390'); # An EBCDIC variant.
+$sum = 103 if ($Config{ebcdic} eq 'define');
 
 print +($x = unpack("%32B*", "Now is the time for all good blurfl")) == $sum
 	? "ok 7\n" : "not ok 7 $x\n";
@@ -142,7 +146,7 @@ print "ok ", $test++, "\n";
 print "not " unless length(pack("V", 0)) == 4;
 print "ok ", $test++, "\n";
 
-# 41..56: test unpack-pack lengths (no gargabe bytes at the end)
+# 41..56: test unpack-pack lengths
 
 my @templates = qw(c C i I s S l L n N v V f d);
 
@@ -160,7 +164,12 @@ foreach my $t (@templates) {
 
 # 57..60: uuencode/decode
 
-$in = join "", map { chr } 0..255;
+# Note that first uuencoding known 'text' data and then checking the
+# binary values of the uuencoded version would not be portable between
+# character sets.  Uuencoding is meant for encoding binary data, not
+# text data.
+ 
+$in = pack 'C*', 0 .. 255;
 
 # just to be anal, we do some random tr/`/ /
 $uu = <<'EOUU';
@@ -199,86 +208,141 @@ EOUU
 print "not " unless unpack('u', $uu) eq $in;
 print "ok ", $test++, "\n";
 
-# Note that first uuencoding known 'text' data and then checking the
-# binary values of the uuencoded version would not be portable between
-# character sets.  Uuencoding is meant for encoding binary data, not
-# text data.
+# 61..72: test the ascii template types (A, a, Z)
+
+print "not " unless pack('A*', "foo\0bar\0 ") eq "foo\0bar\0 ";
+print "ok ", $test++, "\n";
+
+print "not " unless pack('A11', "foo\0bar\0 ") eq "foo\0bar\0   ";
+print "ok ", $test++, "\n";
+
+print "not " unless unpack('A*', "foo\0bar \0") eq "foo\0bar";
+print "ok ", $test++, "\n";
+
+print "not " unless unpack('A8', "foo\0bar \0") eq "foo\0bar";
+print "ok ", $test++, "\n";
+
+print "not " unless pack('a*', "foo\0bar\0 ") eq "foo\0bar\0 ";
+print "ok ", $test++, "\n";
+
+print "not " unless pack('a11', "foo\0bar\0 ") eq "foo\0bar\0 \0\0";
+print "ok ", $test++, "\n";
+
+print "not " unless unpack('a*', "foo\0bar \0") eq "foo\0bar \0";
+print "ok ", $test++, "\n";
+
+print "not " unless unpack('a8', "foo\0bar \0") eq "foo\0bar ";
+print "ok ", $test++, "\n";
+
+print "not " unless pack('Z*', "foo\0bar\0 ") eq "foo\0bar\0 ";
+print "ok ", $test++, "\n";
+
+print "not " unless pack('Z11', "foo\0bar\0 ") eq "foo\0bar\0 \0\0";
+print "ok ", $test++, "\n";
+
+print "not " unless unpack('Z*', "foo\0bar \0") eq "foo";
+print "ok ", $test++, "\n";
+
+print "not " unless unpack('Z8', "foo\0bar \0") eq "foo";
+print "ok ", $test++, "\n";
+
+# 73..78: packing native shorts/ints/longs
+
+# integrated from mainline and don't want to change numbers all the way
+# down. native ints are not supported in _0x so comment out checks
+#print "not " unless length(pack("s!", 0)) == $Config{shortsize};
+print "ok ", $test++, "\n";
+
+#print "not " unless length(pack("i!", 0)) == $Config{intsize};
+print "ok ", $test++, "\n";
+
+#print "not " unless length(pack("l!", 0)) == $Config{longsize};
+print "ok ", $test++, "\n";
+
+#print "not " unless length(pack("s!", 0)) <= length(pack("i!", 0));
+print "ok ", $test++, "\n";
+
+#print "not " unless length(pack("i!", 0)) <= length(pack("l!", 0));
+print "ok ", $test++, "\n";
+
+#print "not " unless length(pack("i!", 0)) == length(pack("i", 0));
+print "ok ", $test++, "\n";
 
-#  61..120: pack <-> unpack bijectionism
+# 79..138: pack <-> unpack bijectionism
 
-#  61.. 65: c
+#  79.. 83 c
 foreach my $c (-128, -1, 0, 1, 127) {
     print "not " unless unpack("c", pack("c", $c)) == $c;
     print "ok ", $test++, "\n";
 }
 
-#  66.. 70: C
+#  84.. 88: C
 foreach my $C (0, 1, 127, 128, 255) {
     print "not " unless unpack("C", pack("C", $C)) == $C;
     print "ok ", $test++, "\n";
 }
 
-#  71.. 75: s
+#  89.. 93: s
 foreach my $s (-32768, -1, 0, 1, 32767) {
     print "not " unless unpack("s", pack("s", $s)) == $s;
     print "ok ", $test++, "\n";
 }
 
-#  76.. 80: S
+#  94.. 98: S
 foreach my $S (0, 1, 32767, 32768, 65535) {
     print "not " unless unpack("S", pack("S", $S)) == $S;
     print "ok ", $test++, "\n";
 }
 
-#  81.. 85: i
+#  99..103: i
 foreach my $i (-2147483648, -1, 0, 1, 2147483647) {
     print "not " unless unpack("i", pack("i", $i)) == $i;
     print "ok ", $test++, "\n";
 }
 
-#  86..90: I
+# 104..108: I
 foreach my $I (0, 1, 2147483647, 2147483648, 4294967295) {
     print "not " unless unpack("I", pack("I", $I)) == $I;
     print "ok ", $test++, "\n";
 }
 
-#  91.. 95: l
+# 109..113: l
 foreach my $l (-2147483648, -1, 0, 1, 2147483647) {
     print "not " unless unpack("l", pack("l", $l)) == $l;
     print "ok ", $test++, "\n";
 }
 
-#  96..100: L
+# 114..118: L
 foreach my $L (0, 1, 2147483647, 2147483648, 4294967295) {
     print "not " unless unpack("L", pack("L", $L)) == $L;
     print "ok ", $test++, "\n";
 }
 
-# 101..105: n
+# 119..123: n
 foreach my $n (0, 1, 32767, 32768, 65535) {
     print "not " unless unpack("n", pack("n", $n)) == $n;
     print "ok ", $test++, "\n";
 }
 
-# 106..110: v
+# 124..128: v
 foreach my $v (0, 1, 32767, 32768, 65535) {
     print "not " unless unpack("v", pack("v", $v)) == $v;
     print "ok ", $test++, "\n";
 }
 
-# 111..115: N
+# 129..133: N
 foreach my $N (0, 1, 2147483647, 2147483648, 4294967295) {
     print "not " unless unpack("N", pack("N", $N)) == $N;
     print "ok ", $test++, "\n";
 }
 
-# 116..120: V
+# 134..138: V
 foreach my $V (0, 1, 2147483647, 2147483648, 4294967295) {
     print "not " unless unpack("V", pack("V", $V)) == $V;
     print "ok ", $test++, "\n";
 }
 
-# 120..124: pack nvNV byteorders
+# 139..142: pack nvNV byteorders
 
 print "not " unless pack("n", 0xdead) eq "\xde\xad";
 print "ok ", $test++, "\n";