Try to grok numbers both with the locale specific separator

and with the usual "." (if different from the lss); add a test
to locale.t to do also a little bit of math in addition to just
equalness testing; remove extraneous logic as suggested in

Subject: Re: pragma/locale.t #107
Message-ID: <20010609223735.Y76396@plum.flirble.org>

p4raw-id: //depot/perl@10494

diff --git a/sv.c b/sv.c
index aeb471d..2a843e6 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -1505,7 +1505,7 @@ S_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep)
     int sawinf = 0;
     char* radix = ".";
     STRLEN radixlen = 1;
-         
+    bool radixfound;
 
     while (isSPACE(*s))
        s++;
@@ -1589,44 +1589,64 @@ S_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep)
            *valuep = value;
 
       skip_value:
-       if (s + radixlen <= send && memEQ(s, radix, radixlen)) {
+       if (s + radixlen <= send && memEQ(s, radix, radixlen))
+           radixfound = TRUE;
+#ifdef USE_LOCALE_NUMERIC
+       /* if we did change the radix and the radix is not the "."
+        * retry with the "." (in case of mixed data) */
+       else if (IN_LOCALE && !(*radix == '.' && radixlen == 1) && *s == '.') {
+           radixlen = 1;
+           radixfound = TRUE;
+       }
+#endif
+       if (radixfound) {
            s += radixlen;
            numtype |= IS_NUMBER_NOT_INT;
            while (isDIGIT(*s))  /* optional digits after the radix */
                s++;
        }
     }
