From: Nicholas Clark Date: Fri, 12 Apr 2002 21:59:06 +0000 (+0100) Subject: Re: OK, what did I break in unpack? X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c8f824eb951d8adfb39678d45af41501189b9734;p=p5sagit%2Fp5-mst-13.2.git 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 --- 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 --- 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]}); + } + } +}