diff options
Diffstat (limited to 'generic/tclConfig.c')
| -rw-r--r-- | generic/tclConfig.c | 392 |
1 files changed, 392 insertions, 0 deletions
diff --git a/generic/tclConfig.c b/generic/tclConfig.c new file mode 100644 index 0000000..28549ed --- /dev/null +++ b/generic/tclConfig.c @@ -0,0 +1,392 @@ +/* + * tclConfig.c -- + * + * This file provides the facilities which allow Tcl and other packages + * to embed configuration information into their binary libraries. + * + * 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. + */ + +#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 UTF-8, converted from the external representation given to us + * by the caller. + */ + +#define ASSOC_KEY "tclPackageAboutDict" + +/* + * A ClientData struct for the QueryConfig command. Store the two bits + * of data we need; the package name for which we store a config dict, + * and the (Tcl_Interp *) in which it is stored. + */ + +typedef struct QCCD { + Tcl_Obj *pkg; + Tcl_Interp *interp; +} QCCD; + +/* + * Static functions in this file: + */ + +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 function does. + * + * Results: + * None. + * + * Side effects: + * Creates namespace and cfg query command in it as per TIP #59. + * + *---------------------------------------------------------------------- + */ + +void +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. */ + Tcl_Config *configuration, /* Embedded configuration. */ + CONST char *valEncoding) /* Name of the encoding used to store the + * configuration values, ASCII, thus UTF-8. */ +{ + Tcl_Obj *pDB, *pkgDict; + Tcl_DString cmdName; + Tcl_Config *cfg; + Tcl_Encoding venc = Tcl_GetEncoding(NULL, valEncoding); + QCCD *cdPtr = (QCCD *)ckalloc(sizeof(QCCD)); + + cdPtr->interp = interp; + 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. + * + * 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. + */ + + 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 + */ + + if (venc != NULL) { + /* + * Retrieve package specific configuration... + */ + + pDB = GetConfigDict(interp); + + 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); + + /* + * We know that the keys are in ASCII/UTF-8, so for them is no + * conversion required. + */ + + Tcl_DictObjPut(interp, pkgDict, Tcl_NewStringObj(cfg->key, -1), + Tcl_NewStringObj(convValue, -1)); + Tcl_DStringFree(&conv); + } + + /* + * We're now done with the encoding, so drop it. + */ + + Tcl_FreeEncoding(venc); + + /* + * Write the changes back into the overall database. + */ + + 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); + + /* + * The incomplete command name is the name of the namespace to place it + * in. + */ + + 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_CreateObjCommand(interp, Tcl_DStringValue(&cmdName), + QueryConfigObjCmd, (ClientData) cdPtr, QueryConfigDelete) == NULL) { + Tcl_Panic("%s: %s", "Tcl_RegisterConfig", + "Unable to create query command for package configuration"); + } + + Tcl_DStringFree(&cmdName); +} + +/* + *---------------------------------------------------------------------- + * + * QueryConfigObjCmd -- + * + * Implementation of "::<package>::pkgconfig", the command to query + * configuration information embedded into a binary library. + * + * Results: + * A standard tcl result. + * + * Side effects: + * See the manual for what this command does. + * + *---------------------------------------------------------------------- + */ + +static int +QueryConfigObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + struct Tcl_Obj *CONST *objv) +{ + QCCD *cdPtr = (QCCD *) clientData; + Tcl_Obj *pkgName = cdPtr->pkg; + Tcl_Obj *pDB, *pkgDict, *val, *listPtr; + int n, index; + static const char *subcmdStrings[] = { + "get", "list", NULL + }; + enum subcmds { + CFG_GET, CFG_LIST + }; + + if ((objc < 2) || (objc > 3)) { + Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?argument?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], subcmdStrings, "subcommand", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + + pDB = GetConfigDict(interp); + 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_SetResult(interp, "package not known", TCL_STATIC); + return TCL_ERROR; + } + + switch ((enum subcmds) index) { + case CFG_GET: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "key"); + return TCL_ERROR; + } + + if (Tcl_DictObjGet(interp, pkgDict, objv [2], &val) != TCL_OK + || val == NULL) { + Tcl_SetResult(interp, "key not known", TCL_STATIC); + return TCL_ERROR; + } + + Tcl_SetObjResult(interp, val); + return TCL_OK; + + case CFG_LIST: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + + Tcl_DictObjSize(interp, pkgDict, &n); + listPtr = Tcl_NewListObj(n, NULL); + + if (!listPtr) { + Tcl_SetResult(interp, "insufficient memory to create list", + TCL_STATIC); + return TCL_ERROR; + } + + if (n) { + Tcl_DictSearch s; + Tcl_Obj *key; + int done; + + for (Tcl_DictObjFirst(interp, pkgDict, &s, &key, NULL, &done); + !done; Tcl_DictObjNext(&s, &key, NULL, &done)) { + Tcl_ListObjAppendElement(NULL, listPtr, key); + } + } + + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; + + default: + Tcl_Panic("QueryConfigObjCmd: Unknown subcommand to 'pkgconfig'. This can't happen"); + break; + } + return TCL_ERROR; +} + +/* + *------------------------------------------------------------------------- + * + * QueryConfigDelete -- + * + * Command delete function. Cleans up after the configuration query + * command when it is deleted by the user or during finalization. + * + * Results: + * None. + * + * Side effects: + * Deallocates all non-transient memory allocated by Tcl_RegisterConfig. + * + *------------------------------------------------------------------------- + */ + +static void +QueryConfigDelete( + ClientData clientData) +{ + QCCD *cdPtr = (QCCD *) clientData; + Tcl_Obj *pkgName = cdPtr->pkg; + Tcl_Obj *pDB = GetConfigDict(cdPtr->interp); + Tcl_DictObjRemove(NULL, pDB, pkgName); + Tcl_DecrRefCount(pkgName); + ckfree((char *)cdPtr); +} + +/* + *------------------------------------------------------------------------- + * + * GetConfigDict -- + * + * Retrieve the package metadata database from the interpreter. + * Initializes it, if not present yet. + * + * Results: + * A Tcl_Obj reference + * + * Side effects: + * May allocate a Tcl_Obj. + * + *------------------------------------------------------------------------- + */ + +static Tcl_Obj * +GetConfigDict( + Tcl_Interp *interp) +{ + Tcl_Obj *pDB = Tcl_GetAssocData(interp, ASSOC_KEY, NULL); + + if (pDB == NULL) { + pDB = Tcl_NewDictObj(); + Tcl_IncrRefCount(pDB); + Tcl_SetAssocData(interp, ASSOC_KEY, ConfigDictDeleteProc, pDB); + } + + return pDB; +} + +/* + *---------------------------------------------------------------------- + * + * ConfigDictDeleteProc -- + * + * 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 + * reports. + * + * Results: + * None. + * + * Side effects: + * The package metadata database is freed. + * + *---------------------------------------------------------------------- + */ + +static void +ConfigDictDeleteProc( + ClientData clientData, /* Pointer to Tcl_Obj. */ + Tcl_Interp *interp) /* Interpreter being deleted. */ +{ + Tcl_Obj *pDB = (Tcl_Obj *) clientData; + + Tcl_DecrRefCount(pDB); +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ |