Re: OK, what did I break in unpack?

Message-ID: <20020412205906.GD353@Bagpuss.unfortu.net>

p4raw-id: //depot/perl@15883

diff --git a/pp_pack.c b/pp_pack.c
index 8439151..63e9d4b 100644 (file)
--- a/pp_pack.c
+++ b/pp_pack.c
@@ -720,6 +720,8 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
            else {
+                if (len && (flags & UNPACK_ONLY_ONE))
+                    len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
                while (len-- > 0) {
@@ -748,6 +750,8 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
            else {
+                if (len && (flags & UNPACK_ONLY_ONE))
+                    len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
                while (len-- > 0) {
@@ -780,6 +784,8 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
            else {
+                if (len && (flags & UNPACK_ONLY_ONE))
+                    len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
                while (len-- > 0 && s < strend) {
@@ -833,6 +839,8 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
            else {
+                if (len && (flags & UNPACK_ONLY_ONE))
+                    len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
 #if SHORTSIZE != SIZE16
@@ -909,6 +917,8 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
            else {
+                if (len && (flags & UNPACK_ONLY_ONE))
+                    len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
 #if SHORTSIZE != SIZE16
@@ -958,6 +968,8 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
            else {
+                if (len && (flags & UNPACK_ONLY_ONE))
+                    len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
                while (len-- > 0) {
@@ -1009,6 +1021,8 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
            else {
+                if (len && (flags & UNPACK_ONLY_ONE))
+                    len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
                while (len-- > 0) {
@@ -1042,6 +1056,8 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
            else {
+                if (len && (flags & UNPACK_ONLY_ONE))
+                    len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
                while (len-- > 0) {
@@ -1068,6 +1084,8 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
            else {
+                if (len && (flags & UNPACK_ONLY_ONE))
+                    len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
                while (len-- > 0) {
@@ -1120,6 +1138,8 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
            else {
+                if (len && (flags & UNPACK_ONLY_ONE))
+                    len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
 #if LONGSIZE != SIZE32
@@ -1198,6 +1218,8 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
            else {
+                if (len && (flags & UNPACK_ONLY_ONE))
+                    len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
 #if LONGSIZE != SIZE32
@@ -1252,6 +1274,8 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
            }
            break;
        case 'w':
+            if (len && (flags & UNPACK_ONLY_ONE))
+                len = 1;
            EXTEND(SP, len);
            EXTEND_MORTAL(len);
            {
@@ -1325,6 +1349,8 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
             else {
+                if (len && (flags & UNPACK_ONLY_ONE))
+                    len = 1;
                 EXTEND(SP, len);
                 EXTEND_MORTAL(len);
                 while (len-- > 0) {
@@ -1358,6 +1384,8 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
             else {
+                if (len && (flags & UNPACK_ONLY_ONE))
+                    len = 1;
                 EXTEND(SP, len);
                 EXTEND_MORTAL(len);
                 while (len-- > 0) {
@@ -1390,6 +1418,8 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
            else {
+                if (len && (flags & UNPACK_ONLY_ONE))
+                    len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
                while (len-- > 0) {
@@ -1413,6 +1443,8 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
            else {
+                if (len && (flags & UNPACK_ONLY_ONE))
+                    len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
                while (len-- > 0) {
@@ -1436,6 +1468,8 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
            else {
+                if (len && (flags & UNPACK_ONLY_ONE))
+                    len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
                while (len-- > 0) {
@@ -1460,6 +1494,8 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
            else {
+                if (len && (flags & UNPACK_ONLY_ONE))
+                    len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
                while (len-- > 0) {

diff --git a/t/op/pack.t b/t/op/pack.t
index 42be19e..ca5ab4a 100755 (executable)
--- a/t/op/pack.t
+++ b/t/op/pack.t
@@ -6,7 +6,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan tests => 5625;
+plan tests => 5816;
 
 use strict;
 use warnings;
@@ -26,12 +26,12 @@ sub encode_list {
 
 sub list_eq ($$) {
   my ($l, $r) = @_;
-  return unless @$l == @$r;
+  return 0 unless @$l == @$r;
   for my $i (0..$#$l) {
     if (defined $l->[$i]) {
-      return unless defined ($r->[$i]) && $l->[$i] eq $r->[$i];
+      return 0 unless defined ($r->[$i]) && $l->[$i] eq $r->[$i];
     } else {
-      return if defined $r->[$i]
+      return 0 if defined $r->[$i]
     }
   }
   return 1;
@@ -674,7 +674,7 @@ foreach (
   my ($template, $in, @out) = @$_;
   my @got = eval {unpack $template, $in};
   is($@, '');
-  list_eq (\@got, \@out) ||
+  ok (list_eq (\@got, \@out)) ||
     printf "# list unpack ('$template', %s) gave %s expected %s\n",
            _qq($in), encode_list (@got), encode_list (@out);
 
@@ -890,3 +890,50 @@ SKIP: {
     numbers ('D', -(2**34), -1, 0, 1, 2**34);
 }
 
+# Maybe this knowledge needs to be "global" for all of pack.t
+# Or a "can checksum" which would effectively be all the number types"
+my %cant_checksum = map {$_=> 1} qw(A Z u w);
+# not a b B h H
+foreach my $template (qw(A Z c C s S i I l L n N v V q Q j J f d F D u U w)) {
+  SKIP: {
+    my $packed = eval {pack "${template}4", 1, 4, 9, 16};
+    if ($@) {
+      die unless $@ =~ /Invalid type in pack: '$template'/;
+      skip ("$template not supported on this perl",
+            $cant_checksum{$template} ? 4 : 8);
+    }
+    my @unpack4 = unpack "${template}4", $packed;
+    my @unpack = unpack "${template}*", $packed;
+    my @unpack1 = unpack "${template}", $packed;
+    my @unpack1s = scalar unpack "${template}", $packed;
+    my @unpack4s = scalar unpack "${template}4", $packed;
+    my @unpacks = scalar unpack "${template}*", $packed;
+
+    my @tests = ( ["${template}4 vs ${template}*", \@unpack4, \@unpack],
+                  ["scalar ${template} ${template}", \@unpack1s, \@unpack1],
+                  ["scalar ${template}4 vs ${template}", \@unpack4s, \@unpack1],
+                  ["scalar ${template}* vs ${template}", \@unpacks, \@unpack1],
+                );
+
+    unless ($cant_checksum{$template}) {
+      my @unpack4_c = unpack "\%${template}4", $packed;
+      my @unpack_c = unpack "\%${template}*", $packed;
+      my @unpack1_c = unpack "\%${template}", $packed;
+      my @unpack1s_c = scalar unpack "\%${template}", $packed;
+      my @unpack4s_c = scalar unpack "\%${template}4", $packed;
+      my @unpacks_c = scalar unpack "\%${template}*", $packed;
+
+      push @tests,
+        ( ["% ${template}4 vs ${template}*", \@unpack4_c, \@unpack_c],
+          ["% scalar ${template} ${template}", \@unpack1s_c, \@unpack1_c],
+          ["% scalar ${template}4 vs ${template}*", \@unpack4s_c, \@unpack_c],
+          ["% scalar ${template}* vs ${template}*", \@unpacks_c, \@unpack_c],
+        );
+    }
+    foreach my $test (@tests) {
+      ok (list_eq ($test->[1], $test->[2]), $test->[0]) ||
+        printf "# unpack gave %s expected %s\n",
+          encode_list (@{$test->[1]}), encode_list (@{$test->[2]});
+    }
+  }
+}