* generic/tclInt.h: New internal routine TclObjPrintf()

        * generic/tclStringObj.c:       is similar to TclFormatObj() but
        accepts arguments in non-Tcl_Obj format.

3 files changed, 136 insertions, 2 deletions

diff --git a/ChangeLog b/ChangeLog
index 7a4ae40..f059824 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -5,6 +5,10 @@
 	
 2005-09-09  Don Porter  <dgp@users.sourceforge.net>
 
+	* generic/tclInt.h:		New internal routine TclObjPrintf()
+	* generic/tclStringObj.c:	is similar to TclFormatObj() but
+	accepts arguments in non-Tcl_Obj format.
+
 	* generic/tclInt.h:		New internal routines TclFormatObj()
 	* generic/tclStringObj.c:	and TclAppendFormattedObjs() to offer
 	sprintf()-like means to append to Tcl_Obj.  Work in progress toward
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 25b4b78..689f95f 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -12,7 +12,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclInt.h,v 1.249 2005/09/09 15:44:27 dgp Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.250 2005/09/09 17:47:18 dgp Exp $
  */
 
 #ifndef _TCLINT
@@ -2053,6 +2053,7 @@ MODULE_SCOPE int	TclMergeReturnOptions(Tcl_Interp *interp, int objc,
 MODULE_SCOPE int	TclObjInvokeNamespace(Tcl_Interp *interp,
 			    int objc, Tcl_Obj *CONST objv[],
 			    Tcl_Namespace *nsPtr, int flags);
+MODULE_SCOPE int	TclObjPrintf TCL_VARARGS(Tcl_Interp *, arg1);
 MODULE_SCOPE int	TclParseBackslash(CONST char *src,
 			    int numBytes, int *readPtr, char *dst);
 MODULE_SCOPE int	TclParseHex(CONST char *src, int numBytes,
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index f048540..be926fe 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -33,7 +33,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclStringObj.c,v 1.40 2005/09/09 17:19:19 kennykb Exp $ */
+ * RCS: @(#) $Id: tclStringObj.c,v 1.41 2005/09/09 17:47:19 dgp Exp $ */
 
 #include "tclInt.h"
 
@@ -54,6 +54,8 @@ static void		AppendUtfToUtfRep _ANSI_ARGS_((Tcl_Obj *objPtr,
 static void		FillUnicodeRep _ANSI_ARGS_((Tcl_Obj *objPtr));
 static int		FormatObjVA _ANSI_ARGS_((Tcl_Interp *interp,
 			    va_list argList));
+static int		ObjPrintfVA _ANSI_ARGS_((Tcl_Interp *interp,
+			    va_list argList));
 static void		FreeStringInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr));
 static void		DupStringInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr,
 			    Tcl_Obj *copyPtr));
@@ -2269,6 +2271,133 @@ TclFormatObj TCL_VARARGS_DEF(Tcl_Interp *,arg1)
 /*
  *---------------------------------------------------------------------------
  *
+ * ObjPrintfVA --
+ *
+ * Results:
+ *
+ * Side effects:
+ *
+ *---------------------------------------------------------------------------
+ */
+
+static int
+ObjPrintfVA(interp, argList)
+    Tcl_Interp *interp;
+    va_list argList;
+{
+    int code, objc;
+    Tcl_Obj **objv, *element, *list = Tcl_NewObj();
+    CONST char *format, *p;
+    Tcl_Obj *objPtr = va_arg(argList, Tcl_Obj *);
+
+    if (objPtr == NULL) {
+	Tcl_Panic("TclObjPrintf: no Tcl_Obj to append to");
+    }
+
+    p = format = va_arg(argList, CONST char *);
+    if (format == NULL) {
+	Tcl_Panic("TclObjPrintf: no format string argument");
+    }
+
+    Tcl_IncrRefCount(list);
+    while (*p != '\0') {
+	int size = 0;
+	int seekingConversion = 1;
+	if (*p++ != '%') {
+	    continue;
+	}
+	if (*p == '%') {
+	    p++;
+	    continue;
+	}
+	do {
+	    switch (*p) {
+
+	    case '\0':
+		seekingConversion = 0;
+		break;
+	    case 's':
+		Tcl_ListObjAppendElement(NULL, list, Tcl_NewStringObj(
+			va_arg(argList, char *), -1));
+		seekingConversion = 0;
+		break;
+	    case 'c':
+	    case 'i':
+	    case 'u':
+	    case 'd':
+	    case 'o':
+	    case 'x':
+	    case 'X':
+		seekingConversion = 0;
+		switch (size) {
+		case -1:
+		    Tcl_ListObjAppendElement(NULL, list, Tcl_NewLongObj(
+			    (long int)va_arg(argList, short int)));
+		    break;
+		case 0:
+		    Tcl_ListObjAppendElement(NULL, list, Tcl_NewLongObj(
+			    (long int)va_arg(argList, int)));
+		    break;
+		case 1:
+		    Tcl_ListObjAppendElement(NULL, list, Tcl_NewLongObj(
+			    va_arg(argList, long int)));
+		    break;
+		}
+		break;
+	    case 'e':
+	    case 'E':
+	    case 'f':
+	    case 'g':
+	    case 'G':
+		Tcl_ListObjAppendElement(NULL, list, Tcl_NewDoubleObj(
+			va_arg(argList, double)));
+		seekingConversion = 0;
+		break;
+	    case 'l':
+		size = 1;
+		p++;
+		break;
+	    case 'h':
+		size = -1;
+	    default:
+		p++;
+	    }
+	} while (seekingConversion);
+    }
+    Tcl_ListObjGetElements(NULL, list, &objc, &objv);
+    code = TclAppendFormattedObjs(interp, objPtr, format, objc, objv);
+    Tcl_DecrRefCount(list);
+    return code;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclObjPrintf --
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ * 	None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+TclObjPrintf TCL_VARARGS_DEF(Tcl_Interp *,arg1)
+{
+    va_list argList;
+    int result;
+    Tcl_Interp *interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
+    result = ObjPrintfVA(interp, argList);
+    va_end(argList);
+    return result;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
  * FillUnicodeRep --
  *
  *	Populate the Unicode internal rep with the Unicode form of its string