summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2005-09-09 17:47:18 (GMT)
committerdgp <dgp@users.sourceforge.net>2005-09-09 17:47:18 (GMT)
commit90b8834c64cb9d111fb0f663393cd5b0696df6cb (patch)
tree80077a3970c52480b94b10b1c8dbe7282cf8f4aa
parent0fa613150f4fab3a1cb24978c8c342293dcf3e56 (diff)
downloadtcl-90b8834c64cb9d111fb0f663393cd5b0696df6cb.zip
tcl-90b8834c64cb9d111fb0f663393cd5b0696df6cb.tar.gz
tcl-90b8834c64cb9d111fb0f663393cd5b0696df6cb.tar.bz2
* generic/tclInt.h: New internal routine TclObjPrintf()
* generic/tclStringObj.c: is similar to TclFormatObj() but accepts arguments in non-Tcl_Obj format.
-rw-r--r--ChangeLog4
-rw-r--r--generic/tclInt.h3
-rw-r--r--generic/tclStringObj.c131
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