diff options
author | andreas_kupries <akupries@shaw.ca> | 2002-01-25 01:47:01 (GMT) |
---|---|---|
committer | andreas_kupries <akupries@shaw.ca> | 2002-01-25 01:47:01 (GMT) |
commit | a7119303818347be3a1448e12dd868c41371de05 (patch) | |
tree | 737ede57f173dbe1cba88077ecc84db48fa8abf1 /generic | |
parent | a6b8152740ffe25d2be6a130a03abbedf558538b (diff) | |
download | tcl-a7119303818347be3a1448e12dd868c41371de05.zip tcl-a7119303818347be3a1448e12dd868c41371de05.tar.gz tcl-a7119303818347be3a1448e12dd868c41371de05.tar.bz2 |
First implementation of TIP #59 for Unix and Windows platforms.
Made into a branch to allow me and platform specific maintainers
to work on this in a coordinated way.
Diffstat (limited to 'generic')
-rw-r--r-- | generic/tcl.decls | 8 | ||||
-rw-r--r-- | generic/tcl.h | 11 | ||||
-rw-r--r-- | generic/tclBasic.c | 11 | ||||
-rw-r--r-- | generic/tclConfig.c | 287 | ||||
-rw-r--r-- | generic/tclDecls.h | 12 | ||||
-rw-r--r-- | generic/tclInt.h | 4 | ||||
-rw-r--r-- | generic/tclPkgConfig.c | 111 | ||||
-rw-r--r-- | generic/tclStubInit.c | 3 |
8 files changed, 441 insertions, 6 deletions
diff --git a/generic/tcl.decls b/generic/tcl.decls index fb2bd6d..af6546f 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -10,7 +10,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.77 2002/01/23 20:46:01 dgp Exp $ +# RCS: @(#) $Id: tcl.decls,v 1.77.2.1 2002/01/25 01:47:01 andreas_kupries Exp $ library tcl @@ -1698,6 +1698,12 @@ declare 482 generic { void Tcl_GetTime( Tcl_Time* timeBuf ) } +# New export due to TIP#59 +declare 483 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 7965e2a..8b39291 100644 --- a/generic/tcl.h +++ b/generic/tcl.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: tcl.h,v 1.110 2002/01/17 04:37:33 dgp Exp $ + * RCS: @(#) $Id: tcl.h,v 1.110.2.1 2002/01/25 01:47:01 andreas_kupries Exp $ */ #ifndef _TCL @@ -2070,6 +2070,15 @@ typedef struct Tcl_Parse { typedef unsigned short Tcl_UniChar; +/* 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 0cf25fc..9244ab3 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.43 2001/12/14 20:31:22 msofer Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.43.2.1 2002/01/25 01:47:01 andreas_kupries Exp $ */ #include "tclInt.h" @@ -558,6 +558,15 @@ 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..7e02c20 --- /dev/null +++ b/generic/tclConfig.c @@ -0,0 +1,287 @@ +/* + * 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.1.2.1 2002/01/25 01:47:01 andreas_kupries 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); +} diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 967636e..3773485 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.77 2002/01/23 20:46:01 dgp Exp $ + * RCS: @(#) $Id: tclDecls.h,v 1.77.2.1 2002/01/25 01:47:01 andreas_kupries Exp $ */ #ifndef _TCLDECLS @@ -1514,6 +1514,11 @@ EXTERN int Tcl_EvalTokensStandard _ANSI_ARGS_(( int count)); /* 482 */ EXTERN void Tcl_GetTime _ANSI_ARGS_((Tcl_Time* timeBuf)); +/* 483 */ +EXTERN void Tcl_RegisterConfig _ANSI_ARGS_((Tcl_Interp* interp, + CONST char* pkgName, + Tcl_Config* configuration, + CONST char* valEncoding)); typedef struct TclStubHooks { struct TclPlatStubs *tclPlatStubs; @@ -2056,6 +2061,7 @@ typedef struct TclStubs { void (*tcl_FSMountsChanged) _ANSI_ARGS_((Tcl_Filesystem * fsPtr)); /* 480 */ int (*tcl_EvalTokensStandard) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Token * tokenPtr, int count)); /* 481 */ void (*tcl_GetTime) _ANSI_ARGS_((Tcl_Time* timeBuf)); /* 482 */ + void (*tcl_RegisterConfig) _ANSI_ARGS_((Tcl_Interp* interp, CONST char* pkgName, Tcl_Config* configuration, CONST char* valEncoding)); /* 483 */ } TclStubs; #ifdef __cplusplus @@ -4028,6 +4034,10 @@ extern TclStubs *tclStubsPtr; #define Tcl_GetTime \ (tclStubsPtr->tcl_GetTime) /* 482 */ #endif +#ifndef Tcl_RegisterConfig +#define Tcl_RegisterConfig \ + (tclStubsPtr->tcl_RegisterConfig) /* 483 */ +#endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclInt.h b/generic/tclInt.h index 301632d..d586616 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.75 2002/01/15 21:19:07 dgp Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.75.2.1 2002/01/25 01:47:01 andreas_kupries Exp $ */ #ifndef _TCLINT @@ -1652,6 +1652,8 @@ EXTERN int TclDoGlob _ANSI_ARGS_((Tcl_Interp *interp, char *separators, Tcl_DString *headPtr, char *tail, Tcl_GlobTypeData *types)); EXTERN void TclDumpMemoryInfo _ANSI_ARGS_((FILE *outFile)); +EXTERN void TclInitEmbeddedConfigurationInformation + _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN void TclExpandTokenArray _ANSI_ARGS_(( Tcl_Parse *parsePtr)); EXTERN void TclExprFloatError _ANSI_ARGS_((Tcl_Interp *interp, diff --git a/generic/tclPkgConfig.c b/generic/tclPkgConfig.c new file mode 100644 index 0000000..89ef6c1 --- /dev/null +++ b/generic/tclPkgConfig.c @@ -0,0 +1,111 @@ +/* + * 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.1.2.1 2002/01/25 01:47:01 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_PREFIX Path to platform independent data at runtime + * - CFG_RUNTIME_EXEC_PREFIX Path to platform dependent data at runtime + * - CFG_INSTALL_PREFIX Path to platform independent data during installation + * - CFG_INSTALL_EXEC_PREFIX Path to platform dependent data during installation + * + * - 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}, + {"prefix,runtime", CFG_RUNTIME_PREFIX}, + {"exec_prefix,runtime", CFG_RUNTIME_EXEC_PREFIX}, + {"prefix,install", CFG_INSTALL_PREFIX}, + {"exec_prefix,install", CFG_INSTALL_EXEC_PREFIX}, + /* Last entry, closes the array */ + {NULL, NULL} +}; + +void +TclInitEmbeddedConfigurationInformation (interp) + Tcl_Interp* interp; /* interp 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 9f739bd..a8cb812 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.66 2002/01/05 22:55:52 dgp Exp $ + * RCS: @(#) $Id: tclStubInit.c,v 1.66.2.1 2002/01/25 01:47:01 andreas_kupries Exp $ */ #include "tclInt.h" @@ -885,6 +885,7 @@ TclStubs tclStubs = { Tcl_FSMountsChanged, /* 480 */ Tcl_EvalTokensStandard, /* 481 */ Tcl_GetTime, /* 482 */ + Tcl_RegisterConfig, /* 483 */ }; /* !END!: Do not edit above this line. */ |