-    else if (s + radixlen <= send && memEQ(s, radix, radixlen)) {
-       s += radixlen;
-       numtype |= IS_NUMBER_NOT_INT;
-       /* no digits before the radix means we need digits after it */
-       if (isDIGIT(*s)) {
-          do {
-              s++;
-          } while (isDIGIT(*s));
-          numtype |= IS_NUMBER_IN_UV;
-          if (valuep) {
-              /* integer approximation is valid - it's 0.  */
-              *valuep = 0;
-          }
-       }
-       else
-        return 0;
-    }
-    else if (*s == 'I' || *s == 'i') {
-       s++; if (*s != 'N' && *s != 'n') return 0;
-       s++; if (*s != 'F' && *s != 'f') return 0;
-       s++; if (*s == 'I' || *s == 'i') {
+    else {
+        if (s + radixlen <= send && memEQ(s, radix, radixlen))
+           radixfound = TRUE;
+#ifdef USE_LOCALE_NUMERIC
+       else if (IN_LOCALE && !(*radix == '.' && radixlen == 1) && *s == '.') {
+           radixlen = 1;
+           radixfound = TRUE;
+       }
+#endif
+       if (radixfound) {
+         s += radixlen;
+         numtype |= IS_NUMBER_NOT_INT;
+         /* no digits before the radix means we need digits after it */
+         if (isDIGIT(*s)) {
+             do {
+                 s++;
+             } while (isDIGIT(*s));
+             numtype |= IS_NUMBER_IN_UV;
+             if (valuep) {
+                 /* integer approximation is valid - it's 0.  */
+               *valuep = 0;
+             }
+         }
+         else
+           return 0;
+       }
+       else if (*s == 'I' || *s == 'i') {
            s++; if (*s != 'N' && *s != 'n') return 0;
-           s++; if (*s != 'I' && *s != 'i') return 0;
-           s++; if (*s != 'T' && *s != 't') return 0;
-           s++; if (*s != 'Y' && *s != 'y') return 0;
-           s++;
+           s++; if (*s != 'F' && *s != 'f') return 0;
+           s++; if (*s == 'I' || *s == 'i') {
+               s++; if (*s != 'N' && *s != 'n') return 0;
+               s++; if (*s != 'I' && *s != 'i') return 0;
+               s++; if (*s != 'T' && *s != 't') return 0;
+               s++; if (*s != 'Y' && *s != 'y') return 0;
+               s++;
+           }
+           sawinf = 1;
        }
-       sawinf = 1;
+       else /* Add test for NaN here.  */
+           return 0;
     }
-    else /* Add test for NaN here.  */
-        return 0;
 
     if (sawinf) {
        numtype &= IS_NUMBER_NEG; /* Keep track of sign  */
@@ -2423,7 +2443,7 @@ Perl_sv_2nv(pTHX_ register SV *sv)
            sv_upgrade(sv, SVt_PVNV);
        else
            sv_upgrade(sv, SVt_NV);
-#if defined(USE_LONG_DOUBLE)
+#ifdef USE_LONG_DOUBLE
        DEBUG_c({
            STORE_NUMERIC_LOCAL_SET_STANDARD();
            PerlIO_printf(Perl_debug_log,
@@ -2445,9 +2465,7 @@ Perl_sv_2nv(pTHX_ register SV *sv)
     if (SvNOKp(sv) && !(SvIOK(sv) || SvPOK(sv))) {
        SvNOK_on(sv);
     }
-    else if (SvIOKp(sv) &&
-            (!SvPOKp(sv) || !grok_number(SvPVX(sv), SvCUR(sv),NULL)))
-    {
+    else if (SvIOKp(sv)) {
        SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
 #ifdef NV_PRESERVES_UV
        SvNOK_on(sv);

diff --git a/t/pragma/locale.t b/t/pragma/locale.t
index df6df60..0926a6e 100755 (executable)
--- a/t/pragma/locale.t
+++ b/t/pragma/locale.t
@@ -45,7 +45,7 @@ eval {
 # and mingw32 uses said silly CRT
 $have_setlocale = 0 if $^O eq 'MSWin32' && $Config{cc} =~ /^(cl|gcc)/i;
 
-my $last = $have_setlocale ? 116 : 98;
+my $last = $have_setlocale ? &last : &last_without_setlocale;
 
 print "1..$last\n";
 
@@ -235,6 +235,8 @@ check_taint_not  97, $2;
 
 check_taint_not  98, $a;
 
+sub last_without_setlocale { 98 }
+
 # I think we've seen quite enough of taint.
 # Let us do some *real* locale work now,
 # unless setlocale() is missing (i.e. minitest).
@@ -638,7 +640,7 @@ foreach $Locale (@Locale) {
        my $w = 0;
        local $SIG{__WARN__} =
            sub {
-               print "# @_";
+               print "# @_\n";
                $w++;
            };
 
@@ -665,17 +667,20 @@ foreach $Locale (@Locale) {
            tryneoalpha($Locale, 110, $e == $c);
        }
        
-       tryneoalpha($Locale, 111, $w == 0);
-
        my $f = "1.23";
+       my $g = 2.34;
 
-       debug "# 112..114: f = $f, locale = $Locale\n";
+       debug "# 111..115: f = $f, g = $g, locale = $Locale\n";
 
-       tryneoalpha($Locale, 112, $f == 1.23);
+       tryneoalpha($Locale, 111, $f == 1.23);
 
-       tryneoalpha($Locale, 113, $f == $x);
+       tryneoalpha($Locale, 112, $f == $x);
        
-       tryneoalpha($Locale, 114, $f == $c);
+       tryneoalpha($Locale, 113, $f == $c);
+
+       tryneoalpha($Locale, 114, abs(($f + $g) - 3.57) < 0.01);
+
+       tryneoalpha($Locale, 115, $w == 0);
     }
 
     # Does taking lc separately differ from taking
@@ -698,7 +703,7 @@ foreach $Locale (@Locale) {
         my $y = "aa";
         my $z = "AB";
 
-        tryneoalpha($Locale, 115,
+        tryneoalpha($Locale, 116,
                    lcA($x, $y) == 1 && lcB($x, $y) == 1 ||
                    lcA($x, $z) == 0 && lcB($x, $z) == 0);
     }
@@ -711,7 +716,7 @@ foreach $Locale (@Locale) {
            # utf8 and locales do not mix.
            debug "# skipping UTF-8 locale '$Locale'\n";
            push @utf8locale, $Locale;
-            $utf8skip{116}++;
+            $utf8skip{117}++;
        } else {
            use locale;
            use locale;
@@ -728,9 +733,9 @@ foreach $Locale (@Locale) {
                next unless lc $y eq $x;
                push @f, $x unless $x =~ /$y/i && $y =~ /$x/i;
            }
-           tryneoalpha($Locale, 116, @f == 0);
+           tryneoalpha($Locale, 117, @f == 0);
            if (@f) {
-               print "# failed 116 locale '$Locale' characters @f\n"
+               print "# failed 117 locale '$Locale' characters @f\n"
            }
         }
     }
@@ -738,7 +743,7 @@ foreach $Locale (@Locale) {
 
 # Recount the errors.
 
-foreach (99..$last) {
+foreach (&last_without_setlocale()+1..$last) {
     if ($Problem{$_} || !defined $Okay{$_} || !@{$Okay{$_}}) {
        if ($_ == 102) {
            print "# The failure of test 102 is not necessarily fatal.\n";
@@ -829,4 +834,6 @@ if ($didwarn) {
     }
 }
 
+sub last { 117 }
+
 # eof