tclConfig.c Go to the documentation of this file. /* * 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. * * RCS: @(#) $Id: tclConfig.c,v 1.19 2007/12/13 15:23:16 dgp Exp $ */ #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) { List *listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; Tcl_DictSearch s; Tcl_Obj *key, **vals; int done, i = 0; listRepPtr->elemCount = n; vals = &listRepPtr->elements; for (Tcl_DictObjFirst(interp, pkgDict, &s, &key, NULL, &done); !done; Tcl_DictObjNext(&s, &key, NULL, &done)) { vals[i++] = key; Tcl_IncrRefCount(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: */

• ソフトウェア開発
• ホームページ制作
• Doxygen版
• STLport版