stock perl 5.8.0 from CPAN

2 files changed, 370 insertions, 0 deletions

diff --git a/gnu/usr.bin/perl/uts/sprintf_wrap.c b/gnu/usr.bin/perl/uts/sprintf_wrap.c
new file mode 100644
index 00000000000..e86eae084b9
--- /dev/null
+++ b/gnu/usr.bin/perl/uts/sprintf_wrap.c
@@ -0,0 +1,196 @@
+#include	<stdlib.h>
+#include	<stdio.h>
+#include	<assert.h>
+#include	<string.h>
+
+char	*UTS_sprintf_wrap();
+char	*do_efmt();
+char	*do_gfmt();
+char	*Fill();
+
+/* main(argc, argv)
+ * char	**argv;
+ * {
+ * 	double	d;
+ * 	char	*Fmt, *Ret;
+ * 	char	obuf[200];
+ * 
+ * 	assert(argc > 2);
+ * 	Fmt = argv[1];
+ * 	d = strtod(argv[2], (char **)0);
+ * 
+ * 	putchar('{');
+ * 	printf(Fmt, d);
+ * 	printf("}\n");
+ * 
+ * 	Ret = UTS_sprintf_wrap(obuf, Fmt, d);
+ * 	assert(Ret == obuf);
+ * 
+ * 	printf("{%s}\n", obuf);
+ * }
+ */
+
+char *
+UTS_sprintf_wrap(obuf, fmt, d,
+	a0,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,a15)
+char	*obuf, *fmt;
+double	d;
+{
+	int	fmtlen, Width=0, Precision=6, Alt=0, Plus=0, Minus=0,
+		Zero = 0;
+	int	FmtChar, BaseFmt = 0;
+	char	*f = fmt, *AfterWidth = 0, *AfterPrecision = 0;
+	char	*Dot;
+
+	if(*f++ != '%') {
+		return
+sprintf(obuf, fmt, d, a0,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,a15);
+	}
+	fmtlen = strlen(fmt);
+	FmtChar = fmt[fmtlen - 1];
+	switch(FmtChar) {
+	case 'f':
+	case 'F':
+		return
+sprintf(obuf, fmt, d, a0,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,a15);
+	case 'e':
+	case 'E':
+		BaseFmt = 'e';
+		goto BaseFmt_IsSet;
+	case 'g':
+	case 'G':
+		BaseFmt = 'g';
+BaseFmt_IsSet:
+		if(*f == '#') { Alt = 1; ++f; }   /* Always has '.' */
+		if(*f == '+') { Plus = 1; ++f; }  /* Force explicit sign */
+		if(*f == '-') { Minus = 1; ++f; } /* Left justify */
+		if(*f == '0') { Zero = 1; ++f;} /* Fill using 0s*/
+		if(Dot = strchr(f, '.')) {
+			Precision = strtol(Dot+1, &AfterPrecision, 0);
+		}
+		if(!Dot || (Dot && Dot > f)) { /* Next char=='.' => no width*/
+			Width = strtol(f, &AfterWidth, 0);
+		}
+		if(Dot) { f = AfterPrecision; }
+		else if(AfterWidth) { f = AfterWidth; }
+		if(*f != FmtChar) goto regular_sprintf;
+		 /* It doesn't look like a f.p. sprintf call */
+		 /* from Perl_sv_vcatpvfn		     */
+
+		if(BaseFmt == 'e') {
+			return do_efmt(d, obuf, Width, Precision, Alt,
+				Plus, Minus, Zero, FmtChar == 'E');
+		} else {
+			return do_gfmt(d, obuf, Width, Precision, Alt,
+				Plus, Minus, Zero, FmtChar == 'G');
+		}
+	default:
+regular_sprintf:
+		return
+sprintf(obuf, fmt, d, a0,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,a15);
+	}
+}
+
+char	*
+do_efmt(d, obuf, Width, Precision, Alt, Plus, Minus, Zero, UpperCase)
+char	*obuf;
+double	d;
+{
+	char	*Ecvt;
+	char	*ob;
+	int	decpt, sign, E;
+	int	len;
+	int	AllZeroes = 0;
+
+	Ecvt = ecvt( d , Precision+1, &decpt, &sign);
+
+	/* fprintf(stderr, "decpt=%d, sign=%d\n", decpt, sign); */
+
+	len = strlen(Ecvt);
+	if(strspn(Ecvt, "0") == len) AllZeroes = 1;
+
+	ob = obuf;
+	if(sign)	*ob++ = '-';
+	else if(Plus)	*ob++ = '+';
+
+	*ob++ = Ecvt[0];
+
+	if(Precision > 0 || Alt) *ob++ = '.';
+	strcpy(ob, &Ecvt[1]);
+
+	ob += strlen(ob);	/* ADVANCE TO END OF WHAT WE JUST ADDED */
+	*ob++ = UpperCase ? 'E' : 'e';
+
+	if(AllZeroes)	E = 0;
+	else		E = decpt - 1;
+
+	if(E < 0)	{ *ob++ = '-'; E = -E; }
+	else		{ *ob++ = '+'; }
+
+	sprintf(ob, "%.2d", E);	/* Too much horsepower used here */
+
+	if(Width > strlen(obuf)) return Fill(obuf, Width, Minus, Zero);
+	else			 return obuf;
+}
+
+char	*
+do_gfmt(d, obuf, Width, Precision, Alt, Plus, Minus, Zero, UpperCase)
+char	*obuf;
+double	d;
+{
+	char	*Ecvt = gcvt(d, Precision ? Precision : 1, obuf);
+	int	len = strlen(obuf);
+
+	 /* gcvt fails (maybe give a warning? For now return empty string): */
+	if(!Ecvt) { *obuf = '\0'; return obuf; }
+
+	/* printf("Ecvt='%s'\n", Ecvt); */
+	if(Plus && (Ecvt[0] != '-')) {
+		memmove(obuf+1, obuf, len+1); /* "+1" to get '\0' at end */
+		obuf[0] = '+';
+		++len;
+	}
+	if(Alt && !strchr(Ecvt, '.')) {
+		int	LenUpTo_E = strcspn(obuf, "eE");
+		int	E_etc_len = strlen(&obuf[LenUpTo_E]);
+			/* ABOVE: Will be 0 if there's no E/e because */
+			/* strcspn will return length of whole string */
+
+		if(E_etc_len)
+			memmove(obuf+LenUpTo_E+1, obuf+LenUpTo_E, E_etc_len);
+		obuf[LenUpTo_E] = '.';
+		obuf[LenUpTo_E + 1 + E_etc_len ] = '\0';
+	}
+	{ char *E_loc;
+	  if(UpperCase && (E_loc = strchr(obuf, 'e'))) { *E_loc = 'E'; }
+	}
+	if(Width > len)
+		return Fill(obuf, Width, Minus, Zero);
+	else
+		return obuf;
+}
+
+char *
+Fill(obuf, Width, LeftJustify, Zero)
+char	*obuf;
+{
+	int	W = strlen(obuf);
+	int	diff = Width - W;
+	 /* LeftJustify means there was a '-' flag, and in that case,	*/
+	 /* printf man page (UTS4.4) says ignore '0'			*/
+	char	FillChar = (Zero && !LeftJustify) ? '0' : ' ';
+	int	i;
+	int	LeftFill = ! LeftJustify;
+
+	if(Width <= W) return obuf;
+
+	if(LeftFill) {
+		memmove(obuf+diff, obuf, W+1); /* "+1" to get '\0' at end */
+		for(i=0 ; i < diff ; ++i) { obuf[i] = FillChar; }
+	} else {
+		for(i=W ; i < Width ; ++i)
+			obuf[i] = FillChar;
+		obuf[Width] = '\0';
+	}
+	return obuf;
+}
diff --git a/gnu/usr.bin/perl/uts/strtol_wrap.c b/gnu/usr.bin/perl/uts/strtol_wrap.c
new file mode 100644
index 00000000000..24bb05542f5
--- /dev/null
+++ b/gnu/usr.bin/perl/uts/strtol_wrap.c
@@ -0,0 +1,174 @@
+/* A wrapper around strtol() and strtoul() to correct some
+ * "out of bounds" cases that don't work well on at least UTS.
+ * If a value is Larger than the max, strto[u]l should return
+ * the max value, and set errno to ERANGE
+ *  The same if a value is smaller than the min value (only
+ * relevant for strtol(); not strtoul()), except the minimum
+ * value is returned (and errno == ERANGE).
+ */
+
+#include	<ctype.h>
+#include	<string.h>
+#include	<sys/errno.h>
+#include	<stdlib.h>
+
+extern int	errno;
+
+#undef	I32
+#undef	U32
+
+#define	I32	int
+#define	U32	unsigned int
+
+struct	base_info {
+	char	*ValidChars;
+
+	char	*Ulong_max_str;
+	char	*Long_max_str;
+	char	*Long_min_str;	/* Absolute value */
+
+	int	Ulong_max_str_len;
+	int	Long_max_str_len;
+	int	Long_min_str_len;	/* Absolute value */
+
+	U32	Ulong_max;
+	I32	Long_max;
+	I32	Long_min;	/* NOT Absolute value */
+};
+static struct	base_info Base_info[37];
+
+static struct base_info Base_info_16 = {
+	"0123456789abcdefABCDEF",
+	"4294967295", "2147483648" /* <== ABS VAL */ , "2147483647",
+	10, 10, 10,
+	4294967295, 2147483647, - 2147483648,
+};
+
+static struct base_info Base_info_10 = {
+	"0123456789",
+	"4294967295", "2147483648" /* <== ABS VAL */ , "2147483647",
+	10, 10, 10,
+	4294967295, 2147483647, - 2147483648,
+};
+
+ /* Used eventually (if this is fully developed) to hold info
+  * for processing bases 2-36.  So that we can just plug the
+  * base in as a selector for its info, we sacrifice
+  * Base_info[0] and Base_info[1] (unless they are used
+  * at some point for special information).
+  */
+
+/* This may be replaced later by something more universal */
+static void
+init_Base_info()
+{
+	if(Base_info[10].ValidChars) return;
+	Base_info[10] = Base_info_10;
+	Base_info[16] = Base_info_16;
+}
+
+unsigned int
+strtoul_wrap32(char *s, char **pEnd, int base)
+{
+	int	Len;
+	int	isNegated = 0;
+	char	*sOrig = s;
+
+	init_Base_info();
+
+	while(*s && isspace(*s)) ++s;
+
+	if(*s == '-') {
+		++isNegated;
+		++s;
+		while(*s && isspace(*s)) ++s;
+	}
+	if(base == 0) {
+		if(*s == '0') {
+			if(s[1] == 'x' || s[1] == 'X') {
+				s += 2;
+				base = 16;
+			} else {
+				++s;
+				base = 8;
+			}
+		} else if(isdigit(*s)) {
+			base = 10;
+		}
+	}
+	if(base != 10) {
+		return strtoul(sOrig, pEnd, base);
+	}
+	
+	Len = strspn(s, Base_info[base].ValidChars);
+
+	if(Len > Base_info[base].Ulong_max_str_len
+		||
+	   (Len == Base_info[base].Ulong_max_str_len
+	   		&&
+	    strncmp(Base_info[base].Ulong_max_str, s, Len) < 0)
+	  ) {
+		/* In case isNegated is set - what to do?? */
+		/* Mightn't we say a negative number is ERANGE for strtoul? */
+		errno = ERANGE;
+		return Base_info[base].Ulong_max;
+	}
+
+	return strtoul(sOrig, pEnd, base);
+}
+
+int
+strtol_wrap32(char *s, char **pEnd, int base)
+{
+	int	Len;
+	int	isNegated = 0;
+	char	*sOrig = s;
+
+	init_Base_info();
+
+	while(*s && isspace(*s)) ++s;
+
+	if(*s == '-') {
+		++isNegated;
+		++s;
+		while(*s && isspace(*s)) ++s;
+	}
+	if(base == 0) {
+		if(*s == '0') {
+			if(s[1] == 'x' || s[1] == 'X') {
+				s += 2;
+				base = 16;
+			} else {
+				++s;
+				base = 8;
+			}
+		} else if(isdigit(*s)) {
+			base = 10;
+		}
+	}
+	if(base != 10) {
+		return strtol(sOrig, pEnd, base);
+	}
+	
+	Len = strspn(s, Base_info[base].ValidChars);
+
+	if(Len > Base_info[base].Long_max_str_len
+				||
+	   (!isNegated && Len == Base_info[base].Long_max_str_len
+	   	&&
+	    strncmp(Base_info[base].Long_max_str, s, Len) < 0)
+	    			||
+	   (isNegated && Len == Base_info[base].Long_min_str_len
+	   	&&
+	    strncmp(Base_info[base].Long_min_str, s, Len) < 0)
+	  ) {
+		/* In case isNegated is set - what to do?? */
+		/* Mightn't we say a negative number is ERANGE for strtol? */
+		errno = ERANGE;
+		return(isNegated ? Base_info[base].Long_min
+					:
+				   Base_info[base].Long_min);
+	}
+
+	return strtol(sOrig, pEnd, base);
+}