Re: strtod / strtol patch for POSIX module

6 files changed, 201 insertions, 30 deletions

diff --git a/Configure b/Configure
index 36f612cba3..f1c6f92ab6 100755
--- a/Configure
+++ b/Configure
@@ -394,6 +394,9 @@ d_strerrm=''
 d_strerror=''
 d_sysernlst=''
 d_syserrlst=''
+d_strtod=''
+d_strtol=''
+d_strtoul=''
 d_strxfrm=''
 d_symlink=''
 d_syscall=''
@@ -7598,6 +7601,18 @@ else
 	d_strerrm='"unknown"'
 fi
 
+: see if strtod exists
+set strtod d_strtod
+eval $inlibc
+
+: see if strtol exists
+set strtol d_strtol
+eval $inlibc
+
+: see if strtoul exists
+set strtoul d_strtoul
+eval $inlibc
+
 : see if strxfrm exists
 set strxfrm d_strxfrm
 eval $inlibc
@@ -9444,19 +9459,24 @@ known_extensions=''
 : some additional extensions into the source tree and expect them
 : to be built.
 for xxx in * ; do
-	if $test -f $xxx/$xxx.xs; then
-		known_extensions="$known_extensions $xxx"
-	else
-		if $test -d $xxx; then
-			cd $xxx
-			for yyy in * ; do
-				if $test -f $yyy/$yyy.xs; then
-					known_extensions="$known_extensions $xxx/$yyy"
-				fi
-			done
-			cd ..
-		fi
-	fi
+	case "$xxx" in
+	DynaLoader)
+		known_extensions="$known_extensions $xxx" ;;
+	*)
+		if $test -f $xxx/$xxx.xs; then
+			known_extensions="$known_extensions $xxx"
+		else
+			if $test -d $xxx; then
+				cd $xxx
+				for yyy in * ; do
+					if $test -f $yyy/$yyy.xs; then
+						known_extensions="$known_extensions $xxx/$yyy"
+					fi
+				done
+				cd ..
+			fi
+		fi ;;
+	esac
 done
 set X $known_extensions
 shift
@@ -9845,6 +9865,9 @@ d_strcoll='$d_strcoll'
 d_strctcpy='$d_strctcpy'
 d_strerrm='$d_strerrm'
 d_strerror='$d_strerror'
+d_strtod='$d_strtod'
+d_strtol='$d_strtol'
+d_strtoul='$d_strtoul'
 d_strxfrm='$d_strxfrm'
 d_suidsafe='$d_suidsafe'
 d_symlink='$d_symlink'
diff --git a/config_h.SH b/config_h.SH
index 1f1880964f..0a8bc626da 100644
--- a/config_h.SH
+++ b/config_h.SH
@@ -800,6 +800,24 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un-
 #$d_syserrlst HAS_SYS_ERRLIST	/**/
 #define Strerror(e) $d_strerrm
 
+/* HAS_STRTOD:
+ *	This symbol, if defined, indicates that the strtod routine is
+ *	available to translate strings to doubles.
+ */
+#$d_strtod HAS_STRTOD	/**/
+
+/* HAS_STRTOL:
+ *	This symbol, if defined, indicates that the strtol routine is
+ *	available to translate strings to integers.
+ */
+#$d_strtol HAS_STRTOL	/**/
+
+/* HAS_STRTOUL:
+ *	This symbol, if defined, indicates that the strtoul routine is
+ *	available to translate strings to integers.
+ */
+#$d_strtoul HAS_STRTOUL	/**/
+
 /* HAS_STRXFRM:
  *	This symbol, if defined, indicates that the strxfrm() routine is
  *	available to transform strings.
diff --git a/ext/POSIX/POSIX.pm b/ext/POSIX/POSIX.pm
index 66b55c1565..22eed0283b 100644
--- a/ext/POSIX/POSIX.pm
+++ b/ext/POSIX/POSIX.pm
@@ -96,7 +96,7 @@ $VERSION = "1.00" ;
     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 stroul wcstombs wctomb)],
+		qsort realloc strtod strtol strtoul wcstombs wctomb)],
 
     string_h =>	[qw(NULL memchr memcmp memcpy memmove memset strcat
 		strchr strcmp strcoll strcpy strcspn strerror strlen
@@ -628,18 +628,6 @@ sub srand {
     unimpl "srand()";
 }
 
-sub strtod {
-    unimpl "strtod() is C-specific, stopped";
-}
-
-sub strtol {
-    unimpl "strtol() is C-specific, stopped";
-}
-
-sub stroul {
-    unimpl "stroul() is C-specific, stopped";
-}
-
 sub system {
     usage "system(command)" if @_ != 1;
     system($_[0]);
diff --git a/ext/POSIX/POSIX.pod b/ext/POSIX/POSIX.pod
index a8cd0d1ca0..7dee4a3652 100644
--- a/ext/POSIX/POSIX.pod
+++ b/ext/POSIX/POSIX.pod
@@ -1060,7 +1060,26 @@ This is identical to Perl's builtin C<index()> function.
 
 =item strtod
 
-strtod() is C-specific.
+String to double translation. Returns the parsed number and the number
+of characters in the unparsed portion of the string.  Truly
+POSIX-compliant systems set $! ($ERRNO) to indicate a translation
+error, so clear $! before calling strtod.  However, non-POSIX systems
+may not check for overflow, and therefore will never set $!.
+
+strtod should respect any POSIX I<setlocale()> settings.
+
+To parse a string $str as a floating point number use
+
+    $! = 0;
+    ($num, $n_unparsed) = POSIX::strtod($str);
+
+The second returned item and $! can be used to check for valid input:
+
+    if (($str eq '') || ($n_unparsed != 0) || !$!) {
+        die "Non-numeric input $str" . $! ? ": $!\n" : "\n";
+    }
+
+When called in a scalar context strtod returns the parsed number.
 
 =item strtok
 
@@ -1068,7 +1087,42 @@ strtok() is C-specific.
 
 =item strtol
 
-strtol() is C-specific.
+String to (long) integer translation.  Returns the parsed number and
+the number of characters in the unparsed portion of the string.  Truly
+POSIX-compliant systems set $! ($ERRNO) to indicate a translation
+error, so clear $! before calling strtol.  However, non-POSIX systems
+may not check for overflow, and therefore will never set $!.
+
+strtol should respect any POSIX I<setlocale()> settings.
+
+To parse a string $str as a number in some base $base use
+
+    $! = 0;
+    ($num, $n_unparsed) = POSIX::strtol($str, $base);
+
+The base should be zero or between 2 and 36, inclusive.  When the base
+is zero or omitted strtol will use the string itself to determine the
+base: a leading "0x" or "0X" means hexadecimal; a leading "0" means
+octal; any other leading characters mean decimal.  Thus, "1234" is
+parsed as a decimal number, "01234" as an octal number, and "0x1234"
+as a hexadecimal number.
+
+The second returned item and $! can be used to check for valid input:
+
+    if (($str eq '') || ($n_unparsed != 0) || !$!) {
+        die "Non-numeric input $str" . $! ? ": $!\n" : "\n";
+    }
+
+When called in a scalar context strtol returns the parsed number.
+
+=item strtoul
+
+String to unsigned (long) integer translation.  strtoul is identical
+to strtol except that strtoul only parses unsigned integers.  See
+I<strtol> for details.
+
+Note: Some vendors supply strtod and strtol but not strtoul.
+Other vendors that do suply strtoul parse "-1" as a valid value.
 
 =item strxfrm
 
diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs
index def5fb1235..808ef8e030 100644
--- a/ext/POSIX/POSIX.xs
+++ b/ext/POSIX/POSIX.xs
@@ -191,6 +191,9 @@ typedef struct termios* POSIX__Termios;
 
 /* Possibly needed prototypes */
 char *cuserid _((char *));
+double strtod _((const char *, char **));
+long strtol _((const char *, char **, int));
+unsigned long strtoul _((const char *, char **, int));
 
 #ifndef HAS_CUSERID
 #define cuserid(a) (char *) not_here("cuserid")
@@ -227,6 +230,15 @@ char *cuserid _((char *));
 #ifndef HAS_STRCOLL
 #define strcoll(s1,s2) not_here("strcoll")
 #endif
+#ifndef HAS_STRTOD
+#define strtod(s1,s2) not_here("strtod")
+#endif
+#ifndef HAS_STRTOL
+#define strtol(s1,s2,b) not_here("strtol")
+#endif
+#ifndef HAS_STRTOUL
+#define strtoul(s1,s2,b) not_here("strtoul")
+#endif
 #ifndef HAS_STRXFRM
 #define strxfrm(s1,s2,n) not_here("strxfrm")
 #endif
@@ -3034,6 +3046,65 @@ strcoll(s1, s2)
 	char *		s1
 	char *		s2
 
+void
+strtod(str)
+	char *		str
+    PREINIT:
+	double num;
+	char *unparsed;
+    PPCODE:
+	num = strtod(str, &unparsed);
+	PUSHs(sv_2mortal(newSVnv(num)));
+	if (GIMME == G_ARRAY) {
+	    EXTEND(sp, 1);
+	    if (unparsed)
+		PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
+	    else
+		PUSHs(&sv_undef);
+	}
+
+void
+strtol(str, base = 0)
+	char *		str
+	int		base
+    PREINIT:
+	long num;
+	char *unparsed;
+    PPCODE:
+	num = strtol(str, &unparsed, base);
+	if (num >= IV_MIN && num <= IV_MAX)
+	    PUSHs(sv_2mortal(newSViv((IV)num)));
+	else
+	    PUSHs(sv_2mortal(newSVnv((double)num)));
+	if (GIMME == G_ARRAY) {
+	    EXTEND(sp, 1);
+	    if (unparsed)
+		PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
+	    else
+		PUSHs(&sv_undef);
+	}
+
+void
+strtoul(str, base = 0)
+	char *		str
+	int		base
+    PREINIT:
+	unsigned long num;
+	char *unparsed;
+    PPCODE:
+	num = strtoul(str, &unparsed, base);
+	if (num <= IV_MAX)
+	    PUSHs(sv_2mortal(newSViv((IV)num)));
+	else
+	    PUSHs(sv_2mortal(newSVnv((double)num)));
+	if (GIMME == G_ARRAY) {
+	    EXTEND(sp, 1);
+	    if (unparsed)
+		PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
+	    else
+		PUSHs(&sv_undef);
+	}
+
 SV *
 strxfrm(src)
 	SV *		src
diff --git a/t/lib/posix.t b/t/lib/posix.t
index 23007ff059..3adc602305 100755
--- a/t/lib/posix.t
+++ b/t/lib/posix.t
@@ -14,7 +14,7 @@ use POSIX qw(fcntl_h signal_h limits_h _exit getcwd open read write);
 use strict subs;
 
 $| = 1;
-print "1..14\n";
+print "1..17\n";
 
 $testfd = open("TEST", O_RDONLY, 0) and print "ok 1\n";
 read($testfd, $buffer, 9) if $testfd > 2;
@@ -58,8 +58,25 @@ print &_POSIX_OPEN_MAX > $fds[1] ? "ok 12\n" : "not ok 12\n";
 
 print getcwd() =~ m#/t$# ? "ok 13\n" : "not ok 13\n";
 
+# Check string conversion functions.
+
+if ($Config{d_strtod}) {
+    ($n, $x) = &POSIX::strtod('3.14159_OR_SO');
+    print (($n == 3.14159) && ($x == 6) ? "ok 14\n" : "not ok 14\n");
+} else { print "# strtod not present\n", "ok 14\n"; }
+
+if ($Config{d_strtol}) {
+    ($n, $x) = &POSIX::strtol('21_PENGUINS');
+    print (($n == 21) && ($x == 9) ? "ok 15\n" : "not ok 15\n");
+} else { print "# strtol not present\n", "ok 15\n"; }
+
+if ($Config{d_strtoul}) {
+    ($n, $x) = &POSIX::strtoul('88_TEARS');
+    print (($n == 88) && ($x == 6) ? "ok 16\n" : "not ok 16\n");
+} else { print "# strtoul not present\n", "ok 16\n"; }
+
 # Pick up whether we're really able to dynamically load everything.
-print &POSIX::acos(1.0) == 0.0 ? "ok 14\n" : "not ok 14\n";
+print &POSIX::acos(1.0) == 0.0 ? "ok 17\n" : "not ok 17\n";
 
 $| = 0;
 print '@#!*$@(!@#$';