summaryrefslogtreecommitdiffstats
path: root/generic/tclConfig.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclConfig.c')
-rw-r--r--generic/tclConfig.c143
1 files changed, 76 insertions, 67 deletions
diff --git a/generic/tclConfig.c b/generic/tclConfig.c
index 0bcd0d8..2fb3e92 100644
--- a/generic/tclConfig.c
+++ b/generic/tclConfig.c
@@ -8,8 +8,6 @@
*
* 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.25 2009/01/09 11:21:45 dkf Exp $
*/
#include "tclInt.h"
@@ -28,14 +26,15 @@
#define ASSOC_KEY "tclPackageAboutDict"
/*
- * A ClientData struct for the QueryConfig command. Store the two bits
+ * 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,
- * and the (Tcl_Interp *) in which it is stored.
+ * the (Tcl_Interp *) in which it is stored, and the encoding.
*/
typedef struct QCCD {
Tcl_Obj *pkg;
Tcl_Interp *interp;
+ char *encoding;
} QCCD;
/*
@@ -77,22 +76,28 @@ Tcl_RegisterConfig(
const char *valEncoding) /* Name of the encoding used to store the
* configuration values, ASCII, thus UTF-8. */
{
+ Tcl_Obj *pDB, *pkgDict;
Tcl_DString cmdName;
const Tcl_Config *cfg;
- Tcl_Encoding venc = Tcl_GetEncoding(NULL, valEncoding);
- QCCD *cdPtr = (QCCD *) ckalloc(sizeof(QCCD));
+ 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. Only if we have an ok encoding.
+ * 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.
@@ -105,51 +110,35 @@ Tcl_RegisterConfig(
* dictionaries visible at Tcl level. I.e. they are not filled
*/
- if (venc != NULL) {
- Tcl_Obj *pkgDict, *pDB = GetConfigDict(interp);
-
- /*
- * Retrieve package specific configuration...
- */
-
- if (Tcl_DictObjGet(interp, pDB, cdPtr->pkg, &pkgDict) != TCL_OK
- || (pkgDict == NULL)) {
- pkgDict = Tcl_NewDictObj();
- } else if (Tcl_IsShared(pkgDict)) {
- pkgDict = Tcl_DuplicateObj(pkgDict);
- }
-
- /*
- * Extend the package configuration...
- */
-
- for (cfg=configuration ; cfg->key!=NULL && cfg->key[0]!='\0' ; cfg++) {
- Tcl_DString conv;
- const char *convValue =
- Tcl_ExternalToUtfDString(venc, cfg->value, -1, &conv);
+ pDB = GetConfigDict(interp);
- /*
- * We know that the keys are in ASCII/UTF-8, so for them is no
- * conversion required.
- */
+ /*
+ * Retrieve package specific configuration...
+ */
- Tcl_DictObjPut(interp, pkgDict, Tcl_NewStringObj(cfg->key, -1),
- Tcl_NewStringObj(convValue, -1));
- Tcl_DStringFree(&conv);
- }
+ if (Tcl_DictObjGet(interp, pDB, cdPtr->pkg, &pkgDict) != TCL_OK
+ || (pkgDict == NULL)) {
+ pkgDict = Tcl_NewDictObj();
+ } else if (Tcl_IsShared(pkgDict)) {
+ pkgDict = Tcl_DuplicateObj(pkgDict);
+ }
- /*
- * We're now done with the encoding, so drop it.
- */
+ /*
+ * 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].
+ */
- Tcl_FreeEncoding(venc);
+ for (cfg=configuration ; cfg->key!=NULL && cfg->key[0]!='\0' ; cfg++) {
+ Tcl_DictObjPut(interp, pkgDict, Tcl_NewStringObj(cfg->key, -1),
+ Tcl_NewByteArrayObj((unsigned char *)cfg->value, strlen(cfg->value)));
+ }
- /*
- * Write the changes back into the overall database.
- */
+ /*
+ * Write the changes back into the overall database.
+ */
- Tcl_DictObjPut(interp, pDB, cdPtr->pkg, pkgDict);
- }
+ Tcl_DictObjPut(interp, pDB, cdPtr->pkg, pkgDict);
/*
* Now create the interface command for retrieval of the package
@@ -157,7 +146,7 @@ Tcl_RegisterConfig(
*/
Tcl_DStringInit(&cmdName);
- Tcl_DStringAppend(&cmdName, "::", -1);
+ TclDStringAppendLiteral(&cmdName, "::");
Tcl_DStringAppend(&cmdName, pkgName, -1);
/*
@@ -175,7 +164,7 @@ Tcl_RegisterConfig(
}
}
- Tcl_DStringAppend(&cmdName, "::pkgconfig", -1);
+ TclDStringAppendLiteral(&cmdName, "::pkgconfig");
if (Tcl_CreateObjCommand(interp, Tcl_DStringValue(&cmdName),
QueryConfigObjCmd, cdPtr, QueryConfigDelete) == NULL) {
@@ -220,6 +209,9 @@ QueryConfigObjCmd(
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 ?arg?");
@@ -238,7 +230,9 @@ QueryConfigObjCmd(
* present.
*/
- Tcl_SetResult(interp, "package not known", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("package not known", -1));
+ Tcl_SetErrorCode(interp, "TCL", "FATAL", "PKGCFG_BASE",
+ Tcl_GetString(pkgName), NULL);
return TCL_ERROR;
}
@@ -249,13 +243,29 @@ QueryConfigObjCmd(
return TCL_ERROR;
}
- if (Tcl_DictObjGet(interp, pkgDict, objv [2], &val) != TCL_OK
+ if (Tcl_DictObjGet(interp, pkgDict, objv[2], &val) != TCL_OK
|| val == NULL) {
- Tcl_SetResult(interp, "key not known", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("key not known", -1));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONFIG",
+ Tcl_GetString(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:
@@ -268,25 +278,20 @@ QueryConfigObjCmd(
listPtr = Tcl_NewListObj(n, NULL);
if (!listPtr) {
- Tcl_SetResult(interp, "insufficient memory to create list",
- TCL_STATIC);
+ 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;
- int done, i = 0;
-
- listRepPtr->elemCount = n;
- vals = &listRepPtr->elements;
+ Tcl_Obj *key;
+ int done;
for (Tcl_DictObjFirst(interp, pkgDict, &s, &key, NULL, &done);
!done; Tcl_DictObjNext(&s, &key, NULL, &done)) {
- vals[i++] = key;
- Tcl_IncrRefCount(key);
+ Tcl_ListObjAppendElement(NULL, listPtr, key);
}
}
@@ -321,11 +326,15 @@ static void
QueryConfigDelete(
ClientData clientData)
{
- QCCD *cdPtr = (QCCD *) 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((char *)cdPtr->encoding);
+ }
ckfree((char *)cdPtr);
}
@@ -368,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:
generated by cgit v0.12 at 2025-10-21 21:11:19 (GMT)