Attachment "tclConfig.c" to
ticket [507083ffff]
added by
andreas_kupries
2002-01-25 00:33:32.
/*
* 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 <[email protected]>
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclIO.c,v 1.47 2002/01/17 04:37:33 dgp Exp $
*/
#include "tclInt.h"
/*
* Internal structure to hold additional information about the
* embedded configuration. Allocated on the heap during construction
* of the configuration command. Allocated big enough to hold
* references to as many strings as there are entries in the
* configuration itself. These references will refer to the
* configuration values, converted into UTF 8. This conversion is done
* on demand.
*/
typedef struct Tcl_ConfigMeta {
Tcl_Config* configuration; /* Reference to the embedded
* configuration. */
Tcl_Encoding valEncoding; /* Token for the encoding used to
* represent the values in the
* configuration. */
Tcl_Obj* keylist; /* List of the registered keys */
int entries; /* Number of entries in
* configuration. */
Tcl_Obj* value [1]; /* Array of the values converted to
* UTF-8 */
} Tcl_ConfigMeta;
/*
* 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));
/*
*---------------------------------------------------------------------------
*
* 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; /* interp 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 */
{
/* Actions:
* - Count the entries in the configuration,
* - Allocate a big enough wrapper (meta) and initialize it
* - Create the configuration query command and use the wrapper
* as its client data.
*/
int n, i;
Tcl_Config* cfg;
Tcl_ConfigMeta* wrap;
Tcl_DString cmdName;
for (n = 0, cfg = configuration; cfg->key != (CONST char*) NULL; n++, cfg++)
/* empty loop */
;
wrap = (Tcl_ConfigMeta*) Tcl_Alloc (sizeof (Tcl_ConfigMeta) + (sizeof (char*) * n));
wrap->configuration = configuration;
wrap->entries = n;
wrap->valEncoding = Tcl_GetEncoding (NULL, valEncoding);
wrap->keylist = (Tcl_Obj*) NULL;
for (i = 0; i < n; i++) {
wrap->value [i] = (Tcl_Obj*) NULL;
}
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_CreateNamespace (interp,
Tcl_DStringValue (&cmdName), (ClientData) NULL,
(Tcl_NamespaceDeleteProc *) NULL)) {
Tcl_Panic ("Unable to create namespace for package configuration");
}
Tcl_DStringAppend (&cmdName, "::pkgconfig", -1);
if ((Tcl_Command) NULL == Tcl_CreateObjCommand (interp, Tcl_DStringValue (&cmdName),
QueryConfigObjCmd, (ClientData) wrap, QueryConfigDelete)) {
Tcl_Panic ("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_ConfigMeta* wrap = (Tcl_ConfigMeta*) clientData;
int index, i;
static CONST char *subcmdStrings[] = {
"get", "list", NULL
};
enum subcmds {
CFG_GET, CFG_LIST
};
if ((objc < 2) || (objc > 3)) {
Tcl_WrongNumArgs (interp, objc-1, objv+1, "list | get key");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], subcmdStrings, "subcommand", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum subcmds) index) {
case CFG_GET:
if (objc != 3) {
Tcl_WrongNumArgs (interp, objc-1, objv+1, "get key");
return TCL_ERROR;
}
for (i=0; i < wrap->entries; i++) {
/* We can use 'strcmp' as we know that the keys are in
* ASCII/UTF-8
*/
if (strcmp (wrap->configuration [i].key, Tcl_GetString (objv [2])) == 0) {
if (wrap->value [i] == (Tcl_Obj*) NULL) {
/* Convert the value associated with a key to
* UTF 8 on demand, i.e. only if requested at
* all and cache the result as it will never
* change.
*/
Tcl_DString conv;
Tcl_Obj* s = Tcl_NewStringObj (Tcl_ExternalToUtfDString (wrap->valEncoding,
wrap->configuration [i].value, -1, &conv), -1 );
Tcl_DStringFree (&conv);
if (s == (Tcl_Obj*) NULL) {
Tcl_SetObjResult (interp,
Tcl_NewStringObj ("unable to convert value to utf-8", -1));
return TCL_ERROR;
}
Tcl_IncrRefCount (s);
wrap->value [i] = s;
}
Tcl_SetObjResult (interp, wrap->value [i]);
return TCL_OK;
}
}
Tcl_SetObjResult (interp, Tcl_NewStringObj ("key not known", -1));
return TCL_ERROR;
case CFG_LIST:
if (objc != 2) {
Tcl_WrongNumArgs (interp, objc-1, objv+1, "list");
return TCL_ERROR;
}
if (wrap->keylist == (Tcl_Obj*) NULL) {
/* Generate the list of know keys on demand and cache
* it as it will never change.
*/
int i;
Tcl_Obj* l = Tcl_NewListObj (0, NULL);
if (l == (Tcl_Obj*) NULL) {
return TCL_ERROR;
}
for (i=0; i < wrap->entries; i++) {
Tcl_Obj* s = Tcl_NewStringObj (wrap->configuration [i].key, -1);
if (s == (Tcl_Obj*) NULL) {
Tcl_DecrRefCount (l);
return TCL_ERROR;
}
if (TCL_OK != Tcl_ListObjAppendElement (interp, l, s)) {
Tcl_DecrRefCount (l);
return TCL_ERROR;
}
}
Tcl_IncrRefCount (l);
wrap->keylist = l;
}
Tcl_SetObjResult (interp, wrap->keylist);
return TCL_OK;
default:
Tcl_Panic ("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_ConfigMeta* wrap = (Tcl_ConfigMeta*) clientData;
int i;
for (i = 0; i < wrap->entries; i++) {
if (wrap->value[i] != (Tcl_Obj*) NULL) {
Tcl_DecrRefCount (wrap->value [i]);
}
}
if (wrap->keylist != (Tcl_Obj*) NULL) {
Tcl_DecrRefCount (wrap->keylist);
}
Tcl_FreeEncoding (wrap->valEncoding);
Tcl_Free ((char*) wrap);
}