summaryrefslogtreecommitdiffstats
path: root/generic/tclConfig.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclConfig.c')
-rw-r--r--generic/tclConfig.c365
1 files changed, 365 insertions, 0 deletions
diff --git a/generic/tclConfig.c b/generic/tclConfig.c
new file mode 100644
index 0000000..5b03c98
--- /dev/null
+++ b/generic/tclConfig.c
@@ -0,0 +1,365 @@
+/*
+ * 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.2 2003/06/09 22:48:32 andreas_kupries 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 UTF8,
+ * converted from the external representation given to us by the
+ * caller.
+ */
+
+#define ASSOC_KEY "Package About Dict"
+
+/*
+ * Static functions in this file:
+ */
+
+static int
+QueryConfigObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, struct Tcl_Obj * CONST * objv));
+
+static void
+QueryConfigDelete _ANSI_ARGS_((ClientData clientData));
+
+static Tcl_Obj*
+GetConfigDict _ANSI_ARGS_((Tcl_Interp* interp));
+
+static void
+ConfigDictDeleteProc _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp));
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_RegisterConfig --
+ *
+ * See TIP#59 for details on what this procedure does.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Creates namespace and cfg query command in it as per TIP #59.
+ *
+ *----------------------------------------------------------------------
+ */
+
+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_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;
+
+ /*
+ * 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 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 (pkg);
+
+ /* Retrieve package specific configuration ... */
+
+ 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);
+ }
+
+ /* Extend the package configuration ... */
+
+ for (cfg = configuration;
+ (cfg->key != (CONST char*) 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);
+ }
+
+ /* Write the changes back into the overall database */
+
+ Tcl_DictObjPut (interp, pDB, 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_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.");
+ }
+ }
+
+ Tcl_DStringAppend (&cmdName, "::pkgconfig", -1);
+
+ if ((Tcl_Command) NULL == Tcl_CreateObjCommand (interp,
+ Tcl_DStringValue (&cmdName), QueryConfigObjCmd,
+ (ClientData) pkg, QueryConfigDelete)) {
+
+ 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, interp, objc, objv)
+ ClientData clientData;
+ Tcl_Interp *interp;
+ int objc;
+ struct Tcl_Obj * CONST * objv;
+{
+ Tcl_Obj* pkgName = (Tcl_Obj*) clientData;
+ Tcl_Obj* pDB;
+ Tcl_Obj* pkgDict;
+ Tcl_Obj* val;
+ Tcl_DictSearch s;
+ int n, i, res, done, index;
+ Tcl_Obj* key;
+ Tcl_Obj** vals;
+
+ static CONST char *subcmdStrings[] = {
+ "get", "list", NULL
+ };
+ enum subcmds {
+ CFG_GET, CFG_LIST
+ };
+
+ if ((objc < 2) || (objc > 3)) {
+ Tcl_WrongNumArgs (interp, 0, NULL, "list | get key");
+ return TCL_ERROR;
+ }
+ 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 panic is better, because the package data has to be present */
+ Tcl_SetObjResult (interp, Tcl_NewStringObj ("package not known", -1));
+ return TCL_ERROR;
+ }
+
+ switch ((enum subcmds) index) {
+ case CFG_GET:
+ if (objc != 3) {
+ Tcl_WrongNumArgs (interp, 0, NULL, "get key");
+ return TCL_ERROR;
+ }
+
+ res = Tcl_DictObjGet (interp, pkgDict, objv [2], &val);
+ if ((res != TCL_OK) || (val == NULL)) {
+ Tcl_SetObjResult (interp, Tcl_NewStringObj ("key not known", -1));
+ return TCL_ERROR;
+ }
+
+ Tcl_SetObjResult (interp, val);
+ return TCL_OK;
+
+
+ case CFG_LIST:
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 0, NULL, "list");
+ return TCL_ERROR;
+ }
+
+ Tcl_DictObjSize (interp, pkgDict, &n);
+ if (n == 0) {
+ Tcl_SetObjResult (interp, Tcl_NewListObj (0, NULL));
+ return TCL_OK;
+ }
+
+ vals = (Tcl_Obj**) ckalloc (n * sizeof (Tcl_Obj*));
+
+ for (i = 0, Tcl_DictObjFirst(interp, pkgDict, &s, &key, NULL, &done);
+ !done;
+ Tcl_DictObjNext (&s, &key, NULL, &done), i++) {
+ if (done) break;
+ vals [i] = key;
+ }
+ Tcl_DictObjDone (&s);
+
+ Tcl_SetObjResult (interp, Tcl_NewListObj (n, vals));
+ ckfree ((char*) vals);
+
+ return TCL_OK;
+
+ default:
+ Tcl_Panic ("QueryConfigObjCmd: Unknown subcommand to 'pkgconfig'. This can't happen");
+ break;
+ }
+ return TCL_ERROR;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * QueryConfigDelete --
+ *
+ * Command delete procedure. 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 clientData;
+{
+ Tcl_Obj* pkgName = (Tcl_Obj*) clientData;
+ Tcl_DecrRefCount (pkgName);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * 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 (interp)
+ Tcl_Interp* interp;
+{
+ 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);
+ }
+
+ return pDB;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The package metadata database is freed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+ConfigDictDeleteProc(clientData, interp)
+ ClientData clientData; /* Pointer to Tcl_Obj. */
+ Tcl_Interp *interp; /* Interpreter being deleted. */
+{
+ Tcl_Obj* pDB = (Tcl_Obj*) clientData;
+ Tcl_DecrRefCount (pDB);
+}