make sprintf("%g",...) threadsafe; only taint its result iff the

formatted result looks nonstandard

p4raw-id: //depot/perl@4130

12 files changed, 75 insertions, 37 deletions

diff --git a/embed.pl b/embed.pl
index 5f0711f493..eaee6f7264 100755
--- a/embed.pl
+++ b/embed.pl
@@ -1653,10 +1653,10 @@ p	|bool	|sv_upgrade	|SV* sv|U32 mt
 p	|void	|sv_usepvn	|SV* sv|char* ptr|STRLEN len
 p	|void	|sv_vcatpvfn	|SV* sv|const char* pat|STRLEN patlen \
 				|va_list* args|SV** svargs|I32 svmax \
-				|bool *used_locale
+				|bool *maybe_tainted
 p	|void	|sv_vsetpvfn	|SV* sv|const char* pat|STRLEN patlen \
 				|va_list* args|SV** svargs|I32 svmax \
-				|bool *used_locale
+				|bool *maybe_tainted
 p	|SV*	|swash_init	|char* pkg|char* name|SV* listsv \
 				|I32 minbits|I32 none
 p	|UV	|swash_fetch	|SV *sv|U8 *ptr
diff --git a/embedvar.h b/embedvar.h
index 3e83de1d22..65a31f1ec7 100644
--- a/embedvar.h
+++ b/embedvar.h
@@ -49,6 +49,8 @@
 #define PL_delaymagic		(vTHX->Tdelaymagic)
 #define PL_dirty		(vTHX->Tdirty)
 #define PL_dumpindent		(vTHX->Tdumpindent)
+#define PL_efloatbuf		(vTHX->Tefloatbuf)
+#define PL_efloatsize		(vTHX->Tefloatsize)
 #define PL_extralen		(vTHX->Textralen)
 #define PL_firstgv		(vTHX->Tfirstgv)
 #define PL_formtarget		(vTHX->Tformtarget)
@@ -229,8 +231,6 @@
 #define PL_doswitches		(PERL_GET_INTERP->Idoswitches)
 #define PL_dowarn		(PERL_GET_INTERP->Idowarn)
 #define PL_e_script		(PERL_GET_INTERP->Ie_script)
-#define PL_efloatbuf		(PERL_GET_INTERP->Iefloatbuf)
-#define PL_efloatsize		(PERL_GET_INTERP->Iefloatsize)
 #define PL_egid			(PERL_GET_INTERP->Iegid)
 #define PL_endav		(PERL_GET_INTERP->Iendav)
 #define PL_envgv		(PERL_GET_INTERP->Ienvgv)
@@ -500,8 +500,6 @@
 #define PL_doswitches		(vTHX->Idoswitches)
 #define PL_dowarn		(vTHX->Idowarn)
 #define PL_e_script		(vTHX->Ie_script)
-#define PL_efloatbuf		(vTHX->Iefloatbuf)
-#define PL_efloatsize		(vTHX->Iefloatsize)
 #define PL_egid			(vTHX->Iegid)
 #define PL_endav		(vTHX->Iendav)
 #define PL_envgv		(vTHX->Ienvgv)
@@ -773,8 +771,6 @@
 #define PL_Idoswitches		PL_doswitches
 #define PL_Idowarn		PL_dowarn
 #define PL_Ie_script		PL_e_script
-#define PL_Iefloatbuf		PL_efloatbuf
-#define PL_Iefloatsize		PL_efloatsize
 #define PL_Iegid		PL_egid
 #define PL_Iendav		PL_endav
 #define PL_Ienvgv		PL_envgv
@@ -1002,6 +998,8 @@
 #define PL_delaymagic		(aTHX->Tdelaymagic)
 #define PL_dirty		(aTHX->Tdirty)
 #define PL_dumpindent		(aTHX->Tdumpindent)
+#define PL_efloatbuf		(aTHX->Tefloatbuf)
+#define PL_efloatsize		(aTHX->Tefloatsize)
 #define PL_extralen		(aTHX->Textralen)
 #define PL_firstgv		(aTHX->Tfirstgv)
 #define PL_formtarget		(aTHX->Tformtarget)
@@ -1136,6 +1134,8 @@
 #define PL_Tdelaymagic		PL_delaymagic
 #define PL_Tdirty		PL_dirty
 #define PL_Tdumpindent		PL_dumpindent
+#define PL_Tefloatbuf		PL_efloatbuf
+#define PL_Tefloatsize		PL_efloatsize
 #define PL_Textralen		PL_extralen
 #define PL_Tfirstgv		PL_firstgv
 #define PL_Tformtarget		PL_formtarget
diff --git a/intrpvar.h b/intrpvar.h
index a291d393ca..669e6f97ad 100644
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -353,8 +353,6 @@ PERLVAR(Iyyval,		YYSTYPE)
 PERLVAR(Iyylval,	YYSTYPE)
 
 PERLVAR(Iglob_index,	int)
-PERLVAR(Iefloatbuf,	char*)
-PERLVAR(Iefloatsize,	STRLEN)
 PERLVAR(Isrand_called,	bool)
 PERLVARA(Iuudmap,256,	char)
 PERLVAR(Ibitcount,	char *)
diff --git a/objXSUB.h b/objXSUB.h
index 437a219a70..5da23fe984 100644
--- a/objXSUB.h
+++ b/objXSUB.h
@@ -130,10 +130,6 @@
 #define PL_dowarn		(*Perl_Idowarn_ptr(aTHXo))
 #undef  PL_e_script
 #define PL_e_script		(*Perl_Ie_script_ptr(aTHXo))
-#undef  PL_efloatbuf
-#define PL_efloatbuf		(*Perl_Iefloatbuf_ptr(aTHXo))
-#undef  PL_efloatsize
-#define PL_efloatsize		(*Perl_Iefloatsize_ptr(aTHXo))
 #undef  PL_egid
 #define PL_egid			(*Perl_Iegid_ptr(aTHXo))
 #undef  PL_endav
@@ -580,6 +576,10 @@
 #define PL_dirty		(*Perl_Tdirty_ptr(aTHXo))
 #undef  PL_dumpindent
 #define PL_dumpindent		(*Perl_Tdumpindent_ptr(aTHXo))
+#undef  PL_efloatbuf
+#define PL_efloatbuf		(*Perl_Tefloatbuf_ptr(aTHXo))
+#undef  PL_efloatsize
+#define PL_efloatsize		(*Perl_Tefloatsize_ptr(aTHXo))
 #undef  PL_extralen
 #define PL_extralen		(*Perl_Textralen_ptr(aTHXo))
 #undef  PL_firstgv
diff --git a/perl.c b/perl.c
index ed88bc3eb4..de91ed456f 100644
--- a/perl.c
+++ b/perl.c
@@ -409,6 +409,11 @@ perl_destruct(pTHXx)
     Safefree(PL_screamnext);
     PL_screamnext  = 0;
 
+    /* float buffer */
+    Safefree(PL_efloatbuf);
+    PL_efloatbuf = Nullch;
+    PL_efloatsize = 0;
+
     /* startup and shutdown function lists */
     SvREFCNT_dec(PL_beginav);
     SvREFCNT_dec(PL_endav);
diff --git a/perlapi.c b/perlapi.c
index f04706c9cd..ed7ab92d99 100644
--- a/perlapi.c
+++ b/perlapi.c
@@ -4134,16 +4134,16 @@ Perl_sv_usepvn(pTHXo_ SV* sv, char* ptr, STRLEN len)
 
 #undef  Perl_sv_vcatpvfn
 void
-Perl_sv_vcatpvfn(pTHXo_ SV* sv, const char* pat, STRLEN patlen, va_list* args, SV** svargs, I32 svmax, bool *used_locale)
+Perl_sv_vcatpvfn(pTHXo_ SV* sv, const char* pat, STRLEN patlen, va_list* args, SV** svargs, I32 svmax, bool *maybe_tainted)
 {
-    ((CPerlObj*)pPerl)->Perl_sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale);
+    ((CPerlObj*)pPerl)->Perl_sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
 }
 
 #undef  Perl_sv_vsetpvfn
 void
-Perl_sv_vsetpvfn(pTHXo_ SV* sv, const char* pat, STRLEN patlen, va_list* args, SV** svargs, I32 svmax, bool *used_locale)
+Perl_sv_vsetpvfn(pTHXo_ SV* sv, const char* pat, STRLEN patlen, va_list* args, SV** svargs, I32 svmax, bool *maybe_tainted)
 {
-    ((CPerlObj*)pPerl)->Perl_sv_vsetpvfn(sv, pat, patlen, args, svargs, svmax, used_locale);
+    ((CPerlObj*)pPerl)->Perl_sv_vsetpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
 }
 
 #undef  Perl_swash_init
diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod
index 0d47260e10..995a671110 100644
--- a/pod/perlfunc.pod
+++ b/pod/perlfunc.pod
@@ -4120,6 +4120,13 @@ If C<use locale> is in effect, the character used for the decimal
 point in formatted real numbers is affected by the LC_NUMERIC locale.
 See L<perllocale>.
 
+To cope with broken systems that allow the standard locales to be
+overridden by malicious users, the return value may be tainted
+if any of the floating point formats are used and the conversion
+yields something that doesn't look like a normal C-locale floating
+point number.  This happens regardless of whether C<use locale> is
+in effect or not.
+
 If Perl understands "quads" (64-bit integers) (this requires
 either that the platform natively supports quads or that Perl
 has been specifically compiled to support quads), the characters
diff --git a/pod/perlguts.pod b/pod/perlguts.pod
index 93d4bd70c4..af12297ec3 100644
--- a/pod/perlguts.pod
+++ b/pod/perlguts.pod
@@ -3649,24 +3649,26 @@ Like C<sv_usepvn>, but also handles 'set' magic.
 
 	void	sv_usepvn_mg (SV* sv, char* ptr, STRLEN len)
 
-=item sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale)
+=item sv_vcatpvfn
 
 Processes its arguments like C<vsprintf> and appends the formatted output
 to an SV.  Uses an array of SVs if the C style variable argument list is
-missing (NULL).  Indicates if locale information has been used for formatting.
+missing (NULL).  When running with taint checks enabled, indicates via
+C<maybe_tainted> if results are untrustworthy (often due to the use of
+locales).
 
 	void	sv_catpvfn (SV* sv, const char* pat, STRLEN patlen,
 			    va_list *args, SV **svargs, I32 svmax,
-			    bool *used_locale);
+			    bool *maybe_tainted);
 
-=item sv_vsetpvfn(sv, pat, patlen, args, svargs, svmax, used_locale)
+=item sv_vsetpvfn
 
 Works like C<vcatpvfn> but copies the text into the SV instead of
 appending it.
 
 	void	sv_setpvfn (SV* sv, const char* pat, STRLEN patlen,
 			    va_list *args, SV **svargs, I32 svmax,
-			    bool *used_locale);
+			    bool *maybe_tainted);
 
 =item SvUV
 
diff --git a/proto.h b/proto.h
index ddb31429fa..38c7ce6273 100644
--- a/proto.h
+++ b/proto.h
@@ -630,8 +630,8 @@ VIRTUAL void	Perl_sv_unref(pTHX_ SV* sv);
 VIRTUAL void	Perl_sv_untaint(pTHX_ SV* sv);
 VIRTUAL bool	Perl_sv_upgrade(pTHX_ SV* sv, U32 mt);
 VIRTUAL void	Perl_sv_usepvn(pTHX_ SV* sv, char* ptr, STRLEN len);
-VIRTUAL void	Perl_sv_vcatpvfn(pTHX_ SV* sv, const char* pat, STRLEN patlen, va_list* args, SV** svargs, I32 svmax, bool *used_locale);
-VIRTUAL void	Perl_sv_vsetpvfn(pTHX_ SV* sv, const char* pat, STRLEN patlen, va_list* args, SV** svargs, I32 svmax, bool *used_locale);
+VIRTUAL void	Perl_sv_vcatpvfn(pTHX_ SV* sv, const char* pat, STRLEN patlen, va_list* args, SV** svargs, I32 svmax, bool *maybe_tainted);
+VIRTUAL void	Perl_sv_vsetpvfn(pTHX_ SV* sv, const char* pat, STRLEN patlen, va_list* args, SV** svargs, I32 svmax, bool *maybe_tainted);
 VIRTUAL SV*	Perl_swash_init(pTHX_ char* pkg, char* name, SV* listsv, I32 minbits, I32 none);
 VIRTUAL UV	Perl_swash_fetch(pTHX_ SV *sv, U8 *ptr);
 VIRTUAL void	Perl_taint_env(pTHX);
