Logo Search packages:      
Sourcecode: tcl8.5 version File versions  Download package

tclConfig.c

/*
 * 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:
 */

Generated by  Doxygen 1.6.0   Back to index