Add a new warning about redundant printf arguments

Implement RT #121025 and add a "redundant" warning category that
currently only warns about redundant arguments to printf. Now similarly
to how we already warned about missing printf arguments:

    $ ./miniperl -Ilib -we 'printf "%s\n", qw()'
    Missing argument in printf at -e line 1.

We'll now warn about redundant printf arguments:

    $ ./miniperl -Ilib -we 'printf "%s\n", qw(x y)'
    Redundant argument in printf at -e line 1.
    x

The motivation for this is that I recently fixed an insidious
long-standing 6 year old bug in a codebase I maintain that came down to
an issue that would have been detected by this warning.

Things to note about this patch:

 * It found a some long-standing redundant printf arguments in our own
   ExtUtils::MakeMaker code which I submitted fixes to in
   https://github.com/Perl-Toolchain-Gang/ExtUtils-MakeMaker/pull/84 and
   https://github.com/Perl-Toolchain-Gang/ExtUtils-MakeMaker/pull/86,
   those fixes were merged into blead in v5.19.8-265-gb33b7ab

 * This warning correctly handles format parameter indexes (e.g. "%1$s")
   for some value of correctly. See the comment in t/op/sprintf2.t for
   an extensive discussion of how I've handled that.

 * We do the correct thing in my opinion when a pattern has redundant
   arguments *and* an invalid printf format. E.g. for the pattern "%A%s"
   with one argument we'll just warn about an invalid format as before,
   but with two arguments we'll warn about the invalid format *and* the
   redundant argument.

   This helps to disambiguate cases where the user just meant to write a
   literal "%SOMETHING" v.s. cases where he though "%S" might be a valid
   printf format.

 * I originally wrote this while the 5.19 series was under way, but Dave
   Mitchell has noted that a warning like this should go into blead
   after 5.20 is released:

       "[...] I think it should go into blead just after 5.20 is
       released, rather than now; I think it'd going to kick up a lot of
       dust and we'll want to give CPAN module owners maximum lead time
       to fix up their code. For example, if its generating warnings in
       cpan/ code in blead, then we need those module authors to fix
       their code, produce stable new releases, pull them back into
       blead, and let them bed in before we start pushing out 5.20 RC
       candidates"

   I agree, but we could have our cake and eat it too if "use warnings"
   didn't turn this on but an explicit "use warnings qw(redundant)" did.
   Then in 5.22 we could make "use warnings" also import the "redundant"
   category, and in the meantime you could turn this on
   explicitly.

   There isn't an existing feature for adding that kind of warning in
   the core. And my attempts at doing so failed, see commentary in RT
   #121025.

The warning needed to be added to a few places in sv.c because the "",
"%s" and "%-p" patterns all bypass the normal printf handling for
optimization purposes. The new warning works correctly on all of
them. See the tests in t/op/sprintf2.t.

It's worth mentioning that both Debian Clang 3.3-16 and GCC 4.8.2-12
warn about this in C code under -Wall:

    $ cat redundant.c
    #include <stdio.h>

    int main(void) {
        printf("%d\n", 123, 345);
        return 0;
    }
    $ clang -Wall -o redundant redundant.c
    redundant.c:4:25: warning: data argument not used by format string [-Wformat-extra-args]
        printf("%d\n", 123, 345);
               ~~~~~~       ^
    1 warning generated.
    $ gcc -Wall -o redundant redundant.c
    redundant.c: In function ‘main’:
    redundant.c:4:5: warning: too many arguments for format [-Wformat-extra-args]
         printf("%d\n", 123, 345);
         ^

So I'm not the first person to think that this might be generally
useful.

There are also other internal functions that could benefit from
missing/redundant warnings, e.g. pack. Neither of these things currently
warn, but should:

    $ perl -wE 'say pack "AA", qw(x y z)'
    xy
    $ perl -wE 'say pack "AAAA", qw(x y z)'
    xyz

