Re: scalar context unpack bugs

Message-ID: <20010922230755.O4971@plum.flirble.org>

p4raw-id: //depot/perl@12144

diff --git a/pp_pack.c b/pp_pack.c
index 1075143..ff2f8e0 100644 (file)
--- a/pp_pack.c
+++ b/pp_pack.c
@@ -170,33 +170,6 @@ PP(pp_unpack)
 #endif
     bool do_utf8 = DO_UTF8(right);
 
-    if (gimme != G_ARRAY) {            /* arrange to do first one only */
-       /*SUPPRESS 530*/
-        /* Skipping spaces will be useful later on.  */
-        while (isSPACE(*pat))
-            pat++;
-        /* Give up on optimisation of only doing first if the pattern
-           is getting too complex to parse.  */
-        if (*pat != '#') {
-            /* This pre-parser will let through certain invalid patterns
-               such as rows of !s, but the nothing that would cause multiple
-               conversions to be attempted.  */
-            char *here = pat;
-            bool seen_percent = FALSE;
-            if (*here == '%')
-                seen_percent = TRUE;
-            while (!isALPHA(*here) || *here == 'x')
-                here++;
-            if (strchr("aAZbBhHP", *here) || seen_percent) {
-                here++;
-                while (isDIGIT(*here) || *here == '*' || *here == '!')
-                    here++;
-            }
-            else
-                here++;
-            patend = here;
-        }
-    }
     while (pat < patend) {
       reparse:
        datumtype = *pat++ & 0xFF;
@@ -1161,6 +1134,14 @@ PP(pp_unpack)
            XPUSHs(sv_2mortal(sv));
            checksum = 0;
        }
+        if (gimme != G_ARRAY &&
+            SP - PL_stack_base == start_sp_offset + 1) {
+          /* do first one only unless in list context
+             / is implmented by unpacking the count, then poping it from the
+             stack, so must check that we're not in the middle of a /  */
+          if ((pat >= patend) || *pat != '/')
+            RETURN;
+        }
     }
     if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
        PUSHs(&PL_sv_undef);

diff --git a/t/op/pack.t b/t/op/pack.t
index cb1270a..02b3806 100755 (executable)
--- a/t/op/pack.t
+++ b/t/op/pack.t
@@ -1,6 +1,6 @@
 #!./perl -Tw
 
