diff options
Diffstat (limited to 'generic/tclConfig.c')
| -rw-r--r-- | generic/tclConfig.c | 372 |
1 files changed, 212 insertions, 160 deletions
diff --git a/generic/tclConfig.c b/generic/tclConfig.c index 3cd5813..2fb3e92 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -1,4 +1,4 @@ -/* +/* * tclConfig.c -- * * This file provides the facilities which allow Tcl and other packages @@ -6,54 +6,55 @@ * * Copyright (c) 2002 Andreas Kupries <andreas_kupries@users.sourceforge.net> * - * 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.5 2003/12/24 04:18:19 davygrvy Exp $ + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" - - /* * Internal structure to hold embedded configuration information. * - * Our structure is a two-level dictionary associated with the - * 'interp'. The first level is keyed with the package name and maps - * to the dictionary for that package. The package dictionary is keyed - * with metadata keys and maps to the metadata value for that - * key. This is package specific. The metadata values are in UTF8, - * converted from the external representation given to us by the - * caller. + * Our structure is a two-level dictionary associated with the 'interp'. The + * first level is keyed with the package name and maps to the dictionary for + * that package. The package dictionary is keyed with metadata keys and maps + * to the metadata value for that key. This is package specific. The metadata + * values are in UTF-8, converted from the external representation given to us + * by the caller. */ -#define ASSOC_KEY "tclPackageAboutDict" +#define ASSOC_KEY "tclPackageAboutDict" /* - * Static functions in this file: + * 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. */ -static int -QueryConfigObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, struct Tcl_Obj * CONST * objv)); - -static void -QueryConfigDelete _ANSI_ARGS_((ClientData clientData)); +typedef struct QCCD { + Tcl_Obj *pkg; + Tcl_Interp *interp; + char *encoding; +} QCCD; -static Tcl_Obj* -GetConfigDict _ANSI_ARGS_((Tcl_Interp* interp)); +/* + * Static functions in this file: + */ -static void -ConfigDictDeleteProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp)); +static int QueryConfigObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + struct Tcl_Obj *const *objv); +static void QueryConfigDelete(ClientData clientData); +static Tcl_Obj * GetConfigDict(Tcl_Interp *interp); +static void ConfigDictDeleteProc(ClientData clientData, + Tcl_Interp *interp); /* *---------------------------------------------------------------------- * * Tcl_RegisterConfig -- * - * See TIP#59 for details on what this procedure does. + * See TIP#59 for details on what this function does. * * Results: * None. @@ -65,110 +66,113 @@ ConfigDictDeleteProc _ANSI_ARGS_((ClientData clientData, */ void -Tcl_RegisterConfig (interp, pkgName, configuration, valEncoding) - Tcl_Interp* interp; /* Interpreter the configuration - * command is registered in. */ - 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 configuration values, - * ASCII, thus UTF-8 */ +Tcl_RegisterConfig( + Tcl_Interp *interp, /* Interpreter the configuration command is + * registered in. */ + const char *pkgName, /* Name of the package registering the + * embedded configuration. ASCII, thus in + * UTF-8 too. */ + 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_DString cmdName; - Tcl_Config* cfg; - int res; + Tcl_Obj *pDB, *pkgDict; + Tcl_DString cmdName; + 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 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 registering its configuration. This is the approved interface + * in TIP 59. In the future a more general interface should be done, as + * follow-up to TIP 59. Simply because our database is now general across + * packages, and not a structure tied to one package. * - * Phase II: Create a command for querying this database, specific - * to the package registerting 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 packages, and not a - * structure tied to one package. + * Note, the created command will have a reference through its clientdata. */ - /* Note, the created command will have a reference through its clientdata */ - Tcl_IncrRefCount (pkg); - - /* Retrieve package specific configuration ... */ + Tcl_IncrRefCount(cdPtr->pkg); - res = Tcl_DictObjGet (interp, pDB, pkg, &pkgDict); - if ((TCL_OK != res) || (pkgDict == NULL)) { - pkgDict = Tcl_NewDictObj (); - } else if (Tcl_IsShared (pkgDict)) { - pkgDict = Tcl_DuplicateObj (pkgDict); - } + /* + * For venc == NULL aka bogus encoding we skip the step setting up the + * dictionaries visible at Tcl level. I.e. they are not filled + */ - /* Extend the package configuration ... */ + pDB = GetConfigDict(interp); - for (cfg = configuration; - (cfg->key != (CONST char*) NULL) && (cfg->key [0] != '\0') ; - cfg++) { + /* + * Retrieve package specific configuration... + */ - Tcl_DString conv; - CONST char* convValue = Tcl_ExternalToUtfDString (venc, cfg->value, -1, &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 know that the keys are in ASCII/UTF-8, so for them is no - * conversion required. - */ + /* + * 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_DictObjPut (interp, pkgDict, - Tcl_NewStringObj (cfg->key, -1), - Tcl_NewStringObj (convValue, -1)); - Tcl_DStringFree (&conv); + 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, pkg, pkgDict); + Tcl_DictObjPut(interp, pDB, cdPtr->pkg, pkgDict); /* * Now create the interface command for retrieval of the package * information. */ - Tcl_DStringInit (&cmdName); - Tcl_DStringAppend (&cmdName, "::", -1); - Tcl_DStringAppend (&cmdName, pkgName, -1); + Tcl_DStringInit(&cmdName); + TclDStringAppendLiteral(&cmdName, "::"); + Tcl_DStringAppend(&cmdName, pkgName, -1); - /* The incomplete command name is the name of the namespace to - * place it in. + /* + * The incomplete command name is the name of the namespace to place it + * in. */ - if ((Tcl_Namespace*) NULL == Tcl_FindNamespace(interp, - Tcl_DStringValue (&cmdName), NULL, TCL_GLOBAL_ONLY)) { - - if ((Tcl_Namespace*) NULL == Tcl_CreateNamespace (interp, - Tcl_DStringValue (&cmdName), (ClientData) NULL, - (Tcl_NamespaceDeleteProc *) NULL)) { - - Tcl_Panic ("%s.\n%s %s", Tcl_GetStringResult(interp), - "Tcl_RegisterConfig: Unable to create namespace for", - "package configuration."); + if (Tcl_FindNamespace(interp, Tcl_DStringValue(&cmdName), NULL, + TCL_GLOBAL_ONLY) == NULL) { + if (Tcl_CreateNamespace(interp, Tcl_DStringValue(&cmdName), + 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); - - if ((Tcl_Command) NULL == Tcl_CreateObjCommand (interp, - Tcl_DStringValue (&cmdName), QueryConfigObjCmd, - (ClientData) pkg, QueryConfigDelete)) { + TclDStringAppendLiteral(&cmdName, "::pkgconfig"); - Tcl_Panic ("%s %s", "Tcl_RegisterConfig: Unable to create query", - "command for package configuration"); + if (Tcl_CreateObjCommand(interp, Tcl_DStringValue(&cmdName), + QueryConfigObjCmd, cdPtr, QueryConfigDelete) == NULL) { + Tcl_Panic("%s: %s", "Tcl_RegisterConfig", + "Unable to create query command for package configuration"); } - Tcl_DStringFree (&cmdName); + Tcl_DStringFree(&cmdName); } /* @@ -176,8 +180,8 @@ Tcl_RegisterConfig (interp, pkgName, configuration, valEncoding) * * 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. @@ -189,78 +193,109 @@ Tcl_RegisterConfig (interp, pkgName, configuration, valEncoding) */ static int -QueryConfigObjCmd(clientData, interp, objc, objv) - ClientData clientData; - Tcl_Interp *interp; - int objc; - struct Tcl_Obj * CONST *objv; +QueryConfigObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + struct Tcl_Obj *const *objv) { - Tcl_Obj *pkgName = (Tcl_Obj*) clientData; - Tcl_Obj *pDB, *pkgDict, *val; - Tcl_DictSearch s; - int n, i, res, done, index; - Tcl_Obj *key, **vals; - - static CONST char *subcmdStrings[] = { + QCCD *cdPtr = clientData; + Tcl_Obj *pkgName = cdPtr->pkg; + Tcl_Obj *pDB, *pkgDict, *val, *listPtr; + 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, 0, NULL, "list | get key"); + Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg?"); return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[1], subcmdStrings, - "subcommand", 0, &index) != TCL_OK) { + if (Tcl_GetIndexFromObj(interp, objv[1], subcmdStrings, "subcommand", 0, + &index) != TCL_OK) { return TCL_ERROR; } pDB = GetConfigDict(interp); - res = Tcl_DictObjGet(interp, pDB, pkgName, &pkgDict); - if (res!=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)); + 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_SetErrorCode(interp, "TCL", "FATAL", "PKGCFG_BASE", + Tcl_GetString(pkgName), NULL); return TCL_ERROR; } switch ((enum subcmds) index) { case CFG_GET: if (objc != 3) { - Tcl_WrongNumArgs(interp, 0, NULL, "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", + 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: if (objc != 2) { - Tcl_WrongNumArgs(interp, 0, NULL, "list"); + Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } Tcl_DictObjSize(interp, pkgDict, &n); - if (n == 0) { - Tcl_SetObjResult(interp, Tcl_NewListObj(0, NULL)); - return TCL_OK; + listPtr = Tcl_NewListObj(n, NULL); + + if (!listPtr) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "insufficient memory to create list", -1)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + return TCL_ERROR; } - vals = (Tcl_Obj**) ckalloc(n * sizeof(Tcl_Obj*)); + if (n) { + Tcl_DictSearch s; + Tcl_Obj *key; + int done; - for (i=0, Tcl_DictObjFirst(interp, pkgDict, &s, &key, NULL, &done); - !done; Tcl_DictObjNext(&s, &key, NULL, &done), i++) { - vals[i] = key; + for (Tcl_DictObjFirst(interp, pkgDict, &s, &key, NULL, &done); + !done; Tcl_DictObjNext(&s, &key, NULL, &done)) { + Tcl_ListObjAppendElement(NULL, listPtr, key); + } } - Tcl_SetObjResult(interp, TclNewListObjDirect(n, vals)); + Tcl_SetObjResult(interp, listPtr); return TCL_OK; default: @@ -275,7 +310,7 @@ QueryConfigObjCmd(clientData, interp, objc, objv) * * QueryConfigDelete -- * - * Command delete procedure. Cleans up after the configuration query + * Command delete function. Cleans up after the configuration query * command when it is deleted by the user or during finalization. * * Results: @@ -288,11 +323,19 @@ QueryConfigObjCmd(clientData, interp, objc, objv) */ static void -QueryConfigDelete (clientData) - ClientData clientData; +QueryConfigDelete( + ClientData clientData) { - Tcl_Obj* pkgName = (Tcl_Obj*) clientData; - Tcl_DecrRefCount (pkgName); + 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); } /* @@ -312,19 +355,19 @@ QueryConfigDelete (clientData) *------------------------------------------------------------------------- */ -static Tcl_Obj* -GetConfigDict (interp) - Tcl_Interp* interp; +static Tcl_Obj * +GetConfigDict( + Tcl_Interp *interp) { - Tcl_Obj* pDB = Tcl_GetAssocData (interp, ASSOC_KEY, NULL); + Tcl_Obj *pDB = Tcl_GetAssocData(interp, ASSOC_KEY, NULL); - if (pDB == (Tcl_Obj*) NULL) { - pDB = Tcl_NewDictObj (); - Tcl_IncrRefCount (pDB); - Tcl_SetAssocData (interp, ASSOC_KEY, ConfigDictDeleteProc, pDB); - } + if (pDB == NULL) { + pDB = Tcl_NewDictObj(); + Tcl_IncrRefCount(pDB); + Tcl_SetAssocData(interp, ASSOC_KEY, ConfigDictDeleteProc, pDB); + } - return pDB; + return pDB; } /* @@ -332,10 +375,10 @@ GetConfigDict (interp) * * ConfigDictDeleteProc -- * - * This procedure 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 reports. + * 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 associated with any pending error + * reports. * * Results: * None. @@ -347,10 +390,19 @@ GetConfigDict (interp) */ static void -ConfigDictDeleteProc(clientData, interp) - ClientData clientData; /* Pointer to Tcl_Obj. */ - Tcl_Interp *interp; /* Interpreter being deleted. */ +ConfigDictDeleteProc( + ClientData clientData, /* Pointer to Tcl_Obj. */ + Tcl_Interp *interp) /* Interpreter being deleted. */ { - Tcl_Obj* pDB = (Tcl_Obj*) clientData; - Tcl_DecrRefCount (pDB); + Tcl_Obj *pDB = clientData; + + Tcl_DecrRefCount(pDB); } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ |