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.

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