From 0cdb762ff0a1aa77e68dd137315bcd46861505da Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 2 Jul 2013 12:05:51 +0000 Subject: First experimental implementation of RFE [854941], built on top of [http://tip.tcl.tk/414|TIP #414]. --- generic/tclStubLibDl.c | 91 ++++++++++++++++++++++++++++++++++++++++++++++++++ unix/Makefile.in | 6 +++- win/Makefile.in | 4 +++ win/makefile.bc | 4 +++ win/makefile.vc | 4 +++ win/tcl.dsp | 4 +++ 6 files changed, 112 insertions(+), 1 deletion(-) create mode 100644 generic/tclStubLibDl.c diff --git a/generic/tclStubLibDl.c b/generic/tclStubLibDl.c new file mode 100644 index 0000000..1b12698 --- /dev/null +++ b/generic/tclStubLibDl.c @@ -0,0 +1,91 @@ +/* + * tclStubLibDl.c -- + * + * Stub object that will be statically linked into extensions that want + * to access Tcl. + * + * Copyright (c) 1998-1999 by Scriptics Corporation. + * Copyright (c) 1998 Paul Duffin. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include "tclInt.h" +#ifndef _WIN32 +# include +#else +# define dlopen(a,b) (void *)LoadLibraryA(a) +# define dlsym(a,b) (void *)GetProcAddress((HANDLE)(a),b) +#endif + +/* + *---------------------------------------------------------------------- + * + * Tcl_InitSubsystems -- + * + * Initialize the stub table, using the structure pointed at + * by the "version" argument. + * + * Results: + * Outputs the value of the "version" argument. + * + * Side effects: + * Sets the stub table pointers. + * + *---------------------------------------------------------------------- + */ + +static TclStubInfoType info; + +MODULE_SCOPE const char * +Tcl_InitSubsystems( + Tcl_PanicProc *panicProc) +{ + void *handle = dlopen(TCL_LIB_FILE, RTLD_NOW|RTLD_LOCAL); + const char *(*initSubsystems)(Tcl_PanicProc *); + const char *(*setPanicProc)(Tcl_PanicProc *); + Tcl_Interp *interp, *(*createInterp)(void); + int a,b,c,d; + + if (!handle) { + if (panicProc) { + panicProc("Cannot find Tcl core"); + } else { + fprintf(stderr, "Cannot find Tcl core"); + abort(); + } + return NULL; + } + initSubsystems = dlsym(handle, "Tcl_InitSubsystems"); + if (!initSubsystems) { + initSubsystems = dlsym(handle, "_Tcl_InitSubsystems"); + } + if (initSubsystems) { + return initSubsystems(panicProc); + } + setPanicProc = dlsym(handle, "Tcl_SetPanicProc"); + if (!setPanicProc) { + setPanicProc = dlsym(handle, "_Tcl_SetPanicProc"); + } + createInterp = dlsym(handle, "Tcl_CreateInterp"); + if (!createInterp) { + createInterp = dlsym(handle, "_Tcl_CreateInterp"); + } + + setPanicProc(panicProc); + interp = createInterp(); + info.stubs = ((Interp *) interp)->stubTable; + info.stubs->tcl_DeleteInterp(interp); + info.stubs->tcl_GetVersion(&a, &b, &c, &d); + sprintf(info.version, "%d.%d.%d", a, b, c); + return info.version; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/unix/Makefile.in b/unix/Makefile.in index 5295a45..3f44748 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -335,7 +335,7 @@ TOMMATH_OBJS = bncore.o bn_reverse.o bn_fast_s_mp_mul_digs.o \ bn_mp_unsigned_bin_size.o bn_mp_xor.o bn_mp_zero.o bn_s_mp_add.o \ bn_s_mp_mul_digs.o bn_s_mp_sqr.o bn_s_mp_sub.o -STUB_LIB_OBJS = tclStubLib.o tclStubLibTbl.o tclTomMathStubLib.o tclOOStubLib.o ${COMPAT_OBJS} +STUB_LIB_OBJS = tclStubLib.o tclStubLibTbl.o tclStubLibDl.o tclTomMathStubLib.o tclOOStubLib.o ${COMPAT_OBJS} UNIX_OBJS = tclUnixChan.o tclUnixEvent.o tclUnixFCmd.o \ tclUnixFile.o tclUnixPipe.o tclUnixSock.o \ @@ -471,6 +471,7 @@ OO_SRCS = \ STUB_SRCS = \ $(GENERIC_DIR)/tclStubLib.c \ $(GENERIC_DIR)/tclStubLibTbl.c \ + $(GENERIC_DIR)/tclStubLibDl.c \ $(GENERIC_DIR)/tclTomMathStubLib.c \ $(GENERIC_DIR)/tclOOStubLib.c @@ -1689,6 +1690,9 @@ tclStubLib.o: $(GENERIC_DIR)/tclStubLib.c tclStubLibTbl.o: $(GENERIC_DIR)/tclStubLibTbl.c $(CC) -c $(STUB_CC_SWITCHES) $(GENERIC_DIR)/tclStubLibTbl.c +tclStubLibDl.o: $(GENERIC_DIR)/tclStubLibDl.c + $(CC) -c $(STUB_CC_SWITCHES) -DTCL_LIB_FILE="\"$(TCL_LIB_FILE)\"" $(GENERIC_DIR)/tclStubLibDl.c + tclTomMathStubLib.o: $(GENERIC_DIR)/tclTomMathStubLib.c $(CC) -c $(STUB_CC_SWITCHES) $(GENERIC_DIR)/tclTomMathStubLib.c diff --git a/win/Makefile.in b/win/Makefile.in index d7b25b7..986b517 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -386,6 +386,7 @@ REG_OBJS = tclWinReg.$(OBJEXT) STUB_OBJS = \ tclStubLib.$(OBJEXT) \ tclStubLibTbl.$(OBJEXT) \ + tclStubLibDl.$(OBJEXT) \ tclTomMathStubLib.$(OBJEXT) \ tclOOStubLib.$(OBJEXT) @@ -519,6 +520,9 @@ tclStubLib.${OBJEXT}: tclStubLib.c tclStubLibTbl.${OBJEXT}: tclStubLibTbl.c $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @DEPARG@ $(CC_OBJNAME) +tclStubLibDl.${OBJEXT}: tclStubLibDl.c + $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD -DTCL_LIB_FILE="\"$(TCL_LIB_FILE)\"" @DEPARG@ $(CC_OBJNAME) + tclTomMathStubLib.${OBJEXT}: tclTomMathStubLib.c $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @DEPARG@ $(CC_OBJNAME) diff --git a/win/makefile.bc b/win/makefile.bc index 2726dad..0315c98 100644 --- a/win/makefile.bc +++ b/win/makefile.bc @@ -280,6 +280,7 @@ TCLOBJS = \ TCLSTUBOBJS = \ $(TMPDIR)\tclStubLib.obj \ $(TMPDIR)\tclStubLibTbl.obj \ + $(TMPDIR)\tclStubLibDl.obj \ $(TMPDIR)\tclTomMathStubLib.obj \ $(TMPDIR)\tclOOStubLib.obj @@ -532,6 +533,9 @@ $(TMPDIR)\tclStubLib.obj : $(GENERICDIR)\tclStubLib.c $(TMPDIR)\tclStubLibTbl.obj : $(GENERICDIR)\tclStubLibTbl.c $(cc32) $(TCL_CFLAGS) -DSTATIC_BUILD -o$(TMPDIR)\$@ $? +$(TMPDIR)\tclStubLibDl.obj : $(GENERICDIR)\tclStubLibDl.c + $(cc32) $(TCL_CFLAGS) -DSTATIC_BUILD -o$(TMPDIR)\$@ $? + $(TMPDIR)\tclTomMathStubLib.obj : $(GENERICDIR)\tclTomMathStubLib.c $(cc32) $(TCL_CFLAGS) -DSTATIC_BUILD -o$(TMPDIR)\$@ $? diff --git a/win/makefile.vc b/win/makefile.vc index c24534a..cf61bbf 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -451,6 +451,7 @@ TCLOBJS = $(COREOBJS) $(ZLIBOBJS) $(TOMMATHOBJS) $(PLATFORMOBJS) TCLSTUBOBJS = \ $(TMP_DIR)\tclStubLib.obj \ $(TMP_DIR)\tclStubLibTbl.obj \ + $(TMP_DIR)\tclStubLibDl.obj \ $(TMP_DIR)\tclTomMathStubLib.obj \ $(TMP_DIR)\tclOOStubLib.obj @@ -983,6 +984,9 @@ $(TMP_DIR)\tclStubLib.obj: $(GENERICDIR)\tclStubLib.c $(TMP_DIR)\tclStubLibTbl.obj: $(GENERICDIR)\tclStubLibTbl.c $(cc32) $(STUB_CFLAGS) -Zl -DSTATIC_BUILD $(TCL_INCLUDES) -Fo$@ $? +$(TMP_DIR)\tclStubLibDl.obj: $(GENERICDIR)\tclStubLibDl.c + $(cc32) $(STUB_CFLAGS) -Zl -DSTATIC_BUILD $(TCL_INCLUDES) -Fo$@ $? + $(TMP_DIR)\tclTomMathStubLib.obj: $(GENERICDIR)\tclTomMathStubLib.c $(cc32) $(STUB_CFLAGS) -Zl -DSTATIC_BUILD $(TCL_INCLUDES) -Fo$@ $? diff --git a/win/tcl.dsp b/win/tcl.dsp index 2708051..afe1960 100644 --- a/win/tcl.dsp +++ b/win/tcl.dsp @@ -1304,6 +1304,10 @@ SOURCE=..\generic\tclStubLibTbl.c # End Source File # Begin Source File +SOURCE=..\generic\tclStubLibDl.c +# End Source File +# Begin Source File + SOURCE=..\generic\tclOOStubLib.c # End Source File # Begin Source File -- cgit v0.12 From f44c65ff893ab9fe381cbd0556fe81c35d09c6fa Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 24 Sep 2015 14:43:22 +0000 Subject: Minor simplification and correct TCL_NORETURN decoration --- generic/tclStubLibDl.c | 15 ++++----------- 1 file changed, 4 insertions(+), 11 deletions(-) diff --git a/generic/tclStubLibDl.c b/generic/tclStubLibDl.c index bae2e64..2e09659 100644 --- a/generic/tclStubLibDl.c +++ b/generic/tclStubLibDl.c @@ -46,7 +46,7 @@ Tcl_InitSubsystems( const char *(*initSubsystems)(TCL_NORETURN1 Tcl_PanicProc *); int a,b,c,d; - if (!info.version[0]) { + if (!info.stubs) { void *handle = dlopen(TCL_DLL_FILE, RTLD_NOW|RTLD_LOCAL); if (!handle) { handle = dlopen(TCL_PREV_DLL_FILE, RTLD_NOW|RTLD_LOCAL); @@ -67,12 +67,11 @@ Tcl_InitSubsystems( if (initSubsystems) { /* If the core has TIP #414, use it. */ const char *version = initSubsystems(panicProc); + strcpy(info.version, version); info.stubs = ((const TclStubs **)version)[-1]; - strcpy(info.version+1, version+1); - info.version[0] = version[0]; } else { const TclStubs *stubs; - const char *(*setPanicProc)(Tcl_PanicProc *); + const char *(*setPanicProc)(TCL_NORETURN1 Tcl_PanicProc *); Tcl_Interp *interp, *(*createInterp)(void); setPanicProc = dlsym(handle, "Tcl_SetPanicProc"); @@ -88,14 +87,8 @@ Tcl_InitSubsystems( stubs = ((Interp *) interp)->stubTable; stubs->tcl_DeleteInterp(interp); stubs->tcl_GetVersion(&a, &b, &c, &d); + sprintf(info.version, "%d.%d%c%d", a, b, "ab."[d], c); info.stubs = stubs; - if (a>9) { - sprintf(info.version+1, "%d.%d%c%d", a%10, b, "ab."[d], c); - info.version[0] = '0' + (a/10); - } else { - sprintf(info.version+1, ".%d%c%d", b, "ab."[d], c); - info.version[0] = '0' + a; - } } } return info.version; -- cgit v0.12