pack / for general types

Message-Id: <d1i7ed$62c$1@post.home.lunix>

Allow "len/format" to work for any format type, not just strings.

p4raw-id: //depot/perl@24052

diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 3687d41..0f71025 100644 (file)
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -2336,12 +2336,6 @@ See L<perlfunc/open> for details.
 (W syntax) Multidimensional arrays aren't written like C<$foo[1,2,3]>.
 They're written like C<$foo[1][2][3]>, as in C.
 
-=item '/' must be followed by 'a*', 'A*' or 'Z*'
-
-(F) You had a 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 in unpack
 
 (F) You had an unpack template that contained a '/', but this did not

diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod
index 559e94b..9785a25 100644 (file)
--- a/pod/perlfunc.pod
+++ b/pod/perlfunc.pod
@@ -3502,24 +3502,32 @@ so will result in a fatal error.
 
 =item *
 
-The C</> template 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 C</> template character allows packing and unpacking of a sequence of
+items where the packed structure contains a packed item count followed by 
+the packed items themselves.
+You write I<length-item>C</>I<sequence-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).
 
-For C<pack>, 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. For all other
-codes, C<unpack> applies the length value to the next item, which must not
-have a repeat count.
-
-    unpack 'W/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"
+For C<pack>, the I<sequence-item> may have a repeat count, in which case
+the minimum of that and the number of available items is used as argument
+for the I<length-item>. If it has no repeat count or uses a '*', the number
+of available items is used. For C<unpack> the repeat count is always obtained
+by decoding the packed item count, and the I<sequence-item> must not have a
+repeat count.
+
+If the I<sequence-item> refers to a string type (C<"A">, C<"a"> or C<"Z">),
+the I<length-item> is a string length, not a number of strings. If there is
+an explicit repeat count for pack, the packed string will be adjusted to that
+given length.
+
+    unpack 'W/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"
+    pack 'a/W2', ord('a') .. ord('z');  gives '2ab'
 
 The I<length-item> is not returned explicitly from C<unpack>.
 

diff --git a/pp_pack.c b/pp_pack.c
index e62f56d..1b56392 100644 (file)
--- a/pp_pack.c
+++ b/pp_pack.c
@@ -2471,13 +2471,26 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist )
         /* Look ahead for next symbol. Do we have code/code? */
         lookahead = *symptr;
         found = next_symbol(&lookahead);
-       if ( symptr->flags & FLAG_SLASH ) {
+       if (symptr->flags & FLAG_SLASH) {
+           IV count;
            if (!found) Perl_croak(aTHX_ "Code missing after '/' in pack");
-               if ( 0 == strchr( "aAZ", lookahead.code ) ||
-                     e_star != lookahead.howlen )
-                   Perl_croak(aTHX_ "'/' must be followed by 'a*', 'A*' or 'Z*' in pack");
-           lengthcode =
-               sv_2mortal(newSViv((items > 0 ? DO_UTF8(*beglist) ? sv_len_utf8(*beglist) : sv_len(*beglist) : 0) + (lookahead.code == 'Z' ? 1 : 0)));
+           if (strchr("aAZ", lookahead.code)) {
+               if (lookahead.howlen == e_number) count = lookahead.length;
+               else {
+                   if (items > 0)
+                       count = DO_UTF8(*beglist) ?
+                           sv_len_utf8(*beglist) : sv_len(*beglist);
+                   else count = 0;
+                   if (lookahead.code == 'Z') count++;
+               }
+           } else {
+               if (lookahead.howlen == e_number && lookahead.length < items)
+                   count = lookahead.length;
+               else count = items;
+           }
+           lookahead.howlen = e_number;
+           lookahead.length = count;
+           lengthcode = sv_2mortal(newSViv(count));
        }
 
        /* Code inside the switch must take care to properly update

diff --git a/t/op/pack.t b/t/op/pack.t
index 06c3a9a..3009510 100755 (executable)
--- 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 => 14606;
+plan tests => 14621;
 
 use strict;
 use warnings;
@@ -1782,3 +1782,28 @@ is(unpack('c'), 65, "one-arg unpack (change #18751)"); # defaulting to $_
     is(pack("U0A*", $high), "\xfeb");
     is(pack("U0Z*", $high), "\xfeb\x00");
 }
+{
+    # pack /
+    my @array = 1..14;
+    my @out = unpack("N/S", pack("N/S", @array) . "abcd");
+    is("@out", "@array", "pack N/S works");
+    @out = unpack("N/S*", pack("N/S*", @array) . "abcd");
+    is("@out", "@array", "pack N/S* works");
+    @out = unpack("N/S*", pack("N/S14", @array) . "abcd");
+    is("@out", "@array", "pack N/S14 works");
+    @out = unpack("N/S*", pack("N/S15", @array) . "abcd");
+    is("@out", "@array", "pack N/S15 works");
+    @out = unpack("N/S*", pack("N/S13", @array) . "abcd");
+    is("@out", "@array[0..12]", "pack N/S13 works");
+    @out = unpack("N/S*", pack("N/S0", @array) . "abcd");
+    is("@out", "", "pack N/S0 works");
+    is(pack("Z*/a0", "abc"), "0\0", "pack Z*/a0 makes a short string");
+    is(pack("Z*/Z0", "abc"), "0\0", "pack Z*/Z0 makes a short string");
+    is(pack("Z*/a3", "abc"), "3\0abc", "pack Z*/a3 makes a full string");
+    is(pack("Z*/Z3", "abc"), "3\0ab\0", "pack Z*/Z3 makes a short string");
+    is(pack("Z*/a5", "abc"), "5\0abc\0\0", "pack Z*/a5 makes a long string");
+    is(pack("Z*/Z5", "abc"), "5\0abc\0\0", "pack Z*/Z5 makes a long string");
+    is(pack("Z*/Z"), "1\0\0", "pack Z*/Z makes an extended string");
+    is(pack("Z*/Z", ""), "1\0\0", "pack Z*/Z makes an extended string");
+    is(pack("Z*/a", ""), "0\0", "pack Z*/a makes an extended string");
+}