Implement POSIX::strtold().

Defined of course only with long doubles.

diff --git a/ext/B/t/concise-xs.t b/ext/B/t/concise-xs.t
index ca82cbd..039d194 100644 (file)
--- a/ext/B/t/concise-xs.t
+++ b/ext/B/t/concise-xs.t
@@ -200,7 +200,7 @@ my $testpkgs = {
               XS => [qw/ write wctomb wcstombs uname tzset tzname
                      ttyname tmpnam times tcsetpgrp tcsendbreak
                      tcgetpgrp tcflush tcflow tcdrain tanh tan
-                     sysconf strxfrm strtoul strtol strtod
+                     sysconf strxfrm strtoul strtol strtod strtold
                      strftime strcoll sinh sigsuspend sigprocmask
                      sigpending sigaction setuid setsid setpgid
                      setlocale setgid read pipe pause pathconf

diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs
index e3dac9b..c5596ae 100644 (file)
--- a/ext/POSIX/POSIX.xs
+++ b/ext/POSIX/POSIX.xs
@@ -189,6 +189,9 @@ START_EXTERN_C
 double strtod (const char *, char **);
 long strtol (const char *, char **, int);
 unsigned long strtoul (const char *, char **, int);
+#ifdef HAS_STRTOLD
+long double strtold (const char *, char **);
+#endif
 END_EXTERN_C
 #endif
 
@@ -227,6 +230,9 @@ END_EXTERN_C
 #ifndef HAS_STRTOD
 #define strtod(s1,s2) not_here("strtod")
 #endif
+#ifndef HAS_STRTOLD
+#define strtold(s1,s2) not_here("strtold")
+#endif
 #ifndef HAS_STRTOL
 #define strtol(s1,s2,b) not_here("strtol")
 #endif
@@ -1570,6 +1576,29 @@ strtod(str)
        }
         RESTORE_NUMERIC_STANDARD();
 
+#ifdef HAS_STRTOLD
+
+void
+strtold(str)
+       char *          str
+    PREINIT:
+       long double num;
+       char *unparsed;
+    PPCODE:
+        STORE_NUMERIC_STANDARD_FORCE_LOCAL();
+       num = strtold(str, &unparsed);
+       PUSHs(sv_2mortal(newSVnv(num)));
+       if (GIMME == G_ARRAY) {
+           EXTEND(SP, 1);
+           if (unparsed)
+               PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
+           else
+               PUSHs(&PL_sv_undef);
+       }
+        RESTORE_NUMERIC_STANDARD();
+
+#endif
+
 void
 strtol(str, base = 0)
        char *          str

diff --git a/ext/POSIX/lib/POSIX.pm b/ext/POSIX/lib/POSIX.pm
index 3daa2f3..0b61237 100644 (file)
--- a/ext/POSIX/lib/POSIX.pm
+++ b/ext/POSIX/lib/POSIX.pm
@@ -329,7 +329,7 @@ our %EXPORT_TAGS = (
     stdlib_h =>        [qw(EXIT_FAILURE EXIT_SUCCESS MB_CUR_MAX NULL RAND_MAX
                abort atexit atof atoi atol bsearch calloc div
                free getenv labs ldiv malloc mblen mbstowcs mbtowc
-               qsort realloc strtod strtol strtoul wcstombs wctomb)],
+               qsort realloc strtod strtol strtold strtoul wcstombs wctomb)],
 
     string_h =>        [qw(NULL memchr memcmp memcpy memmove memset strcat
                strchr strcmp strcoll strcpy strcspn strerror strlen

diff --git a/ext/POSIX/lib/POSIX.pod b/ext/POSIX/lib/POSIX.pod
index 677a599..73c500b 100644 (file)
--- a/ext/POSIX/lib/POSIX.pod
+++ b/ext/POSIX/lib/POSIX.pod
@@ -1543,6 +1543,11 @@ The second returned item and C<$!> can be used to check for valid input:
 
 When called in a scalar context strtol returns the parsed number.
 
+=item C<strtold>
+
+Like L</strtod> but for long doubles.  Defined only if the
+system supports long doubles.
+
 =item C<strtoul>
 
 String to unsigned (long) integer translation.  C<strtoul()> is identical

diff --git a/ext/POSIX/t/export.t b/ext/POSIX/t/export.t
index f76c60c..afcd097 100644 (file)
--- a/ext/POSIX/t/export.t
+++ b/ext/POSIX/t/export.t
@@ -96,10 +96,10 @@ my %expect = (
                  sinh sscanf stderr stdin stdout strcat strchr strcmp strcoll
                  strcpy strcspn strerror strftime strlen strncat strncmp
                  strncpy strpbrk strrchr strspn strstr strtod strtok strtol
-                 strtoul strxfrm sysconf tan tanh tcdrain tcflow tcflush
-                 tcgetattr tcgetpgrp tcsendbreak tcsetattr tcsetpgrp tmpfile
-                 tmpnam tolower toupper ttyname tzname tzset uname ungetc
-                 vfprintf vprintf vsprintf wcstombs wctomb)],
+                 strtold strtoul strxfrm sysconf tan tanh tcdrain tcflow
+                 tcflush tcgetattr tcgetpgrp tcsendbreak tcsetattr tcsetpgrp
+                 tmpfile tmpnam tolower toupper ttyname tzname tzset uname
+                 ungetc vfprintf vprintf vsprintf wcstombs wctomb)],
     EXPORT_OK => [qw(abs alarm atan2 chdir chmod chown close closedir cos exit
                     exp fcntl fileno fork getc getgrgid getgrnam getlogin
                     getpgrp getppid getpwnam getpwuid gmtime kill lchown link

diff --git a/ext/POSIX/t/posix.t b/ext/POSIX/t/posix.t
index c2e4abe..da4aba8 100644 (file)
--- a/ext/POSIX/t/posix.t
+++ b/ext/POSIX/t/posix.t
@@ -8,7 +8,7 @@ BEGIN {
     }
 }
 
-use Test::More tests => 109;
+use Test::More tests => 111;
 
 use POSIX qw(fcntl_h signal_h limits_h _exit getcwd open read strftime write
             errno localeconv dup dup2 lseek access);
@@ -176,6 +176,22 @@ SKIP: {
 }
 
 SKIP: {
+    skip("strtold() not present", 2) unless $Config{d_strtold};
+
+    if ($Config{d_setlocale}) {
+        $lc = &POSIX::setlocale(&POSIX::LC_NUMERIC);
+        &POSIX::setlocale(&POSIX::LC_NUMERIC, 'C');
+    }
+
+    # we're just checking that strtold works, not how accurate it is
+    ($n, $x) = &POSIX::strtod('2.718_ISH');
+    cmp_ok(abs("2.718" - $n), '<', 1e-6, 'strtold works');
+    is($x, 4, 'strtold works');
+
+    &POSIX::setlocale(&POSIX::LC_NUMERIC, $lc) if $Config{d_setlocale};
+}
+
+SKIP: {
     skip("strtol() not present", 2) unless $Config{d_strtol};
 
     ($n, $x) = &POSIX::strtol('21_PENGUINS');