New function Tcl_InitSubsystems, still to be TIP'ed

5 files changed, 154 insertions, 29 deletions

diff --git a/doc/FindExec.3 b/doc/FindExec.3
index e4b4ed0..216588c 100644
--- a/doc/FindExec.3
+++ b/doc/FindExec.3
@@ -8,7 +8,7 @@
 .TH Tcl_FindExecutable 3 8.1 Tcl "Tcl Library Procedures"
 .BS
 .SH NAME
-Tcl_FindExecutable, Tcl_GetNameOfExecutable \- identify or return the name of the binary file containing the application
+Tcl_FindExecutable, Tcl_GetNameOfExecutable, Tcl_InitSubsystems \- identify or return the name of the binary file containing the application
 .SH SYNOPSIS
 .nf
 \fB#include <tcl.h>\fR
@@ -18,11 +18,18 @@ void
 .sp
 const char *
 \fBTcl_GetNameOfExecutable\fR()
+.sp
+Tcl_Interp *
+\fBTcl_InitSubsystems\fR(\fIflags\fR, \fI...\fR)
 .SH ARGUMENTS
 .AS char *argv0
 .AP char *argv0 in
 The first command-line argument to the program, which gives the
 application's name.
+.AP int flags in
+Any combination of TCL_INIT_PANIC or TCL_INIT_CREATE, which indicate
+whether a custom panicProc is registered and/or a real interpreter is created.
+The value 0 can be used if Tcl is used as utility library only.
 .BE
 
 .SH DESCRIPTION
@@ -58,6 +65,49 @@ internal full path name of the executable file as computed by
 equivalent to the \fBinfo nameofexecutable\fR command.  NULL
 is returned if the internal full path name has not been
 computed or unknown.
-
+.PP
+The \fBTcl_InitSubsystems\fR can be used as alternative to
+\fBTcl_FindExecutable\fR, when more flexibility is required.
+Its flags control exactly what is initialized.
+.PP
+The call \fBTcl_InitSubsystems(0)\fR does the same as
+\fBTcl_FindExecutable(NULL)\fR, except that a Tcl_Interp *
+is returned which can be used only by \fBTcl_InitStubs\fR
+to initialize the stub table. This opens up the Tcl Stub
+technology for Tcl embedders, which now can dynamically
+load the Tcl shared library and use functions in it
+without ever creating an interpreter. E.g. the
+following code can be compiled with -DUSE_TCL_STUBS:
+.CS
+    handle = dlopen("libtcl8.6.so", RTLD_NOW|RTLD_LOCAL);
+    initSubSystems = dlsym(handle, "Tcl_InitSubsystems");
+    interp = initSubSystems(0); /* not a real interpreter */
+    Tcl_InitStubs(interp, NULL, 0); /* initialize the stub table */
+    interp = Tcl_CreateInterp(); /* now we have a real interpreter */
+.CE
+The function \fBTcl_CreateInterp\fR, or any other Tcl function you
+would like to call, no longer needs to be searched for in the
+shared library. It can be called directly though the stub table. 
+.PP
+If you supply the flag TCL_INIT_PANIC to \fBTcl_InitSubsystems\fR,
+the function expects an additional argument, a custom panicProc.
+This is equivalent to calling \fBTcl_SetPanicProc\fR immediately
+before \fBTcl_InitSubsystems\fR.
+.PP
+If you supply the flag TCL_INIT_CREATE to \fBTcl_InitSubsystems\fR,
+the function gets two additional parameters, argc and argv. A real
+Tcl interpreter will be created and if argc > 0 then the variables
+"argc" and "argv" will be set in this interpreter. So, the above
+example code could be simplified to:
+.CS
+    handle = dlopen("libtcl8.6.so", RTLD_NOW|RTLD_LOCAL);
+    initSubSystems = dlsym(handle, "Tcl_InitSubsystems");
+    interp = initSubSystems(TCL_INIT_CREATE, 0, NULL); /* real interpreter */
+    Tcl_InitStubs(interp, NULL, 0); /* initialize the stub table */
+.CE
+.PP
+The interpreter returned by Tcl_InitSubsystems(0) cannot be passed to
+any other function than Tcl_InitStubs(). Tcl functions with an "interp"
+argument can only be called if this function supports passing NULL.
 .SH KEYWORDS
 binary, executable file
diff --git a/doc/InitStubs.3 b/doc/InitStubs.3
index 4dc62c6..8188b0b 100644
--- a/doc/InitStubs.3
+++ b/doc/InitStubs.3
@@ -83,6 +83,10 @@ non-zero means that only the specified \fIversion\fR is acceptable.
 \fBTcl_InitStubs\fR returns a string containing the actual version
 of Tcl satisfying the request, or NULL if the Tcl version is not
 acceptable, does not support stubs, or any other error condition occurred.
+.PP
+If \fBTcl_InitStubs\fR is called with as first argument the
+pseudo interpreter returned by \fBTcl_InitSubsystems(0)\fR, then
+the \fIversion\fR and \fIexact\fR parameters have no effect. 
 .SH "SEE ALSO"
 Tk_InitStubs
 .SH KEYWORDS
