diff options
Diffstat (limited to 'generic/tclConfig.c')
| -rw-r--r-- | generic/tclConfig.c | 408 |
1 files changed, 408 insertions, 0 deletions
diff --git a/generic/tclConfig.c b/generic/tclConfig.c new file mode 100644 index 0000000..2fb3e92 --- /dev/null +++ b/generic/tclConfig.c @@ -0,0 +1,408 @@ +/* + * 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 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: + */ + +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. */ + const 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; + 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 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. + * + * 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 + */ + + 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... + * 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_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. + */ + + Tcl_DictObjPut(interp, pDB, cdPtr->pkg, pkgDict); + + /* + * Now create the interface command for retrieval of the package + * information. + */ + + Tcl_DStringInit(&cmdName); + TclDStringAppendLiteral(&cmdName, "::"); + 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."); + } + } + + TclDStringAppendLiteral(&cmdName, "::pkgconfig"); + + 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); +} + +/* + *---------------------------------------------------------------------- + * + * 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 = 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, 1, objv, "subcommand ?arg?"); + 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_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, 2, objv, "key"); + return TCL_ERROR; + } + + 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; + } + + 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, 2, objv, NULL); + return TCL_ERROR; + } + + Tcl_DictObjSize(interp, pkgDict, &n); + 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; + } + + 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 = 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); +} + +/* + *------------------------------------------------------------------------- + * + * 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 associated 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 = clientData; + + Tcl_DecrRefCount(pDB); +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ |