allow any unpack specifier to take a count via '/'

(from Ilya Zakharevich)

p4raw-id: //depot/perl@4352

diff --git a/pp.c b/pp.c
index 7168be0..8f4a156 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -3264,6 +3264,7 @@ PP(pp_unpack)
     register U32 culong;
     NV cdouble;
     int commas = 0;
+    int star;
 #ifdef PERL_NATINT_PACK
     int natint;                /* native integer */
     int unatint;       /* unsigned native integer */
@@ -3305,11 +3306,13 @@ PP(pp_unpack)
            else
                DIE(aTHX_ "'!' allowed only after types %s", natstr);
        }
+       star = 0;
        if (pat >= patend)
            len = 1;
        else if (*pat == '*') {
            len = strend - strbeg;      /* long enough */
            pat++;
+           star = 1;
        }
        else if (isDIGIT(*pat)) {
            len = *pat++ - '0';
@@ -3321,6 +3324,7 @@ PP(pp_unpack)
        }
        else
            len = (datumtype != '@');
+      redo_switch:
        switch(datumtype) {
        default:
            DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
@@ -3356,15 +3360,14 @@ PP(pp_unpack)
        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 */
+           star = 0;
+           goto redo_switch;
        case 'A':
        case 'Z':
        case 'a':
@@ -3395,7 +3398,7 @@ PP(pp_unpack)
            break;
        case 'B':
        case 'b':
-           if (pat[-1] == '*' || len > (strend - s) * 8)
+           if (star || len > (strend - s) * 8)
                len = (strend - s) * 8;
            if (checksum) {
                if (!PL_bitcount) {
@@ -3463,7 +3466,7 @@ PP(pp_unpack)
            break;
        case 'H':
        case 'h':
-           if (pat[-1] == '*' || len > (strend - s) * 2)
+           if (star || len > (strend - s) * 2)
                len = (strend - s) * 2;
            sv = NEWSV(35, len + 1);
            SvCUR_set(sv, len);

diff --git a/t/op/pack.t b/t/op/pack.t
index 9b96289..11ada39 100755 (executable)
--- a/t/op/pack.t
+++ b/t/op/pack.t
@@ -6,7 +6,7 @@ BEGIN {
     require Config; import Config;
 }
 
-print "1..153\n";
+print "1..156\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
@@ -357,7 +357,7 @@ print "ok ", $test++, "\n";
 print "not " unless pack("V", 0xdeadbeef) eq "\xef\xbe\xad\xde";
 print "ok ", $test++, "\n";
 
-# 144..149: /
+# 144..152: /
 
 my $z;
 eval { ($x) = unpack '/a*','hello' };
@@ -372,7 +372,19 @@ 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++;
 
-# 150..153: / with #
+eval { ($x) = unpack 'a/a*/a*', '212ab345678901234567' };
+print $@ eq '' && $x eq 'ab3456789012' ? "ok $test\n" : "#$x,$@\nnot ok $test\n";
+$test++;
+
+eval { ($x) = unpack 'a/a*/a*', '3012ab345678901234567' };
+print $@ eq '' && $x eq 'ab3456789012' ? "ok $test\n" : "not ok $test\n";
+$test++;
+
+eval { ($x) = unpack 'a/a*/b*', '212ab' };
+print $@ eq '' && $x eq '100001100100' ? "ok $test\n" : "#$x,$@\nnot ok $test\n";
+$test++;
+
+# 153..156: / with #
 
 eval { ($z,$x,$y) = unpack <<EOU, "003ok \003yes\004z\000abc" };
  a3/A                  # Count in ASCII