diff --git a/generic/tcl.h b/generic/tcl.h
index 3003abf..8a7911b 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -2409,13 +2409,21 @@ const char *		TclTomMathInitializeStubs(Tcl_Interp *interp,
  * TODO - tommath stubs export goes here!
  */
 
+/* Tcl_InitSubsystems, see TIP ??? */
+
+#define TCL_INIT_PANIC (1) /* Set Panic proc */
+#define TCL_INIT_CREATE (4) /* Call Tcl_CreateInterp(), and set argc/argv */
+
+EXTERN Tcl_Interp *Tcl_InitSubsystems(int flags, ...);
+
 /*
  * Public functions that are not accessible via the stubs table.
  * Tcl_GetMemoryInfo is needed for AOLserver. [Bug 1868171]
  */
 
 #define Tcl_Main(argc, argv, proc) Tcl_MainEx(argc, argv, proc, \
-	    (Tcl_FindExecutable(argv[0]), (Tcl_CreateInterp)()))
+	    Tcl_InitSubsystems(TCL_INIT_CREATE, argc, argv))
+//	    (Tcl_FindExecutable(argv[0]), (Tcl_CreateInterp)()))
 EXTERN void		Tcl_MainEx(int argc, char **argv,
 			    Tcl_AppInitProc *appInitProc, Tcl_Interp *interp);
 EXTERN const char *	Tcl_PkgInitStubsCheck(Tcl_Interp *interp,
diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c
index 7a55724..9a64f10 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.c
@@ -1411,7 +1411,7 @@ Tcl_UtfToExternal(
 /*
  *---------------------------------------------------------------------------
  *
- * Tcl_FindExecutable --
+ * Tcl_InitSubsystems/Tcl_FindExecutable --
  *
  *	This function computes the absolute path name of the current
  *	application, given its argv[0] value.
@@ -1425,6 +1425,64 @@ Tcl_UtfToExternal(
  *
  *---------------------------------------------------------------------------
  */
+MODULE_SCOPE const TclStubs tclStubs;
+
+/* Dummy const structure returned by Tcl_InitSubsystems,
+ * which looks like an Tcl_Interp, but in reality is not.
+ * It contains just enough for Tcl_InitStubs to be able
+ * to initialize the stub table. */
+static const struct {
+    const char *version; /* a real interpreter has interp->result here. */
+    void (*unused2) (void); /* a real interpreter has interp->freeProc here. */
+    int magic; /* a real interpreter has interp->errorLine here. */
+    const struct TclStubs *stubTable;
+} dummyInterp = {
+    TCL_PATCH_LEVEL, 0, TCL_STUB_MAGIC, &tclStubs
+};
+
+Tcl_Interp *
+Tcl_InitSubsystems(int flags, ...)
+{
+    va_list argList;
+
+    int argc = 0;
+    char **argv = NULL;
+
+    va_start(argList, flags);
+    if (flags & TCL_INIT_PANIC) {
+	Tcl_SetPanicProc(va_arg(argList, Tcl_PanicProc *));
+    }
+    if (flags & TCL_INIT_CREATE) {
+	argc = va_arg(argList, int);
+	argv = va_arg(argList, char **);
+    }
+    va_end (argList);
+
+    TclInitSubsystems();
+    TclpSetInitialEncodings();
+    TclpFindExecutable(argv ? argv[0] : NULL);
+    if (flags & TCL_INIT_CREATE) {
+	Tcl_Interp *interp = Tcl_CreateInterp();
+	if (argc > 0) {
+	    Tcl_Obj *argvPtr;
+	    argc--;
+	    argv++;
+
+	    Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewIntObj(argc), TCL_GLOBAL_ONLY);
+	    argvPtr = Tcl_NewListObj(argc, NULL);
+	    while (argc--) {
+		Tcl_DString ds;
+
+		Tcl_ExternalToUtfDString(NULL, *argv++, -1, &ds);
+		Tcl_ListObjAppendElement(NULL, argvPtr, TclDStringToObj(&ds));
+	    }
+	    Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY);
+	}
+	return interp;
+    }
+    return (Tcl_Interp *) &dummyInterp;
+}
+
 #undef Tcl_FindExecutable
 void
 Tcl_FindExecutable(
diff --git a/generic/tclStubLib.c b/generic/tclStubLib.c
index 859cbf9..c5c0d92 100644
--- a/generic/tclStubLib.c
+++ b/generic/tclStubLib.c
@@ -73,37 +73,42 @@ Tcl_InitStubs(
 	return NULL;
     }
 
-    actualVersion = stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 0, &pkgData);
-    if (actualVersion == NULL) {
-	return NULL;
-    }
-    if (exact) {
-	const char *p = version;
-	int count = 0;
-
-	while (*p) {
-	    count += !isDigit(*p++);
+    if(iPtr->errorLine == TCL_STUB_MAGIC) {
+	actualVersion = iPtr->result;
+	tclStubsPtr = stubsPtr;
+    } else {
+	actualVersion = stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 0, &pkgData);
+	if (actualVersion == NULL) {
+	    return NULL;
 	}
-	if (count == 1) {
-	    const char *q = actualVersion;
+	if (exact) {
+	    const char *p = version;
+	    int count = 0;
 
-	    p = version;
-	    while (*p && (*p == *q)) {
-		p++; q++;
-	    }
-	    if (*p || isDigit(*q)) {
-		/* Construct error message */
-		stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 1, NULL);
-		return NULL;
+	    while (*p) {
+		count += !isDigit(*p++);
 	    }
-	} else {
-	    actualVersion = stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 1, NULL);
-	    if (actualVersion == NULL) {
-		return NULL;
+	    if (count == 1) {
+		const char *q = actualVersion;
+
+		p = version;
+		while (*p && (*p == *q)) {
+		    p++; q++;
+		}
+		if (*p || isDigit(*q)) {
+		    /* Construct error message */
+		    stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 1, NULL);
+		    return NULL;
+		}
+	    } else {
+		actualVersion = stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 1, NULL);
+		if (actualVersion == NULL) {
+		    return NULL;
+		}
 	    }
 	}
+	tclStubsPtr = (const TclStubs *)pkgData;
     }
-    tclStubsPtr = (TclStubs *)pkgData;
 
     if (tclStubsPtr->hooks) {
 	tclPlatStubsPtr = tclStubsPtr->hooks->tclPlatStubs;