util/src/TclTk/tcl8.6.12/generic/tclConfig.c

   1 /*
   2  * tclConfig.c --
   3  *
   4  *      This file provides the facilities which allow Tcl and other packages
   5  *      to embed configuration information into their binary libraries.
   6  *
   7  * Copyright (c) 2002 Andreas Kupries <andreas_kupries@users.sourceforge.net>
   8  *
   9  * See the file "license.terms" for information on usage and redistribution of
  10  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  11  */
  12
  13 #include "tclInt.h"
  14 \f
  15 /*
  16  * Internal structure to hold embedded configuration information.
  17  *
  18  * Our structure is a two-level dictionary associated with the 'interp'. The
  19  * first level is keyed with the package name and maps to the dictionary for
  20  * that package. The package dictionary is keyed with metadata keys and maps
  21  * to the metadata value for that key. This is package specific. The metadata
  22  * values are in UTF-8, converted from the external representation given to us
  23  * by the caller.
  24  */
  25
  26 #define ASSOC_KEY       "tclPackageAboutDict"
  27
  28 /*
  29  * A ClientData struct for the QueryConfig command.  Store the three bits
  30  * of data we need; the package name for which we store a config dict,
  31  * the (Tcl_Interp *) in which it is stored, and the encoding.
  32  */
  33
  34 typedef struct QCCD {
  35     Tcl_Obj *pkg;
  36     Tcl_Interp *interp;
  37     char *encoding;
  38 } QCCD;
  39
  40 /*
  41  * Static functions in this file:
  42  */
  43
  44 static int              QueryConfigObjCmd(ClientData clientData,
  45                             Tcl_Interp *interp, int objc,
  46                             struct Tcl_Obj *const *objv);
  47 static void             QueryConfigDelete(ClientData clientData);
  48 static Tcl_Obj *        GetConfigDict(Tcl_Interp *interp);
  49 static void             ConfigDictDeleteProc(ClientData clientData,
  50                             Tcl_Interp *interp);
  51 \f
  52 /*
  53  *----------------------------------------------------------------------
  54  *
  55  * Tcl_RegisterConfig --
  56  *
  57  *      See TIP#59 for details on what this function does.
  58  *
  59  * Results:
  60  *      None.
  61  *
  62  * Side effects:
  63  *      Creates namespace and cfg query command in it as per TIP #59.
  64  *
  65  *----------------------------------------------------------------------
  66  */
  67
  68 void
  69 Tcl_RegisterConfig(
  70     Tcl_Interp *interp,         /* Interpreter the configuration command is
  71                                  * registered in. */
  72     const char *pkgName,        /* Name of the package registering the
  73                                  * embedded configuration. ASCII, thus in
  74                                  * UTF-8 too. */
  75     const Tcl_Config *configuration,    /* Embedded configuration. */
  76     const char *valEncoding)    /* Name of the encoding used to store the
  77                                  * configuration values, ASCII, thus UTF-8. */
  78 {
  79     Tcl_Obj *pDB, *pkgDict;
  80     Tcl_DString cmdName;
  81     const Tcl_Config *cfg;
  82     QCCD *cdPtr = ckalloc(sizeof(QCCD));
  83
  84     cdPtr->interp = interp;
  85     if (valEncoding) {
  86         cdPtr->encoding = ckalloc(strlen(valEncoding)+1);
  87         strcpy(cdPtr->encoding, valEncoding);
  88     } else {
  89         cdPtr->encoding = NULL;
  90     }
  91     cdPtr->pkg = Tcl_NewStringObj(pkgName, -1);
  92
  93     /*
  94      * Phase I: Adding the provided information to the internal database of
  95      * package meta data.
  96      *
  97      * Phase II: Create a command for querying this database, specific to the
  98      * package registering its configuration. This is the approved interface
  99      * in TIP 59. In the future a more general interface should be done, as
 100      * follow-up to TIP 59. Simply because our database is now general across
 101      * packages, and not a structure tied to one package.
 102      *
 103      * Note, the created command will have a reference through its clientdata.
 104      */
 105
 106     Tcl_IncrRefCount(cdPtr->pkg);
 107
 108     /*
 109      * For venc == NULL aka bogus encoding we skip the step setting up the
 110      * dictionaries visible at Tcl level. I.e. they are not filled
 111      */
 112
 113     pDB = GetConfigDict(interp);
 114
 115     /*
 116      * Retrieve package specific configuration...
 117      */
 118
 119     if (Tcl_DictObjGet(interp, pDB, cdPtr->pkg, &pkgDict) != TCL_OK
 120             || (pkgDict == NULL)) {
 121         pkgDict = Tcl_NewDictObj();
 122     } else if (Tcl_IsShared(pkgDict)) {
 123         pkgDict = Tcl_DuplicateObj(pkgDict);
 124     }
 125
 126     /*
 127      * Extend the package configuration...
 128      * We cannot assume that the encodings are initialized, therefore
 129      * store the value as-is in a byte array. See Bug [9b2e636361].
 130      */
 131
 132     for (cfg=configuration ; cfg->key!=NULL && cfg->key[0]!='\0' ; cfg++) {
 133         Tcl_DictObjPut(interp, pkgDict, Tcl_NewStringObj(cfg->key, -1),
 134                 Tcl_NewByteArrayObj((unsigned char *)cfg->value, strlen(cfg->value)));
 135     }
 136
 137     /*
 138      * Write the changes back into the overall database.
 139      */
 140
 141     Tcl_DictObjPut(interp, pDB, cdPtr->pkg, pkgDict);
 142
 143     /*
 144      * Now create the interface command for retrieval of the package
 145      * information.
 146      */
 147
 148     Tcl_DStringInit(&cmdName);
 149     TclDStringAppendLiteral(&cmdName, "::");
 150     Tcl_DStringAppend(&cmdName, pkgName, -1);
 151
 152     /*
 153      * The incomplete command name is the name of the namespace to place it
 154      * in.
 155      */
 156
 157     if (Tcl_FindNamespace(interp, Tcl_DStringValue(&cmdName), NULL,
 158             TCL_GLOBAL_ONLY) == NULL) {
 159         if (Tcl_CreateNamespace(interp, Tcl_DStringValue(&cmdName),
 160                 NULL, NULL) == NULL) {
 161             Tcl_Panic("%s.\n%s: %s",
 162                     Tcl_GetStringResult(interp), "Tcl_RegisterConfig",
 163                     "Unable to create namespace for package configuration.");
 164         }
 165     }
 166
 167     TclDStringAppendLiteral(&cmdName, "::pkgconfig");
 168
 169     if (Tcl_CreateObjCommand(interp, Tcl_DStringValue(&cmdName),
 170             QueryConfigObjCmd, cdPtr, QueryConfigDelete) == NULL) {
 171         Tcl_Panic("%s: %s", "Tcl_RegisterConfig",
 172                 "Unable to create query command for package configuration");
 173     }
 174
 175     Tcl_DStringFree(&cmdName);
 176 }
 177 \f
 178 /*
 179  *----------------------------------------------------------------------
 180  *
 181  * QueryConfigObjCmd --
 182  *
 183  *      Implementation of "::<package>::pkgconfig", the command to query
 184  *      configuration information embedded into a binary library.
 185  *
 186  * Results:
 187  *      A standard tcl result.
 188  *
 189  * Side effects:
 190  *      See the manual for what this command does.
 191  *
 192  *----------------------------------------------------------------------
 193  */
 194
 195 static int
 196 QueryConfigObjCmd(
 197     ClientData clientData,
 198     Tcl_Interp *interp,
 199     int objc,
 200     struct Tcl_Obj *const *objv)
 201 {
 202     QCCD *cdPtr = clientData;
 203     Tcl_Obj *pkgName = cdPtr->pkg;
 204     Tcl_Obj *pDB, *pkgDict, *val, *listPtr;
 205     int n, index;
 206     static const char *const subcmdStrings[] = {
 207         "get", "list", NULL
 208     };
 209     enum subcmds {
 210         CFG_GET, CFG_LIST
 211     };
 212     Tcl_DString conv;
 213     Tcl_Encoding venc = NULL;
 214     const char *value;
 215
 216     if ((objc < 2) || (objc > 3)) {
 217         Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg?");
 218         return TCL_ERROR;
 219     }
 220     if (Tcl_GetIndexFromObj(interp, objv[1], subcmdStrings, "subcommand", 0,
 221             &index) != TCL_OK) {
 222         return TCL_ERROR;
 223     }
 224
 225     pDB = GetConfigDict(interp);
 226     if (Tcl_DictObjGet(interp, pDB, pkgName, &pkgDict) != TCL_OK
 227             || pkgDict == NULL) {
 228         /*
 229          * Maybe a Tcl_Panic is better, because the package data has to be
 230          * present.
 231          */
 232
 233         Tcl_SetObjResult(interp, Tcl_NewStringObj("package not known", -1));
 234         Tcl_SetErrorCode(interp, "TCL", "FATAL", "PKGCFG_BASE",
 235                 Tcl_GetString(pkgName), NULL);
 236         return TCL_ERROR;
 237     }
 238
 239     switch ((enum subcmds) index) {
 240     case CFG_GET:
 241         if (objc != 3) {
 242             Tcl_WrongNumArgs(interp, 2, objv, "key");
 243             return TCL_ERROR;
 244         }
 245
 246         if (Tcl_DictObjGet(interp, pkgDict, objv[2], &val) != TCL_OK
 247                 || val == NULL) {
 248             Tcl_SetObjResult(interp, Tcl_NewStringObj("key not known", -1));
 249             Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONFIG",
 250                     Tcl_GetString(objv[2]), NULL);
 251             return TCL_ERROR;
 252         }
 253
 254         if (cdPtr->encoding) {
 255             venc = Tcl_GetEncoding(interp, cdPtr->encoding);
 256             if (!venc) {
 257                 return TCL_ERROR;
 258             }
 259         }
 260         /*
 261          * Value is stored as-is in a byte array, see Bug [9b2e636361],
 262          * so we have to decode it first.
 263          */
 264         value = (const char *) Tcl_GetByteArrayFromObj(val, &n);
 265         value = Tcl_ExternalToUtfDString(venc, value, n, &conv);
 266         Tcl_SetObjResult(interp, Tcl_NewStringObj(value,
 267                 Tcl_DStringLength(&conv)));
 268         Tcl_DStringFree(&conv);
 269         return TCL_OK;
 270
 271     case CFG_LIST:
 272         if (objc != 2) {
 273             Tcl_WrongNumArgs(interp, 2, objv, NULL);
 274             return TCL_ERROR;
 275         }
 276
 277         Tcl_DictObjSize(interp, pkgDict, &n);
 278         listPtr = Tcl_NewListObj(n, NULL);
 279
 280         if (!listPtr) {
 281             Tcl_SetObjResult(interp, Tcl_NewStringObj(
 282                     "insufficient memory to create list", -1));
 283             Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
 284             return TCL_ERROR;
 285         }
 286
 287         if (n) {
 288             Tcl_DictSearch s;
 289             Tcl_Obj *key;
 290             int done;
 291
 292             for (Tcl_DictObjFirst(interp, pkgDict, &s, &key, NULL, &done);
 293                     !done; Tcl_DictObjNext(&s, &key, NULL, &done)) {
 294                 Tcl_ListObjAppendElement(NULL, listPtr, key);
 295             }
 296         }
 297
 298         Tcl_SetObjResult(interp, listPtr);
 299         return TCL_OK;
 300
 301     default:
 302         Tcl_Panic("QueryConfigObjCmd: Unknown subcommand to 'pkgconfig'. This can't happen");
 303         break;
 304     }
 305     return TCL_ERROR;
 306 }
 307 \f
 308 /*
 309  *-------------------------------------------------------------------------
 310  *
 311  * QueryConfigDelete --
 312  *
 313  *      Command delete function. Cleans up after the configuration query
 314  *      command when it is deleted by the user or during finalization.
 315  *
 316  * Results:
 317  *      None.
 318  *
 319  * Side effects:
 320  *      Deallocates all non-transient memory allocated by Tcl_RegisterConfig.
 321  *
 322  *-------------------------------------------------------------------------
 323  */
 324
 325 static void
 326 QueryConfigDelete(
 327     ClientData clientData)
 328 {
 329     QCCD *cdPtr = clientData;
 330     Tcl_Obj *pkgName = cdPtr->pkg;
 331     Tcl_Obj *pDB = GetConfigDict(cdPtr->interp);
 332
 333     Tcl_DictObjRemove(NULL, pDB, pkgName);
 334     Tcl_DecrRefCount(pkgName);
 335     if (cdPtr->encoding) {
 336         ckfree((char *)cdPtr->encoding);
 337     }
 338     ckfree((char *)cdPtr);
 339 }
 340 \f
 341 /*
 342  *-------------------------------------------------------------------------
 343  *
 344  * GetConfigDict --
 345  *
 346  *      Retrieve the package metadata database from the interpreter.
 347  *      Initializes it, if not present yet.
 348  *
 349  * Results:
 350  *      A Tcl_Obj reference
 351  *
 352  * Side effects:
 353  *      May allocate a Tcl_Obj.
 354  *
 355  *-------------------------------------------------------------------------
 356  */
 357
 358 static Tcl_Obj *
 359 GetConfigDict(
 360     Tcl_Interp *interp)
 361 {
 362     Tcl_Obj *pDB = Tcl_GetAssocData(interp, ASSOC_KEY, NULL);
 363
 364     if (pDB == NULL) {
 365         pDB = Tcl_NewDictObj();
 366         Tcl_IncrRefCount(pDB);
 367         Tcl_SetAssocData(interp, ASSOC_KEY, ConfigDictDeleteProc, pDB);
 368     }
 369
 370     return pDB;
 371 }
 372 \f
 373 /*
 374  *----------------------------------------------------------------------
 375  *
 376  * ConfigDictDeleteProc --
 377  *
 378  *      This function is associated with the "Package About dict" assoc data
 379  *      for an interpreter; it is invoked when the interpreter is deleted in
 380  *      order to free the information associated with any pending error
 381  *      reports.
 382  *
 383  * Results:
 384  *      None.
 385  *
 386  * Side effects:
 387  *      The package metadata database is freed.
 388  *
 389  *----------------------------------------------------------------------
 390  */
 391
 392 static void
 393 ConfigDictDeleteProc(
 394     ClientData clientData,      /* Pointer to Tcl_Obj. */
 395     Tcl_Interp *interp)         /* Interpreter being deleted. */
 396 {
 397     Tcl_Obj *pDB = clientData;
 398
 399     Tcl_DecrRefCount(pDB);
 400 }
 401 \f
 402 /*
 403  * Local Variables:
 404  * mode: c
 405  * c-basic-offset: 4
 406  * fill-column: 78
 407  * End:
 408  */