summaryrefslogtreecommitdiffstats
path: root/generic/tclConfig.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclConfig.c')
-rw-r--r--generic/tclConfig.c256
1 files changed, 130 insertions, 126 deletions
diff --git a/generic/tclConfig.c b/generic/tclConfig.c
index f9c6dda..49eb04b 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,10 +6,10 @@
*
* 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.
+ * 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.8 2005/05/10 18:34:28 kennykb Exp $
+ * RCS: @(#) $Id: tclConfig.c,v 1.9 2005/07/24 22:56:43 dkf Exp $
*/
#include "tclInt.h"
@@ -19,13 +19,12 @@
/*
* 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"
@@ -34,26 +33,20 @@
* 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));
+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.
+ * See TIP#59 for details on what this function does.
*
* Results:
* None.
@@ -65,110 +58,108 @@ 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(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;
+ 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 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.
+ * 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);
+ Tcl_IncrRefCount(pkg);
- /* Retrieve package specific configuration ... */
+ /*
+ * Retrieve package specific configuration...
+ */
- res = Tcl_DictObjGet (interp, pDB, pkg, &pkgDict);
+ 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);
+ 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++) {
+ /*
+ * 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);
+ 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);
+ Tcl_DictObjPut(interp, pkgDict, Tcl_NewStringObj(cfg->key, -1),
+ Tcl_NewStringObj(convValue, -1));
+ Tcl_DStringFree(&conv);
}
- /* 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, 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);
+ Tcl_DStringAppend(&cmdName, "::", -1);
+ 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),
+ if (Tcl_FindNamespace(interp, Tcl_DStringValue(&cmdName), NULL,
+ TCL_GLOBAL_ONLY) == NULL) {
+ if (Tcl_CreateNamespace(interp, Tcl_DStringValue(&cmdName),
+ (ClientData) NULL, (Tcl_NamespaceDeleteProc *) 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);
+ 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",
+ if (Tcl_CreateObjCommand(interp, Tcl_DStringValue(&cmdName),
+ QueryConfigObjCmd, (ClientData) pkg, QueryConfigDelete) == NULL) {
+ Tcl_Panic("%s %s", "Tcl_RegisterConfig: Unable to create query",
"command for package configuration");
}
- Tcl_DStringFree (&cmdName);
+ Tcl_DStringFree(&cmdName);
}
/*
@@ -190,16 +181,14 @@ 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;
+ ClientData clientData;
+ Tcl_Interp *interp;
+ int objc;
+ struct Tcl_Obj * CONST *objv;
{
- Tcl_Obj *pkgName = (Tcl_Obj*) clientData;
+ Tcl_Obj *pkgName = (Tcl_Obj *) clientData;
Tcl_Obj *pDB, *pkgDict, *val, *listPtr;
- Tcl_DictSearch s;
- int n, i, res, done, index;
- Tcl_Obj *key, **vals;
+ int n, i, res, index;
static CONST char *subcmdStrings[] = {
"get", "list", NULL
@@ -212,15 +201,19 @@ QueryConfigObjCmd(clientData, interp, objc, objv)
Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?argument?");
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 */
+ /*
+ * Maybe a Tcl_Panic is better, because the package data has to be
+ * present.
+ */
+
Tcl_SetObjResult(interp, Tcl_NewStringObj("package not known", -1));
return TCL_ERROR;
}
@@ -249,16 +242,19 @@ QueryConfigObjCmd(clientData, interp, objc, objv)
Tcl_DictObjSize(interp, pkgDict, &n);
listPtr = Tcl_NewListObj(n, NULL);
-
+
if (!listPtr) {
Tcl_SetObjResult(interp,
- Tcl_NewStringObj("insufficient memory to create list", -1));
+ Tcl_NewStringObj("insufficient memory to create list",-1));
return TCL_ERROR;
}
-
+
if (n) {
- List *listRepPtr =
- (List *) listPtr->internalRep.twoPtrValue.ptr1;
+ List *listRepPtr = (List *)
+ listPtr->internalRep.twoPtrValue.ptr1;
+ Tcl_DictSearch s;
+ Tcl_Obj *key, **vals;
+ int done;
listRepPtr->elemCount = n;
vals = &listRepPtr->elements;
@@ -285,7 +281,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:
@@ -298,11 +294,11 @@ QueryConfigObjCmd(clientData, interp, objc, objv)
*/
static void
-QueryConfigDelete (clientData)
- ClientData clientData;
+QueryConfigDelete(clientData)
+ ClientData clientData;
{
- Tcl_Obj* pkgName = (Tcl_Obj*) clientData;
- Tcl_DecrRefCount (pkgName);
+ Tcl_Obj *pkgName = (Tcl_Obj *) clientData;
+ Tcl_DecrRefCount(pkgName);
}
/*
@@ -322,19 +318,19 @@ QueryConfigDelete (clientData)
*-------------------------------------------------------------------------
*/
-static Tcl_Obj*
-GetConfigDict (interp)
- Tcl_Interp* interp;
+static Tcl_Obj *
+GetConfigDict(interp)
+ 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 == (Tcl_Obj *) NULL) {
+ pDB = Tcl_NewDictObj();
+ Tcl_IncrRefCount(pDB);
+ Tcl_SetAssocData(interp, ASSOC_KEY, ConfigDictDeleteProc, pDB);
+ }
- return pDB;
+ return pDB;
}
/*
@@ -342,10 +338,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 assoicated with any pending error
+ * reports.
*
* Results:
* None.
@@ -361,6 +357,14 @@ ConfigDictDeleteProc(clientData, interp)
ClientData clientData; /* Pointer to Tcl_Obj. */
Tcl_Interp *interp; /* Interpreter being deleted. */
{
- Tcl_Obj* pDB = (Tcl_Obj*) clientData;
- Tcl_DecrRefCount (pDB);
+ Tcl_Obj *pDB = (Tcl_Obj *) clientData;
+ Tcl_DecrRefCount(pDB);
}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */