integrate change #2846 from mainline
authorValeriy E. Ushakov <uwe@ptc.spbu.ru>
Mon, 16 Jun 1997 03:00:31 +0000 (07:00 +0400)
committerGraham Barr <gbarr@pobox.com>
Sun, 28 Mar 1999 06:37:41 +0000 (06:37 +0000)
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..)

pod/perldelta.pod
pod/perlfunc.pod
pp.c
t/op/pack.t

index 0ed844c..a0af1e1 100644 (file)
@@ -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
index 6ed1f5b..f40e991 100644 (file)
@@ -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 f083fab..1f62886 100644 (file)
--- 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);
index cd4d69b..902fc28 100755 (executable)
@@ -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";