"Perl_newSVpvf("%lld")" is broken

Message-Id: <200811081329.mA8DTv7e018896@zen.crypt.org>

Plus some test cases.

p4raw-id: //depot/perl@34780

diff --git a/sv.c b/sv.c
index 65b6249..000cfd2 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -9557,8 +9557,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
                case 'l':       iv = va_arg(*args, long); break;
                case 'V':       iv = va_arg(*args, IV); break;
                default:        iv = va_arg(*args, int); break;
+               case 'q':
 #ifdef HAS_QUAD
-               case 'q':       iv = va_arg(*args, Quad_t); break;
+                               iv = va_arg(*args, Quad_t); break;
+#else
+                               goto unknown;
 #endif
                }
            }
@@ -9569,8 +9572,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
                case 'l':       iv = (long)tiv; break;
                case 'V':
                default:        iv = tiv; break;
+               case 'q':
 #ifdef HAS_QUAD
-               case 'q':       iv = (Quad_t)tiv; break;
+                               iv = (Quad_t)tiv; break;
+#else
+                               goto unknown;
 #endif
                }
            }
@@ -9642,8 +9648,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
                case 'l':  uv = va_arg(*args, unsigned long); break;
                case 'V':  uv = va_arg(*args, UV); break;
                default:   uv = va_arg(*args, unsigned); break;
+               case 'q':
 #ifdef HAS_QUAD
-               case 'q':  uv = va_arg(*args, Uquad_t); break;
+                          uv = va_arg(*args, Uquad_t); break;
+#else
+                          goto unknown;
 #endif
                }
            }
@@ -9654,8 +9663,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
                case 'l':       uv = (unsigned long)tuv; break;
                case 'V':
                default:        uv = tuv; break;
+               case 'q':
 #ifdef HAS_QUAD
-               case 'q':       uv = (Uquad_t)tuv; break;
+                               uv = (Uquad_t)tuv; break;
+#else
+                               goto unknown;
 #endif
                }
            }
@@ -9941,8 +9953,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
                default:        *(va_arg(*args, int*)) = i; break;
                case 'l':       *(va_arg(*args, long*)) = i; break;
                case 'V':       *(va_arg(*args, IV*)) = i; break;
+               case 'q':
 #ifdef HAS_QUAD
-               case 'q':       *(va_arg(*args, Quad_t*)) = i; break;
+                               *(va_arg(*args, Quad_t*)) = i; break;
+#else
+                               goto unknown;
 #endif
                }
            }

diff --git a/t/op/sprintf2.t b/t/op/sprintf2.t
index 397c19e..3e608d8 100644 (file)
--- a/t/op/sprintf2.t
+++ b/t/op/sprintf2.t
@@ -6,7 +6,10 @@ BEGIN {
     require './test.pl';
 }   
 
-plan tests => 1295;
+plan tests => 1319;
+
+use strict;
+use Config;
 
 is(
     sprintf("%.40g ",0.01),
@@ -139,3 +142,26 @@ foreach my $n (2**1e100, -2**1e100, 2**1e100/2**1e100) { # +Inf, -Inf, NaN
     eval { my $f = sprintf("%f", $n); };
     is $@, "", "sprintf(\"%f\", $n)";
 }
+
+# test %ll formats with and without HAS_QUAD
+eval { my $q = pack "q", 0 };
+my $Q = $@ eq '';
+
+my @tests = (
+  [ '%lld' => '%d', [qw( 4294967296 -100000000000000 )] ],
+  [ '%lli' => '%i', [qw( 4294967296 -100000000000000 )] ],
+  [ '%llu' => '%u', [qw( 4294967296  100000000000000 )] ],
+  [ '%Ld'  => '%d', [qw( 4294967296 -100000000000000 )] ],
+  [ '%Li'  => '%i', [qw( 4294967296 -100000000000000 )] ],
+  [ '%Lu'  => '%u', [qw( 4294967296  100000000000000 )] ],
+);
+
+for my $t (@tests) {
+  my($fmt, $conv) = @$t;
+  for my $num (@{$t->[2]}) {
+    my $w; local $SIG{__WARN__} = sub { $w = shift };
+    is(sprintf($fmt, $num), $Q ? $num : $fmt, "quad: $fmt -> $num");
+    like($w, $Q ? '' : qr/Invalid conversion in sprintf: "$conv"/, "warning: $fmt");
+  }
+}
+