diff --git a/sv.c b/sv.c
index 956f3b961a..acded3146d 100644
--- a/sv.c
+++ b/sv.c
@@ -4645,14 +4645,14 @@ Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
 }
 
 void
-Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale)
+Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
 {
     sv_setpvn(sv, "", 0);
-    sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale);
+    sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
 }
 
 void
-Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale)
+Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
 {
     dTHR;
     char *p;
@@ -5086,6 +5086,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 		Safefree(PL_efloatbuf);
 		PL_efloatsize = need + 20; /* more fudge */
 		New(906, PL_efloatbuf, PL_efloatsize, char);
+		PL_efloatbuf[0] = '\0';
 	    }
 
 	    eptr = ebuf + sizeof ebuf;
@@ -5125,15 +5126,36 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 	    eptr = PL_efloatbuf;
 	    elen = strlen(PL_efloatbuf);
 
-#ifdef LC_NUMERIC
+#ifdef USE_LOCALE_NUMERIC
 	    /*
 	     * User-defined locales may include arbitrary characters.
-	     * And, unfortunately, some system may alloc the "C" locale
-	     * to be overridden by a malicious user.
+	     * And, unfortunately, some (broken) systems may allow the
+	     * "C" locale to be overridden by a malicious user.
+	     * XXX This is an extreme way to cope with broken systems.
 	     */
-	    if (used_locale)
-		*used_locale = TRUE;
-#endif /* LC_NUMERIC */
+	    if (maybe_tainted && PL_tainting) {
+		/* safe if it matches /[-+]?\d*(\.\d*)?([eE][-+]?\d*)?/ */
+		if (*eptr == '-' || *eptr == '+')
+		    ++eptr;
+		while (isDIGIT(*eptr))
+		    ++eptr;
+		if (*eptr == '.') {
+		    ++eptr;
+		    while (isDIGIT(*eptr))
+			++eptr;
+		}
+		if (*eptr == 'e' || *eptr == 'E') {
+		    ++eptr;
+		    if (*eptr == '-' || *eptr == '+')
+			++eptr;
+		    while (isDIGIT(*eptr))
+			++eptr;
+		}
+		if (*eptr)
+		    *maybe_tainted = TRUE;	/* results are suspect */
+		eptr = PL_efloatbuf;
+	    }
+#endif /* USE_LOCALE_NUMERIC */
 
 	    break;
 
diff --git a/t/pragma/locale.t b/t/pragma/locale.t
index 82adcf3fb8..c453c47bd1 100755
--- a/t/pragma/locale.t
+++ b/t/pragma/locale.t
@@ -78,9 +78,9 @@ check_taint       7, "\L$a";
 check_taint       8, lcfirst($a);
 check_taint       9, "\l$a";
 
-check_taint      10, sprintf('%e', 123.456);
-check_taint      11, sprintf('%f', 123.456);
-check_taint      12, sprintf('%g', 123.456);
+check_taint_not  10, sprintf('%e', 123.456);
+check_taint_not  11, sprintf('%f', 123.456);
+check_taint_not  12, sprintf('%g', 123.456);
 check_taint_not  13, sprintf('%d', 123.456);
 check_taint_not  14, sprintf('%x', 123.456);
 
diff --git a/thrdvar.h b/thrdvar.h
index 4434b5ddb2..06bcb5b4e7 100644
--- a/thrdvar.h
+++ b/thrdvar.h
@@ -119,6 +119,10 @@ PERLVAR(Tfirstgv,	GV *)		/* $a */
 PERLVAR(Tsecondgv,	GV *)		/* $b */
 PERLVAR(Tsortcxix,	I32)		/* from pp_ctl.c */
 
+/* float buffer */
+PERLVAR(Tefloatbuf,	char*)
+PERLVAR(Tefloatsize,	STRLEN)
+
 /* regex stuff */
 
 PERLVAR(Tscreamfirst,	I32 *)