diff options
Diffstat (limited to 'generic')
| -rw-r--r-- | generic/tcl.decls | 8 | ||||
| -rw-r--r-- | generic/tcl.h | 12 | ||||
| -rw-r--r-- | generic/tclBasic.c | 10 | ||||
| -rw-r--r-- | generic/tclConfig.c | 365 | ||||
| -rw-r--r-- | generic/tclDecls.h | 12 | ||||
| -rw-r--r-- | generic/tclInt.h | 4 | ||||
| -rw-r--r-- | generic/tclPkgConfig.c | 122 | ||||
| -rw-r--r-- | generic/tclStubInit.c | 3 |
8 files changed, 530 insertions, 6 deletions
diff --git a/generic/tcl.decls b/generic/tcl.decls index 7fcb4c6..0f8935d 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: tcl.decls,v 1.97 2003/05/13 10:16:16 mistachkin Exp $ +# RCS: @(#) $Id: tcl.decls,v 1.98 2003/06/09 22:48:32 andreas_kupries Exp $ library tcl @@ -1797,6 +1797,12 @@ declare 504 generic { Tcl_Obj *Tcl_DbNewDictObj(CONST char *file, int line) } +# New export due to TIP#59 +declare 505 generic { + void Tcl_RegisterConfig (Tcl_Interp* interp, CONST char* pkgName, Tcl_Config* configuration, \ + CONST char* valEncoding) +} + ############################################################################## # Define the platform specific public Tcl interface. These functions are diff --git a/generic/tcl.h b/generic/tcl.h index 5885e15..6c87307 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tcl.h,v 1.157 2003/04/16 23:33:43 dgp Exp $ + * RCS: @(#) $Id: tcl.h,v 1.158 2003/06/09 22:48:32 andreas_kupries Exp $ */ #ifndef _TCL @@ -2196,6 +2196,16 @@ typedef struct Tcl_Parse { */ typedef unsigned short Tcl_UniChar; +/* TIP #59: The following structure is used in calls + * 'Tcl_RegisterConfig' to provide the system with the embedded + * configuration data. + */ + +typedef struct Tcl_Config { + CONST char* key; /* Configuration key to register. ASCII encoded, thus UTF-8 */ + CONST char* value; /* The value associated with the key. System encoding */ +} Tcl_Config; + /* * Deprecated Tcl procedures: diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 0fc1e59..68dd065 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.82 2003/05/12 20:15:28 dgp Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.83 2003/06/09 22:48:32 andreas_kupries Exp $ */ #include "tclInt.h" @@ -599,6 +599,14 @@ Tcl_CreateInterp() #endif Tcl_InitStubs(interp, TCL_VERSION, 1); + /* + * TIP #59: Make embedded configuration information + * available. This makes use of a public API call + * (Tcl_RegisterConfig) and thus requires that the global stub + * table is initialized. + */ + + TclInitEmbeddedConfigurationInformation (interp); return interp; } diff --git a/generic/tclConfig.c b/generic/tclConfig.c new file mode 100644 index 0000000..5b03c98 --- /dev/null +++ b/generic/tclConfig.c @@ -0,0 +1,365 @@ +/* + * 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.2 2003/06/09 22:48:32 andreas_kupries 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 UTF8, + * converted from the external representation given to us by the + * caller. + */ + +#define ASSOC_KEY "Package About Dict" + +/* + * 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)); + +/* + *---------------------------------------------------------------------- + * + * 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; /* 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; + + /* + * 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. + */ + + /* Note, the created command will have a reference through its clientdata */ + Tcl_IncrRefCount (pkg); + + /* Retrieve package specific configuration ... */ + + 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); + } + + /* Extend the package configuration ... */ + + for (cfg = configuration; + (cfg->key != (CONST char*) 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); + } + + /* Write the changes back into the overall database */ + + 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); + + /* 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), + "Tcl_RegisterConfig: Unable to create namespace for", + "package configuration."); + } + } + + 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", + "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_Obj* pkgName = (Tcl_Obj*) clientData; + Tcl_Obj* pDB; + Tcl_Obj* pkgDict; + Tcl_Obj* val; + Tcl_DictSearch s; + int n, i, res, done, index; + Tcl_Obj* key; + Tcl_Obj** vals; + + static CONST char *subcmdStrings[] = { + "get", "list", NULL + }; + enum subcmds { + CFG_GET, CFG_LIST + }; + + if ((objc < 2) || (objc > 3)) { + Tcl_WrongNumArgs (interp, 0, NULL, "list | get key"); + return TCL_ERROR; + } + 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 panic is better, because the package data has to be present */ + Tcl_SetObjResult (interp, Tcl_NewStringObj ("package not known", -1)); + return TCL_ERROR; + } + + switch ((enum subcmds) index) { + case CFG_GET: + if (objc != 3) { + Tcl_WrongNumArgs (interp, 0, NULL, "get key"); + return TCL_ERROR; + } + + res = Tcl_DictObjGet (interp, pkgDict, objv [2], &val); + if ((res != TCL_OK) || (val == NULL)) { + Tcl_SetObjResult (interp, Tcl_NewStringObj ("key not known", -1)); + return TCL_ERROR; + } + + Tcl_SetObjResult (interp, val); + return TCL_OK; + + + case CFG_LIST: + if (objc != 2) { + Tcl_WrongNumArgs (interp, 0, NULL, "list"); + return TCL_ERROR; + } + + Tcl_DictObjSize (interp, pkgDict, &n); + if (n == 0) { + Tcl_SetObjResult (interp, Tcl_NewListObj (0, NULL)); + return TCL_OK; + } + + vals = (Tcl_Obj**) ckalloc (n * sizeof (Tcl_Obj*)); + + for (i = 0, Tcl_DictObjFirst(interp, pkgDict, &s, &key, NULL, &done); + !done; + Tcl_DictObjNext (&s, &key, NULL, &done), i++) { + if (done) break; + vals [i] = key; + } + Tcl_DictObjDone (&s); + + Tcl_SetObjResult (interp, Tcl_NewListObj (n, vals)); + ckfree ((char*) vals); + + return TCL_OK; + + default: + Tcl_Panic ("QueryConfigObjCmd: Unknown subcommand to 'pkgconfig'. 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_Obj* pkgName = (Tcl_Obj*) clientData; + Tcl_DecrRefCount (pkgName); +} + +/* + *------------------------------------------------------------------------- + * + * 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 (interp) + Tcl_Interp* interp; +{ + 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); + } + + return pDB; +} + +/* + *---------------------------------------------------------------------- + * + * 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. + * + * Results: + * None. + * + * Side effects: + * The package metadata database is freed. + * + *---------------------------------------------------------------------- + */ + +static void +ConfigDictDeleteProc(clientData, interp) + ClientData clientData; /* Pointer to Tcl_Obj. */ + Tcl_Interp *interp; /* Interpreter being deleted. */ +{ + Tcl_Obj* pDB = (Tcl_Obj*) clientData; + Tcl_DecrRefCount (pDB); +} diff --git a/generic/tclDecls.h b/generic/tclDecls.h index e8eb34a..b4ea365 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclDecls.h,v 1.95 2003/05/13 10:16:16 mistachkin Exp $ + * RCS: @(#) $Id: tclDecls.h,v 1.96 2003/06/09 22:48:32 andreas_kupries Exp $ */ #ifndef _TCLDECLS @@ -1606,6 +1606,11 @@ EXTERN Tcl_Obj * Tcl_NewDictObj _ANSI_ARGS_((void)); /* 504 */ EXTERN Tcl_Obj * Tcl_DbNewDictObj _ANSI_ARGS_((CONST char * file, int line)); +/* 505 */ +EXTERN void Tcl_RegisterConfig _ANSI_ARGS_((Tcl_Interp* interp, + CONST char* pkgName, + Tcl_Config* configuration, + CONST char* valEncoding)); typedef struct TclStubHooks { struct TclPlatStubs *tclPlatStubs; @@ -2170,6 +2175,7 @@ typedef struct TclStubs { int (*tcl_DictObjRemoveKeyList) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * dictPtr, int keyc, Tcl_Obj *CONST * keyv)); /* 502 */ Tcl_Obj * (*tcl_NewDictObj) _ANSI_ARGS_((void)); /* 503 */ Tcl_Obj * (*tcl_DbNewDictObj) _ANSI_ARGS_((CONST char * file, int line)); /* 504 */ + void (*tcl_RegisterConfig) _ANSI_ARGS_((Tcl_Interp* interp, CONST char* pkgName, Tcl_Config* configuration, CONST char* valEncoding)); /* 505 */ } TclStubs; #ifdef __cplusplus @@ -4230,6 +4236,10 @@ extern TclStubs *tclStubsPtr; #define Tcl_DbNewDictObj \ (tclStubsPtr->tcl_DbNewDictObj) /* 504 */ #endif +#ifndef Tcl_RegisterConfig +#define Tcl_RegisterConfig \ + (tclStubsPtr->tcl_RegisterConfig) /* 505 */ +#endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclInt.h b/generic/tclInt.h index c440202..02987c2 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.127 2003/05/05 20:54:40 dgp Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.128 2003/06/09 22:48:32 andreas_kupries Exp $ */ #ifndef _TCLINT @@ -1648,6 +1648,8 @@ EXTERN int TclGlob _ANSI_ARGS_((Tcl_Interp *interp, int globFlags, Tcl_GlobTypeData* types)); EXTERN void TclInitAlloc _ANSI_ARGS_((void)); EXTERN void TclInitDbCkalloc _ANSI_ARGS_((void)); +EXTERN void TclInitEmbeddedConfigurationInformation + _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN void TclInitEncodingSubsystem _ANSI_ARGS_((void)); EXTERN void TclInitIOSubsystem _ANSI_ARGS_((void)); EXTERN void TclInitNamespaceSubsystem _ANSI_ARGS_((void)); diff --git a/generic/tclPkgConfig.c b/generic/tclPkgConfig.c new file mode 100644 index 0000000..06070ef --- /dev/null +++ b/generic/tclPkgConfig.c @@ -0,0 +1,122 @@ +/* + * tclPkgConfig.c -- + * + * This file contains the configuration information to + * embed into the tcl binary library. + * + * 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: tclPkgConfig.c,v 1.2 2003/06/09 22:48:33 andreas_kupries Exp $ + */ + +/* Note, the definitions in this module are influenced by the + * following C preprocessor macros: + * + * OSCMa = shortcut for "old style configuration macro activates" + * NSCMdt = shortcut for "new style configuration macro declares that" + * + * - TCL_THREADS OSCMa compilation as threaded core. + * - TCL_MEM_DEBUG OSCMa memory debugging. + * - TCL_COMPILE_DEBUG OSCMa debugging of bytecode compiler. + * - TCL_COMPILE_STATS OSCMa bytecode compiler statistics. + * + * - TCL_CFG_DO64BIT NSCMdt tcl is compiled for a 64bit system. + * - TCL_CFG_DEBUG NSCMdt tcl is compiled with symbol info on. + * - TCL_CFG_OPTIMIZED NSCMdt tcl is compiled with cc optimizations on. + * - TCL_CFG_PROFILED NSCMdt tcl is compiled with profiling info. + * + * - CFG_RUNTIME_* Paths to various stuff at runtime. + * - CFG_INSTALL_* Paths to various stuff at installation time. + * + * - TCL_CFGVAL_ENCODING string containing the encoding used for the + * configuration values. + */ + +#include "tclInt.h" + + + +/* Use C preprocessor statements to define the various values for the + * embedded configuration information. */ + +#ifdef TCL_THREADS +# define CFG_THREADED "1" +#else +# define CFG_THREADED "0" +#endif +#ifdef TCL_MEM_DEBUG +# define CFG_MEMDEBUG "1" +#else +# define CFG_MEMDEBUG "0" +#endif +#ifdef TCL_COMPILE_DEBUG +# define CFG_COMPILE_DEBUG "1" +#else +# define CFG_COMPILE_DEBUG "0" +#endif +#ifdef TCL_COMPILE_STATS +# define CFG_COMPILE_STATS "1" +#else +# define CFG_COMPILE_STATS "0" +#endif +#ifdef TCL_CFG_DO64BIT +# define CFG_64 "1" +#else +# define CFG_64 "0" +#endif +#ifdef TCL_CFG_DEBUG +# define CFG_DEBUG "1" +#else +# define CFG_DEBUG "0" +#endif +#ifdef TCL_CFG_OPTIMIZED +# define CFG_OPTIMIZED "1" +#else +# define CFG_OPTIMIZED "0" +#endif +#ifdef TCL_CFG_PROFILED +# define CFG_PROFILED "1" +#else +# define CFG_PROFILED "0" +#endif + +static Tcl_Config cfg [] = { + {"debug", CFG_DEBUG}, + {"threaded", CFG_THREADED}, + {"profiled", CFG_PROFILED}, + {"64bit", CFG_64}, + {"optimized", CFG_OPTIMIZED}, + {"mem_debug", CFG_MEMDEBUG}, + {"compile_debug", CFG_COMPILE_DEBUG}, + {"compile_stats", CFG_COMPILE_STATS}, + + /* Runtime paths to various stuff */ + + {"libdir,runtime", CFG_RUNTIME_LIBDIR}, + {"bindir,runtime", CFG_RUNTIME_BINDIR}, + {"scriptdir,runtime", CFG_RUNTIME_SCRDIR}, + {"includedir,runtime", CFG_RUNTIME_INCDIR}, + {"docdir,runtime", CFG_RUNTIME_DOCDIR}, + + /* Installation paths to various stuff */ + + {"libdir,install", CFG_INSTALL_LIBDIR}, + {"bindir,install", CFG_INSTALL_BINDIR}, + {"scriptdir,install", CFG_INSTALL_SCRDIR}, + {"includedir,install", CFG_INSTALL_INCDIR}, + {"docdir,install", CFG_INSTALL_DOCDIR}, + + /* Last entry, closes the array */ + {NULL, NULL} +}; + +void +TclInitEmbeddedConfigurationInformation (interp) + Tcl_Interp* interp; /* Interpreter the configuration + * command is registered in. */ +{ + Tcl_RegisterConfig (interp, "tcl", cfg, TCL_CFGVAL_ENCODING); +} diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 6bd10ef..60fdcf3 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclStubInit.c,v 1.84 2003/05/14 19:21:23 das Exp $ + * RCS: @(#) $Id: tclStubInit.c,v 1.85 2003/06/09 22:48:33 andreas_kupries Exp $ */ #include "tclInt.h" @@ -944,6 +944,7 @@ TclStubs tclStubs = { Tcl_DictObjRemoveKeyList, /* 502 */ Tcl_NewDictObj, /* 503 */ Tcl_DbNewDictObj, /* 504 */ + Tcl_RegisterConfig, /* 505 */ }; /* !END!: Do not edit above this line. */ |