Overview
| Artifact ID: | d2a4556d7f2e8158c2742299da4253c6b9f218d6 |
|---|---|
| Ticket: | 507083ffffffffffffffffffffffffffffffffff |
| Date: | 2002-01-25 00:33:32 |
| User: | andreas_kupries |
| Artifact Attached: | 059483312fc0190a9ec7e1b7fca9dd926ff04377 |
| Filename: | tclConfig.c |
| Description: | tclConfig.c, generic embedding support, Version 2 |
Content Appended
/* * 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); }