I'll file a bug for that, and might take a stab at implementing it.

diff --git a/lib/warnings.pm b/lib/warnings.pm
index f650ef0..a08be18 100644 (file)
--- a/lib/warnings.pm
+++ b/lib/warnings.pm
@@ -5,7 +5,7 @@
 
 package warnings;
 
-our $VERSION = '1.25';
+our $VERSION = '1.26';
 
 # Verify that we're called correctly so that warnings will work.
 # see also strict.pm.
@@ -317,6 +317,8 @@ The current hierarchy is:
          |
          +- redefine
          |
+         +- redundant
+         |
          +- regexp
          |
          +- severe --------+
@@ -825,10 +827,11 @@ our %Offsets = (
 
     'experimental::win32_perlio'=> 120,
     'missing'          => 122,
+    'redundant'                => 124,
   );
 
 our %Bits = (
-    'all'              => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x05", # [0..61]
+    'all'              => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x15", # [0..62]
     'ambiguous'                => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [29]
     'bareword'         => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [30]
     'closed'           => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
@@ -873,6 +876,7 @@ our %Bits = (
     'qw'               => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [36]
     'recursion'                => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [18]
     'redefine'         => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [19]
+    'redundant'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [62]
     'regexp'           => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [20]
     'reserved'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [37]
     'semicolon'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [38]
@@ -893,7 +897,7 @@ our %Bits = (
   );
 
 our %DeadBits = (
-    'all'              => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x0a", # [0..61]
+    'all'              => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x2a", # [0..62]
     'ambiguous'                => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [29]
     'bareword'         => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [30]
     'closed'           => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
@@ -938,6 +942,7 @@ our %DeadBits = (
     'qw'               => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [36]
     'recursion'                => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [18]
     'redefine'         => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [19]
+    'redundant'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [62]
     'regexp'           => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [20]
     'reserved'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [37]
     'semicolon'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [38]
@@ -959,7 +964,7 @@ our %DeadBits = (
 
 $NONE     = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
 $DEFAULT  = "\x10\x01\x00\x00\x00\x50\x04\x00\x00\x00\x00\x00\x00\x55\x15\x01", # [2,56,52,53,57,54,58,55,60,4,22,23,25]
-$LAST_BIT = 124 ;
+$LAST_BIT = 126 ;
 $BYTES    = 16 ;
 
 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;

diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 86ba73b..9365c42 100644 (file)
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -2995,6 +2995,13 @@ arguments than were supplied, but might be used in the future for
 other cases where we can statically determine that arguments to
 functions are missing, e.g. for the L<perlfunc/pack> function.
 
+=item Redundant argument in %s
+
+(W redundant) You called a function with more arguments than other
+arguments you supplied indicated would be needed. Currently only
+emitted when a printf-type format required fewer arguments than were
+supplied, but might be used in the future for e.g. L<perlfunc/pack>.
+
 =item Missing argument to -%c
 
 (F) The argument to the indicated command line switch must follow

diff --git a/regen/warnings.pl b/regen/warnings.pl
index b910657..a9b3649 100644 (file)
--- a/regen/warnings.pl
+++ b/regen/warnings.pl
@@ -105,6 +105,7 @@ my $tree = {
                         }],
 
                'missing'       => [ 5.021, DEFAULT_OFF],
+               'redundant'     => [ 5.021, DEFAULT_OFF],
 
                 #'default'     => [ 5.008, DEFAULT_ON ],
        }],
@@ -474,7 +475,7 @@ read_only_bottom_close_and_rename($pm);
 __END__
 package warnings;
 
-our $VERSION = '1.25';
+our $VERSION = '1.26';
 
 # Verify that we're called correctly so that warnings will work.
 # see also strict.pm.

diff --git a/sv.c b/sv.c
index 19afcb6..ea3e651 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -10639,6 +10639,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p
     char ebuf[IV_DIG * 4 + NV_DIG + 32];
     /* large enough for "%#.#f" --chip */
     /* what about long double NVs? --jhi */
+    bool no_redundant_warning = FALSE; /* did we use any explicit format parameter index? */
 
     DECLARATION_FOR_STORE_LC_NUMERIC_SET_TO_NEEDED;
 
@@ -10652,9 +10653,17 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p
     (void)SvPV_force_nomg(sv, origlen);
 
     /* special-case "", "%s", and "%-p" (SVf - see below) */
-    if (patlen == 0)
+    if (patlen == 0) {
+       if (svmax && ckWARN(WARN_REDUNDANT))
+           Perl_warner(aTHX_ packWARN(WARN_REDUNDANT), "Redundant argument in %s",
+                       PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
        return;
+    }
     if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
+       if (svmax > 1 && ckWARN(WARN_REDUNDANT))
+           Perl_warner(aTHX_ packWARN(WARN_REDUNDANT), "Redundant argument in %s",
+                       PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
+
        if (args) {
            const char * const s = va_arg(*args, char*);
            sv_catpv_nomg(sv, s ? s : nullstr);
@@ -10670,6 +10679,9 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p
     }
     if (args && patlen == 3 && pat[0] == '%' &&
                pat[1] == '-' && pat[2] == 'p') {
+       if (svmax > 1 && ckWARN(WARN_REDUNDANT))
+           Perl_warner(aTHX_ packWARN(WARN_REDUNDANT), "Redundant argument in %s",
+                       PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
        argsv = MUTABLE_SV(va_arg(*args, void*));
        sv_catsv_nomg(sv, argsv);
        return;
@@ -10685,6 +10697,10 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p
        pp = pat + 2;
        while (*pp >= '0' && *pp <= '9')
            digits = 10 * digits + (*pp++ - '0');
+
+       /* XXX: Why do this `svix < svmax` test? Couldn't we just
+          format the first argument and WARN_REDUNDANT if svmax > 1?
+          Munged by Nicholas Clark in v5.13.0-209-g95ea86d */
        if (pp - pat == (int)patlen - 1 && svix < svmax) {
            const NV nv = SvNV(*svargs);
            if (*pp == 'g') {
@@ -10865,6 +10881,11 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p
            if (*q == '$') {
                ++q;
                efix = width;
+               if (!no_redundant_warning)
+                   /* I've forgotten if it's a better
+                      micro-optimization to always set this or to
+                      only set it if it's unset */
+                   no_redundant_warning = TRUE;
            } else {
                goto gotwidth;
            }
@@ -11789,6 +11810,15 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p
            goto vector;
        }
     }
+
+    /* Now that we've consumed all our printf format arguments (svix)
+     * do we have things left on the stack that we didn't use?
+     */
+    if (!no_redundant_warning && svmax >= svix + 1 && ckWARN(WARN_REDUNDANT)) {
+       Perl_warner(aTHX_ packWARN(WARN_REDUNDANT), "Redundant argument in %s",
+               PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
+    }
+
     SvTAINT(sv);
 
     RESTORE_LC_NUMERIC();   /* Done outside loop, so don't have to save/restore

diff --git a/t/op/sprintf.t b/t/op/sprintf.t
index 17e269a..4c41b16 100644 (file)
--- a/t/op/sprintf.t
+++ b/t/op/sprintf.t
@@ -65,6 +65,8 @@ $SIG{__WARN__} = sub {
        $w .= ' UNINIT';
     } elsif ($_[0] =~ /^Missing argument/) {
        $w .= ' MISSING';
+    } elsif ($_[0] =~ /^Redundant argument/) {
+       $w .= ' REDUNDANT';
     } elsif ($_[0]=~/^vector argument not supported with alpha versions/) {
        $w .= ' ALPHA';
     } else {
@@ -174,14 +176,14 @@ for (@tests) {
 
 # template    data          result
 __END__
->%6. 6s<    >''<          >%6. 6s INVALID< >(See use of $w in code above)<
->%6 .6s<    >''<          >%6 .6s INVALID<
->%6.6 s<    >''<          >%6.6 s INVALID<
->%A<        >''<          >%A INVALID<
+>%6. 6s<    >''<          >%6. 6s INVALID REDUNDANT< >(See use of $w in code above)<
+>%6 .6s<    >''<          >%6 .6s INVALID REDUNDANT<
+>%6.6 s<    >''<          >%6.6 s INVALID REDUNDANT<
+>%A<        >''<          >%A INVALID REDUNDANT<
 >%B<        >2**32-1<     >11111111111111111111111111111111<
 >%+B<       >2**32-1<     >11111111111111111111111111111111<
 >%#B<       >2**32-1<     >0B11111111111111111111111111111111<
->%C<        >''<          >%C INVALID<
+>%C<        >''<          >%C INVALID REDUNDANT<
 >%D<        >0x7fffffff<  >2147483647<     >Synonym for %ld<
 >%E<        >123456.789<  >1.234568E+05<   >Like %e, but using upper-case "E"<
 >%F<        >123456.789<  >123456.789000<  >Synonym for %f<
@@ -191,27 +193,27 @@ __END__
 >%G<        >12345.6789<  >12345.7<
 >%G<        >1234567e96<  >1.23457E+102<       >exponent too big skip: os390<
 >%G<        >.1234567e-101< >1.23457E-102<     >exponent too small skip: os390<
->%H<        >''<          >%H INVALID<
->%I<        >''<          >%I INVALID<
->%J<        >''<          >%J INVALID<
->%K<        >''<          >%K INVALID<
->%L<        >''<          >%L INVALID<
->%M<        >''<          >%M INVALID<
->%N<        >''<          >%N INVALID<
+>%H<        >''<          >%H INVALID REDUNDANT<
+>%I<        >''<          >%I INVALID REDUNDANT<
+>%J<        >''<          >%J INVALID REDUNDANT<
+>%K<        >''<          >%K INVALID REDUNDANT<
+>%L<        >''<          >%L INVALID REDUNDANT<
+>%M<        >''<          >%M INVALID REDUNDANT<
+>%N<        >''<          >%N INVALID REDUNDANT<
 >%O<        >2**32-1<     >37777777777<    >Synonym for %lo<
->%P<        >''<          >%P INVALID<
->%Q<        >''<          >%Q INVALID<
->%R<        >''<          >%R INVALID<
->%S<        >''<          >%S INVALID<
->%T<        >''<          >%T INVALID<
+>%P<        >''<          >%P INVALID REDUNDANT<
+>%Q<        >''<          >%Q INVALID REDUNDANT<
+>%R<        >''<          >%R INVALID REDUNDANT<
+>%S<        >''<          >%S INVALID REDUNDANT<
+>%T<        >''<          >%T INVALID REDUNDANT<
 >%U<        >2**32-1<     >4294967295<     >Synonym for %lu<
->%V<        >''<          >%V INVALID<
->%W<        >''<          >%W INVALID<
+>%V<        >''<          >%V INVALID REDUNDANT<
+>%W<        >''<          >%W INVALID REDUNDANT<
 >%X<        >2**32-1<     >FFFFFFFF<       >Like %x, but with u/c letters<
 >%#X<       >2**32-1<     >0XFFFFFFFF<
->%Y<        >''<          >%Y INVALID<
->%Z<        >''<          >%Z INVALID<
->%a<        >''<          >%a INVALID<
+>%Y<        >''<          >%Y INVALID REDUNDANT<
+>%Z<        >''<          >%Z INVALID REDUNDANT<
+>%a<        >''<          >%a INVALID REDUNDANT<
 >%b<        >2**32-1<     >11111111111111111111111111111111<
 >%+b<       >2**32-1<     >11111111111111111111111111111111<
 >%#b<       >2**32-1<     >0b11111111111111111111111111111111<
@@ -396,7 +398,7 @@ __END__
 >%.0f<      >1<           >1<
 >%#.0f<     >1<           >1.<
 >%.0lf<     >1<           >1<              >'l' should have no effect<
->%.0hf<     >1<           >%.0hf INVALID<  >'h' should be rejected<
+>%.0hf<     >1<           >%.0hf INVALID REDUNDANT<  >'h' should be rejected<
 >%g<        >12345.6789<  >12345.7<
 >%+g<       >12345.6789<  >+12345.7<
 >%#g<       >12345.6789<  >12345.7<
@@ -434,12 +436,12 @@ __END__
 >%-13g<     >1234567.89<  >1.23457e+06  <
 >%g<        >.1234567E-101< >1.23457e-102<     >exponent too small skip: os390<
 >%g<        >1234567E96<  >1.23457e+102<       >exponent too big skip: os390<
->%h<        >''<          >%h INVALID<
+>%h<        >''<          >%h INVALID REDUNDANT<
 >%i<        >123456.789<  >123456<         >Synonym for %d<
->%j<        >''<          >%j INVALID<
->%k<        >''<          >%k INVALID<
->%l<        >''<          >%l INVALID<
->%m<        >''<          >%m INVALID<
+>%j<        >''<          >%j INVALID REDUNDANT<
+>%k<        >''<          >%k INVALID REDUNDANT<
+>%l<        >''<          >%l INVALID REDUNDANT<
+>%m<        >''<          >%m INVALID REDUNDANT<
 >%s< >sprintf('%%n%n %d', $n, $n)< >%n 2< >Slight sneakiness to test %n<
 >%s< >$n="abc"; sprintf(' %n%s', substr($n,1,1), $n)< > a1c< >%n w/magic<
 >%s< >no warnings; sprintf('%s%n', chr(256)x5, $n),$n< >5< >Unicode %n<
@@ -510,9 +512,9 @@ __END__
 >%#06.4o<   >18<          >  0022<        >0 flag with precision: no effect<
 >%d< >$p=sprintf('%p',$p);$p=~/^[0-9a-f]+$/< >1< >Coarse hack: hex from %p?<
 >%d< >$p=sprintf('%-8p',$p);$p=~/^[0-9a-f]+\s*$/< >1< >Coarse hack: hex from %p?<
->%#p<       >''<          >%#p INVALID<
->%q<        >''<          >%q INVALID<
->%r<        >''<          >%r INVALID<
+>%#p<       >''<          >%#p INVALID REDUNDANT<
+>%q<        >''<          >%q INVALID REDUNDANT<
+>%r<        >''<          >%r INVALID REDUNDANT<
 >%s<        >[]<          > MISSING<
 > %s<       >[]<          >  MISSING<
 >%s<        >'string'<    >string<
@@ -534,7 +536,7 @@ __END__
 >%3.*s<     >[1, 'string']< >  s<
 >%3.*s<     >[0, 'string']< >   <
 >%3.*s<     >[-1,'string']< >string<  >negative precision to be ignored<
->%t<        >''<          >%t INVALID<
+>%t<        >''<          >%t INVALID REDUNDANT<
 >%u<        >2**32-1<     >4294967295<
 >%+u<       >2**32-1<     >4294967295<
 >%#u<       >2**32-1<     >4294967295<
@@ -549,8 +551,8 @@ __END__
 >% 4.3u<    >18<          > 018<
 >%04.3u<    >18<          > 018<         >0 flag with precision: no effect<
 >%.3u<      >18<          >018<
->%v<        >''<          >%v INVALID<
->%w<        >''<          >%w INVALID<
+>%v<        >''<          >%v INVALID REDUNDANT<
+>%w<        >''<          >%w INVALID REDUNDANT<
 >%x<        >2**32-1<     >ffffffff<
 >%+x<       >2**32-1<     >ffffffff<
 >%#x<       >2**32-1<     >0xffffffff<
@@ -632,37 +634,37 @@ __END__
 >%#+.*x<    >[-1,0]<      >0<
 >%# .*x<    >[-1,0]<      >0<
 >%#0.*x<    >[-1,0]<      >0<
->%y<        >''<          >%y INVALID<
->%z<        >''<          >%z INVALID<
+>%y<        >''<          >%y INVALID REDUNDANT<
+>%z<        >''<          >%z INVALID REDUNDANT<
 >%2$d %1$d<    >[12, 34]<      >34 12<
->%*2$d<                >[12, 3]<       > 12<
+>%*2$d<                >[12, 3]<       > 12 REDUNDANT<
 >%2$d %d<      >[12, 34]<      >34 12<
 >%2$d %d %d<   >[12, 34]<      >34 12 34<
 >%3$d %d %d<   >[12, 34, 56]<  >56 12 34<
 >%2$*3$d %d<   >[12, 34, 3]<   > 34 12<
->%*3$2$d %d<   >[12, 34, 3]<   >%*3$2$d 12 INVALID<
+>%*3$2$d %d<   >[12, 34, 3]<   >%*3$2$d 12 INVALID REDUNDANT<
 >%2$d<         >12<    >0 MISSING<
->%0$d<         >12<    >%0$d INVALID<
+>%0$d<         >12<    >%0$d INVALID REDUNDANT<
 >%1$$d<                >12<    >%1$$d INVALID<
 >%1$1$d<       >12<    >%1$1$d INVALID<
->%*2$*2$d<     >[12, 3]<       >%*2$*2$d INVALID<
->%*2*2$d<      >[12, 3]<       >%*2*2$d INVALID<
->%*2$1d<       >[12, 3]<       >%*2$1d INVALID<
+>%*2$*2$d<     >[12, 3]<       >%*2$*2$d INVALID REDUNDANT<
+>%*2*2$d<      >[12, 3]<       >%*2*2$d INVALID REDUNDANT<
+>%*2$1d<       >[12, 3]<       >%*2$1d INVALID REDUNDANT<
 >%0v2.2d<      >''<    ><
->%vc,%d<       >[63, 64, 65]<  >%vc,63 INVALID<
->%v%,%d<       >[63, 64, 65]<  >%v%,63 INVALID<
->%vd,%d<       >["\x1", 2, 3]< >1,2<
->%vf,%d<       >[1, 2, 3]<     >%vf,1 INVALID<
->%vF,%d<       >[1, 2, 3]<     >%vF,1 INVALID<
->%ve,%d<       >[1, 2, 3]<     >%ve,1 INVALID<
->%vE,%d<       >[1, 2, 3]<     >%vE,1 INVALID<
->%vg,%d<       >[1, 2, 3]<     >%vg,1 INVALID<
->%vG,%d<       >[1, 2, 3]<     >%vG,1 INVALID<
->%vp<  >''<    >%vp INVALID<
->%vn<  >''<    >%vn INVALID<
->%vs,%d<       >[1, 2, 3]<     >%vs,1 INVALID<
->%v_<  >''<    >%v_ INVALID<
->%v#x< >''<    >%v#x INVALID<
+>%vc,%d<       >[63, 64, 65]<  >%vc,63 INVALID REDUNDANT<
+>%v%,%d<       >[63, 64, 65]<  >%v%,63 INVALID REDUNDANT<
+>%vd,%d<       >["\x1", 2, 3]< >1,2 REDUNDANT<
+>%vf,%d<       >[1, 2, 3]<     >%vf,1 INVALID REDUNDANT<
+>%vF,%d<       >[1, 2, 3]<     >%vF,1 INVALID REDUNDANT<
+>%ve,%d<       >[1, 2, 3]<     >%ve,1 INVALID REDUNDANT<
+>%vE,%d<       >[1, 2, 3]<     >%vE,1 INVALID REDUNDANT<
+>%vg,%d<       >[1, 2, 3]<     >%vg,1 INVALID REDUNDANT<
+>%vG,%d<       >[1, 2, 3]<     >%vG,1 INVALID REDUNDANT<
+>%vp<  >''<    >%vp INVALID REDUNDANT<
+>%vn<  >''<    >%vn INVALID REDUNDANT<
+>%vs,%d<       >[1, 2, 3]<     >%vs,1 INVALID REDUNDANT<
+>%v_<  >''<    >%v_ INVALID REDUNDANT<
+>%v#x< >''<    >%v#x INVALID REDUNDANT<
 >%v02x<        >"\x66\x6f\x6f\012"<    >66.6f.6f.0a<
 >%#v.8b<       >"\141\000\142"<        >0b01100001.00000000.0b01100010<        >perl #39530<
 >%#v.0o<       >"\001\000\002\000"<    >01.0.02.0<
@@ -700,10 +702,10 @@ __END__
 >%#v.2X<       >"\141\x{1e01}\017\142\x{1e03}"<        >0X61.0X1E01.0X0F.0X62.0X1E03<  >perl #39530<
 >%V-%s<                >["Hello"]<     >%V-Hello INVALID<
 >%K %d %d<     >[13, 29]<      >%K 13 29 INVALID<
->%*.*K %d<     >[13, 29, 76]<  >%*.*K 13 INVALID<
+>%*.*K %d<     >[13, 29, 76]<  >%*.*K 13 INVALID REDUNDANT<
 >%4$K %d<      >[45, 67]<      >%4$K 45 MISSING INVALID<
 >%d %K %d<     >[23, 45]<      >23 %K 45 INVALID<
->%*v*999\$d %d %d<     >[11, 22, 33]<  >%*v*999\$d 11 22 INVALID<
+>%*v*999\$d %d %d<     >[11, 22, 33]<  >%*v*999\$d 11 22 INVALID REDUNDANT<
 >%#b<          >0<     >0<
 >%#o<          >0<     >0<
 >%#x<          >0<     >0<

diff --git a/t/op/sprintf2.t b/t/op/sprintf2.t
index d914de0..5fd3cd7 100644 (file)
--- a/t/op/sprintf2.t
+++ b/t/op/sprintf2.t
@@ -8,7 +8,7 @@ BEGIN {
     require './test.pl';
 }   
 
-plan tests => 1370;
+plan tests => 1406;
 
 use strict;
 use Config;
@@ -77,6 +77,142 @@ for (int(~0/2+1), ~0, "9999999999999999999") {
     is($bad,   0, "unexpected warnings");
 }
 
+# Tests for "missing argument" and "redundant argument" warnings
+{
+    my ($warn_missing, $warn_redundant, $warn_bad) = (0,0,0);
+    local $SIG{__WARN__} = sub {
+       if ($_[0] =~ /missing argument/i) {
+           $warn_missing++
+       }
+       elsif ($_[0] =~ /redundant argument/i) {
+           $warn_redundant++
+       }
+       else {
+           $warn_bad++
+       }
+    };
+
+    my @tests = (
+       # The "", "%s", and "%-p" formats have special-case handling
+       # in sv.c
+       {
+           fmt  => "",
+           args => [ qw( x ) ],
+           res  => "",
+           m    => 0,
+           r    => 1,
+       },
+       {
+           fmt  => "%s",
+           args => [ qw( x y ) ],
+           res  => "x",
+           m    => 0,
+           r    => 1,
+       },
+       {
+           fmt  => "%-p",
+           args => [ qw( x y ) ],
+           res  => qr/^[0-9a-f]+$/as,
+           m    => 0,
+           r    => 1,
+       },
+       # Other non-specialcased patterns
+       {
+           fmt  => "%s : %s",
+           args => [ qw( a b c ) ],
+           res  => "a : b",
+           m    => 0,
+           r    => 1,
+       },
+       {
+           fmt  => "%s : %s : %s",
+           args => [ qw( a b c d e ) ],
+           res  => "a : b : c",
+           m    => 0,
+           # Note how we'll only warn about redundant arguments once,
+           # even though both "d" and "e" are redundant...
+           r    => 1,
+       },
+       {
+           fmt  => "%s : %s : %s",
+           args => [ ],
+           res  => " :  : ",
+           # ...But when arguments are missing we'll warn about every
+           # missing argument. This difference between the two
+           # warnings is a feature.
+           m    => 3,
+           r    => 0,
+       },
+
+       # Tests for format parameter indexes.
+       #
+       # Deciding what to do about these is a bit tricky, and so is
+       # "correctly" warning about missing arguments on them.
+       #
+       # Should we warn if you supply 4 arguments but only use
+       # argument 1,3 & 4? Or only if you supply 5 arguments and your
+       # highest used argument is 4?
+       #
+       # For some uses of this printf feature (e.g. i18n systems)
+       # it's a always a logic error to not print out every provided
+       # argument, but for some other uses skipping some might be a
+       # feature (although you could argue that then printf should be
+       # called as e.g:
+       #
+       #     printf q[%1$s %3$s], x(), undef, z();
+       #
+       # Instead of:
+       #
+       #    printf q[%1$s %3$s], x(), y(), z();
+       #
+       # Since calling the (possibly expensive) y() function is
+       # completely redundant there.
+       #
+       # We deal with all these potential problems by not even
+       # trying. If the pattern contains any format parameter indexes
+       # whatsoever we'll never warn about redundant arguments.
+       {
+           fmt  => '%1$s : %2$s',
+           args => [ qw( x y z ) ],
+           res  => "x : y",
+           m    => 0,
+           r    => 0,
+       },
+       {
+           fmt  => '%2$s : %4$s : %5$s',
+           args => [ qw( a b c d )],
+           res  => "b : d : ",
+           m    => 1,
+           r    => 0,
+       },
+       {
+           fmt  => '%s : %1$s : %s',
+           args => [ qw( x y z ) ],
+           res  => "x : x : y",
+           m    => 0,
+           r    => 0,
+       },
+
+    );
+
+    for my $i (0..$#tests) {
+       my $test = $tests[$i];
+       my $result = sprintf $test->{fmt}, @{$test->{args}};
+
+       my $prefix = "For format '$test->{fmt}' and arguments/result '@{$test->{args}}'/'$result'";
+       if (ref $test->{res} eq 'Regexp') {
+           like($result, $test->{res}, "$prefix got the right result");
+       } else {
+           is($result, $test->{res}, "$prefix got the right result");
+       }
+       is($warn_missing, $test->{m}, "$prefix got '$test->{m}' 'missing argument' warnings");
+       is($warn_redundant, $test->{r}, "$prefix got '$test->{r}' 'redundant argument' warnings");
+       is($warn_bad, 0, "$prefix No unknown warnings");
+
+       ($warn_missing, $warn_redundant, $warn_bad) = (0,0,0);
+    }
+}
+
 {
     foreach my $ord (0 .. 255) {
        my $bad = 0;

diff --git a/warnings.h b/warnings.h
index a5bd239..21c6d83 100644 (file)
--- a/warnings.h
+++ b/warnings.h
@@ -106,6 +106,7 @@
 
 #define WARN_EXPERIMENTAL__WIN32_PERLIO 60
 #define WARN_MISSING            61
+#define WARN_REDUNDANT          62
 
 #define WARNsize               16
 #define WARN_ALLstring         "\125\125\125\125\125\125\125\125\125\125\125\125\125\125\125\125"