-print "1..581\n";
+print "1..610\n";
 
 BEGIN {
     chdir 't' if -d 't';
@@ -18,10 +18,28 @@ my $test = 1;
 
 sub encode {
   my @result = @_;
-  s/([[:cntrl:]\177 ])/sprintf "\\%03o", ord $1/ge foreach @result;
+  foreach (@result) {
+    s/([[:cntrl:]\177 ])/sprintf "\\%03o", ord $1/ge if defined;
+  }
   @result;
 }
 
+sub encode_list {
+  my @result = @_;
+  foreach (@result) {
+    if (defined) {
+      s/([[:cntrl:]\177])/sprintf "\\%03o", ord $1/ge;
+      $_ = qq("$_");
+    } else {
+      $_ = 'undef';
+    }
+  }
+  if (@result == 1) {
+    return @result;
+  }
+  return '(' . join (', ', @result) . ')';
+}
+
 sub ok {
   my ($pass, $wrong, $err) = @_;
   if ($pass) {
@@ -45,6 +63,24 @@ sub ok {
   return;
 }
 
+sub list_eq ($$) {
+  my ($l, $r) = @_;
+  return unless @$l == @$r;
+  for my $i (0..$#$l) {
+    if (defined $l->[$i]) {
+      return unless defined ($r->[$i]) && $l->[$i] eq $r->[$i];
+    } else {
+      return if defined $r->[$i]
+    }
+  }
+  return 1;
+}
+
+##############################################################################
+#
+# Here starteth the tests
+#
+
 {
 my $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
@@ -404,8 +440,9 @@ numbers ('N', 0, 1, 2147483647, 2147483648, 4294967295);
 numbers ('V', 0, 1, 2147483647, 2147483648, 4294967295);
 # All these should have exact binary representations:
 numbers ('f', -1, 0, 0.5, 42, 2**34);
-# These don't, but 'd' is NV.
-numbers ('d', -1, 0, 1, 1-exp(-1), -exp(1));
+numbers ('d', -(2**34), -1, 0, 1, 2**34);
+## These don't, but 'd' is NV.  XXX wrong, it's double
+#numbers ('d', -1, 0, 1, 1-exp(-1), -exp(1));
 
 numbers_with_total ('q', -1,
                     -9223372036854775808, -1, 0, 1,9223372036854775807);
@@ -444,6 +481,17 @@ ok (pack("V", 0xdeadbeef) eq "\xef\xbe\xad\xde");
     printf "# got '%s'\n", encode $z;
   }
 
+  $expect = 'hello world';
+  eval { ($x) = unpack ("w/a", chr (11) . "hello world!")};
+  ok ($x eq $expect);
+  ok ($@ eq '', undef, $@);
+  # Doing this in scalar context used to fail.
+  eval { $x = unpack ("w/a", chr (11) . "hello world!")};
+  unless (ok ($x eq $expect, undef, $@)) {
+    printf "# expected '$expect' got '%s'\n", encode $x;
+  }
+  ok ($@ eq '', undef, $@);
+
   foreach (
 ['a/a*/a*', '212ab345678901234567','ab3456789012'],
 ['a/a*/a*', '3012ab345678901234567', 'ab3456789012'],
@@ -451,10 +499,13 @@ ok (pack("V", 0xdeadbeef) eq "\xef\xbe\xad\xde");
 ) {
     my ($pat, $in, $expect) = @$_;
     eval { ($x) = unpack $pat, $in };
-    unless (ok ($x eq $expect)) {
-      $x = encode $x;
-      print "# pack ('$pat', '$in') gave '$x', expected '$expect'\n";
-    }
+    ok ($@ eq '' && $x eq $expect, undef, $@)
+      or printf "# list unpack ('$pat', '$in') gave %s, expected '$expect'\n",
+      encode_list ($x);
+    eval { $x = unpack $pat, $in };
+    ok ($@ eq '' && $x eq $expect, undef, $@)
+      or printf "# scalar unpack ('$pat', '$in') gave %s, expected '$expect'\n",
+      encode_list ($x);
   }
 
 # / with #
@@ -551,3 +602,47 @@ EOPOEMSNIPPET
     ok (unpack ("%33n$len", $pat) == 65535 * $len);
   }
 }
+
+
+# pack x X @
+foreach (
+['x', "N", "\0"],
+['x4', "N", "\0"x4],
+['xX', "N", ""],
+['xXa*', "Nick", "Nick"],
+['a5Xa5', "cameL", "llama", "camellama"],
+['@4', 'N', "\0"x4],
+['a*@8a*', 'Camel', 'Dromedary', "Camel\0\0\0Dromedary"],
+['a*@4a', 'Perl rules', '!', 'Perl!'],
+) {
+  my ($template, @in) = @$_;
+  my $out = pop @in;
+  my $got = eval {pack $template, @in};
+  ok ($@ eq '' and $out eq $got, '', $@)
+    or printf "# pack ('$template', %s) gave %s expected %s\n",
+    encode_list (@in), encode_list ($got), encode_list ($out);
+}
+
+# unpack x X @
+foreach (
+['x', "N"],
+['xX', "N"],
+['xXa*', "Nick", "Nick"],
+['a5Xa5', "camellama", "camel", "llama"],
+['@3', "ice"],
+['@2a2', "water", "te"],
+['a*@1a3', "steam", "steam", "tea"],
+) {
+  my ($template, $in, @out) = @$_;
+  my @got = eval {unpack $template, $in};
+  ok (($@ eq '' and list_eq (\@got, \@out)), undef, $@)
+    or printf "# list unpack ('$template', \"%s\") gave %s expected %s\n",
+    encode ($in), encode_list (@got), encode_list (@out);
+
+  my $got = eval {unpack $template, $in};
+  ok (($@ eq '' and @out ? $got eq $out[0] # 1 or more items; should get first
+       : !defined $got) # 0 items; should get undef
+      , "", $@)
+    or printf "# scalar unpack ('$template', \"%s\") gave %s expected %s\n",
+    encode ($in), encode_list ($got), encode_list ($out[0]);
+}