1 files changed, 115 insertions, 77 deletions

diff --git a/generic/tclConfig.c b/generic/tclConfig.c
index 756b396..eb6807c 100644
--- a/generic/tclConfig.c
+++ b/generic/tclConfig.c
@@ -8,14 +8,10 @@
  *
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
- *
- * RCS: @(#) $Id: tclConfig.c,v 1.10 2005/11/01 15:30:52 dkf Exp $
  */
 
 #include "tclInt.h"
-
 
-
 /*
  * Internal structure to hold embedded configuration information.
  *
@@ -27,7 +23,19 @@
  * by the caller.
  */
 
-#define ASSOC_KEY "tclPackageAboutDict"
+#define ASSOC_KEY	"tclPackageAboutDict"
+
+/*
+ * A ClientData struct for the QueryConfig command.  Store the three bits
+ * of data we need; the package name for which we store a config dict,
+ * the (Tcl_Interp *) in which it is stored, and the encoding.
+ */
+
+typedef struct QCCD {
+    Tcl_Obj *pkg;
+    Tcl_Interp *interp;
+    char *encoding;
+} QCCD;
 
 /*
  * Static functions in this file:
@@ -35,9 +43,9 @@
 
 static int		QueryConfigObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
-			    struct Tcl_Obj * CONST * objv);
+			    struct Tcl_Obj *const *objv);
 static void		QueryConfigDelete(ClientData clientData);
-static Tcl_Obj *	GetConfigDict(Tcl_Interp* interp);
+static Tcl_Obj *	GetConfigDict(Tcl_Interp *interp);
 static void		ConfigDictDeleteProc(ClientData clientData,
 			    Tcl_Interp *interp);
 
@@ -61,71 +69,76 @@ void
 Tcl_RegisterConfig(
     Tcl_Interp *interp,		/* Interpreter the configuration command is
 				 * registered in. */
-    CONST char *pkgName,	/* Name of the package registering the
+    const char *pkgName,	/* Name of the package registering the
 				 * embedded configuration. ASCII, thus in
 				 * UTF-8 too. */
-    Tcl_Config *configuration,	/* Embedded configuration. */
-    CONST char *valEncoding)	/* Name of the encoding used to store the
+    const Tcl_Config *configuration,	/* Embedded configuration. */
+    const char *valEncoding)	/* Name of the encoding used to store the
 				 * configuration values, ASCII, thus UTF-8. */
 {
-    Tcl_Encoding venc = Tcl_GetEncoding(NULL, valEncoding);
-    Tcl_Obj *pDB = GetConfigDict(interp);
-    Tcl_Obj *pkg = Tcl_NewStringObj(pkgName, -1);
-    Tcl_Obj *pkgDict;
+    Tcl_Obj *pDB, *pkgDict;
     Tcl_DString cmdName;
-    Tcl_Config *cfg;
-    int res;
+    const Tcl_Config *cfg;
+    QCCD *cdPtr = ckalloc(sizeof(QCCD));
+
+    cdPtr->interp = interp;
+    if (valEncoding) {
+	cdPtr->encoding = ckalloc(strlen(valEncoding)+1);
+	strcpy(cdPtr->encoding, valEncoding);
+    } else {
+	cdPtr->encoding = NULL;
+    }
+    cdPtr->pkg = Tcl_NewStringObj(pkgName, -1);
 
     /*
      * Phase I: Adding the provided information to the internal database of
      * package meta data.
      *
      * Phase II: Create a command for querying this database, specific to the
-     * package registerting its configuration. This is the approved interface
+     * package registering its configuration. This is the approved interface
      * in TIP 59. In the future a more general interface should be done, as
-     * followup to TIP 59. Simply because our database is now general across
+     * follow-up to TIP 59. Simply because our database is now general across
      * packages, and not a structure tied to one package.
      *
      * Note, the created command will have a reference through its clientdata.
      */
 
-    Tcl_IncrRefCount(pkg);
+    Tcl_IncrRefCount(cdPtr->pkg);
+
+    /*
+     * For venc == NULL aka bogus encoding we skip the step setting up the
+     * dictionaries visible at Tcl level. I.e. they are not filled
+     */
+
+    pDB = GetConfigDict(interp);
 
     /*
      * Retrieve package specific configuration...
      */
 
-    res = Tcl_DictObjGet(interp, pDB, pkg, &pkgDict);
-    if ((TCL_OK != res) || (pkgDict == NULL)) {
-        pkgDict = Tcl_NewDictObj();
+    if (Tcl_DictObjGet(interp, pDB, cdPtr->pkg, &pkgDict) != TCL_OK
+	    || (pkgDict == NULL)) {
+	pkgDict = Tcl_NewDictObj();
     } else if (Tcl_IsShared(pkgDict)) {
-        pkgDict = Tcl_DuplicateObj(pkgDict);
+	pkgDict = Tcl_DuplicateObj(pkgDict);
     }
 
     /*
      * Extend the package configuration...
+     * We cannot assume that the encodings are initialized, therefore
+     * store the value as-is in a byte array. See Bug [9b2e636361].
      */
 
-    for (cfg=configuration ; (cfg->key!=NULL) && (cfg->key[0]!='\0') ; cfg++) {
-        Tcl_DString conv;
-	CONST char *convValue =
-		Tcl_ExternalToUtfDString(venc, cfg->value, -1, &conv);
-
-	/*
-	 * We know that the keys are in ASCII/UTF-8, so for them is no
-	 * conversion required.
-	 */
-
+    for (cfg=configuration ; cfg->key!=NULL && cfg->key[0]!='\0' ; cfg++) {
 	Tcl_DictObjPut(interp, pkgDict, Tcl_NewStringObj(cfg->key, -1),
-		Tcl_NewStringObj(convValue, -1));
-	Tcl_DStringFree(&conv);
+		Tcl_NewByteArrayObj((unsigned char *)cfg->value, strlen(cfg->value)));
     }
 
     /*
      * Write the changes back into the overall database.
      */
 
-    Tcl_DictObjPut(interp, pDB, pkg, pkgDict);
+    Tcl_DictObjPut(interp, pDB, cdPtr->pkg, pkgDict);
 
     /*
      * Now create the interface command for retrieval of the package
@@ -133,7 +146,7 @@ Tcl_RegisterConfig(
      */
 
     Tcl_DStringInit(&cmdName);
-    Tcl_DStringAppend(&cmdName, "::", -1);
+    TclDStringAppendLiteral(&cmdName, "::");
     Tcl_DStringAppend(&cmdName, pkgName, -1);
 
     /*
@@ -144,19 +157,19 @@ Tcl_RegisterConfig(
     if (Tcl_FindNamespace(interp, Tcl_DStringValue(&cmdName), NULL,
 	    TCL_GLOBAL_ONLY) == NULL) {
 	if (Tcl_CreateNamespace(interp, Tcl_DStringValue(&cmdName),
-		(ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL) == NULL) {
-	    Tcl_Panic("%s.\n%s %s", Tcl_GetStringResult(interp),
-		    "Tcl_RegisterConfig: Unable to create namespace for",
-		    "package configuration.");
+		NULL, NULL) == NULL) {
+	    Tcl_Panic("%s.\n%s: %s",
+		    Tcl_GetStringResult(interp), "Tcl_RegisterConfig",
+		    "Unable to create namespace for package configuration.");
 	}
     }
 
-    Tcl_DStringAppend(&cmdName, "::pkgconfig", -1);
+    TclDStringAppendLiteral(&cmdName, "::pkgconfig");
 
     if (Tcl_CreateObjCommand(interp, Tcl_DStringValue(&cmdName),
-	    QueryConfigObjCmd, (ClientData) pkg, QueryConfigDelete) == NULL) {
-        Tcl_Panic("%s %s", "Tcl_RegisterConfig: Unable to create query",
-		"command for package configuration");
+	    QueryConfigObjCmd, cdPtr, QueryConfigDelete) == NULL) {
+	Tcl_Panic("%s: %s", "Tcl_RegisterConfig",
+		"Unable to create query command for package configuration");
     }
 
     Tcl_DStringFree(&cmdName);
@@ -167,8 +180,8 @@ Tcl_RegisterConfig(
  *
  * QueryConfigObjCmd --
  *
- *	Implementation of "::<package>::pkgconfig", the command to
- *	query configuration information embedded into a binary library.
+ *	Implementation of "::<package>::pkgconfig", the command to query
+ *	configuration information embedded into a binary library.
  *
  * Results:
  *	A standard tcl result.
@@ -184,21 +197,24 @@ QueryConfigObjCmd(
     ClientData clientData,
     Tcl_Interp *interp,
     int objc,
-    struct Tcl_Obj * CONST *objv)
+    struct Tcl_Obj *const *objv)
 {
-    Tcl_Obj *pkgName = (Tcl_Obj *) clientData;
+    QCCD *cdPtr = clientData;
+    Tcl_Obj *pkgName = cdPtr->pkg;
     Tcl_Obj *pDB, *pkgDict, *val, *listPtr;
-    int n, i, res, index;
-
-    static CONST char *subcmdStrings[] = {
+    int n, index;
+    static const char *const subcmdStrings[] = {
 	"get", "list", NULL
     };
     enum subcmds {
 	CFG_GET, CFG_LIST
     };
+    Tcl_DString conv;
+    Tcl_Encoding venc = NULL;
+    const char *value;
 
     if ((objc < 2) || (objc > 3)) {
-	Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?argument?");
+	Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg?");
 	return TCL_ERROR;
     }
     if (Tcl_GetIndexFromObj(interp, objv[1], subcmdStrings, "subcommand", 0,
@@ -207,36 +223,54 @@ QueryConfigObjCmd(
     }
 
     pDB = GetConfigDict(interp);
-    res = Tcl_DictObjGet(interp, pDB, pkgName, &pkgDict);
-    if (res!=TCL_OK || pkgDict==NULL) {
-        /*
+    if (Tcl_DictObjGet(interp, pDB, pkgName, &pkgDict) != TCL_OK
+	    || pkgDict == NULL) {
+	/*
 	 * Maybe a Tcl_Panic is better, because the package data has to be
 	 * present.
 	 */
 
-        Tcl_SetObjResult(interp, Tcl_NewStringObj("package not known", -1));
+	Tcl_SetObjResult(interp, Tcl_NewStringObj("package not known", -1));
+	Tcl_SetErrorCode(interp, "TCL", "FATAL", "PKGCFG_BASE",
+		TclGetString(pkgName), NULL);
 	return TCL_ERROR;
     }
 
     switch ((enum subcmds) index) {
     case CFG_GET:
 	if (objc != 3) {
-	    Tcl_WrongNumArgs(interp, 1, objv, "get key");
+	    Tcl_WrongNumArgs(interp, 2, objv, "key");
 	    return TCL_ERROR;
 	}
 
-	res = Tcl_DictObjGet(interp, pkgDict, objv [2], &val);
-	if (res!=TCL_OK || val==NULL) {
+	if (Tcl_DictObjGet(interp, pkgDict, objv[2], &val) != TCL_OK
+		|| val == NULL) {
 	    Tcl_SetObjResult(interp, Tcl_NewStringObj("key not known", -1));
+	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONFIG",
+		    TclGetString(objv[2]), NULL);
 	    return TCL_ERROR;
 	}
 
-	Tcl_SetObjResult(interp, val);
+	if (cdPtr->encoding) {
+	    venc = Tcl_GetEncoding(interp, cdPtr->encoding);
+	    if (!venc) {
+		return TCL_ERROR;
+	    }
+	}
+	/*
+	 * Value is stored as-is in a byte array, see Bug [9b2e636361],
+	 * so we have to decode it first.
+	 */
+	value = (const char *) Tcl_GetByteArrayFromObj(val, &n);
+	value = Tcl_ExternalToUtfDString(venc, value, n, &conv);
+	Tcl_SetObjResult(interp, Tcl_NewStringObj(value,
+		Tcl_DStringLength(&conv)));
+	Tcl_DStringFree(&conv);
 	return TCL_OK;
 
     case CFG_LIST:
 	if (objc != 2) {
-	    Tcl_WrongNumArgs(interp, 1, objv, "list");
+	    Tcl_WrongNumArgs(interp, 2, objv, NULL);
 	    return TCL_ERROR;
 	}
 
@@ -244,25 +278,20 @@ QueryConfigObjCmd(
 	listPtr = Tcl_NewListObj(n, NULL);
 
 	if (!listPtr) {
-	    Tcl_SetObjResult(interp,
-		    Tcl_NewStringObj("insufficient memory to create list",-1));
+	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
+		    "insufficient memory to create list", -1));
+	    Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
 	    return TCL_ERROR;
 	}
 
 	if (n) {
-	    List *listRepPtr = (List *)
-		    listPtr->internalRep.twoPtrValue.ptr1;
 	    Tcl_DictSearch s;
-	    Tcl_Obj *key, **vals;
+	    Tcl_Obj *key;
 	    int done;
 
-	    listRepPtr->elemCount = n;
-	    vals = &listRepPtr->elements;
-
-	    for (i=0, Tcl_DictObjFirst(interp, pkgDict, &s, &key, NULL, &done);
-		    !done; Tcl_DictObjNext(&s, &key, NULL, &done), i++) {
-		vals[i] = key;
-		Tcl_IncrRefCount(key);
+	    for (Tcl_DictObjFirst(interp, pkgDict, &s, &key, NULL, &done);
+		    !done; Tcl_DictObjNext(&s, &key, NULL, &done)) {
+		Tcl_ListObjAppendElement(NULL, listPtr, key);
 	    }
 	}
 
@@ -297,8 +326,16 @@ static void
 QueryConfigDelete(
     ClientData clientData)
 {
-    Tcl_Obj *pkgName = (Tcl_Obj *) clientData;
+    QCCD *cdPtr = clientData;
+    Tcl_Obj *pkgName = cdPtr->pkg;
+    Tcl_Obj *pDB = GetConfigDict(cdPtr->interp);
+
+    Tcl_DictObjRemove(NULL, pDB, pkgName);
     Tcl_DecrRefCount(pkgName);
+    if (cdPtr->encoding) {
+	ckfree(cdPtr->encoding);
+    }
+    ckfree(cdPtr);
 }
 
 /*
@@ -340,7 +377,7 @@ GetConfigDict(
  *
  *	This function is associated with the "Package About dict" assoc data
  *	for an interpreter; it is invoked when the interpreter is deleted in
- *	order to free the information assoicated with any pending error
+ *	order to free the information associated with any pending error
  *	reports.
  *
  * Results:
@@ -357,7 +394,8 @@ ConfigDictDeleteProc(
     ClientData clientData,	/* Pointer to Tcl_Obj. */
     Tcl_Interp *interp)		/* Interpreter being deleted. */
 {
-    Tcl_Obj *pDB = (Tcl_Obj *) clientData;
+    Tcl_Obj *pDB = clientData;
+
     Tcl_DecrRefCount(pDB);
 }