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 From 8a04fcf1ecb00bae11f6d1e7a4482a61a33230b0 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 5 Dec 2016 19:17:52 +0000 Subject: WIP trial of proper bytearrays in Tcl 9. --- generic/tclBinary.c | 21 +++++++++++++++------ 1 file changed, 15 insertions(+), 6 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 5c5e86d..4074596 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -452,7 +452,9 @@ Tcl_GetByteArrayFromObj( if ((objPtr->typePtr != &properByteArrayType) && (objPtr->typePtr != &tclByteArrayType)) { - SetByteArrayFromAny(NULL, objPtr); + if (TCL_ERROR == SetByteArrayFromAny(NULL, objPtr)) { + return NULL; + } } baPtr = GET_BYTEARRAY(objPtr); @@ -496,7 +498,9 @@ Tcl_SetByteArrayLength( } if ((objPtr->typePtr != &properByteArrayType) && (objPtr->typePtr != &tclByteArrayType)) { - SetByteArrayFromAny(NULL, objPtr); + if (TCL_ERROR == SetByteArrayFromAny(NULL, objPtr)) { + return NULL; + } } byteArrayPtr = GET_BYTEARRAY(objPtr); @@ -531,7 +535,7 @@ SetByteArrayFromAny( Tcl_Interp *interp, /* Not used. */ Tcl_Obj *objPtr) /* The object to convert to type ByteArray. */ { - int length, improper = 0; + int length; const char *src, *srcEnd; unsigned char *dst; ByteArray *byteArrayPtr; @@ -550,7 +554,10 @@ SetByteArrayFromAny( byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length)); for (dst = byteArrayPtr->bytes; src < srcEnd; ) { src += Tcl_UtfToUniChar(src, &ch); - improper = improper || (ch > 255); + if (ch > 255) { + ckfree(byteArrayPtr); + return TCL_ERROR; + } *dst++ = UCHAR(ch); } @@ -558,7 +565,7 @@ SetByteArrayFromAny( byteArrayPtr->allocated = length; TclFreeIntRep(objPtr); - objPtr->typePtr = improper ? &tclByteArrayType : &properByteArrayType; + objPtr->typePtr = &properByteArrayType; SET_BYTEARRAY(objPtr, byteArrayPtr); return TCL_OK; } @@ -731,7 +738,9 @@ TclAppendBytesToByteArray( } if ((objPtr->typePtr != &properByteArrayType) && (objPtr->typePtr != &tclByteArrayType)) { - SetByteArrayFromAny(NULL, objPtr); + if (TCL_ERROR == SetByteArrayFromAny(NULL, objPtr)) { + Tcl_Panic("attempt to append bytes to non-bytearray"); + } } byteArrayPtr = GET_BYTEARRAY(objPtr); -- cgit v0.12 From dcd49ec1ee202c50fa9921cabd1b716ae0c159fe Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 6 Dec 2016 18:55:28 +0000 Subject: Several commands should be picky about expecting byte-valued arguments. Make them so. --- generic/tclBinary.c | 31 ++++++++++++++++++++++++++++--- generic/tclCmdAH.c | 6 ++++++ generic/tclTest.c | 4 ++++ tests/utf.test | 4 ++-- 4 files changed, 40 insertions(+), 5 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 4074596..350105a 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -453,6 +453,9 @@ Tcl_GetByteArrayFromObj( if ((objPtr->typePtr != &properByteArrayType) && (objPtr->typePtr != &tclByteArrayType)) { if (TCL_ERROR == SetByteArrayFromAny(NULL, objPtr)) { + if (lengthPtr != NULL) { + *lengthPtr = 0; + } return NULL; } } @@ -1370,9 +1373,13 @@ BinaryScanCmd( "value formatString ?varName ...?"); return TCL_ERROR; } + buffer = Tcl_GetByteArrayFromObj(objv[1], &length); + if (buffer == NULL) { + Tcl_AppendResult(interp, "binary scan expects bytes", NULL); + return TCL_ERROR; + } numberCachePtr = &numberCacheHash; Tcl_InitHashTable(numberCachePtr, TCL_ONE_WORD_KEYS); - buffer = Tcl_GetByteArrayFromObj(objv[1], &length); format = TclGetString(objv[2]); arg = 3; offset = 0; @@ -2411,8 +2418,13 @@ BinaryEncodeHex( return TCL_ERROR; } - TclNewObj(resultObj); data = Tcl_GetByteArrayFromObj(objv[1], &count); + if (data == NULL) { + Tcl_AppendResult(interp, "binary encode expects bytes", NULL); + return TCL_ERROR; + } + + TclNewObj(resultObj); cursor = Tcl_SetByteArrayLength(resultObj, count * 2); for (offset = 0; offset < count; ++offset) { *cursor++ = HexDigits[((data[offset] >> 4) & 0x0f)]; @@ -2605,8 +2617,12 @@ BinaryEncode64( } } - resultObj = Tcl_NewObj(); data = Tcl_GetByteArrayFromObj(objv[objc-1], &count); + if (data == NULL) { + Tcl_AppendResult(interp, "binary encode expects bytes", NULL); + return TCL_ERROR; + } + resultObj = Tcl_NewObj(); if (count > 0) { size = (((count * 4) / 3) + 3) & ~3; /* ensure 4 byte chunks */ if (maxlen > 0 && size > maxlen) { @@ -2705,6 +2721,11 @@ BinaryEncodeUu( break; case OPT_WRAPCHAR: wrapchar = Tcl_GetByteArrayFromObj(objv[i+1], &wrapcharlen); + if (wrapchar == NULL) { + Tcl_AppendResult(interp, + "binary encode -wrapchar expects bytes", NULL); + return TCL_ERROR; + } break; } } @@ -2717,6 +2738,10 @@ BinaryEncodeUu( resultObj = Tcl_NewObj(); offset = 0; data = Tcl_GetByteArrayFromObj(objv[objc-1], &count); + if (data == NULL) { + Tcl_AppendResult(interp, "binary encode expects bytes", NULL); + return TCL_ERROR; + } rawLength = (lineLength - 1) * 3 / 4; start = cursor = Tcl_SetByteArrayLength(resultObj, (lineLength + wrapcharlen) * diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 0883a1d..9afc4f6 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -431,6 +431,12 @@ Tcl_EncodingObjCmd( */ stringPtr = (char *) Tcl_GetByteArrayFromObj(data, &length); + if (stringPtr == NULL) { + Tcl_AppendResult(interp, "encoding conversion expects bytes", + NULL); + Tcl_FreeEncoding(encoding); + return TCL_ERROR; + } Tcl_ExternalToUtfDString(encoding, stringPtr, length, &ds); /* diff --git a/generic/tclTest.c b/generic/tclTest.c index bc64594..d554c54 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -4847,6 +4847,10 @@ TestbytestringObjCmd( return TCL_ERROR; } p = (const char *)Tcl_GetByteArrayFromObj(objv[1], &n); + if (p == NULL) { + Tcl_AppendResult(interp, "testbytestring expects bytes", NULL); + return TCL_ERROR; + } Tcl_SetObjResult(interp, Tcl_NewStringObj(p, n)); return TCL_OK; } diff --git a/tests/utf.test b/tests/utf.test index a03dd6c..4a4c1d0 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -75,7 +75,7 @@ test utf-4.2 {Tcl_NumUtfChars: length 1} {testnumutfchars testbytestring} { testnumutfchars [testbytestring "\xC2\xA2"] } {1} test utf-4.3 {Tcl_NumUtfChars: long string} {testnumutfchars testbytestring} { - testnumutfchars [testbytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e4e"] + testnumutfchars [testbytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e"] } {7} test utf-4.4 {Tcl_NumUtfChars: #u0000} {testnumutfchars testbytestring} { testnumutfchars [testbytestring "\xC0\x80"] @@ -87,7 +87,7 @@ test utf-4.6 {Tcl_NumUtfChars: length 1, calc len} {testnumutfchars testbytestri testnumutfchars [testbytestring "\xC2\xA2"] 1 } {1} test utf-4.7 {Tcl_NumUtfChars: long string, calc len} {testnumutfchars testbytestring} { - testnumutfchars [testbytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e4e"] 1 + testnumutfchars [testbytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e"] 1 } {7} test utf-4.8 {Tcl_NumUtfChars: #u0000, calc len} {testnumutfchars testbytestring} { testnumutfchars [testbytestring "\xC0\x80"] 1 -- cgit v0.12 From 6cdaf31447fff194fce3985d881f5328e110a650 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 6 Dec 2016 20:09:00 +0000 Subject: Purge the old and broken Tcl_ObjType. --- generic/tclBinary.c | 95 +++-------------------------------------------------- generic/tclInt.h | 1 - generic/tclObj.c | 1 - tests/execute.test | 2 +- tests/obj.test | 5 ++- 5 files changed, 8 insertions(+), 96 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 350105a..9175036 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -160,10 +160,6 @@ static const EnsembleImplMap decodeMap[] = { * without loss or damage. Such values are useful for things like * encoded strings or Tk images to name just two. * - * It's strange to have two Tcl_ObjTypes in place for this task when - * one would do, so a bit of detail and history how we got to this point - * and where we might go from here. - * * A bytearray is an ordered sequence of bytes. Each byte is an integer * value in the range [0-255]. To be a Tcl value type, we need a way to * encode each value in the value set as a Tcl string. The simplest @@ -173,75 +169,8 @@ static const EnsembleImplMap decodeMap[] = { * This approach creates a one-to-one map between all bytearray values * and a subset of Tcl string values. * - * When converting a Tcl string value to the bytearray internal rep, the - * question arises what to do with strings outside that subset? That is, - * those Tcl strings containing at least one codepoint greater than 255? - * The obviously correct answer is to raise an error! That string value - * does not represent any valid bytearray value. Full Stop. The - * setFromAnyProc signature has a completion code return value for just - * this reason, to reject invalid inputs. - * - * Unfortunately this was not the path taken by the authors of the - * original tclByteArrayType. They chose to accept all Tcl string values - * as acceptable string encodings of the bytearray values that result - * from masking away the high bits of any codepoint value at all. This - * meant that every bytearray value had multiple accepted string - * representations. - * - * The implications of this choice are truly ugly. When a Tcl value has - * a string representation, we are required to accept that as the true - * value. Bytearray values that possess a string representation cannot - * be processed as bytearrays because we cannot know which true value - * that bytearray represents. The consequence is that we drag around - * an internal rep that we cannot make any use of. This painful price - * is extracted at any point after a string rep happens to be generated - * for the value. This happens even when the troublesome codepoints - * outside the byte range never show up. This happens rather routinely - * in normal Tcl operations unless we burden the script writer with the - * cognitive burden of avoiding it. The price is also paid by callers - * of the C interface. The routine - * - * unsigned char *Tcl_GetByteArrayFromObj(objPtr, lenPtr) - * - * has a guarantee to always return a non-NULL value, but that value - * points to a byte sequence that cannot be used by the caller to - * process the Tcl value absent some sideband testing that objPtr - * is "pure". Tcl offers no public interface to perform this test, - * so callers either break encapsulation or are unavoidably buggy. Tcl - * has defined a public interface that cannot be used correctly. The - * Tcl source code itself suffers the same problem, and has been buggy, - * but progressively less so as more and more portions of the code have - * been retrofitted with the required "purity testing". The set of values - * able to pass the purity test can be increased via the introduction of - * a "canonical" flag marker, but the only way the broken interface itself - * can be discarded is to start over and define the Tcl_ObjType properly. - * Bytearrays should simply be usable as bytearrays without a kabuki - * dance of testing. - * - * The Tcl_ObjType "properByteArrayType" is (nearly) a correct - * implementation of bytearrays. Any Tcl value with the type - * properByteArrayType can have its bytearray value fetched and - * used with confidence that acting on that value is equivalent to - * acting on the true Tcl string value. This still implies a side - * testing burden -- past mistakes will not let us avoid that - * immediately, but it is at least a conventional test of type, and - * can be implemented entirely by examining the objPtr fields, with - * no need to query the intrep, as a canonical flag would require. - * - * Until Tcl_GetByteArrayFromObj() and Tcl_SetByteArrayLength() can - * be revised to admit the possibility of returning NULL when the true - * value is not a valid bytearray, we need a mechanism to retain - * compatibility with the deployed callers of the broken interface. - * That's what the retained "tclByteArrayType" provides. In those - * unusual circumstances where we convert an invalid bytearray value - * to a bytearray type, it is to this legacy type. Essentially any - * time this legacy type gets used, it's a signal of a bug being ignored. - * A TIP should be drafted to remove this connection to the broken past - * so that Tcl 9 will no longer have any trace of it. Prescribing a - * migration path will be the key element of that work. The internal - * changes now in place are the limit of what can be done short of - * interface repair. They provide a great expansion of the histories - * over which bytearray values can be useful in the meanwhile. + * When converting a Tcl string value to the bytearray internal rep, and + * the string value is outside that subset, an error is raised. */ static const Tcl_ObjType properByteArrayType = { @@ -252,14 +181,6 @@ static const Tcl_ObjType properByteArrayType = { NULL }; -const Tcl_ObjType tclByteArrayType = { - "bytearray", - FreeByteArrayInternalRep, - DupByteArrayInternalRep, - NULL, - SetByteArrayFromAny -}; - /* * The following structure is the internal rep for a ByteArray object. Keeps * track of how much memory has been used and how much has been allocated for @@ -450,8 +371,7 @@ Tcl_GetByteArrayFromObj( { ByteArray *baPtr; - if ((objPtr->typePtr != &properByteArrayType) - && (objPtr->typePtr != &tclByteArrayType)) { + if (objPtr->typePtr != &properByteArrayType) { if (TCL_ERROR == SetByteArrayFromAny(NULL, objPtr)) { if (lengthPtr != NULL) { *lengthPtr = 0; @@ -499,8 +419,7 @@ Tcl_SetByteArrayLength( if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayLength"); } - if ((objPtr->typePtr != &properByteArrayType) - && (objPtr->typePtr != &tclByteArrayType)) { + if (objPtr->typePtr != &properByteArrayType) { if (TCL_ERROR == SetByteArrayFromAny(NULL, objPtr)) { return NULL; } @@ -547,9 +466,6 @@ SetByteArrayFromAny( if (objPtr->typePtr == &properByteArrayType) { return TCL_OK; } - if (objPtr->typePtr == &tclByteArrayType) { - return TCL_OK; - } src = TclGetStringFromObj(objPtr, &length); srcEnd = src + length; @@ -739,8 +655,7 @@ TclAppendBytesToByteArray( /* Append zero bytes is a no-op. */ return; } - if ((objPtr->typePtr != &properByteArrayType) - && (objPtr->typePtr != &tclByteArrayType)) { + if (objPtr->typePtr != &properByteArrayType) { if (TCL_ERROR == SetByteArrayFromAny(NULL, objPtr)) { Tcl_Panic("attempt to append bytes to non-bytearray"); } diff --git a/generic/tclInt.h b/generic/tclInt.h index b36f004..253a2f0 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2644,7 +2644,6 @@ MODULE_SCOPE ClientData tclTimeClientData; MODULE_SCOPE const Tcl_ObjType tclBignumType; MODULE_SCOPE const Tcl_ObjType tclBooleanType; -MODULE_SCOPE const Tcl_ObjType tclByteArrayType; MODULE_SCOPE const Tcl_ObjType tclByteCodeType; MODULE_SCOPE const Tcl_ObjType tclDoubleType; MODULE_SCOPE const Tcl_ObjType tclEndOffsetType; diff --git a/generic/tclObj.c b/generic/tclObj.c index 6a1d925..6b2793e 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -394,7 +394,6 @@ TclInitObjSubsystem(void) Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS); Tcl_MutexUnlock(&tableMutex); - Tcl_RegisterObjType(&tclByteArrayType); Tcl_RegisterObjType(&tclDoubleType); Tcl_RegisterObjType(&tclEndOffsetType); Tcl_RegisterObjType(&tclIntType); diff --git a/tests/execute.test b/tests/execute.test index 2480a95..2d6bda2 100644 --- a/tests/execute.test +++ b/tests/execute.test @@ -993,7 +993,7 @@ test execute-9.1 {Interp result resetting [Bug 1522803]} { } SUCCESS test execute-10.1 {TclExecuteByteCode, INST_CONCAT1, bytearrays} { - apply {s {binary scan $s c x; list $x [scan $s$s %c%c]}} \u0130 + apply {s {binary scan [binary format a $s] c x; list $x [scan $s$s %c%c]}} \u0130 } {48 {304 304}} test execute-10.2 {Bug 2802881} -setup { interp create slave diff --git a/tests/obj.test b/tests/obj.test index 4d57c08..ce1883a 100644 --- a/tests/obj.test +++ b/tests/obj.test @@ -27,7 +27,6 @@ test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} tes set r 1 foreach {t} { {array search} - bytearray bytecode cmdName dict @@ -48,10 +47,10 @@ test obj-2.2 {Tcl_GetObjType and Tcl_ConvertToType} testobj { set result "" lappend result [testobj freeallvars] lappend result [testintobj set 1 12] - lappend result [testobj convert 1 bytearray] + lappend result [testobj convert 1 string] lappend result [testobj type 1] lappend result [testobj refcount 1] -} {{} 12 12 bytearray 3} +} {{} 12 12 string 3} test obj-3.1 {Tcl_ConvertToType error} testobj { list [testdoubleobj set 1 12.34] \ -- cgit v0.12 From 09a75041cf1f96850fad5020b35c1b5fb59579c6 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 7 Dec 2016 18:57:34 +0000 Subject: Create a narrowing procedure to make the operation explicit when needed. --- generic/tclBinary.c | 68 +++++++++++++++++++++++++++++++++++++++------------- generic/tclDictObj.c | 3 ++- generic/tclInt.h | 1 + 3 files changed, 54 insertions(+), 18 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 9175036..bcba677 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -453,36 +453,70 @@ Tcl_SetByteArrayLength( */ static int -SetByteArrayFromAny( - Tcl_Interp *interp, /* Not used. */ - Tcl_Obj *objPtr) /* The object to convert to type ByteArray. */ +MakeByteArray( + Tcl_Obj *objPtr, + int earlyOut, + ByteArray **byteArrayPtrPtr) { - int length; - const char *src, *srcEnd; + int length, proper = 1; unsigned char *dst; - ByteArray *byteArrayPtr; - Tcl_UniChar ch; - - if (objPtr->typePtr == &properByteArrayType) { - return TCL_OK; - } - - src = TclGetStringFromObj(objPtr, &length); - srcEnd = src + length; + const char *src = TclGetStringFromObj(objPtr, &length); + ByteArray *byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length)); + const char *srcEnd = src + length; - byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length)); for (dst = byteArrayPtr->bytes; src < srcEnd; ) { + Tcl_UniChar ch; + src += Tcl_UtfToUniChar(src, &ch); if (ch > 255) { + proper = 0; + if (earlyOut) { ckfree(byteArrayPtr); - return TCL_ERROR; + *byteArrayPtrPtr = NULL; + return proper; + } } *dst++ = UCHAR(ch); } - byteArrayPtr->used = dst - byteArrayPtr->bytes; byteArrayPtr->allocated = length; + *byteArrayPtrPtr = byteArrayPtr; + return proper; +} + +Tcl_Obj * +TclNarrowToBytes( + Tcl_Obj *objPtr) +{ + ByteArray *byteArrayPtr; + + if (0 == MakeByteArray(objPtr, 0, &byteArrayPtr)) { + objPtr = Tcl_NewObj(); + TclInvalidateStringRep(objPtr); + } + TclFreeIntRep(objPtr); + objPtr->typePtr = &properByteArrayType; + SET_BYTEARRAY(objPtr, byteArrayPtr); + Tcl_IncrRefCount(objPtr); + return objPtr; +} + +static int +SetByteArrayFromAny( + Tcl_Interp *interp, /* Not used. */ + Tcl_Obj *objPtr) /* The object to convert to type ByteArray. */ +{ + ByteArray *byteArrayPtr; + + if (objPtr->typePtr == &properByteArrayType) { + return TCL_OK; + } + + if (0 == MakeByteArray(objPtr, 1, &byteArrayPtr)) { + return TCL_ERROR; + } + TclFreeIntRep(objPtr); objPtr->typePtr = &properByteArrayType; SET_BYTEARRAY(objPtr, byteArrayPtr); diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 29ab973..3bb2d63 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -492,7 +492,8 @@ UpdateStringOfDict( Dict *dict = DICT(dictPtr); ChainEntry *cPtr; Tcl_Obj *keyPtr, *valuePtr; - size_t i, length, bytesNeeded = 0; + size_t i, length; + int bytesNeeded = 0; const char *elem; char *dst; diff --git a/generic/tclInt.h b/generic/tclInt.h index 253a2f0..4bbaa5c 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2969,6 +2969,7 @@ MODULE_SCOPE int TclMaxListLength(const char *bytes, int numBytes, MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], Tcl_Obj **optionsPtrPtr, int *codePtr, int *levelPtr); +MODULE_SCOPE Tcl_Obj * TclNarrowToBytes(Tcl_Obj *objPtr); MODULE_SCOPE Tcl_Obj * TclNoErrorStack(Tcl_Interp *interp, Tcl_Obj *options); MODULE_SCOPE int TclNokia770Doubles(void); MODULE_SCOPE void TclNsDecrRefCount(Namespace *nsPtr); -- cgit v0.12 From 5f5f3e9be3ff39cf49acb9cd35ab85cae1dbe112 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 7 Dec 2016 19:22:33 +0000 Subject: Make explicit the implicit byte-narrowing function of [binary format]. --- generic/tclBinary.c | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index bcba677..92a9c7f 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -847,7 +847,9 @@ BinaryFormatCmd( goto badIndex; } if (count == BINARY_ALL) { - Tcl_GetByteArrayFromObj(objv[arg], &count); + Tcl_Obj *copy = TclNarrowToBytes(objv[arg]); + Tcl_GetByteArrayFromObj(copy, &count); + Tcl_DecrRefCount(copy); } else if (count == BINARY_NOCOUNT) { count = 1; } @@ -1010,8 +1012,9 @@ BinaryFormatCmd( case 'A': { char pad = (char) (cmd == 'a' ? '\0' : ' '); unsigned char *bytes; + Tcl_Obj *copy = TclNarrowToBytes(objv[arg++]); - bytes = Tcl_GetByteArrayFromObj(objv[arg++], &length); + bytes = Tcl_GetByteArrayFromObj(copy, &length); if (count == BINARY_ALL) { count = length; @@ -1025,6 +1028,7 @@ BinaryFormatCmd( memset(cursor + length, pad, (size_t) (count - length)); } cursor += count; + Tcl_DecrRefCount(copy); break; } case 'b': -- cgit v0.12 From 3c3a7d5a94f2d6f7a209f4af01b0855a3cb9a2f1 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 7 Dec 2016 19:52:37 +0000 Subject: Put explicit byte-narrowing in the write pipeline of -encoding binary channels. This makes tests pass again. I don't much like it. It makes "-encoding binary" something different from "-encoding iso8859-1 -eofchar {} -translation lf" without a known good reason. Seems it would fit in better with other encodings if chars outside the supported set transformed in "?" instead. --- generic/tclIO.c | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 4aaf399..e211d60 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -4078,7 +4078,7 @@ Tcl_WriteChars( Channel *chanPtr = (Channel *) chan; ChannelState *statePtr = chanPtr->state; /* State info for channel */ int result; - Tcl_Obj *objPtr; + Tcl_Obj *objPtr, *copy; if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) { return -1; @@ -4105,9 +4105,11 @@ Tcl_WriteChars( } objPtr = Tcl_NewStringObj(src, len); - src = (char *) Tcl_GetByteArrayFromObj(objPtr, &len); - result = WriteBytes(chanPtr, src, len); + copy = TclNarrowToBytes(objPtr); + src = (char *) Tcl_GetByteArrayFromObj(copy, &len); TclDecrRefCount(objPtr); + result = WriteBytes(chanPtr, src, len); + TclDecrRefCount(copy); return result; } @@ -4157,8 +4159,13 @@ Tcl_WriteObj( return -1; } if (statePtr->encoding == NULL) { - src = (char *) Tcl_GetByteArrayFromObj(objPtr, &srcLen); - return WriteBytes(chanPtr, src, srcLen); + int result; + Tcl_Obj *copy = TclNarrowToBytes(objPtr); + + src = (char *) Tcl_GetByteArrayFromObj(copy, &srcLen); + result = WriteBytes(chanPtr, src, srcLen); + Tcl_DecrRefCount(copy); + return result; } else { src = TclGetStringFromObj(objPtr, &srcLen); return WriteChars(chanPtr, src, srcLen); -- cgit v0.12 From ae718b7106a323f299d3c8227cc740c304f18535 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 7 Dec 2016 20:01:53 +0000 Subject: Enable the no-copy path through narrowing that was overlooked. --- generic/tclBinary.c | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 92a9c7f..ec39caf 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -489,15 +489,17 @@ Tcl_Obj * TclNarrowToBytes( Tcl_Obj *objPtr) { - ByteArray *byteArrayPtr; + if (objPtr->typePtr != &properByteArrayType) { + ByteArray *byteArrayPtr; - if (0 == MakeByteArray(objPtr, 0, &byteArrayPtr)) { - objPtr = Tcl_NewObj(); - TclInvalidateStringRep(objPtr); + if (0 == MakeByteArray(objPtr, 0, &byteArrayPtr)) { + objPtr = Tcl_NewObj(); + TclInvalidateStringRep(objPtr); + } + TclFreeIntRep(objPtr); + objPtr->typePtr = &properByteArrayType; + SET_BYTEARRAY(objPtr, byteArrayPtr); } - TclFreeIntRep(objPtr); - objPtr->typePtr = &properByteArrayType; - SET_BYTEARRAY(objPtr, byteArrayPtr); Tcl_IncrRefCount(objPtr); return objPtr; } -- cgit v0.12 From 2c9bc042ace7212959a36dab4d7d48262b1aa358 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 7 Dec 2016 20:32:50 +0000 Subject: plug memory leak --- generic/tclBinary.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index ec39caf..082c368 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2690,13 +2690,13 @@ BinaryEncodeUu( * enough". */ - resultObj = Tcl_NewObj(); offset = 0; data = Tcl_GetByteArrayFromObj(objv[objc-1], &count); if (data == NULL) { Tcl_AppendResult(interp, "binary encode expects bytes", NULL); return TCL_ERROR; } + resultObj = Tcl_NewObj(); rawLength = (lineLength - 1) * 3 / 4; start = cursor = Tcl_SetByteArrayLength(resultObj, (lineLength + wrapcharlen) * -- cgit v0.12 From f14fd295940da051d212c8b36a92336114cf182e Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 13 Dec 2016 16:49:58 +0000 Subject: Detect binary errors in reflected channels. --- generic/tclIOGT.c | 27 ++++++++++++++++++++------- generic/tclIORChan.c | 11 +++++++++-- 2 files changed, 29 insertions(+), 9 deletions(-) diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c index c1e8c44..5c40212 100644 --- a/generic/tclIOGT.c +++ b/generic/tclIOGT.c @@ -444,9 +444,12 @@ ExecuteCallback( } resObj = Tcl_GetObjResult(eval); resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen); - Tcl_WriteRaw(Tcl_GetStackedChannel(dataPtr->self), (char *) resBuf, - resLen); - break; + if (resBuf) { + Tcl_WriteRaw(Tcl_GetStackedChannel(dataPtr->self), + (char *) resBuf, resLen); + break; + } + goto nonBytes; case TRANSMIT_SELF: if (dataPtr->self == NULL) { @@ -454,14 +457,24 @@ ExecuteCallback( } resObj = Tcl_GetObjResult(eval); resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen); - Tcl_WriteRaw(dataPtr->self, (char *) resBuf, resLen); - break; + if (resBuf) { + Tcl_WriteRaw(dataPtr->self, (char *) resBuf, resLen); + break; + } + goto nonBytes; case TRANSMIT_IBUF: resObj = Tcl_GetObjResult(eval); resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen); - ResultAdd(&dataPtr->result, resBuf, resLen); - break; + if (resBuf) { + ResultAdd(&dataPtr->result, resBuf, resLen); + break; + } + nonBytes: + Tcl_AppendResult(interp, "chan transform callback received non-bytes", + NULL); + Tcl_Release(eval); + return TCL_ERROR; case TRANSMIT_NUM: /* diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index 5ecd99f..52ac933 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -446,6 +446,7 @@ static void MarkDead(ReflectedChannel *rcPtr); */ static const char *msg_read_toomuch = "{read delivered more than requested}"; +static const char *msg_read_nonbyte = "{read delivered nonbyte result}"; static const char *msg_write_toomuch = "{write wrote more than requested}"; static const char *msg_write_nothing = "{write wrote nothing}"; static const char *msg_seek_beforestart = "{Tried to seek before origin}"; @@ -1309,7 +1310,10 @@ ReflectInput( bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); - if (toRead < bytec) { + if (bytev == NULL) { + SetChannelErrorStr(rcPtr->chan, msg_read_nonbyte); + goto invalid; + } else if (toRead < bytec) { SetChannelErrorStr(rcPtr->chan, msg_read_toomuch); goto invalid; } @@ -2982,7 +2986,10 @@ ForwardProc( bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); - if (paramPtr->input.toRead < bytec) { + if (bytev == NULL) { + ForwardSetStaticError(paramPtr, msg_read_nonbyte); + paramPtr->input.toRead = -1; + } else if (paramPtr->input.toRead < bytec) { ForwardSetStaticError(paramPtr, msg_read_toomuch); paramPtr->input.toRead = -1; } else { -- cgit v0.12 From 8d50c93eced72fa6aa0dd6e72080c70796549bae Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 13 Dec 2016 18:29:12 +0000 Subject: Update Tcl_SetByteArrayLength() and callers. --- generic/tclBinary.c | 4 +++- generic/tclIO.c | 3 ++- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 082c368..72f61cc 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -420,7 +420,9 @@ Tcl_SetByteArrayLength( Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayLength"); } if (objPtr->typePtr != &properByteArrayType) { - if (TCL_ERROR == SetByteArrayFromAny(NULL, objPtr)) { + if (length == 0) { + Tcl_SetByteArrayObj(objPtr, NULL, 0); + } else if (TCL_ERROR == SetByteArrayFromAny(NULL, objPtr)) { return NULL; } } diff --git a/generic/tclIO.c b/generic/tclIO.c index e211d60..b707d81 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -4515,7 +4515,8 @@ Tcl_GetsObj( if ((statePtr->encoding == NULL) && ((statePtr->inputTranslation == TCL_TRANSLATE_LF) - || (statePtr->inputTranslation == TCL_TRANSLATE_CR))) { + || (statePtr->inputTranslation == TCL_TRANSLATE_CR)) + && Tcl_GetByteArrayFromObj(objPtr, NULL) != NULL) { return TclGetsObjBinary(chan, objPtr); } -- cgit v0.12 From af6005aab08877b0a6182f85622a1e69720c2fc6 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 16 Jun 2017 21:12:27 +0000 Subject: repair merge --- tests/utf.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/utf.test b/tests/utf.test index aa7a89f..2a8d9ff 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -105,7 +105,7 @@ test utf-4.6 {Tcl_NumUtfChars: length 1, calc len} {testnumutfchars testbytestri testnumutfchars [testbytestring "\xC2\xA2"] 2 } {1} test utf-4.7 {Tcl_NumUtfChars: long string, calc len} {testnumutfchars testbytestring} { - testnumutfchars [testbytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e4e"] 10 + testnumutfchars [testbytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e"] 10 } {7} test utf-4.8 {Tcl_NumUtfChars: #u0000, calc len} {testnumutfchars testbytestring} { testnumutfchars [testbytestring "\xC0\x80"] 2 -- cgit v0.12 From 73609c6f2462ad90f94d2038efec296e7ca99519 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 22 Feb 2019 18:59:11 +0000 Subject: not broke yet --- generic/tclBasic.c | 12 +++--- generic/tclBinary.c | 93 ++++++++++++++++++++++++----------------------- generic/tclClock.c | 2 +- generic/tclCmdAH.c | 4 +- generic/tclCmdIL.c | 8 ++-- generic/tclCmdMZ.c | 4 +- generic/tclCompCmds.c | 6 +-- generic/tclCompCmdsGR.c | 8 ++-- generic/tclConfig.c | 9 +++-- generic/tclDate.c | 2 +- generic/tclDictObj.c | 4 +- generic/tclDisassemble.c | 2 +- generic/tclEnsemble.c | 2 +- generic/tclEvent.c | 2 +- generic/tclExecute.c | 14 +++---- generic/tclFileName.c | 53 ++++++++++++++------------- generic/tclIO.c | 15 +++++--- generic/tclIOCmd.c | 8 ++-- generic/tclIORChan.c | 6 +-- generic/tclIORTrans.c | 24 ++++++------ generic/tclIOUtil.c | 64 ++++++++++++++++---------------- generic/tclIndexObj.c | 16 ++++---- generic/tclInt.h | 8 ++-- generic/tclInterp.c | 8 ++-- generic/tclLink.c | 2 +- generic/tclListObj.c | 28 ++++++++------ generic/tclLoad.c | 16 ++++---- generic/tclMain.c | 8 ++-- generic/tclNamesp.c | 4 +- generic/tclOOBasic.c | 10 ++--- generic/tclOODefineCmds.c | 4 +- generic/tclOOInfo.c | 4 +- generic/tclOOMethod.c | 6 +-- generic/tclPathObj.c | 19 ++++++---- generic/tclPkg.c | 2 +- generic/tclProc.c | 6 +-- generic/tclResult.c | 2 +- generic/tclScan.c | 4 +- generic/tclStringObj.c | 22 +++++------ generic/tclTest.c | 2 +- generic/tclTimer.c | 2 +- generic/tclTrace.c | 28 +++++++------- generic/tclVar.c | 2 +- generic/tclZipfs.c | 87 +++++++++++++++++++++----------------------- generic/tclZlib.c | 16 ++++---- unix/tclLoadDl.c | 4 +- unix/tclLoadDyld.c | 2 +- unix/tclLoadNext.c | 2 +- unix/tclLoadOSF.c | 2 +- unix/tclLoadShl.c | 2 +- unix/tclUnixChan.c | 4 +- unix/tclUnixPipe.c | 4 +- unix/tclUnixSock.c | 3 +- win/tclWinFCmd.c | 10 ++--- win/tclWinFile.c | 22 +++++------ win/tclWinInit.c | 3 +- win/tclWinLoad.c | 4 +- win/tclWinPipe.c | 9 +++-- 58 files changed, 366 insertions(+), 353 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 5c51291..51ff8a6 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -1055,11 +1055,11 @@ Tcl_CreateInterp(void) Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs); if (TclTommath_Init(interp) != TCL_OK) { - Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp))); + Tcl_Panic("%s", Tcl_GetStringResult(interp)); } if (TclOOInit(interp) != TCL_OK) { - Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp))); + Tcl_Panic("%s", Tcl_GetStringResult(interp)); } /* @@ -1069,10 +1069,10 @@ Tcl_CreateInterp(void) #ifdef HAVE_ZLIB if (TclZlibInit(interp) != TCL_OK) { - Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp))); + Tcl_Panic("%s", Tcl_GetStringResult(interp)); } if (TclZipfs_Init(interp) != TCL_OK) { - Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); + Tcl_Panic("%s", Tcl_GetStringResult(interp)); } #endif @@ -1204,7 +1204,7 @@ TclHideUnsafeCommands( TclGetString(hideName)) != TCL_OK) { Tcl_Panic("problem making '%s %s' safe: %s", unsafePtr->ensembleNsName, unsafePtr->commandName, - Tcl_GetString(Tcl_GetObjResult(interp))); + Tcl_GetStringResult(interp)); } Tcl_CreateObjCommand(interp, TclGetString(cmdName), BadEnsembleSubcommand, (ClientData) unsafePtr, NULL); @@ -1219,7 +1219,7 @@ TclHideUnsafeCommands( unsafePtr->ensembleNsName) != TCL_OK) { Tcl_Panic("problem making '%s' safe: %s", unsafePtr->ensembleNsName, - Tcl_GetString(Tcl_GetObjResult(interp))); + Tcl_GetStringResult(interp)); } } } diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 6760020..a78bc3b 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -22,8 +22,8 @@ * special conditions in the parsing of a format specifier. */ -#define BINARY_ALL -1 /* Use all elements in the argument. */ -#define BINARY_NOCOUNT -2 /* No count was specified in format. */ +#define BINARY_ALL ((size_t)-1) /* Use all elements in the argument. */ +#define BINARY_NOCOUNT ((size_t)-2) /* No count was specified in format. */ /* * The following flags may be ORed together and returned by GetFormatSpec @@ -64,7 +64,7 @@ static int FormatNumber(Tcl_Interp *interp, int type, static void FreeByteArrayInternalRep(Tcl_Obj *objPtr); static void FreeProperByteArrayInternalRep(Tcl_Obj *objPtr); static int GetFormatSpec(const char **formatPtr, char *cmdPtr, - int *countPtr, int *flagsPtr); + size_t *countPtr, int *flagsPtr); static Tcl_Obj * ScanNumber(unsigned char *buffer, int type, int flags, Tcl_HashTable **numberCachePtr); static int SetByteArrayFromAny(Tcl_Interp *interp, @@ -73,7 +73,7 @@ static void UpdateStringOfByteArray(Tcl_Obj *listPtr); static void DeleteScanNumberCache(Tcl_HashTable *numberCachePtr); static int NeedReversing(int format); static void CopyNumber(const void *from, void *to, - unsigned length, int type); + size_t length, int type); /* Binary ensemble commands */ static int BinaryFormatCmd(ClientData clientData, Tcl_Interp *interp, @@ -285,8 +285,8 @@ typedef struct { ((TclOffset(ByteArray, bytes) + (len))) #define GET_BYTEARRAY(irPtr) ((ByteArray *) (irPtr)->twoPtrValue.ptr1) #define SET_BYTEARRAY(irPtr, baPtr) \ - (irPtr)->twoPtrValue.ptr1 = (void *) (baPtr) - + (irPtr)->twoPtrValue.ptr1 = (baPtr) + int TclIsPureByteArray( Tcl_Obj * objPtr) @@ -876,7 +876,7 @@ BinaryFormatCmd( int value = 0; /* Current integer value to be packed. * Initialized to avoid compiler warning. */ char cmd; /* Current format character. */ - int count; /* Count associated with current format + size_t count; /* Count associated with current format * character. */ int flags; /* Format field flags */ const char *format; /* Pointer to current position in format @@ -888,7 +888,8 @@ BinaryFormatCmd( * cursor has visited.*/ const char *errorString; const char *errorValue, *str; - int offset, size, length; + int offset, size; + size_t length; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "formatString ?arg ...?"); @@ -927,7 +928,7 @@ BinaryFormatCmd( goto badIndex; } if (count == BINARY_ALL) { - TclGetByteArrayFromObj(objv[arg], &count); + (void)TclGetByteArrayFromObj(objv[arg], &count); } else if (count == BINARY_NOCOUNT) { count = 1; } @@ -999,7 +1000,7 @@ BinaryFormatCmd( if (count == BINARY_ALL) { count = listc; - } else if (count > listc) { + } else if (count > (size_t)listc) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "number of elements in list does not match count", -1)); @@ -1023,16 +1024,16 @@ BinaryFormatCmd( if (count == BINARY_NOCOUNT) { count = 1; } - if ((count > offset) || (count == BINARY_ALL)) { + if ((count > (size_t)offset) || (count == BINARY_ALL)) { count = offset; } - if (offset > length) { + if (offset > (int)length) { length = offset; } offset -= count; break; case '@': - if (offset > length) { + if (offset > (int)length) { length = offset; } if (count == BINARY_ALL) { @@ -1048,7 +1049,7 @@ BinaryFormatCmd( goto badField; } } - if (offset > length) { + if (offset > (int)length) { length = offset; } if (length == 0) { @@ -1062,7 +1063,7 @@ BinaryFormatCmd( resultPtr = Tcl_NewObj(); buffer = Tcl_SetByteArrayLength(resultPtr, length); - memset(buffer, 0, (size_t) length); + memset(buffer, 0, length); /* * Pack the data into the result object. Note that we can skip the @@ -1099,10 +1100,10 @@ BinaryFormatCmd( count = 1; } if (length >= count) { - memcpy(cursor, bytes, (size_t) count); + memcpy(cursor, bytes, count); } else { - memcpy(cursor, bytes, (size_t) length); - memset(cursor + length, pad, (size_t) (count - length)); + memcpy(cursor, bytes, length); + memset(cursor + length, pad, count - length); } cursor += count; break; @@ -1111,7 +1112,7 @@ BinaryFormatCmd( case 'B': { unsigned char *last; - str = Tcl_GetStringFromObj(objv[arg], &length); + str = TclGetStringFromObj(objv[arg], &length); arg++; if (count == BINARY_ALL) { count = length; @@ -1125,7 +1126,7 @@ BinaryFormatCmd( value = 0; errorString = "binary"; if (cmd == 'B') { - for (offset = 0; offset < count; offset++) { + for (offset = 0; (size_t)offset < count; offset++) { value <<= 1; if (str[offset] == '1') { value |= 1; @@ -1140,7 +1141,7 @@ BinaryFormatCmd( } } } else { - for (offset = 0; offset < count; offset++) { + for (offset = 0; (size_t)offset < count; offset++) { value >>= 1; if (str[offset] == '1') { value |= 128; @@ -1173,7 +1174,7 @@ BinaryFormatCmd( unsigned char *last; int c; - str = Tcl_GetStringFromObj(objv[arg], &length); + str = TclGetStringFromObj(objv[arg], &length); arg++; if (count == BINARY_ALL) { count = length; @@ -1187,7 +1188,7 @@ BinaryFormatCmd( value = 0; errorString = "hexadecimal"; if (cmd == 'H') { - for (offset = 0; offset < count; offset++) { + for (offset = 0; (size_t)offset < count; offset++) { value <<= 4; if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */ errorValue = str; @@ -1208,7 +1209,7 @@ BinaryFormatCmd( } } } else { - for (offset = 0; offset < count; offset++) { + for (offset = 0; (size_t)offset < count; offset++) { value >>= 4; if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */ @@ -1279,7 +1280,7 @@ BinaryFormatCmd( } } arg++; - for (i = 0; i < count; i++) { + for (i = 0; (size_t)i < count; i++) { if (FormatNumber(interp, cmd, listv[i], &cursor)!=TCL_OK) { Tcl_DecrRefCount(resultPtr); return TCL_ERROR; @@ -1291,7 +1292,7 @@ BinaryFormatCmd( if (count == BINARY_NOCOUNT) { count = 1; } - memset(cursor, 0, (size_t) count); + memset(cursor, 0, count); cursor += count; break; case 'X': @@ -1301,7 +1302,7 @@ BinaryFormatCmd( if (count == BINARY_NOCOUNT) { count = 1; } - if ((count == BINARY_ALL) || (count > (cursor - buffer))) { + if ((count == BINARY_ALL) || (count > (size_t)(cursor - buffer))) { cursor = buffer; } else { cursor -= count; @@ -1381,7 +1382,7 @@ BinaryScanCmd( int value = 0; /* Current integer value to be packed. * Initialized to avoid compiler warning. */ char cmd; /* Current format character. */ - int count; /* Count associated with current format + size_t count; /* Count associated with current format * character. */ int flags; /* Format field flags */ const char *format; /* Pointer to current position in format @@ -1390,7 +1391,8 @@ BinaryScanCmd( unsigned char *buffer; /* Start of result buffer. */ const char *errorString; const char *str; - int offset, size, length; + int offset, size; + size_t length; int i; Tcl_Obj *valuePtr, *elementPtr; @@ -1429,7 +1431,7 @@ BinaryScanCmd( if (count == BINARY_NOCOUNT) { count = 1; } - if (count > (length - offset)) { + if (count > length - offset) { goto done; } } @@ -1488,7 +1490,7 @@ BinaryScanCmd( if (count == BINARY_NOCOUNT) { count = 1; } - if (count > (length - offset) * 8) { + if (count > (size_t)(length - offset) * 8) { goto done; } } @@ -1498,7 +1500,7 @@ BinaryScanCmd( dest = TclGetString(valuePtr); if (cmd == 'b') { - for (i = 0; i < count; i++) { + for (i = 0; (size_t)i < count; i++) { if (i % 8) { value >>= 1; } else { @@ -1507,7 +1509,7 @@ BinaryScanCmd( *dest++ = (char) ((value & 1) ? '1' : '0'); } } else { - for (i = 0; i < count; i++) { + for (i = 0; (size_t)i < count; i++) { if (i % 8) { value <<= 1; } else { @@ -1553,7 +1555,7 @@ BinaryScanCmd( dest = TclGetString(valuePtr); if (cmd == 'h') { - for (i = 0; i < count; i++) { + for (i = 0; (size_t)i < count; i++) { if (i % 2) { value >>= 4; } else { @@ -1562,7 +1564,7 @@ BinaryScanCmd( *dest++ = hexdigit[value & 0xf]; } } else { - for (i = 0; i < count; i++) { + for (i = 0; (size_t)i < count; i++) { if (i % 2) { value <<= 4; } else { @@ -1619,7 +1621,7 @@ BinaryScanCmd( goto badIndex; } if (count == BINARY_NOCOUNT) { - if ((length - offset) < size) { + if ((length - offset) < (size_t)size) { goto done; } valuePtr = ScanNumber(buffer+offset, cmd, flags, @@ -1634,7 +1636,7 @@ BinaryScanCmd( } valuePtr = Tcl_NewObj(); src = buffer + offset; - for (i = 0; i < count; i++) { + for (i = 0; (size_t)i < count; i++) { elementPtr = ScanNumber(src, cmd, flags, &numberCachePtr); src += size; Tcl_ListObjAppendElement(NULL, valuePtr, elementPtr); @@ -1655,7 +1657,7 @@ BinaryScanCmd( if (count == BINARY_NOCOUNT) { count = 1; } - if ((count == BINARY_ALL) || (count > (length - offset))) { + if ((count == BINARY_ALL) || (count > length - offset)) { offset = length; } else { offset += count; @@ -1665,7 +1667,7 @@ BinaryScanCmd( if (count == BINARY_NOCOUNT) { count = 1; } - if ((count == BINARY_ALL) || (count > offset)) { + if ((count == BINARY_ALL) || (count > (size_t)offset)) { offset = 0; } else { offset -= count; @@ -1749,7 +1751,7 @@ static int GetFormatSpec( const char **formatPtr, /* Pointer to format string. */ char *cmdPtr, /* Pointer to location of command char. */ - int *countPtr, /* Pointer to repeat count value. */ + size_t *countPtr, /* Pointer to repeat count value. */ int *flagsPtr) /* Pointer to field flags */ { /* @@ -1915,7 +1917,7 @@ static void CopyNumber( const void *from, /* source */ void *to, /* destination */ - unsigned length, /* Number of bytes to copy */ + size_t length, /* Number of bytes to copy */ int type) /* What type of thing are we copying? */ { switch (NeedReversing(type)) { @@ -2445,7 +2447,7 @@ BinaryEncodeHex( Tcl_Obj *resultObj = NULL; unsigned char *data = NULL; unsigned char *cursor = NULL; - int offset = 0, count = 0; + size_t offset = 0, count = 0; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "data"); @@ -2611,7 +2613,8 @@ BinaryEncode64( int maxlen = 0; const char *wrapchar = "\n"; size_t wrapcharlen = 1; - int offset, i, index, size, outindex = 0, count = 0; + int i, index, size, outindex = 0; + size_t offset, count = 0; enum {OPT_MAXLEN, OPT_WRAPCHAR }; static const char *const optStrings[] = { "-maxlen", "-wrapchar", NULL }; @@ -2714,11 +2717,11 @@ BinaryEncodeUu( { Tcl_Obj *resultObj; unsigned char *data, *start, *cursor; - int offset, count, rawLength, n, i, j, bits, index; + int rawLength, n, i, bits, index; int lineLength = 61; const unsigned char SingleNewline[] = { (unsigned char) '\n' }; const unsigned char *wrapchar = SingleNewline; - int wrapcharlen = sizeof(SingleNewline); + size_t j, offset, count, wrapcharlen = sizeof(SingleNewline); enum { OPT_MAXLEN, OPT_WRAPCHAR }; static const char *const optStrings[] = { "-maxlen", "-wrapchar", NULL }; diff --git a/generic/tclClock.c b/generic/tclClock.c index f9a8008..ba12b66 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -1922,7 +1922,7 @@ ClockParseformatargsObjCmd( if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &optionIndex) != TCL_OK) { Tcl_SetErrorCode(interp, "CLOCK", "badOption", - Tcl_GetString(objv[i]), NULL); + TclGetString(objv[i]), NULL); return TCL_ERROR; } switch (optionIndex) { diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index bcf5c48..970bdb4 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -1710,7 +1710,7 @@ PathFilesystemCmd( if (fsInfo == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("unrecognised path", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "FILESYSTEM", - Tcl_GetString(objv[1]), NULL); + TclGetString(objv[1]), NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, fsInfo); @@ -1962,7 +1962,7 @@ FilesystemSeparatorCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "unrecognised path", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "FILESYSTEM", - Tcl_GetString(objv[1]), NULL); + TclGetString(objv[1]), NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, separatorObj); diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 3fdb890..e7ff8cb 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -1047,7 +1047,7 @@ InfoErrorStackCmd( target = interp; if (objc == 2) { - target = Tcl_GetSlave(interp, Tcl_GetString(objv[1])); + target = Tcl_GetSlave(interp, TclGetString(objv[1])); if (target == NULL) { return TCL_ERROR; } @@ -2155,7 +2155,7 @@ InfoCmdTypeCmd( Tcl_WrongNumArgs(interp, 1, objv, "commandName"); return TCL_ERROR; } - command = Tcl_FindCommand(interp, Tcl_GetString(objv[1]), NULL, + command = Tcl_FindCommand(interp, TclGetString(objv[1]), NULL, TCL_LEAVE_ERR_MSG); if (command == NULL) { return TCL_ERROR; @@ -3248,7 +3248,7 @@ Tcl_LsearchObjCmd( if (encoded == TCL_INDEX_NONE) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "index \"%s\" cannot select an element " - "from any list", Tcl_GetString(indices[j]))); + "from any list", TclGetString(indices[j]))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX" "OUTOFRANGE", NULL); result = TCL_ERROR; @@ -3965,7 +3965,7 @@ Tcl_LsortObjCmd( if ((result == TCL_OK) && (encoded == TCL_INDEX_NONE)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "index \"%s\" cannot select an element " - "from any list", Tcl_GetString(indexv[j]))); + "from any list", TclGetString(indexv[j]))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX" "OUTOFRANGE", NULL); result = TCL_ERROR; diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 75dac00..8afc98c 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -4211,7 +4211,7 @@ TclNRTryObjCmd( if (Tcl_ListObjLength(NULL, objv[i+1], &dummy) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad prefix '%s': must be a list", - Tcl_GetString(objv[i+1]))); + TclGetString(objv[i+1]))); Tcl_DecrRefCount(handlersObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP", "EXNFORMAT", NULL); @@ -4750,7 +4750,7 @@ TclListLines( Tcl_Obj *const *elems) /* The list elems as Tcl_Obj*, in need of * derived continuation data */ { - const char *listStr = Tcl_GetString(listObj); + const char *listStr = TclGetString(listObj); const char *listHead = listStr; int i, length = strlen(listStr); const char *element = NULL, *next = NULL; diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 810b26e..22faa16 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -3185,7 +3185,7 @@ TclCompileFormatCmd( * the format is broken). Do the format now. */ - tmpObj = Tcl_Format(interp, Tcl_GetString(formatObj), + tmpObj = Tcl_Format(interp, TclGetString(formatObj), parsePtr->numWords-2, objv); for (; --i>=0 ;) { Tcl_DecrRefCount(objv[i]); @@ -3229,7 +3229,7 @@ TclCompileFormatCmd( * Now scan through and check for non-%s and non-%% substitutions. */ - for (bytes = Tcl_GetString(formatObj) ; *bytes ; bytes++) { + for (bytes = TclGetString(formatObj) ; *bytes ; bytes++) { if (*bytes == '%') { bytes++; if (*bytes == 's') { @@ -3262,7 +3262,7 @@ TclCompileFormatCmd( i = 0; /* The count of things to concat. */ j = 2; /* The index into the argument tokens, for * TIP#280 handling. */ - start = Tcl_GetString(formatObj); + start = TclGetString(formatObj); /* The start of the currently-scanned literal * in the format string. */ tmpObj = Tcl_NewObj(); /* The buffer used to accumulate the literal diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 3e8bfee..c790729 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -607,7 +607,7 @@ TclCompileInfoCommandsCmd( if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) { goto notCompilable; } - bytes = Tcl_GetString(objPtr); + bytes = TclGetString(objPtr); /* * We require that the argument start with "::" and not have any of "*\[?" @@ -2298,8 +2298,8 @@ TclCompileRegsubCmd( if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) { goto done; } - if (Tcl_GetString(patternObj)[0] == '-') { - if (strcmp(Tcl_GetString(patternObj), "--") != 0 + if (TclGetString(patternObj)[0] == '-') { + if (strcmp(TclGetString(patternObj), "--") != 0 || parsePtr->numWords == 5) { goto done; } @@ -2364,7 +2364,7 @@ TclCompileRegsubCmd( bytes++; } isSimpleGlob: - for (bytes = Tcl_GetString(replacementObj); *bytes; bytes++) { + for (bytes = TclGetString(replacementObj); *bytes; bytes++) { switch (*bytes) { case '\\': case '&': goto done; diff --git a/generic/tclConfig.c b/generic/tclConfig.c index 3d017ed..7e5a311 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -202,7 +202,8 @@ QueryConfigObjCmd( QCCD *cdPtr = clientData; Tcl_Obj *pkgName = cdPtr->pkg; Tcl_Obj *pDB, *pkgDict, *val, *listPtr; - int n, index; + size_t n; + int index, m; static const char *const subcmdStrings[] = { "get", "list", NULL }; @@ -274,8 +275,8 @@ QueryConfigObjCmd( return TCL_ERROR; } - Tcl_DictObjSize(interp, pkgDict, &n); - listPtr = Tcl_NewListObj(n, NULL); + Tcl_DictObjSize(interp, pkgDict, &m); + listPtr = Tcl_NewListObj(m, NULL); if (!listPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -284,7 +285,7 @@ QueryConfigObjCmd( return TCL_ERROR; } - if (n) { + if (m) { Tcl_DictSearch s; Tcl_Obj *key; int done; diff --git a/generic/tclDate.c b/generic/tclDate.c index 6bc88d9..aa65e77 100644 --- a/generic/tclDate.c +++ b/generic/tclDate.c @@ -2761,7 +2761,7 @@ TclClockOldscanObjCmd( return TCL_ERROR; } - yyInput = Tcl_GetString( objv[1] ); + yyInput = TclGetString(objv[1]); dateInfo.dateStart = yyInput; yyHaveDate = 0; diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 9462581..42b4f87 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -640,7 +640,7 @@ SetDictFromAny( * convert back. */ - (void) Tcl_GetString(objPtr); + (void) TclGetString(objPtr); TclDecrRefCount(discardedValue); } @@ -3236,7 +3236,7 @@ DictUpdateCmd( } if (objPtr == NULL) { /* ??? */ - Tcl_UnsetVar(interp, Tcl_GetString(objv[i+1]), 0); + Tcl_UnsetVar(interp, TclGetString(objv[i+1]), 0); } else if (Tcl_ObjSetVar2(interp, objv[i+1], NULL, objPtr, TCL_LEAVE_ERR_MSG) == NULL) { TclDecrRefCount(dictPtr); diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 9847b6b..6e4d541 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -288,7 +288,7 @@ DisassembleByteCodeObj( GetLocationInformation(codePtr->procPtr, &fileObj, &line); if (line > -1 && fileObj != NULL) { Tcl_AppendPrintfToObj(bufferObj, "\n File \"%s\" Line %d", - Tcl_GetString(fileObj), line); + TclGetString(fileObj), line); } Tcl_AppendPrintfToObj(bufferObj, "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index ef3b0cf..870c6b0 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -1624,7 +1624,7 @@ TclMakeEnsemble( Tcl_DStringSetLength(&hiddenBuf, hiddenLen); if (Tcl_HideCommand(interp, "___tmp", Tcl_DStringAppend(&hiddenBuf, map[i].name, -1))) { - Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); + Tcl_Panic("%s", Tcl_GetStringResult(interp)); } } else { /* diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 91a5323..5d180d5 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -1403,7 +1403,7 @@ Tcl_VwaitObjCmd( Tcl_WrongNumArgs(interp, 1, objv, "name"); return TCL_ERROR; } - nameString = Tcl_GetString(objv[1]); + nameString = TclGetString(objv[1]); if (Tcl_TraceVar2(interp, nameString, NULL, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, VwaitVarProc, &done) != TCL_OK) { diff --git a/generic/tclExecute.c b/generic/tclExecute.c index a30cd4b..c1b85ad 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -3562,7 +3562,7 @@ TEBCresume( arrayPtr = NULL; part1Ptr = part2Ptr = NULL; cleanup = 0; - TRACE(("%u %s => ", opnd, Tcl_GetString(incrPtr))); + TRACE(("%u %s => ", opnd, TclGetString(incrPtr))); doIncrVar: if (TclIsVarDirectModifyable2(varPtr, arrayPtr)) { @@ -4524,8 +4524,8 @@ TEBCresume( { int index, numIndices, fromIdx, toIdx; - int nocase, match, length2, cflags, s1len, s2len; - size_t slength; + int nocase, match, cflags, s1len, s2len; + size_t slength, length2; const char *s1, *s2; case INST_LIST: @@ -5114,7 +5114,7 @@ TEBCresume( { Tcl_UniChar *ustring1, *ustring2, *ustring3, *end, *p; - int length3; + size_t length3; Tcl_Obj *value3Ptr; case INST_STR_REPLACE: @@ -5190,10 +5190,10 @@ TEBCresume( goto doneStringMap; } ustring2 = TclGetUnicodeFromObj(value2Ptr, &length2); - if (length2 > (int)slength || length2 == 0) { + if (length2 > slength || length2 == 0) { objResultPtr = valuePtr; goto doneStringMap; - } else if (length2 == (int)slength) { + } else if (length2 == slength) { if (memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * slength)) { objResultPtr = valuePtr; } else { @@ -8638,7 +8638,7 @@ IllegalExprOperandType( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't use %s \"%s\" as operand of \"%s\"", description, - Tcl_GetString(opndPtr), operator)); + TclGetString(opndPtr), operator)); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", description, NULL); } diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 33980eb..5d0cff6 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -386,8 +386,7 @@ TclpGetNativePathType( Tcl_Obj **driveNameRef) { Tcl_PathType type = TCL_PATH_ABSOLUTE; - int pathLen; - const char *path = TclGetStringFromObj(pathPtr, &pathLen); + const char *path = TclGetString(pathPtr); if (path[0] == '~') { /* @@ -504,11 +503,11 @@ TclpNativeSplitPath( switch (tclPlatform) { case TCL_PLATFORM_UNIX: - resultPtr = SplitUnixPath(Tcl_GetString(pathPtr)); + resultPtr = SplitUnixPath(TclGetString(pathPtr)); break; case TCL_PLATFORM_WINDOWS: - resultPtr = SplitWinPath(Tcl_GetString(pathPtr)); + resultPtr = SplitWinPath(TclGetString(pathPtr)); break; } @@ -557,7 +556,8 @@ Tcl_SplitPath( { Tcl_Obj *resultPtr = NULL; /* Needed only to prevent gcc warnings. */ Tcl_Obj *tmpPtr, *eltPtr; - int i, size, len; + int i; + size_t size, len; char *p; const char *str; @@ -896,7 +896,7 @@ TclpNativeJoinPath( Tcl_SetObjLength(prefix, length + (int) strlen(p)); - dest = Tcl_GetString(prefix) + length; + dest = TclGetString(prefix) + length; for (; *p != '\0'; p++) { if (*p == '/') { while (p[1] == '/') { @@ -910,7 +910,7 @@ TclpNativeJoinPath( needsSep = 1; } } - length = dest - Tcl_GetString(prefix); + length = dest - TclGetString(prefix); Tcl_SetObjLength(prefix, length); break; @@ -931,7 +931,7 @@ TclpNativeJoinPath( */ Tcl_SetObjLength(prefix, length + (int) strlen(p)); - dest = Tcl_GetString(prefix) + length; + dest = TclGetString(prefix) + length; for (; *p != '\0'; p++) { if ((*p == '/') || (*p == '\\')) { while ((p[1] == '/') || (p[1] == '\\')) { @@ -945,7 +945,7 @@ TclpNativeJoinPath( needsSep = 1; } } - length = dest - Tcl_GetString(prefix); + length = dest - TclGetString(prefix); Tcl_SetObjLength(prefix, length); break; } @@ -977,7 +977,8 @@ Tcl_JoinPath( const char *const *argv, Tcl_DString *resultPtr) /* Pointer to previously initialized DString */ { - int i, len; + int i; + size_t len; Tcl_Obj *listObj = Tcl_NewObj(); Tcl_Obj *resultObj; const char *resultStr; @@ -1250,7 +1251,7 @@ Tcl_GlobObjCmd( for (i = 1; i < objc; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) != TCL_OK) { - string = TclGetStringFromObj(objv[i], &length); + string = TclGetString(objv[i]); if (string[0] == '-') { /* * It looks like the command contains an option so signal an @@ -1356,7 +1357,7 @@ Tcl_GlobObjCmd( } if (dir == PATH_GENERAL) { - int pathlength; + size_t pathlength; const char *last; const char *first = TclGetStringFromObj(pathOrDir,&pathlength); @@ -1408,7 +1409,7 @@ Tcl_GlobObjCmd( * there are none presently in the prefix. */ - if (strpbrk(Tcl_GetString(pathOrDir), "\\/") == NULL) { + if (strpbrk(TclGetString(pathOrDir), "\\/") == NULL) { Tcl_AppendToObj(pathOrDir, last-1, 1); } } @@ -1520,9 +1521,9 @@ Tcl_GlobObjCmd( if ((Tcl_ListObjLength(NULL, look, &llen) == TCL_OK) && (llen == 3)) { Tcl_ListObjIndex(interp, look, 0, &item); - if (!strcmp("macintosh", Tcl_GetString(item))) { + if (!strcmp("macintosh", TclGetString(item))) { Tcl_ListObjIndex(interp, look, 1, &item); - if (!strcmp("type", Tcl_GetString(item))) { + if (!strcmp("type", TclGetString(item))) { Tcl_ListObjIndex(interp, look, 2, &item); if (globTypes->macType != NULL) { goto badMacTypesArg; @@ -1530,7 +1531,7 @@ Tcl_GlobObjCmd( globTypes->macType = item; Tcl_IncrRefCount(item); continue; - } else if (!strcmp("creator", Tcl_GetString(item))) { + } else if (!strcmp("creator", TclGetString(item))) { Tcl_ListObjIndex(interp, look, 2, &item); if (globTypes->macCreator != NULL) { goto badMacTypesArg; @@ -1550,7 +1551,7 @@ Tcl_GlobObjCmd( badTypesArg: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad argument to \"-types\": %s", - Tcl_GetString(look))); + TclGetString(look))); Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", NULL); result = TCL_ERROR; join = 0; @@ -1614,7 +1615,7 @@ Tcl_GlobObjCmd( Tcl_DStringFree(&str); } else { for (i = 0; i < objc; i++) { - string = Tcl_GetString(objv[i]); + string = TclGetString(objv[i]); if (TclGlob(interp, string, pathOrDir, globFlags, globTypes) != TCL_OK) { result = TCL_ERROR; @@ -1646,7 +1647,7 @@ Tcl_GlobObjCmd( for (i = 0; i < objc; i++) { Tcl_AppendPrintfToObj(errorMsg, "%s%s", - sep, Tcl_GetString(objv[i])); + sep, TclGetString(objv[i])); sep = " "; } } @@ -1849,7 +1850,7 @@ TclGlob( Tcl_DecrRefCount(temp); return TCL_ERROR; } - pathPrefix = Tcl_NewStringObj(Tcl_GetString(cwd), 3); + pathPrefix = Tcl_NewStringObj(TclGetString(cwd), 3); Tcl_DecrRefCount(cwd); if (tail[0] == '/') { tail++; @@ -1983,7 +1984,7 @@ TclGlob( if (globFlags & TCL_GLOBMODE_TAILS) { int objc, i; Tcl_Obj **objv; - int prefixLen; + size_t prefixLen; const char *pre; /* @@ -2011,7 +2012,7 @@ TclGlob( Tcl_ListObjGetElements(NULL, filenamesObj, &objc, &objv); for (i = 0; i< objc; i++) { - int len; + size_t len; const char *oldStr = TclGetStringFromObj(objv[i], &len); Tcl_Obj *elem; @@ -2343,7 +2344,7 @@ DoGlob( for (i=0; result==TCL_OK && istate; /* State info for channel */ ChannelBuffer *bufPtr; - int inEofChar, skip, copiedTotal, oldLength, oldFlags, oldRemoved; + int inEofChar, skip, copiedTotal, oldFlags, oldRemoved; + size_t oldLength; Tcl_Encoding encoding; char *dst, *dstEnd, *eol, *eof; Tcl_EncodingState oldState; @@ -6085,7 +6086,8 @@ ReadChars( int savedIEFlags = statePtr->inputEncodingFlags; int savedFlags = statePtr->flags; char *dst, *src = RemovePoint(bufPtr); - int numBytes, srcLen = BytesLeft(bufPtr); + size_t numBytes; + int srcLen = BytesLeft(bufPtr); /* * One src byte can yield at most one character. So when the number of @@ -9426,7 +9428,8 @@ CopyData( Tcl_Obj *cmdPtr, *errObj = NULL, *bufObj = NULL, *msg = NULL; Tcl_Channel inChan, outChan; ChannelState *inStatePtr, *outStatePtr; - int result = TCL_OK, size, sizeb; + int result = TCL_OK, size; + size_t sizeb; Tcl_WideInt total; const char *buffer; int inBinary, outBinary, sameEncoding; @@ -9492,7 +9495,7 @@ CopyData( || (csPtr->toRead > (Tcl_WideInt) csPtr->bufSize)) { sizeb = csPtr->bufSize; } else { - sizeb = (int) csPtr->toRead; + sizeb = csPtr->toRead; } if (inBinary || sameEncoding) { @@ -9502,7 +9505,7 @@ CopyData( size = DoReadChars(inStatePtr->topChanPtr, bufObj, sizeb, 0 /* No append */); } - underflow = (size >= 0) && (size < sizeb); /* Input underflow */ + underflow = (size >= 0) && ((size_t)size < sizeb); /* Input underflow */ } if (size < 0) { @@ -9586,7 +9589,7 @@ CopyData( * unsuitable for updating totals and toRead. */ - if (sizeb < 0) { + if (sizeb == TCL_AUTO_LENGTH) { writeError: if (interp) { TclNewObj(errObj); diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 3e65002..cbfd1da 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -708,7 +708,7 @@ Tcl_CloseObjCmd( Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); const char *string; - int len; + size_t len; if (Tcl_IsShared(resultPtr)) { resultPtr = Tcl_DuplicateObj(resultPtr); @@ -870,8 +870,8 @@ Tcl_ExecObjCmd( * on the _Tcl_ stack. */ const char *string; Tcl_Channel chan; - int argc, background, i, index, keepNewline, result, skip, length; - int ignoreStderr; + int argc, background, i, index, keepNewline, result, skip, ignoreStderr; + size_t length; static const char *const options[] = { "-ignorestderr", "-keepnewline", "--", NULL }; @@ -1476,7 +1476,7 @@ Tcl_SocketObjCmd( } for (a = 1; a < objc; a++) { - const char *arg = Tcl_GetString(objv[a]); + const char *arg = TclGetString(objv[a]); if (arg[0] != '-') { break; diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index c8858af..cae0836 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -1957,7 +1957,7 @@ ReflectGetOption( (listc == 1 ? "" : "s"))); goto error; } else { - int len; + size_t len; const char *str = TclGetStringFromObj(resObj, &len); if (len) { @@ -2330,7 +2330,7 @@ InvokeTclMethod( */ if (result != TCL_ERROR) { - int cmdLen; + size_t cmdLen; const char *cmdString = TclGetStringFromObj(cmd, &cmdLen); Tcl_IncrRefCount(cmd); @@ -3194,7 +3194,7 @@ ForwardProc( ForwardSetDynamicError(paramPtr, buf); } else { - int len; + size_t len; const char *str = TclGetStringFromObj(resObj, &len); if (len) { diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c index 678fcc1..3769533 100644 --- a/generic/tclIORTrans.c +++ b/generic/tclIORTrans.c @@ -89,8 +89,8 @@ static const Tcl_ChannelType tclRTransformType = { typedef struct { unsigned char *buf; /* Reference to the buffer area. */ - int allocated; /* Allocated size of the buffer area. */ - int used; /* Number of bytes in the buffer, + size_t allocated; /* Allocated size of the buffer area. */ + size_t used; /* Number of bytes in the buffer, * <= allocated. */ } ResultBuffer; @@ -270,7 +270,7 @@ struct ForwardParamTransform { ForwardParamBase base; /* "Supertype". MUST COME FIRST. */ char *buf; /* I: Bytes to transform, * O: Bytes in transform result */ - int size; /* I: #bytes to transform, + size_t size; /* I: #bytes to transform, * O: #bytes in the transform result */ }; struct ForwardParamLimit { @@ -620,7 +620,7 @@ TclChanPushObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s initialize\" returned %s", TclGetString(cmdObj), - Tcl_GetString(Tcl_GetObjResult(interp)))); + Tcl_GetStringResult(interp))); Tcl_DecrRefCount(resObj); goto error; } @@ -1014,7 +1014,7 @@ ReflectClose( if (!rtPtr->dead) { rtmPtr = GetReflectedTransformMap(rtPtr->interp); - hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle)); + hPtr = Tcl_FindHashEntry(&rtmPtr->map, TclGetString(rtPtr->handle)); if (hPtr) { Tcl_DeleteHashEntry(hPtr); } @@ -2041,7 +2041,7 @@ InvokeTclMethod( */ if (result != TCL_ERROR) { Tcl_Obj *cmd = Tcl_NewListObj(cmdc, rtPtr->argv); - int cmdLen; + size_t cmdLen; const char *cmdString = TclGetStringFromObj(cmd, &cmdLen); Tcl_IncrRefCount(cmd); @@ -2590,7 +2590,7 @@ ForwardProc( if (InvokeTclMethod(rtPtr, "read", bufObj, NULL, &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); - paramPtr->transform.size = -1; + paramPtr->transform.size = TCL_AUTO_LENGTH; } else { /* * Process a regular return. Contains the transformation result. @@ -2624,7 +2624,7 @@ ForwardProc( if (InvokeTclMethod(rtPtr, "write", bufObj, NULL, &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); - paramPtr->transform.size = -1; + paramPtr->transform.size = TCL_AUTO_LENGTH; } else { /* * Process a regular return. Contains the transformation result. @@ -2654,7 +2654,7 @@ ForwardProc( case ForwardedDrain: if (InvokeTclMethod(rtPtr, "drain", NULL, NULL, &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); - paramPtr->transform.size = -1; + paramPtr->transform.size = TCL_AUTO_LENGTH; } else { /* * Process a regular return. Contains the transformation result. @@ -2680,7 +2680,7 @@ ForwardProc( case ForwardedFlush: if (InvokeTclMethod(rtPtr, "flush", NULL, NULL, &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); - paramPtr->transform.size = -1; + paramPtr->transform.size = TCL_AUTO_LENGTH; } else { /* * Process a regular return. Contains the transformation result. @@ -3037,7 +3037,7 @@ ResultCopy( */ copied = 0; - } else if (rPtr->used == toRead) { + } else if (rPtr->used == (size_t)toRead) { /* * We have just enough. Copy everything to the caller. */ @@ -3045,7 +3045,7 @@ ResultCopy( memcpy(buf, rPtr->buf, toRead); rPtr->used = 0; copied = toRead; - } else if (rPtr->used > toRead) { + } else if (rPtr->used > (size_t)toRead) { /* * The internal buffer contains more than requested. Copy the * requested subset to the caller, and shift the remaining bytes down. diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 3a6233a..c366af9 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -539,7 +539,7 @@ TclFSCwdPointerEquals( if (tsdPtr->cwdPathPtr == *pathPtrPtr) { return 1; } else { - int len1, len2; + size_t len1, len2; const char *str1, *str2; str1 = TclGetStringFromObj(tsdPtr->cwdPathPtr, &len1); @@ -681,7 +681,7 @@ FsUpdateCwd( Tcl_Obj *cwdObj, ClientData clientData) { - int len = 0; + size_t len = 0; const char *str = NULL; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); @@ -1203,7 +1203,7 @@ FsAddMountsToGlobResult( } if (!found && dir) { Tcl_Obj *norm; - int len, mlen; + size_t len, mlen; /* * We know mElt is absolute normalized and lies inside pathPtr, so @@ -1390,7 +1390,7 @@ TclFSNormalizeToUniquePath( { FilesystemRecord *fsRecPtr, *firstFsRecPtr; - int i; + size_t i; int isVfsPath = 0; char *path; @@ -1403,7 +1403,7 @@ TclFSNormalizeToUniquePath( * We check these first to avoid useless calls to the native filesystem's * normalizePathProc. */ - path = Tcl_GetStringFromObj(pathPtr, &i); + path = TclGetStringFromObj(pathPtr, &i); if ( (i >= 3) && ( (path[0] == '/' && path[1] == '/') || (path[0] == '\\' && path[1] == '\\') ) ) { @@ -1769,14 +1769,14 @@ Tcl_FSEvalFileEx( Tcl_SetErrno(errno); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", - Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + TclGetString(pathPtr), Tcl_PosixError(interp))); return result; } chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644); if (chan == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", - Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + TclGetString(pathPtr), Tcl_PosixError(interp))); return result; } @@ -1812,10 +1812,10 @@ Tcl_FSEvalFileEx( Tcl_Close(interp, chan); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", - Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + TclGetString(pathPtr), Tcl_PosixError(interp))); goto end; } - string = Tcl_GetString(objPtr); + string = TclGetString(objPtr); /* * If first character is not a BOM, append the remaining characters, @@ -1827,7 +1827,7 @@ Tcl_FSEvalFileEx( Tcl_Close(interp, chan); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", - Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + TclGetString(pathPtr), Tcl_PosixError(interp))); goto end; } @@ -1903,17 +1903,17 @@ TclNREvalFile( Tcl_SetErrno(errno); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", - Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + TclGetString(pathPtr), Tcl_PosixError(interp))); return TCL_ERROR; } chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644); if (chan == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", - Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + TclGetString(pathPtr), Tcl_PosixError(interp))); return TCL_ERROR; } - TclPkgFileSeen(interp, Tcl_GetString(pathPtr)); + TclPkgFileSeen(interp, TclGetString(pathPtr)); /* * The eofchar is \32 (^Z). This is the usual on Windows, but we effect @@ -1947,11 +1947,11 @@ TclNREvalFile( Tcl_Close(interp, chan); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", - Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + TclGetString(pathPtr), Tcl_PosixError(interp))); Tcl_DecrRefCount(objPtr); return TCL_ERROR; } - string = Tcl_GetString(objPtr); + string = TclGetString(objPtr); /* * If first character is not a BOM, append the remaining characters, @@ -1963,7 +1963,7 @@ TclNREvalFile( Tcl_Close(interp, chan); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", - Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + TclGetString(pathPtr), Tcl_PosixError(interp))); Tcl_DecrRefCount(objPtr); return TCL_ERROR; } @@ -2017,14 +2017,14 @@ EvalFileCallback( * Record information telling where the error occurred. */ - int length; + size_t length; const char *pathString = TclGetStringFromObj(pathPtr, &length); - const int limit = 150; + const unsigned int limit = 150; int overflow = (length > limit); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (file \"%.*s%s\" line %d)", - (overflow ? limit : length), pathString, + (overflow ? limit : (unsigned int)length), pathString, (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); } @@ -2301,7 +2301,7 @@ Tcl_FSOpenFileChannel( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "could not seek to end of file while opening \"%s\": %s", - Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + TclGetString(pathPtr), Tcl_PosixError(interp))); } Tcl_Close(NULL, retVal); return NULL; @@ -2320,7 +2320,7 @@ Tcl_FSOpenFileChannel( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't open \"%s\": %s", - Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + TclGetString(pathPtr), Tcl_PosixError(interp))); } return NULL; } @@ -2868,7 +2868,7 @@ Tcl_FSGetCwd( * bug when trying to normalize tsdPtr->cwdPathPtr. */ - int len1, len2; + size_t len1, len2; const char *str1, *str2; str1 = TclGetStringFromObj(tsdPtr->cwdPathPtr, &len1); @@ -3228,7 +3228,7 @@ skipUnlink( #ifndef AUFS_SUPER_MAGIC #define AUFS_SUPER_MAGIC ('a' << 24 | 'u' << 16 | 'f' << 8 | 's') #endif /* AUFS_SUPER_MAGIC */ - if ((statfs(Tcl_GetString(shlibFile), &fs) == 0) + if ((statfs(TclGetString(shlibFile), &fs) == 0) && (fs.f_type == AUFS_SUPER_MAGIC)) { return 1; } @@ -3304,7 +3304,7 @@ Tcl_LoadFile( if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't load library \"%s\": %s", - Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + TclGetString(pathPtr), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -4034,7 +4034,7 @@ Tcl_FSSplitPath( if (sep != NULL) { Tcl_IncrRefCount(sep); - separator = Tcl_GetString(sep)[0]; + separator = TclGetString(sep)[0]; Tcl_DecrRefCount(sep); } } @@ -4046,7 +4046,7 @@ Tcl_FSSplitPath( */ result = Tcl_NewObj(); - p = Tcl_GetString(pathPtr); + p = TclGetString(pathPtr); Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj(p, driveNameLength)); p += driveNameLength; @@ -4123,7 +4123,7 @@ TclGetPathType( * path, already with a refCount for the * caller. */ { - int pathLen; + size_t pathLen; const char *path = TclGetStringFromObj(pathPtr, &pathLen); Tcl_PathType type; @@ -4231,16 +4231,16 @@ TclFSNonnativePathType( } while (numVolumes > 0) { Tcl_Obj *vol; - int len; + size_t len; const char *strVol; numVolumes--; Tcl_ListObjIndex(NULL, thisFsVolumes, numVolumes, &vol); strVol = TclGetStringFromObj(vol,&len); - if (pathLen < len) { + if ((size_t) pathLen < len) { continue; } - if (strncmp(strVol, path, (size_t) len) == 0) { + if (strncmp(strVol, path, len) == 0) { type = TCL_PATH_ABSOLUTE; if (filesystemPtrPtr != NULL) { *filesystemPtrPtr = fsRecPtr->fsPtr; @@ -4579,14 +4579,14 @@ Tcl_FSRemoveDirectory( if (cwdPtr != NULL) { const char *cwdStr, *normPathStr; - int cwdLen, normLen; + size_t cwdLen, normLen; Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr); if (normPath != NULL) { normPathStr = TclGetStringFromObj(normPath, &normLen); cwdStr = TclGetStringFromObj(cwdPtr, &cwdLen); if ((cwdLen >= normLen) && (strncmp(normPathStr, cwdStr, - (size_t) normLen) == 0)) { + normLen) == 0)) { /* * The cwd is inside the directory, so we perform a 'cd * [file dirname $path]'. diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 33656d6..eec6efa 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -143,7 +143,7 @@ GetIndexFromObjList( return TCL_OK; } - tablePtr[t] = Tcl_GetString(objv[t]); + tablePtr[t] = TclGetString(objv[t]); } tablePtr[objc] = NULL; @@ -544,7 +544,7 @@ PrefixMatchObjCmd( return TCL_ERROR; } i++; - message = Tcl_GetString(objv[i]); + message = TclGetString(objv[i]); break; case PRFMATCH_ERROR: if (i > objc-4) { @@ -634,7 +634,8 @@ PrefixAllObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int tableObjc, result, t, length, elemLength; + int tableObjc, result, t; + size_t length, elemLength; const char *string, *elemString; Tcl_Obj **tableObjv, *resultPtr; @@ -691,7 +692,8 @@ PrefixLongestObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int tableObjc, result, i, t, length, elemLength, resultLength; + int tableObjc, result, t; + size_t i, length, elemLength, resultLength; const char *string, *elemString, *resultString; Tcl_Obj **tableObjv; @@ -1124,7 +1126,7 @@ Tcl_ParseArgsObjv( (int *) infoPtr->dstPtr) == TCL_ERROR) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected integer argument for \"%s\" but got \"%s\"", - infoPtr->keyStr, Tcl_GetString(objv[srcIndex]))); + infoPtr->keyStr, TclGetString(objv[srcIndex]))); goto error; } srcIndex++; @@ -1135,7 +1137,7 @@ Tcl_ParseArgsObjv( goto missingArg; } *((const char **) infoPtr->dstPtr) = - Tcl_GetString(objv[srcIndex]); + TclGetString(objv[srcIndex]); srcIndex++; objc--; break; @@ -1157,7 +1159,7 @@ Tcl_ParseArgsObjv( (double *) infoPtr->dstPtr) == TCL_ERROR) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected floating-point argument for \"%s\" but got \"%s\"", - infoPtr->keyStr, Tcl_GetString(objv[srcIndex]))); + infoPtr->keyStr, TclGetString(objv[srcIndex]))); goto error; } srcIndex++; diff --git a/generic/tclInt.h b/generic/tclInt.h index c5022c6..4b41ada 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4394,7 +4394,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, #define TclGetByteArrayFromObj(objPtr, lenPtr) \ (Tcl_GetByteArrayFromObj(objPtr, NULL), \ *(lenPtr) = *((size_t *) (objPtr)->internalRep.twoPtrValue.ptr1), \ - Tcl_GetByteArrayFromObj(objPtr, NULL)) + (unsigned char *)(((size_t *) (objPtr)->internalRep.twoPtrValue.ptr1) + 2)) #endif /* @@ -4492,19 +4492,19 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, allocated = TCL_MAX_TOKENS; \ } \ newPtr = (Tcl_Token *) Tcl_AttemptRealloc((char *) oldPtr, \ - (unsigned int) (allocated * sizeof(Tcl_Token))); \ + (allocated * sizeof(Tcl_Token))); \ if (newPtr == NULL) { \ allocated = _needed + (append) + TCL_MIN_TOKEN_GROWTH; \ if (allocated > TCL_MAX_TOKENS) { \ allocated = TCL_MAX_TOKENS; \ } \ newPtr = (Tcl_Token *) Tcl_Realloc((char *) oldPtr, \ - (unsigned int) (allocated * sizeof(Tcl_Token))); \ + (allocated * sizeof(Tcl_Token))); \ } \ (available) = allocated; \ if (oldPtr == NULL) { \ memcpy(newPtr, staticPtr, \ - (size_t) ((used) * sizeof(Tcl_Token))); \ + ((used) * sizeof(Tcl_Token))); \ } \ (tokenPtr) = newPtr; \ } \ diff --git a/generic/tclInterp.c b/generic/tclInterp.c index dd9fec8..6b28ff2 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -786,7 +786,7 @@ NRInterpCmd( slavePtr = NULL; last = 0; for (i = 2; i < objc; i++) { - if ((last == 0) && (Tcl_GetString(objv[i])[0] == '-')) { + if ((last == 0) && (TclGetString(objv[i])[0] == '-')) { if (Tcl_GetIndexFromObj(interp, objv[i], createOptions, "option", 0, &index) != TCL_OK) { return TCL_ERROR; @@ -1100,7 +1100,7 @@ NRInterpCmd( if (hPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "alias \"%s\" in path \"%s\" not found", - aliasName, Tcl_GetString(objv[2]))); + aliasName, TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL); return TCL_ERROR; @@ -1109,7 +1109,7 @@ NRInterpCmd( if (Tcl_GetInterpPath(interp, aliasPtr->targetInterp) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "target interpreter for alias \"%s\" in path \"%s\" is " - "not my descendant", aliasName, Tcl_GetString(objv[2]))); + "not my descendant", aliasName, TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "TARGETSHROUDED", NULL); return TCL_ERROR; @@ -1727,7 +1727,7 @@ AliasDescribe( */ slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; - hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, Tcl_GetString(namePtr)); + hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, TclGetString(namePtr)); if (hPtr == NULL) { return TCL_OK; } diff --git a/generic/tclLink.c b/generic/tclLink.c index 1ae8501..1ca9215 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -293,7 +293,7 @@ LinkTraceProc( } else if (flags & TCL_TRACE_DESTROYED) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); - Tcl_TraceVar2(interp, Tcl_GetString(linkPtr->varName), NULL, + Tcl_TraceVar2(interp, TclGetString(linkPtr->varName), NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES |TCL_TRACE_UNSETS, LinkTraceProc, linkPtr); } diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 504af4b..85f391c 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -536,9 +536,10 @@ Tcl_ListObjGetElements( ListGetIntRep(listPtr, listRepPtr); if (listRepPtr == NULL) { - int result, length; + int result; + size_t length; - (void) Tcl_GetStringFromObj(listPtr, &length); + (void) TclGetStringFromObj(listPtr, &length); if (length == 0) { *objcPtr = 0; *objvPtr = NULL; @@ -659,9 +660,10 @@ Tcl_ListObjAppendElement( ListGetIntRep(listPtr, listRepPtr); if (listRepPtr == NULL) { - int result, length; + int result; + size_t length; - (void) Tcl_GetStringFromObj(listPtr, &length); + (void) TclGetStringFromObj(listPtr, &length); if (length == 0) { Tcl_SetListObj(listPtr, 1, &objPtr); return TCL_OK; @@ -833,9 +835,10 @@ Tcl_ListObjIndex( ListGetIntRep(listPtr, listRepPtr); if (listRepPtr == NULL) { - int result, length; + int result; + size_t length; - (void) Tcl_GetStringFromObj(listPtr, &length); + (void) TclGetStringFromObj(listPtr, &length); if (length == 0) { *objPtrPtr = NULL; return TCL_OK; @@ -889,9 +892,10 @@ Tcl_ListObjLength( ListGetIntRep(listPtr, listRepPtr); if (listRepPtr == NULL) { - int result, length; + int result; + size_t length; - (void) Tcl_GetStringFromObj(listPtr, &length); + (void) TclGetStringFromObj(listPtr, &length); if (length == 0) { *intPtr = 0; return TCL_OK; @@ -1775,9 +1779,10 @@ TclListObjSetElement( ListGetIntRep(listPtr, listRepPtr); if (listRepPtr == NULL) { - int result, length; + int result; + size_t length; - (void) Tcl_GetStringFromObj(listPtr, &length); + (void) TclGetStringFromObj(listPtr, &length); if (length == 0) { if (interp != NULL) { Tcl_SetObjResult(interp, @@ -2011,7 +2016,8 @@ SetListFromAny( Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done); } } else { - int estCount, length; + int estCount; + size_t length; const char *limit, *nextElem = TclGetStringFromObj(objPtr, &length); /* diff --git a/generic/tclLoad.c b/generic/tclLoad.c index ce8a85f..062e1a0 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -165,7 +165,7 @@ Tcl_LoadObjCmd( if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) { return TCL_ERROR; } - fullFileName = Tcl_GetString(objv[1]); + fullFileName = TclGetString(objv[1]); Tcl_DStringInit(&pkgName); Tcl_DStringInit(&initName); @@ -176,7 +176,7 @@ Tcl_LoadObjCmd( packageName = NULL; if (objc >= 3) { - packageName = Tcl_GetString(objv[2]); + packageName = TclGetString(objv[2]); if (packageName[0] == '\0') { packageName = NULL; } @@ -196,7 +196,7 @@ Tcl_LoadObjCmd( target = interp; if (objc == 4) { - const char *slaveIntName = Tcl_GetString(objv[3]); + const char *slaveIntName = TclGetString(objv[3]); target = Tcl_GetSlave(interp, slaveIntName); if (target == NULL) { @@ -324,7 +324,7 @@ Tcl_LoadObjCmd( splitPtr = Tcl_FSSplitPath(objv[1], &pElements); Tcl_ListObjIndex(NULL, splitPtr, pElements -1, &pkgGuessPtr); - pkgGuess = Tcl_GetString(pkgGuessPtr); + pkgGuess = TclGetString(pkgGuessPtr); if ((pkgGuess[0] == 'l') && (pkgGuess[1] == 'i') && (pkgGuess[2] == 'b')) { pkgGuess += 3; @@ -564,7 +564,7 @@ Tcl_UnloadObjCmd( for (i = 1; i < objc; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) != TCL_OK) { - fullFileName = Tcl_GetString(objv[i]); + fullFileName = TclGetString(objv[i]); if (fullFileName[0] == '-') { /* * It looks like the command contains an option so signal an @@ -604,13 +604,13 @@ Tcl_UnloadObjCmd( return TCL_ERROR; } - fullFileName = Tcl_GetString(objv[i]); + fullFileName = TclGetString(objv[i]); Tcl_DStringInit(&pkgName); Tcl_DStringInit(&tmp); packageName = NULL; if (objc - i >= 2) { - packageName = Tcl_GetString(objv[i+1]); + packageName = TclGetString(objv[i+1]); if (packageName[0] == '\0') { packageName = NULL; } @@ -630,7 +630,7 @@ Tcl_UnloadObjCmd( target = interp; if (objc - i == 3) { - const char *slaveIntName = Tcl_GetString(objv[i + 2]); + const char *slaveIntName = TclGetString(objv[i + 2]); target = Tcl_GetSlave(interp, slaveIntName); if (target == NULL) { diff --git a/generic/tclMain.c b/generic/tclMain.c index f85f8aa..c4afcd9 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -215,7 +215,7 @@ Tcl_GetStartupScript( if (tsdPtr->encoding == NULL) { *encodingPtr = NULL; } else { - *encodingPtr = Tcl_GetString(tsdPtr->encoding); + *encodingPtr = TclGetString(tsdPtr->encoding); } } return tsdPtr->path; @@ -343,7 +343,7 @@ Tcl_MainEx( && ('-' != argv[3][0])) { Tcl_Obj *value = NewNativeObj(argv[2], -1); Tcl_SetStartupScript(NewNativeObj(argv[3], -1), - Tcl_GetString(value)); + TclGetString(value)); Tcl_DecrRefCount(value); argc -= 3; argv += 3; @@ -488,7 +488,7 @@ Tcl_MainEx( Tcl_IncrRefCount(is.commandPtr); } length = Tcl_GetsObj(is.input, is.commandPtr); - if (length == (size_t)-1) { + if (length == TCL_AUTO_LENGTH) { if (Tcl_InputBlocked(is.input)) { /* * This can only happen if stdin has been set to @@ -766,7 +766,7 @@ StdinProc( Tcl_IncrRefCount(commandPtr); } length = Tcl_GetsObj(chan, commandPtr); - if (length == (size_t)-1) { + if (length == TCL_AUTO_LENGTH) { if (Tcl_InputBlocked(chan)) { return; } diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 48a0e34..3c23b97 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -3570,7 +3570,7 @@ NamespaceExportCmd( */ firstArg = 1; - if (strcmp("-clear", Tcl_GetString(objv[firstArg])) == 0) { + if (strcmp("-clear", TclGetString(objv[firstArg])) == 0) { Tcl_Export(interp, NULL, "::", 1); Tcl_ResetResult(interp); firstArg++; @@ -3581,7 +3581,7 @@ NamespaceExportCmd( */ for (i = firstArg; i < objc; i++) { - int result = Tcl_Export(interp, NULL, Tcl_GetString(objv[i]), 0); + int result = Tcl_Export(interp, NULL, TclGetString(objv[i]), 0); if (result != TCL_OK) { return result; } diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 60e7456..72b755b 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -744,7 +744,7 @@ TclOO_Object_VarName( return TCL_ERROR; } argPtr = objv[objc-1]; - arg = Tcl_GetString(argPtr); + arg = TclGetString(argPtr); /* * Convert the variable name to fully-qualified form if it wasn't already. @@ -781,8 +781,8 @@ TclOO_Object_VarName( if (mPtr->declaringObjectPtr == oPtr) { FOREACH_STRUCT(pvPtr, oPtr->privateVariables) { - if (!strcmp(Tcl_GetString(pvPtr->variableObj), - Tcl_GetString(argPtr))) { + if (!strcmp(TclGetString(pvPtr->variableObj), + TclGetString(argPtr))) { argPtr = pvPtr->fullNameObj; break; } @@ -803,8 +803,8 @@ TclOO_Object_VarName( } if (isInstance) { FOREACH_STRUCT(pvPtr, clsPtr->privateVariables) { - if (!strcmp(Tcl_GetString(pvPtr->variableObj), - Tcl_GetString(argPtr))) { + if (!strcmp(TclGetString(pvPtr->variableObj), + TclGetString(argPtr))) { argPtr = pvPtr->fullNameObj; break; } diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 28ea4b5..6685f08 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -556,7 +556,7 @@ InstallPrivateVariableMapping( privatePtr->variableObj = varv[i]; privatePtr->fullNameObj = Tcl_ObjPrintf( PRIVATE_VARIABLE_PATTERN, - creationEpoch, Tcl_GetString(varv[i])); + creationEpoch, TclGetString(varv[i])); Tcl_IncrRefCount(privatePtr->fullNameObj); } else { Tcl_DecrRefCount(varv[i]); @@ -1620,7 +1620,7 @@ TclOODefineDefnNsObjCmd( &kind) != TCL_OK) { return TCL_ERROR; } - if (!Tcl_GetString(objv[objc - 1])[0]) { + if (!TclGetString(objv[objc - 1])[0]) { nsNamePtr = NULL; } else { nsPtr = GetNamespaceInOuterContext(interp, objv[objc - 1]); diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index faf3676..f9767a7 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -816,7 +816,7 @@ InfoObjectVariablesCmd( return TCL_ERROR; } if (objc == 3) { - if (strcmp("-private", Tcl_GetString(objv[2])) != 0) { + if (strcmp("-private", TclGetString(objv[2])) != 0) { return TCL_ERROR; } private = 1; @@ -1595,7 +1595,7 @@ InfoClassVariablesCmd( return TCL_ERROR; } if (objc == 3) { - if (strcmp("-private", Tcl_GetString(objv[2])) != 0) { + if (strcmp("-private", TclGetString(objv[2])) != 0) { return TCL_ERROR; } private = 1; diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index fa3cd6c..fa5cbc9 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -1120,8 +1120,8 @@ ProcedureMethodCompiledVarResolver( * which look like array accesses. Both will lead us astray. */ - if (strstr(Tcl_GetString(variableObj), "::") != NULL || - Tcl_StringMatch(Tcl_GetString(variableObj), "*(*)")) { + if (strstr(TclGetString(variableObj), "::") != NULL || + Tcl_StringMatch(TclGetString(variableObj), "*(*)")) { Tcl_DecrRefCount(variableObj); return TCL_CONTINUE; } @@ -1338,7 +1338,7 @@ CloneProcedureMethod( */ bodyObj = Tcl_DuplicateObj(pmPtr->procPtr->bodyPtr); - Tcl_GetString(bodyObj); + TclGetString(bodyObj); Tcl_StoreIntRep(pmPtr->procPtr->bodyPtr, &tclByteCodeType, NULL); /* diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index d53b05c..b500c7e 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -916,7 +916,7 @@ TclJoinPath( */ if ((tclPlatform != TCL_PLATFORM_WINDOWS) - || (strchr(Tcl_GetString(elt), '\\') == NULL)) { + || (strchr(TclGetString(elt), '\\') == NULL)) { if (PATHFLAGS(elt)) { return TclNewFSPathObj(elt, str, len); @@ -952,7 +952,8 @@ TclJoinPath( assert ( res == NULL ); for (i = 0; i < elements; i++) { - int driveNameLength, strEltLen, length; + int driveNameLength; + size_t strEltLen, length; Tcl_PathType type; char *strElt, *ptr; Tcl_Obj *driveName = NULL; @@ -1407,7 +1408,7 @@ TclFSMakePathRelative( Tcl_Obj *pathPtr, /* The path we have. */ Tcl_Obj *cwdPtr) /* Make it relative to this. */ { - int cwdLen, len; + size_t cwdLen, len; const char *tempStr; Tcl_ObjIntRep *irPtr = TclFetchIntRep(pathPtr, &fsPathType); @@ -1677,11 +1678,11 @@ Tcl_FSGetTranslatedStringPath( Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr); if (transPtr != NULL) { - int len; + size_t len; const char *orig = TclGetStringFromObj(transPtr, &len); char *result = Tcl_Alloc(len+1); - memcpy(result, orig, (size_t) len+1); + memcpy(result, orig, len+1); TclDecrRefCount(transPtr); return result; } @@ -1727,7 +1728,8 @@ Tcl_FSGetNormalizedPath( */ Tcl_Obj *dir, *copy; - int tailLen, cwdLen, pathType; + size_t tailLen, cwdLen; + int pathType; pathType = Tcl_FSGetPathType(fsPathPtr->cwdPtr); dir = Tcl_FSGetNormalizedPath(interp, fsPathPtr->cwdPtr); @@ -1843,7 +1845,7 @@ Tcl_FSGetNormalizedPath( copy = AppendPath(fsPathPtr->cwdPtr, pathPtr); (void) TclGetStringFromObj(fsPathPtr->cwdPtr, &cwdLen); - cwdLen += (Tcl_GetString(copy)[cwdLen] == '/'); + cwdLen += (TclGetString(copy)[cwdLen] == '/'); /* * Normalize the combined string, but only starting after the end @@ -2364,7 +2366,8 @@ SetFsPathFromAny( objc--; objv++; while (objc--) { - TclpNativeJoinPath(transPtr, Tcl_GetString(*objv++)); + TclpNativeJoinPath(transPtr, TclGetString(*objv)); + objv++; } TclDecrRefCount(parts); } else { diff --git a/generic/tclPkg.c b/generic/tclPkg.c index ed04cb1..8966387 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -1007,7 +1007,7 @@ TclNRPackageObjCmd( } pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL); if (pkgFiles) { - Tcl_HashEntry *entry = Tcl_FindHashEntry(&pkgFiles->table, Tcl_GetString(objv[2])); + Tcl_HashEntry *entry = Tcl_FindHashEntry(&pkgFiles->table, TclGetString(objv[2])); if (entry) { Tcl_SetObjResult(interp, (Tcl_Obj *)Tcl_GetHashValue(entry)); } diff --git a/generic/tclProc.c b/generic/tclProc.c index f4d2210..d12e0f2 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -329,7 +329,7 @@ Tcl_ProcObjCmd( * of all procs whose argument list is just _args_ */ - if (TclFetchIntRep(objv[3], &tclProcBodyType)) { + if (objv[3]->typePtr == &tclProcBodyType) { goto done; } @@ -553,7 +553,7 @@ TclCreateProc( if (*argnamelast == ')') { /* We have an array element. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "formal parameter \"%s\" is an array element", - Tcl_GetString(fieldValues[0]))); + TclGetString(fieldValues[0]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; @@ -2423,7 +2423,7 @@ SetLambdaFromAny( if ((result != TCL_OK) || ((objc != 2) && (objc != 3))) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't interpret \"%s\" as a lambda expression", - Tcl_GetString(objPtr))); + TclGetString(objPtr))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "LAMBDA", NULL); return TCL_ERROR; } diff --git a/generic/tclResult.c b/generic/tclResult.c index 76ba02a..a4df031 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -230,7 +230,7 @@ Tcl_GetStringResult( { Interp *iPtr = (Interp *) interp; - return Tcl_GetString(iPtr->objResultPtr); + return TclGetString(iPtr->objResultPtr); } /* diff --git a/generic/tclScan.c b/generic/tclScan.c index bf611fc..1d7edf9 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -589,7 +589,7 @@ Tcl_ScanObjCmd( return TCL_ERROR; } - format = Tcl_GetString(objv[2]); + format = TclGetString(objv[2]); numVars = objc-3; /* @@ -611,7 +611,7 @@ Tcl_ScanObjCmd( } } - string = Tcl_GetString(objv[1]); + string = TclGetString(objv[1]); baseString = string; /* diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 9537490..0bae9f0 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -2642,7 +2642,7 @@ AppendPrintfToObjVA( if (code != TCL_OK) { Tcl_AppendPrintfToObj(objPtr, "Unable to format \"%s\" with supplied arguments: %s", - format, Tcl_GetString(list)); + format, TclGetString(list)); } Tcl_DecrRefCount(list); } @@ -2784,10 +2784,10 @@ TclStringRepeat( if (binary) { /* Result will be pure byte array. Pre-size it */ - TclGetByteArrayFromObj(objPtr, &length); + (void)TclGetByteArrayFromObj(objPtr, &length); } else if (unichar) { /* Result will be pure Tcl_UniChar array. Pre-size it. */ - TclGetUnicodeFromObj(objPtr, &length); + (void)TclGetUnicodeFromObj(objPtr, &length); } else { /* Result will be concat of string reps. Pre-size it. */ (void)TclGetStringFromObj(objPtr, &length); @@ -2856,7 +2856,7 @@ TclStringRepeat( */ if (!inPlace || Tcl_IsShared(objPtr)) { - objResultPtr = Tcl_NewStringObj(Tcl_GetString(objPtr), length); + objResultPtr = Tcl_NewStringObj(TclGetString(objPtr), length); } else { TclFreeIntRep(objPtr); objResultPtr = objPtr; @@ -2875,7 +2875,7 @@ TclStringRepeat( Tcl_AppendObjToObj(objResultPtr, objResultPtr); done *= 2; } - Tcl_AppendToObj(objResultPtr, Tcl_GetString(objResultPtr), + Tcl_AppendToObj(objResultPtr, TclGetString(objResultPtr), (count - done) * length); } return objResultPtr; @@ -2980,7 +2980,7 @@ TclStringCat( */ if (TclIsPureByteArray(objPtr)) { - TclGetByteArrayFromObj(objPtr, &numBytes); /* PANIC? */ + (void)TclGetByteArrayFromObj(objPtr, &numBytes); /* PANIC? */ if (numBytes) { last = objc - oc; @@ -3061,7 +3061,7 @@ TclStringCat( do { Tcl_Obj *objPtr = *ov++; - Tcl_GetString(objPtr); /* PANIC? */ + TclGetString(objPtr); /* PANIC? */ numBytes = objPtr->length; } while (--oc && numBytes == 0 && pendingPtr->bytes == NULL); @@ -3088,7 +3088,7 @@ TclStringCat( /* assert ( length > 0 && pendingPtr == NULL ) */ - Tcl_GetString(objPtr); /* PANIC? */ + TclGetString(objPtr); /* PANIC? */ numBytes = objPtr->length; if (numBytes) { last = objc - oc; @@ -3122,7 +3122,7 @@ TclStringCat( size_t start; objResultPtr = *objv++; objc--; - TclGetByteArrayFromObj(objResultPtr, &start); + (void)TclGetByteArrayFromObj(objResultPtr, &start); dst = Tcl_SetByteArrayLength(objResultPtr, length) + start; } else { objResultPtr = Tcl_NewByteArrayObj(NULL, length); @@ -3214,7 +3214,7 @@ TclStringCat( } return NULL; } - dst = Tcl_GetString(objResultPtr) + start; + dst = TclGetString(objResultPtr) + start; /* assert ( length > start ) */ TclFreeIntRep(objResultPtr); @@ -3230,7 +3230,7 @@ TclStringCat( } return NULL; } - dst = Tcl_GetString(objResultPtr); + dst = TclGetString(objResultPtr); } while (objc--) { Tcl_Obj *objPtr = *objv++; diff --git a/generic/tclTest.c b/generic/tclTest.c index 08669db..277322a 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -976,7 +976,7 @@ AsyncHandlerProc( TclFormatInt(string, code); listArgv[0] = asyncPtr->command; - listArgv[1] = Tcl_GetString(Tcl_GetObjResult(interp)); + listArgv[1] = Tcl_GetStringResult(interp); listArgv[2] = string; listArgv[3] = NULL; cmd = Tcl_Merge(3, listArgv); diff --git a/generic/tclTimer.c b/generic/tclTimer.c index 0dbf834..0833722 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -821,7 +821,7 @@ Tcl_AfterObjCmd( if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) { if (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0, &index) != TCL_OK) { - const char *arg = Tcl_GetString(objv[1]); + const char *arg = TclGetString(objv[1]); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad argument \"%s\": must be" diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 13b7528..c60babb 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -324,7 +324,7 @@ Tcl_TraceObjCmd( return TCL_ERROR; } resultListPtr = Tcl_NewObj(); - name = Tcl_GetString(objv[2]); + name = TclGetString(objv[2]); FOREACH_VAR_TRACE(interp, name, clientData) { TraceVarInfo *tvarPtr = clientData; char *q = ops; @@ -485,7 +485,7 @@ TraceExecutionObjCmd( flags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC); } memcpy(tcmdPtr->command, command, length+1); - name = Tcl_GetString(objv[3]); + name = TclGetString(objv[3]); if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc, tcmdPtr) != TCL_OK) { Tcl_Free(tcmdPtr); @@ -504,7 +504,7 @@ TraceExecutionObjCmd( * First ensure the name given is valid. */ - name = Tcl_GetString(objv[3]); + name = TclGetString(objv[3]); if (Tcl_FindCommand(interp,name,NULL,TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } @@ -565,7 +565,7 @@ TraceExecutionObjCmd( return TCL_ERROR; } - name = Tcl_GetString(objv[3]); + name = TclGetString(objv[3]); /* * First ensure the name given is valid. @@ -718,7 +718,7 @@ TraceCommandObjCmd( tcmdPtr->refCount = 1; flags |= TCL_TRACE_DELETE; memcpy(tcmdPtr->command, command, length+1); - name = Tcl_GetString(objv[3]); + name = TclGetString(objv[3]); if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc, tcmdPtr) != TCL_OK) { Tcl_Free(tcmdPtr); @@ -737,7 +737,7 @@ TraceCommandObjCmd( * First ensure the name given is valid. */ - name = Tcl_GetString(objv[3]); + name = TclGetString(objv[3]); if (Tcl_FindCommand(interp,name,NULL,TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } @@ -773,7 +773,7 @@ TraceCommandObjCmd( * First ensure the name given is valid. */ - name = Tcl_GetString(objv[3]); + name = TclGetString(objv[3]); if (Tcl_FindCommand(interp, name, NULL, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } @@ -926,7 +926,7 @@ TraceVariableObjCmd( ctvarPtr->traceInfo.traceProc = TraceVarProc; ctvarPtr->traceInfo.clientData = &ctvarPtr->traceCmdInfo; ctvarPtr->traceInfo.flags = flags; - name = Tcl_GetString(objv[3]); + name = TclGetString(objv[3]); if (TraceVarEx(interp, name, NULL, (VarTrace *) ctvarPtr) != TCL_OK) { Tcl_Free(ctvarPtr); @@ -939,7 +939,7 @@ TraceVariableObjCmd( * first one that matches. */ - name = Tcl_GetString(objv[3]); + name = TclGetString(objv[3]); FOREACH_VAR_TRACE(interp, name, clientData) { TraceVarInfo *tvarPtr = clientData; @@ -969,7 +969,7 @@ TraceVariableObjCmd( } resultListPtr = Tcl_NewObj(); - name = Tcl_GetString(objv[3]); + name = TclGetString(objv[3]); FOREACH_VAR_TRACE(interp, name, clientData) { Tcl_Obj *opObjPtr, *eachTraceObjPtr, *elemObjPtr; TraceVarInfo *tvarPtr = clientData; @@ -1831,7 +1831,7 @@ TraceExecutionProc( Tcl_DStringInit(&sub); for (i = 0; i < objc; i++) { - Tcl_DStringAppendElement(&sub, Tcl_GetString(objv[i])); + Tcl_DStringAppendElement(&sub, TclGetString(objv[i])); } Tcl_DStringAppendElement(&cmd, Tcl_DStringValue(&sub)); Tcl_DStringFree(&sub); @@ -1855,7 +1855,7 @@ TraceExecutionProc( */ resultCode = Tcl_NewIntObj(code); - resultCodeStr = Tcl_GetString(resultCode); + resultCodeStr = TclGetString(resultCode); Tcl_DStringAppendElement(&cmd, resultCodeStr); Tcl_DecrRefCount(resultCode); @@ -2278,7 +2278,7 @@ StringTraceProc( argv = (const char **) TclStackAlloc(interp, (objc + 1) * sizeof(const char *)); for (i = 0; i < objc; i++) { - argv[i] = Tcl_GetString(objv[i]); + argv[i] = TclGetString(objv[i]); } argv[objc] = 0; @@ -2781,7 +2781,7 @@ TclCallVarTraces( (part2 ? ")" : "") )); if (disposeFlags & TCL_TRACE_RESULT_OBJECT) { TclVarErrMsg((Tcl_Interp *) iPtr, part1, part2, verb, - Tcl_GetString((Tcl_Obj *) result)); + TclGetString((Tcl_Obj *) result)); } else { TclVarErrMsg((Tcl_Interp *) iPtr, part1, part2, verb, result); } diff --git a/generic/tclVar.c b/generic/tclVar.c index c4d95b6..308af04 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -343,7 +343,7 @@ NotArrayError( Tcl_Interp *interp, Tcl_Obj *name) { - const char *nameStr = Tcl_GetString(name); + const char *nameStr = TclGetString(name); Tcl_SetObjResult(interp, Tcl_ObjPrintf("\"%s\" isn't an array", nameStr)); diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index c9a58df..2c91161 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -1873,9 +1873,9 @@ ZipFSMountObjCmd( return TCL_ERROR; } - return TclZipfs_Mount(interp, (objc > 1) ? Tcl_GetString(objv[1]) : NULL, - (objc > 2) ? Tcl_GetString(objv[2]) : NULL, - (objc > 3) ? Tcl_GetString(objv[3]) : NULL); + return TclZipfs_Mount(interp, (objc > 1) ? TclGetString(objv[1]) : NULL, + (objc > 2) ? TclGetString(objv[2]) : NULL, + (objc > 3) ? TclGetString(objv[3]) : NULL); } /* @@ -1918,7 +1918,7 @@ ZipFSMountBufferObjCmd( return ret; } - mountPoint = Tcl_GetString(objv[1]); + mountPoint = TclGetString(objv[1]); if (objc < 3) { ReadLock(); DescribeMounted(interp, mountPoint); @@ -1984,7 +1984,7 @@ ZipFSUnmountObjCmd( Tcl_WrongNumArgs(interp, 1, objv, "zipfile"); return TCL_ERROR; } - return TclZipfs_Unmount(interp, Tcl_GetString(objv[1])); + return TclZipfs_Unmount(interp, TclGetString(objv[1])); } /* @@ -2018,7 +2018,7 @@ ZipFSMkKeyObjCmd( Tcl_WrongNumArgs(interp, 1, objv, "password"); return TCL_ERROR; } - pw = Tcl_GetString(objv[1]); + pw = TclGetString(objv[1]); len = strlen(pw); if (len == 0) { return TCL_OK; @@ -2453,7 +2453,7 @@ ZipFSMkZipOrImgObjCmd( passBuf[0] = 0; if (objc > (isList ? 3 : 4)) { - pw = Tcl_GetString(objv[isList ? 3 : 4]); + pw = TclGetString(objv[isList ? 3 : 4]); pwlen = strlen(pw); if ((pwlen > 255) || strchr(pw, 0xff)) { Tcl_SetObjResult(interp, @@ -2497,7 +2497,7 @@ ZipFSMkZipOrImgObjCmd( Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "EMPTY", NULL); return TCL_ERROR; } - out = Tcl_OpenFileChannel(interp, Tcl_GetString(objv[1]), "wb", 0755); + out = Tcl_OpenFileChannel(interp, TclGetString(objv[1]), "wb", 0755); if (out == NULL) { Tcl_DecrRefCount(list); return TCL_ERROR; @@ -2512,10 +2512,10 @@ ZipFSMkZipOrImgObjCmd( const char *imgName; if (isList) { - imgName = (objc > 4) ? Tcl_GetString(objv[4]) : + imgName = (objc > 4) ? TclGetString(objv[4]) : Tcl_GetNameOfExecutable(); } else { - imgName = (objc > 5) ? Tcl_GetString(objv[5]) : + imgName = (objc > 5) ? TclGetString(objv[5]) : Tcl_GetNameOfExecutable(); } if (pwlen) { @@ -2645,15 +2645,15 @@ ZipFSMkZipOrImgObjCmd( Tcl_InitHashTable(&fileHash, TCL_STRING_KEYS); pos[0] = Tcl_Tell(out); if (!isList && (objc > 3)) { - strip = Tcl_GetString(objv[3]); + strip = TclGetString(objv[3]); slen = strlen(strip); } for (i = 0; i < (size_t) lobjc; i += (isList ? 2 : 1)) { const char *path, *name; - path = Tcl_GetString(lobjv[i]); + path = TclGetString(lobjv[i]); if (isList) { - name = Tcl_GetString(lobjv[i + 1]); + name = TclGetString(lobjv[i + 1]); } else { name = path; if (slen > 0) { @@ -2680,9 +2680,9 @@ ZipFSMkZipOrImgObjCmd( for (i = 0; i < (size_t) lobjc; i += (isList ? 2 : 1)) { const char *path, *name; - path = Tcl_GetString(lobjv[i]); + path = TclGetString(lobjv[i]); if (isList) { - name = Tcl_GetString(lobjv[i + 1]); + name = TclGetString(lobjv[i + 1]); } else { name = path; if (slen > 0) { @@ -2916,11 +2916,11 @@ ZipFSCanonicalObjCmd( } Tcl_DStringInit(&dPath); if (objc == 2) { - filename = Tcl_GetString(objv[1]); + filename = TclGetString(objv[1]); result = CanonicalPath("", filename, &dPath, 1); } else if (objc == 3) { - mntpoint = Tcl_GetString(objv[1]); - filename = Tcl_GetString(objv[2]); + mntpoint = TclGetString(objv[1]); + filename = TclGetString(objv[2]); result = CanonicalPath(mntpoint, filename, &dPath, 1); } else { int zipfs = 0; @@ -2928,8 +2928,8 @@ ZipFSCanonicalObjCmd( if (Tcl_GetBooleanFromObj(interp, objv[3], &zipfs)) { return TCL_ERROR; } - mntpoint = Tcl_GetString(objv[1]); - filename = Tcl_GetString(objv[2]); + mntpoint = TclGetString(objv[1]); + filename = TclGetString(objv[2]); result = CanonicalPath(mntpoint, filename, &dPath, zipfs); } Tcl_SetObjResult(interp, Tcl_NewStringObj(result, -1)); @@ -2974,7 +2974,7 @@ ZipFSExistsObjCmd( * Prepend ZIPFS_VOLUME to filename, eliding the final / */ - filename = Tcl_GetString(objv[1]); + filename = TclGetString(objv[1]); Tcl_DStringInit(&ds); Tcl_DStringAppend(&ds, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN - 1); Tcl_DStringAppend(&ds, filename, -1); @@ -3021,7 +3021,7 @@ ZipFSInfoObjCmd( Tcl_WrongNumArgs(interp, 1, objv, "filename"); return TCL_ERROR; } - filename = Tcl_GetString(objv[1]); + filename = TclGetString(objv[1]); ReadLock(); z = ZipFSLookup(filename); if (z) { @@ -3075,13 +3075,13 @@ ZipFSListObjCmd( return TCL_ERROR; } if (objc == 3) { - int n; - char *what = Tcl_GetStringFromObj(objv[1], &n); + size_t n; + char *what = TclGetStringFromObj(objv[1], &n); if ((n >= 2) && (strncmp(what, "-glob", n) == 0)) { - pattern = Tcl_GetString(objv[2]); + pattern = TclGetString(objv[2]); } else if ((n >= 2) && (strncmp(what, "-regexp", n) == 0)) { - regexp = Tcl_RegExpCompile(interp, Tcl_GetString(objv[2])); + regexp = Tcl_RegExpCompile(interp, TclGetString(objv[2])); if (!regexp) { return TCL_ERROR; } @@ -3092,7 +3092,7 @@ ZipFSListObjCmd( return TCL_ERROR; } } else if (objc == 2) { - pattern = Tcl_GetString(objv[1]); + pattern = TclGetString(objv[1]); } ReadLock(); if (pattern) { @@ -3709,7 +3709,7 @@ ZipChannelOpen( if (trunc) { info->numBytes = 0; } else if (z->data) { - unsigned int j = z->numBytes; + size_t j = z->numBytes; if (j > info->maxWrite) { j = info->maxWrite; @@ -3747,7 +3747,7 @@ ZipChannelOpen( stream.opaque = Z_NULL; stream.avail_in = z->numCompressedBytes; if (z->isEncrypted) { - unsigned int j; + size_t j; stream.avail_in -= 12; cbuf = Tcl_AttemptAlloc(stream.avail_in); @@ -3841,7 +3841,7 @@ ZipChannelOpen( z_stream stream; int err; unsigned char *ubuf = NULL; - unsigned int j; + size_t j; memset(&stream, 0, sizeof(z_stream)); stream.zalloc = Z_NULL; @@ -3911,7 +3911,7 @@ ZipChannelOpen( goto error; } else if (info->isEncrypted) { unsigned char *ubuf = NULL; - unsigned int j, len; + size_t j, len; /* * Decode encrypted but uncompressed file, since we support @@ -4045,13 +4045,11 @@ ZipFSOpenFileChannelProc( int mode, int permissions) { - int len; - pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); if (!pathPtr) { return NULL; } - return ZipChannelOpen(interp, Tcl_GetStringFromObj(pathPtr, &len), mode, + return ZipChannelOpen(interp, TclGetString(pathPtr), mode, permissions); } @@ -4077,13 +4075,12 @@ ZipFSStatProc( Tcl_Obj *pathPtr, Tcl_StatBuf *buf) { - int len; pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); if (!pathPtr) { return -1; } - return ZipEntryStat(Tcl_GetStringFromObj(pathPtr, &len), buf); + return ZipEntryStat(TclGetString(pathPtr), buf); } /* @@ -4108,13 +4105,11 @@ ZipFSAccessProc( Tcl_Obj *pathPtr, int mode) { - int len; - pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); if (!pathPtr) { return -1; } - return ZipEntryAccess(Tcl_GetStringFromObj(pathPtr, &len), mode); + return ZipEntryAccess(TclGetString(pathPtr), mode); } /* @@ -4173,8 +4168,8 @@ ZipFSMatchInDirectoryProc( Tcl_HashEntry *hPtr; Tcl_HashSearch search; Tcl_Obj *normPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); - int scnt, l, dirOnly = -1, prefixLen, strip = 0; - size_t len; + int scnt, l, dirOnly = -1, strip = 0; + size_t len, prefixLen; char *pat, *prefix, *path; Tcl_DString dsPref; @@ -4189,13 +4184,13 @@ ZipFSMatchInDirectoryProc( * The prefix that gets prepended to results. */ - prefix = Tcl_GetStringFromObj(pathPtr, &prefixLen); + prefix = TclGetStringFromObj(pathPtr, &prefixLen); /* * The (normalized) path we're searching. */ - path = Tcl_GetString(normPathPtr); + path = TclGetString(normPathPtr); len = normPathPtr->length; Tcl_DStringInit(&dsPref); @@ -4368,7 +4363,7 @@ ZipFSPathInFilesystemProc( return -1; } - path = Tcl_GetString(pathPtr); + path = TclGetString(pathPtr); if (strncmp(path, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN) != 0) { return -1; } @@ -4493,7 +4488,7 @@ ZipFSFileAttrsGetProc( Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef) { - int len, ret = TCL_OK; + int ret = TCL_OK; char *path; ZipEntry *z; @@ -4501,7 +4496,7 @@ ZipFSFileAttrsGetProc( if (!pathPtr) { return -1; } - path = Tcl_GetStringFromObj(pathPtr, &len); + path = TclGetString(pathPtr); ReadLock(); z = ZipFSLookup(path); if (!z) { diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 34ea90c..ef5eab3 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -185,7 +185,7 @@ static int GenerateHeader(Tcl_Interp *interp, Tcl_Obj *dictObj, static int ZlibPushSubcmd(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static inline int ResultCopy(ZlibChannelData *cd, char *buf, - int toRead); + size_t toRead); static int ResultGenerate(ZlibChannelData *cd, int n, int flush, int *errorCodePtr); static Tcl_Channel ZlibStackChannelTransform(Tcl_Interp *interp, @@ -3391,7 +3391,7 @@ ZlibTransformGetOption( Tcl_DStringAppendElement(dsPtr, "-dictionary"); if (cd->compDictObj) { Tcl_DStringAppendElement(dsPtr, - Tcl_GetString(cd->compDictObj)); + TclGetString(cd->compDictObj)); } else { Tcl_DStringAppendElement(dsPtr, ""); } @@ -3417,7 +3417,7 @@ ZlibTransformGetOption( ExtractHeader(&cd->inHeader.header, tmpObj); if (optionName == NULL) { Tcl_DStringAppendElement(dsPtr, "-header"); - Tcl_DStringAppendElement(dsPtr, Tcl_GetString(tmpObj)); + Tcl_DStringAppendElement(dsPtr, TclGetString(tmpObj)); Tcl_DecrRefCount(tmpObj); } else { TclDStringAppendObj(dsPtr, tmpObj); @@ -3740,9 +3740,9 @@ static inline int ResultCopy( ZlibChannelData *cd, /* The location of the buffer to read from. */ char *buf, /* The buffer to copy into */ - int toRead) /* Number of requested bytes */ + size_t toRead) /* Number of requested bytes */ { - int have = Tcl_DStringLength(&cd->decompressed); + size_t have = Tcl_DStringLength(&cd->decompressed); if (have == 0) { /* @@ -4003,7 +4003,7 @@ int Tcl_ZlibStreamGet( Tcl_ZlibStream zshandle, Tcl_Obj *data, - int count) + size_t count) { return TCL_OK; } @@ -4041,7 +4041,7 @@ Tcl_ZlibInflate( unsigned int Tcl_ZlibCRC32( unsigned int crc, - const char *buf, + const unsigned char *buf, size_t len) { return 0; @@ -4050,7 +4050,7 @@ Tcl_ZlibCRC32( unsigned int Tcl_ZlibAdler32( unsigned int adler, - const char *buf, + const unsigned char *buf, size_t len) { return 0; diff --git a/unix/tclLoadDl.c b/unix/tclLoadDl.c index 88854da..8a801c9 100644 --- a/unix/tclLoadDl.c +++ b/unix/tclLoadDl.c @@ -106,7 +106,7 @@ TclpDlopen( */ Tcl_DString ds; - const char *fileName = Tcl_GetString(pathPtr); + const char *fileName = TclGetString(pathPtr); native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); /* @@ -127,7 +127,7 @@ TclpDlopen( if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't load file \"%s\": %s", - Tcl_GetString(pathPtr), errorStr)); + TclGetString(pathPtr), errorStr)); } return TCL_ERROR; } diff --git a/unix/tclLoadDyld.c b/unix/tclLoadDyld.c index d1701da..af24841 100644 --- a/unix/tclLoadDyld.c +++ b/unix/tclLoadDyld.c @@ -184,7 +184,7 @@ TclpDlopen( */ nativePath = Tcl_FSGetNativePath(pathPtr); - nativeFileName = Tcl_UtfToExternalDString(NULL, Tcl_GetString(pathPtr), + nativeFileName = Tcl_UtfToExternalDString(NULL, TclGetString(pathPtr), -1, &ds); #if TCL_DYLD_USE_DLFCN diff --git a/unix/tclLoadNext.c b/unix/tclLoadNext.c index 58657c8..393bfc5 100644 --- a/unix/tclLoadNext.c +++ b/unix/tclLoadNext.c @@ -61,7 +61,7 @@ TclpDlopen( NXStream *errorStream = NXOpenMemory(0,0,NX_READWRITE); - fileName = Tcl_GetString(pathPtr); + fileName = TclGetString(pathPtr); /* * First try the full path the user gave us. This is particularly diff --git a/unix/tclLoadOSF.c b/unix/tclLoadOSF.c index 6a06b3e..f67725f 100644 --- a/unix/tclLoadOSF.c +++ b/unix/tclLoadOSF.c @@ -79,7 +79,7 @@ TclpDlopen( Tcl_LoadHandle newHandle; ldr_module_t lm; char *pkg; - char *fileName = Tcl_GetString(pathPtr); + char *fileName = TclGetString(pathPtr); const char *native; /* diff --git a/unix/tclLoadShl.c b/unix/tclLoadShl.c index a849ac6..fc5f27c 100644 --- a/unix/tclLoadShl.c +++ b/unix/tclLoadShl.c @@ -57,7 +57,7 @@ TclpDlopen( shl_t handle; Tcl_LoadHandle newHandle; const char *native; - char *fileName = Tcl_GetString(pathPtr); + char *fileName = TclGetString(pathPtr); /* * The flags below used to be BIND_IMMEDIATE; they were changed at the diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c index 04bb28c..1dd2340 100644 --- a/unix/tclUnixChan.c +++ b/unix/tclUnixChan.c @@ -579,7 +579,7 @@ TtySetOptionProc( const char *value) /* New value for option. */ { FileState *fsPtr = instanceData; - unsigned int len, vlen; + size_t len, vlen; TtyAttrs tty; int argc; const char **argv; @@ -806,7 +806,7 @@ TtyGetOptionProc( Tcl_DString *dsPtr) /* Where to store value(s). */ { FileState *fsPtr = instanceData; - unsigned int len; + size_t len; char buf[3*TCL_INTEGER_SPACE + 16]; int valid = 0; /* Flag if valid option parsed. */ diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c index c42dfa7..0623648 100644 --- a/unix/tclUnixPipe.c +++ b/unix/tclUnixPipe.c @@ -524,7 +524,7 @@ TclpCreateProcess( errPipeOut = NULL; fd = GetFd(errPipeIn); - count = read(fd, errSpace, (size_t) (sizeof(errSpace) - 1)); + count = read(fd, errSpace, sizeof(errSpace) - 1); if (count > 0) { char *end; @@ -1274,7 +1274,7 @@ Tcl_PidObjCmd( * Get the channel and make sure that it refers to a pipe. */ - chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL); + chan = Tcl_GetChannel(interp, TclGetString(objv[1]), NULL); if (chan == NULL) { return TCL_ERROR; } diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index 23ef1ba..d53b3de 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -313,7 +313,8 @@ InitializeHostName( const char * Tcl_GetHostName(void) { - return Tcl_GetString(TclGetProcessGlobalValue(&hostName)); + Tcl_Obj *tclObj = TclGetProcessGlobalValue(&hostName); + return TclGetString(tclObj); } /* diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c index 164ed83..d281c22 100644 --- a/win/tclWinFCmd.c +++ b/win/tclWinFCmd.c @@ -911,8 +911,8 @@ TclpObjCopyDirectory( return TCL_ERROR; } - Tcl_WinUtfToTChar(Tcl_GetString(normSrcPtr), -1, &srcString); - Tcl_WinUtfToTChar(Tcl_GetString(normDestPtr), -1, &dstString); + Tcl_WinUtfToTChar(TclGetString(normSrcPtr), -1, &srcString); + Tcl_WinUtfToTChar(TclGetString(normDestPtr), -1, &dstString); ret = TraverseWinTree(TraversalCopy, &srcString, &dstString, &ds); @@ -984,7 +984,7 @@ TclpObjRemoveDirectory( if (normPtr == NULL) { return TCL_ERROR; } - Tcl_WinUtfToTChar(Tcl_GetString(normPtr), -1, &native); + Tcl_WinUtfToTChar(TclGetString(normPtr), -1, &native); ret = DoRemoveDirectory(&native, recursive, &ds); Tcl_DStringFree(&native); } else { @@ -1593,7 +1593,7 @@ ConvertFileNameFormat( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "could not read \"%s\": no such file or directory", - Tcl_GetString(fileName))); + TclGetString(fileName))); errno = ENOENT; Tcl_PosixError(interp); } @@ -1883,7 +1883,7 @@ CannotSetAttribute( { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "cannot set attribute \"%s\" for file \"%s\": attribute is readonly", - tclpFileAttrStrings[objIndex], Tcl_GetString(fileName))); + tclpFileAttrStrings[objIndex], TclGetString(fileName))); errno = EINVAL; Tcl_PosixError(interp); return TCL_ERROR; diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 9545381..7ff8b9b 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -973,8 +973,7 @@ TclpMatchInDirectory( */ Tcl_DStringInit(&dsOrig); - dirName = TclGetString(fileNamePtr); - dirLength = fileNamePtr->length; + dirName = TclGetStringFromObj(fileNamePtr, &dirLength); Tcl_DStringAppend(&dsOrig, dirName, dirLength); lastChar = dirName[dirLength -1]; @@ -2398,7 +2397,7 @@ TclpFilesystemPathType( if (normPath == NULL) { return NULL; } - path = Tcl_GetString(normPath); + path = TclGetString(normPath); if (path == NULL) { return NULL; } @@ -2476,7 +2475,7 @@ TclpObjNormalizePath( Tcl_DString ds; /* Some workspace. */ Tcl_DStringInit(&dsNorm); - path = Tcl_GetString(pathPtr); + path = TclGetString(pathPtr); currentPathEndPosition = path + nextCheckpoint; if (*currentPathEndPosition == '/') { @@ -2570,12 +2569,12 @@ TclpObjNormalizePath( * Convert link to forward slashes. */ - for (path = Tcl_GetString(to); *path != 0; path++) { + for (path = TclGetString(to); *path != 0; path++) { if (*path == '\\') { *path = '/'; } } - path = Tcl_GetString(to); + path = TclGetString(to); currentPathEndPosition = path + nextCheckpoint; if (temp != NULL) { Tcl_DecrRefCount(temp); @@ -2807,7 +2806,7 @@ TclWinVolumeRelativeNormalize( * current volume. */ - const char *drive = Tcl_GetString(useThisCwd); + const char *drive = TclGetString(useThisCwd); absolutePath = Tcl_NewStringObj(drive,2); Tcl_AppendToObj(absolutePath, path, -1); @@ -2822,8 +2821,8 @@ TclWinVolumeRelativeNormalize( * also on drive C. */ - const char *drive = TclGetString(useThisCwd); - size_t cwdLen = useThisCwd->length; + size_t cwdLen; + const char *drive = TclGetStringFromObj(useThisCwd, &cwdLen); char drive_cur = path[0]; if (drive_cur >= 'a') { @@ -2986,10 +2985,9 @@ TclNativeCreateNativeRep( Tcl_IncrRefCount(validPathPtr); } - str = Tcl_GetString(validPathPtr); - len = validPathPtr->length; + str = TclGetStringFromObj(validPathPtr, &len); - if (strlen(str)!=(unsigned int)len) { + if (strlen(str) != len) { /* String contains NUL-bytes. This is invalid. */ goto done; } diff --git a/win/tclWinInit.c b/win/tclWinInit.c index 11d182a..e7ecd72 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -223,8 +223,7 @@ TclpInitLibraryPath( TclGetProcessGlobalValue(&sourceLibraryDir)); *encodingPtr = NULL; - bytes = TclGetString(pathPtr); - *lengthPtr = pathPtr->length; + bytes = TclGetStringFromObj(pathPtr, lengthPtr); *valuePtr = Tcl_Alloc(*lengthPtr + 1); memcpy(*valuePtr, bytes, *lengthPtr + 1); Tcl_DecrRefCount(pathPtr); diff --git a/win/tclWinLoad.c b/win/tclWinLoad.c index 3d0b804..9d398d7 100644 --- a/win/tclWinLoad.c +++ b/win/tclWinLoad.c @@ -95,7 +95,7 @@ TclpDlopen( firstError = (nativeName == NULL) ? ERROR_MOD_NOT_FOUND : GetLastError(); - nativeName = Tcl_WinUtfToTChar(Tcl_GetString(pathPtr), -1, &ds); + nativeName = Tcl_WinUtfToTChar(TclGetString(pathPtr), -1, &ds); hInstance = LoadLibraryEx(nativeName, NULL, LOAD_WITH_ALTERED_SEARCH_PATH); Tcl_DStringFree(&ds); @@ -117,7 +117,7 @@ TclpDlopen( lastError = firstError; errMsg = Tcl_ObjPrintf("couldn't load library \"%s\": ", - Tcl_GetString(pathPtr)); + TclGetString(pathPtr)); /* * Check for possible DLL errors. This doesn't work quite right, diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index 4659021..bd97c6c 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -2217,7 +2217,7 @@ PipeOutputProc( infoPtr->writeBufLen = toWrite; infoPtr->writeBuf = Tcl_Alloc(toWrite); } - memcpy(infoPtr->writeBuf, buf, (size_t) toWrite); + memcpy(infoPtr->writeBuf, buf, toWrite); infoPtr->toWrite = toWrite; ResetEvent(infoPtr->writable); TclPipeThreadSignal(&infoPtr->writeTI); @@ -2672,7 +2672,7 @@ Tcl_PidObjCmd( if (objc == 1) { Tcl_SetObjResult(interp, Tcl_NewWideIntObj((unsigned) getpid())); } else { - chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), + chan = Tcl_GetChannel(interp, TclGetString(objv[1]), NULL); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; @@ -3123,9 +3123,10 @@ TclpOpenTemporaryFile( } namePtr += length * sizeof(TCHAR); if (basenameObj) { - const char *string = Tcl_GetString(basenameObj); + size_t length; + const char *string = TclGetStringFromObj(basenameObj, &length); - Tcl_WinUtfToTChar(string, basenameObj->length, &buf); + Tcl_WinUtfToTChar(string, length, &buf); memcpy(namePtr, Tcl_DStringValue(&buf), Tcl_DStringLength(&buf)); namePtr += Tcl_DStringLength(&buf); Tcl_DStringFree(&buf); -- cgit v0.12 From 211f04efe783ccaf8e903dffad758d37bdff6348 Mon Sep 17 00:00:00 2001 From: dgp Date: Sat, 23 Feb 2019 01:04:44 +0000 Subject: Adapt the gratuitous macro that doubles the burden of core development. --- generic/tclInt.h | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 5ba5b94..b0ec11b 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4392,9 +4392,9 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, *(lenPtr) = *((size_t *) (objPtr)->internalRep.twoPtrValue.ptr1), \ Tcl_GetUnicodeFromObj(objPtr, NULL)) #define TclGetByteArrayFromObj(objPtr, lenPtr) \ - (Tcl_GetByteArrayFromObj(objPtr, NULL), \ - *(lenPtr) = *((size_t *) (objPtr)->internalRep.twoPtrValue.ptr1), \ - (unsigned char *)(((size_t *) (objPtr)->internalRep.twoPtrValue.ptr1) + 2)) + (Tcl_GetByteArrayFromObj(objPtr, NULL) ? \ + (*(lenPtr) = *((size_t *) (objPtr)->internalRep.twoPtrValue.ptr1), \ + (unsigned char *)(((size_t *) (objPtr)->internalRep.twoPtrValue.ptr1) + 2)) : (*(lenPtr) = 0, NULL)) #endif /* -- cgit v0.12 From d43f6b9af5bfe8a22cfe5b922efc480e05f1fd47 Mon Sep 17 00:00:00 2001 From: dgp Date: Sat, 23 Feb 2019 01:21:15 +0000 Subject: Revise crashing test now that [binary encode] rejects bogus inputs. --- tests/binary.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/binary.test b/tests/binary.test index aede659..b756717 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -2916,7 +2916,7 @@ test binary-78.1 {unicode (out of BMP) to byte-array conversion, bug-[bd94500678 binary encode hex \U0001f415 binary scan \U0001f415 a* v; set v set str {} -} -result {} +} -result * -match glob -returnCodes error # ---------------------------------------------------------------------- # cleanup -- cgit v0.12 From 810b6c7f3298a148dbfdd9e789e39cc338ea4525 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 19 Aug 2019 15:01:09 +0000 Subject: Further implementation of 2 new functions. --- generic/tcl.decls | 4 +-- generic/tcl.h | 21 ++++++++---- generic/tclDecls.h | 10 ------ generic/tclStubFindExecutable.c | 71 ++++++++++++++++++++++++++++++++++++++ generic/tclStubInitSubsystems.c | 70 +++++++++++++++++++++++++++++++++++++ generic/tclStubLibDl.c | 73 --------------------------------------- generic/tclStubSetPanicProc.c | 76 +++++++++++++++++++++++++++++++++++++++++ unix/Makefile.in | 18 +++++++--- unix/tclAppInit.c | 4 +-- win/Makefile.in | 16 ++++++--- win/makefile.vc | 12 +++++-- win/tcl.dsp | 26 +++++++++----- win/tclAppInit.c | 2 +- 13 files changed, 289 insertions(+), 114 deletions(-) create mode 100644 generic/tclStubFindExecutable.c create mode 100644 generic/tclStubInitSubsystems.c delete mode 100644 generic/tclStubLibDl.c create mode 100644 generic/tclStubSetPanicProc.c diff --git a/generic/tcl.decls b/generic/tcl.decls index 815183e..ec697f2 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -532,7 +532,7 @@ declare 143 { } # Removed in 9.0 (stub entry only) #declare 144 { -# void Tcl_FindExecutable(const char *argv0) +# const char *Tcl_FindExecutable(const char *argv0) #} declare 145 { Tcl_HashEntry *Tcl_FirstHashEntry(Tcl_HashTable *tablePtr, @@ -2502,7 +2502,7 @@ export { Tcl_ExitProc *Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc) } export { - void Tcl_FindExecutable(const char *argv0) + const char *Tcl_FindExecutable(const char *argv0) } export { const char *Tcl_InitStubs(Tcl_Interp *interp, const char *version, diff --git a/generic/tcl.h b/generic/tcl.h index 6a9e818..0ace839 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2225,21 +2225,16 @@ const char * TclInitStubTable(const char *version); */ #define Tcl_Main(argc, argv, proc) Tcl_MainEx(argc, argv, proc, \ - ((Tcl_SetPanicProc(Tcl_ConsolePanic), Tcl_CreateInterp)())) + ((Tcl_SetPanicProc(Tcl_ConsolePanic), Tcl_CreateInterp()))) EXTERN TCL_NORETURN void Tcl_MainEx(int argc, char **argv, Tcl_AppInitProc *appInitProc, Tcl_Interp *interp); EXTERN const char * Tcl_PkgInitStubsCheck(Tcl_Interp *interp, const char *version, int exact); EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); EXTERN const char * Tcl_FindExecutable(const char *argv0); +EXTERN const char * Tcl_InitSubsystems(void); EXTERN const char * Tcl_SetPanicProc( TCL_NORETURN1 Tcl_PanicProc *panicProc); -#ifdef USE_TCL_STUBS -#define Tcl_SetPanicProc(panicProc) \ - TclInitStubTable((Tcl_SetPanicProc)(panicProc)) -#define Tcl_FindExecutable(argv0) \ - TclInitStubTable((Tcl_FindExecutable)((const char *)argv0)) -#endif EXTERN void Tcl_StaticPackage(Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, @@ -2248,6 +2243,18 @@ EXTERN Tcl_ExitProc *Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc); #ifndef _WIN32 EXTERN int TclZipfs_AppHook(int *argc, char ***argv); #endif +extern const char *TclStubFindExecutable(const char *argv0); +extern const char *TclStubInitSubsystems(void); +extern const char *TclStubSetPanicProc( + TCL_NORETURN1 Tcl_PanicProc *panicProc); +#ifdef USE_TCL_STUBS +#define Tcl_FindExecutable(argv0) \ + TclInitStubTable((TclStubFindExecutable)((const char *)argv0)) +#define Tcl_InitSubsystems() \ + TclInitStubTable((TclStubInitSubsystems)()) +#define Tcl_SetPanicProc(panicProc) \ + TclInitStubTable((TclStubSetPanicProc)(panicProc)) +#endif /* *---------------------------------------------------------------------------- diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 71aa8b8..e28d724 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -3711,16 +3711,6 @@ extern const TclStubs *tclStubsPtr; /* !END!: Do not edit above this line. */ -#if defined(USE_TCL_STUBS) -# undef Tcl_CreateInterp -# undef Tcl_Init -# undef Tcl_ObjSetVar2 -# define Tcl_CreateInterp() (tclStubsPtr->tcl_CreateInterp()) -# define Tcl_Init(interp) (tclStubsPtr->tcl_Init(interp)) -# define Tcl_ObjSetVar2(interp, part1, part2, newValue, flags) \ - (tclStubsPtr->tcl_ObjSetVar2(interp, part1, part2, newValue, flags)) -#endif - #if defined(_WIN32) && defined(UNICODE) #ifndef USE_TCL_STUBS # define Tcl_FindExecutable(arg) ((Tcl_FindExecutable)((const char *)(arg))) diff --git a/generic/tclStubFindExecutable.c b/generic/tclStubFindExecutable.c new file mode 100644 index 0000000..17ee576 --- /dev/null +++ b/generic/tclStubFindExecutable.c @@ -0,0 +1,71 @@ +/* + * 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 *)LoadLibrary(TEXT(a)) +# define dlsym(a,b) (void *)GetProcAddress((HANDLE)(a),b) +# define dlerror() "" +#endif + +/* + *---------------------------------------------------------------------- + * + * Tcl_FindExecutable -- + * + * Load the Tcl core dynamically, version "9.0" (or higher, in future versions) + * + * Results: + * Outputs the value of the "version" argument. + * + * Side effects: + * Sets the stub table pointers. + * + *---------------------------------------------------------------------- + */ + +static const char PROCNAME[] = "_Tcl_FindExecutable"; + +MODULE_SCOPE const char * +TclStubFindExecutable( + const char *argv0) +{ + static const char *(*findExecutable)(const char *argv0) = NULL; + static const char *version = NULL; + + if (!findExecutable) { + void *handle = dlopen(TCL_DLL_FILE, RTLD_NOW|RTLD_LOCAL); + if (!handle) { + fprintf(stderr, "Cannot find " TCL_DLL_FILE ": %s\n", dlerror()); + abort(); + } + findExecutable = dlsym(handle, PROCNAME + 1); + if (!findExecutable) { + findExecutable = dlsym(handle, PROCNAME); + } + if (findExecutable) { + version = findExecutable(argv0); + } + } + return version; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclStubInitSubsystems.c b/generic/tclStubInitSubsystems.c new file mode 100644 index 0000000..e683adf --- /dev/null +++ b/generic/tclStubInitSubsystems.c @@ -0,0 +1,70 @@ +/* + * 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 *)LoadLibrary(TEXT(a)) +# define dlsym(a,b) (void *)GetProcAddress((HANDLE)(a),b) +# define dlerror() "" +#endif + +/* + *---------------------------------------------------------------------- + * + * Tcl_InitSubsystems -- + * + * Load the Tcl core dynamically, version "9.0" (or higher, in future versions) + * + * Results: + * Outputs the value of the "version" argument. + * + * Side effects: + * Sets the stub table pointers. + * + *---------------------------------------------------------------------- + */ + +static const char PROCNAME[] = "_Tcl_InitSubsystems"; + +MODULE_SCOPE const char * +TclStubInitSubsystems(void) +{ + static const char *(*initSubsystems)(void) = NULL; + static const char *version = NULL; + + if (!initSubsystems) { + void *handle = dlopen(TCL_DLL_FILE, RTLD_NOW|RTLD_LOCAL); + if (!handle) { + fprintf(stderr, "Cannot find " TCL_DLL_FILE ": %s\n", dlerror()); + abort(); + } + initSubsystems = dlsym(handle, PROCNAME + 1); + if (!initSubsystems) { + initSubsystems = dlsym(handle, PROCNAME); + } + if (initSubsystems) { + version = initSubsystems(); + } + } + return version; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclStubLibDl.c b/generic/tclStubLibDl.c deleted file mode 100644 index 67d9e7d..0000000 --- a/generic/tclStubLibDl.c +++ /dev/null @@ -1,73 +0,0 @@ -/* - * 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 *)LoadLibrary(TEXT(a)) -# define dlsym(a,b) (void *)GetProcAddress((HANDLE)(a),b) -#endif - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetPanicProc -- - * - * Load the Tcl core dynamically, version "9.0" (or higher, in future versions) - * - * Results: - * Outputs the value of the "version" argument. - * - * Side effects: - * Sets the stub table pointers. - * - *---------------------------------------------------------------------- - */ - -MODULE_SCOPE const char * -Tcl_SetPanicProc( - TCL_NORETURN1 Tcl_PanicProc *panicProc) -{ - static const char *(*setPanicProc)(TCL_NORETURN1 Tcl_PanicProc *) = NULL; - static const char *version = NULL; - - if (!setPanicProc) { - void *handle = dlopen(TCL_DLL_FILE, RTLD_NOW|RTLD_LOCAL); - if (!handle) { - if (panicProc) { - panicProc("Cannot find " TCL_DLL_FILE); - } else { - fprintf(stderr, "Cannot find " TCL_DLL_FILE); - abort(); - } - return NULL; - } - setPanicProc = dlsym(handle, "Tcl_SetPanicProc"); - if (!setPanicProc) { - setPanicProc = dlsym(handle, "_Tcl_SetPanicProc"); - } - if (setPanicProc) { - version = setPanicProc(panicProc); - } - } - return version; -} - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ diff --git a/generic/tclStubSetPanicProc.c b/generic/tclStubSetPanicProc.c new file mode 100644 index 0000000..8742370 --- /dev/null +++ b/generic/tclStubSetPanicProc.c @@ -0,0 +1,76 @@ +/* + * 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 *)LoadLibrary(TEXT(a)) +# define dlsym(a,b) (void *)GetProcAddress((HANDLE)(a),b) +# define dlerror() "" +#endif + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetPanicProc -- + * + * Load the Tcl core dynamically, version "9.0" (or higher, in future versions) + * + * Results: + * Outputs the value of the "version" argument. + * + * Side effects: + * Sets the stub table pointers. + * + *---------------------------------------------------------------------- + */ + +static const char PROCNAME[] = "_Tcl_SetPanicProc"; + +MODULE_SCOPE const char * +TclStubSetPanicProc( + TCL_NORETURN1 Tcl_PanicProc *panicProc) +{ + static const char *(*setPanicProc)(TCL_NORETURN1 Tcl_PanicProc *) = NULL; + static const char *version = NULL; + + if (!setPanicProc) { + void *handle = dlopen(TCL_DLL_FILE, RTLD_NOW|RTLD_LOCAL); + if (!handle) { + if (panicProc) { + panicProc("Cannot find " TCL_DLL_FILE ": %s\n", dlerror()); + } else { + fprintf(stderr, "Cannot find " TCL_DLL_FILE ": %s\n", dlerror()); + abort(); + } + return NULL; + } + setPanicProc = dlsym(handle, PROCNAME + 1); + if (!setPanicProc) { + setPanicProc = dlsym(handle, PROCNAME); + } + if (setPanicProc) { + version = setPanicProc(panicProc); + } + } + return version; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/unix/Makefile.in b/unix/Makefile.in index 3b24caf..5767db1 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -345,7 +345,9 @@ TOMMATH_OBJS = bn_reverse.o bn_fast_s_mp_mul_digs.o \ bn_s_mp_mul_digs.o bn_s_mp_sqr.o bn_s_mp_sub.o STUB_LIB_OBJS = tclStubLib.o \ - tclStubLibDl.o \ + tclStubFindExecutable.o \ + tclStubInitSubsystems.o \ + tclStubSetPanicProc.o \ tclStubLibTbl.o \ tclTomMathStubLib.o \ tclOOStubLib.o \ @@ -489,7 +491,9 @@ OO_SRCS = \ STUB_SRCS = \ $(GENERIC_DIR)/tclStubLib.c \ - $(GENERIC_DIR)/tclStubLibDl.c \ + $(GENERIC_DIR)/tclStubFindExecutable.c \ + $(GENERIC_DIR)/tclStubInitSubsystems.c \ + $(GENERIC_DIR)/tclStubSetPanicProc.c \ $(GENERIC_DIR)/tclStubLibTbl.c \ $(GENERIC_DIR)/tclTomMathStubLib.c \ $(GENERIC_DIR)/tclOOStubLib.c @@ -1825,8 +1829,14 @@ Zzutil.o: $(ZLIB_DIR)/zutil.c tclStubLib.o: $(GENERIC_DIR)/tclStubLib.c $(CC) -c $(STUB_CC_SWITCHES) -DSTATIC_BUILD $(GENERIC_DIR)/tclStubLib.c -tclStubLibDl.o: $(GENERIC_DIR)/tclStubLibDl.c - $(CC) -c $(STUB_CC_SWITCHES) -DSTATIC_BUILD -DTCL_DLL_FILE="\"$(TCL_LIB_FILE)\"" $(GENERIC_DIR)/tclStubLibDl.c +tclStubFindExecutable.o: $(GENERIC_DIR)/tclStubFindExecutable.c + $(CC) -c $(STUB_CC_SWITCHES) -DSTATIC_BUILD -DTCL_DLL_FILE="\"$(TCL_LIB_FILE)\"" $(GENERIC_DIR)/tclStubFindExecutable.c + +tclStubInitSubsystems.o: $(GENERIC_DIR)/tclStubInitSubsystems.c + $(CC) -c $(STUB_CC_SWITCHES) -DSTATIC_BUILD -DTCL_DLL_FILE="\"$(TCL_LIB_FILE)\"" $(GENERIC_DIR)/tclStubInitSubsystems.c + +tclStubSetPanicProc.o: $(GENERIC_DIR)/tclStubSetPanicProc.c + $(CC) -c $(STUB_CC_SWITCHES) -DSTATIC_BUILD -DTCL_DLL_FILE="\"$(TCL_LIB_FILE)\"" $(GENERIC_DIR)/tclStubSetPanicProc.c tclStubLibTbl.o: $(GENERIC_DIR)/tclStubLibTbl.c $(CC) -c $(STUB_CC_SWITCHES) -DSTATIC_BUILD $(GENERIC_DIR)/tclStubLibTbl.c diff --git a/unix/tclAppInit.c b/unix/tclAppInit.c index 3587f35..b791440 100644 --- a/unix/tclAppInit.c +++ b/unix/tclAppInit.c @@ -152,10 +152,10 @@ Tcl_AppInit( */ #ifdef DJGPP - (Tcl_ObjSetVar2)(interp, Tcl_NewStringObj("tcl_rcFileName", -1), NULL, + Tcl_ObjSetVar2(interp, Tcl_NewStringObj("tcl_rcFileName", -1), NULL, Tcl_NewStringObj("~/tclsh.rc", -1), TCL_GLOBAL_ONLY); #else - (Tcl_ObjSetVar2)(interp, Tcl_NewStringObj("tcl_rcFileName", -1), NULL, + Tcl_ObjSetVar2(interp, Tcl_NewStringObj("tcl_rcFileName", -1), NULL, Tcl_NewStringObj("~/.tclshrc", -1), TCL_GLOBAL_ONLY); #endif diff --git a/win/Makefile.in b/win/Makefile.in index 8bc34d5..13100af 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -455,7 +455,9 @@ REG_OBJS = tclWinReg.$(OBJEXT) STUB_OBJS = \ tclStubLib.$(OBJEXT) \ - tclStubLibDl.$(OBJEXT) \ + tclStubFindExecutable.$(OBJEXT) \ + tclStubInitSubsystems.$(OBJEXT) \ + tclStubSetPanicProc.$(OBJEXT) \ tclStubLibTbl.$(OBJEXT) \ tclTomMathStubLib.$(OBJEXT) \ tclOOStubLib.$(OBJEXT) \ @@ -622,8 +624,8 @@ tclWinInit.${OBJEXT}: tclWinInit.c tclWinPipe.${OBJEXT}: tclWinPipe.c $(CC) -c $(CC_SWITCHES) -DBUILD_tcl $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME) -testMain.${OBJEXT}: tclAppInit.c - $(CC) -c $(CC_SWITCHES) -DTCL_TEST @DEPARG@ $(CC_OBJNAME) +tclAppInit.${OBJEXT}: tclAppInit.c + $(CC) -c $(CC_SWITCHES) -DBUILD_tcl @DEPARG@ $(CC_OBJNAME) tclMain2.${OBJEXT}: tclMain.c $(CC) -c $(CC_SWITCHES) -DBUILD_tcl -DTCL_ASCII_MAIN @DEPARG@ $(CC_OBJNAME) @@ -671,7 +673,13 @@ tclPkgConfig.${OBJEXT}: tclPkgConfig.c tclStubLib.${OBJEXT}: tclStubLib.c $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @DEPARG@ $(CC_OBJNAME) -tclStubLibDl.${OBJEXT}: tclStubLibDl.c +tclStubFindExecutable.${OBJEXT}: tclStubFindExecutable.c + $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD -DTCL_DLL_FILE="\"$(TCL_DLL_FILE)\"" @DEPARG@ $(CC_OBJNAME) + +tclStubInitSubsystems.${OBJEXT}: tclStubInitSubsystems.c + $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD -DTCL_DLL_FILE="\"$(TCL_DLL_FILE)\"" @DEPARG@ $(CC_OBJNAME) + +tclStubSetPanicProc.${OBJEXT}: tclStubSetPanicProc.c $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD -DTCL_DLL_FILE="\"$(TCL_DLL_FILE)\"" @DEPARG@ $(CC_OBJNAME) tclStubLibTbl.${OBJEXT}: tclStubLibTbl.c diff --git a/win/makefile.vc b/win/makefile.vc index aafd9fb..ea15b0d 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -413,7 +413,9 @@ TCLOBJS = $(COREOBJS) $(ZLIBOBJS) $(TOMMATHOBJS) $(PLATFORMOBJS) TCLSTUBOBJS = \ $(TMP_DIR)\tclStubLib.obj \ - $(TMP_DIR)\tclStubLibDl.obj \ + $(TMP_DIR)\tclStubFindExecutable.obj \ + $(TMP_DIR)\tclStubInitSubsystems.obj \ + $(TMP_DIR)\tclStubSetPanicProc.obj \ $(TMP_DIR)\tclStubLibTbl.obj \ $(TMP_DIR)\tclTomMathStubLib.obj \ $(TMP_DIR)\tclOOStubLib.obj \ @@ -802,7 +804,13 @@ $(TMP_DIR)\tclWinDde.obj: $(WINDIR)\tclWinDde.c $(TMP_DIR)\tclStubLib.obj: $(GENERICDIR)\tclStubLib.c $(cc32) $(stubscflags) -Fo$@ $? -$(TMP_DIR)\tclStubLibDl.obj: $(GENERICDIR)\tclStubLibDl.c +$(TMP_DIR)\tclStubFindExecutable.obj: $(GENERICDIR)\tclStubFindExecutable.c + $(cc32) $(STUB_CFLAGS) -Zl -DSTATIC_BUILD -DTCL_DLL_FILE="\"tcl86.dll\"" $(TCL_INCLUDES) -Fo$@ $? + +$(TMP_DIR)\tclStubInitSubsystems.obj: $(GENERICDIR)\tclStubInitSubsystems.c + $(cc32) $(STUB_CFLAGS) -Zl -DSTATIC_BUILD -DTCL_DLL_FILE="\"tcl86.dll\"" $(TCL_INCLUDES) -Fo$@ $? + +$(TMP_DIR)\tclStubSetPanicProc.obj: $(GENERICDIR)\tclStubSetPanicProc.c $(cc32) $(STUB_CFLAGS) -Zl -DSTATIC_BUILD -DTCL_DLL_FILE="\"tcl86.dll\"" $(TCL_INCLUDES) -Fo$@ $? $(TMP_DIR)\tclStubLibTbl.obj: $(GENERICDIR)\tclStubLibTbl.c diff --git a/win/tcl.dsp b/win/tcl.dsp index a8e71d2..68a1612 100644 --- a/win/tcl.dsp +++ b/win/tcl.dsp @@ -7,21 +7,21 @@ CFG=tcl - Win32 Debug Static !MESSAGE This is not a valid makefile. To build this project using NMAKE, !MESSAGE use the Export Makefile command and run -!MESSAGE +!MESSAGE !MESSAGE NMAKE /f "tcl.mak". -!MESSAGE +!MESSAGE !MESSAGE You can specify a configuration when running NMAKE !MESSAGE by defining the macro CFG on the command line. For example: -!MESSAGE +!MESSAGE !MESSAGE NMAKE /f "tcl.mak" CFG="tcl - Win32 Debug Static" -!MESSAGE +!MESSAGE !MESSAGE Possible choices for configuration are: -!MESSAGE +!MESSAGE !MESSAGE "tcl - Win32 Release" (based on "Win32 (x86) External Target") !MESSAGE "tcl - Win32 Debug" (based on "Win32 (x86) External Target") !MESSAGE "tcl - Win32 Debug Static" (based on "Win32 (x86) External Target") !MESSAGE "tcl - Win32 Release Static" (based on "Win32 (x86) External Target") -!MESSAGE +!MESSAGE # Begin Project # PROP AllowPerConfigDependencies 0 @@ -112,7 +112,7 @@ CFG=tcl - Win32 Debug Static # PROP Bsc_Name "" # PROP Target_Dir "" -!ENDIF +!ENDIF # Begin Target @@ -129,7 +129,7 @@ CFG=tcl - Win32 Debug Static !ELSEIF "$(CFG)" == "tcl - Win32 Release Static" -!ENDIF +!ENDIF # Begin Group "compat" @@ -1288,7 +1288,15 @@ SOURCE=..\generic\tclStubLib.c # End Source File # Begin Source File -SOURCE=..\generic\tclStubLibDl.c +SOURCE=..\generic\tclStubFindExecutable.c +# End Source File +# Begin Source File + +SOURCE=..\generic\tclStubInitSubsystems.c +# End Source File +# Begin Source File + +SOURCE=..\generic\tclStubSetPanicProc.c # End Source File # Begin Source File diff --git a/win/tclAppInit.c b/win/tclAppInit.c index 3292335..5820723 100644 --- a/win/tclAppInit.c +++ b/win/tclAppInit.c @@ -205,7 +205,7 @@ Tcl_AppInit( * user-specific startup file will be run under any conditions. */ - (Tcl_ObjSetVar2)(interp, Tcl_NewStringObj("tcl_rcFileName", -1), NULL, + Tcl_ObjSetVar2(interp, Tcl_NewStringObj("tcl_rcFileName", -1), NULL, Tcl_NewStringObj("~/tclshrc.tcl", -1), TCL_GLOBAL_ONLY); return TCL_OK; } -- cgit v0.12 From 594b14d3e3b65d3dea5188a3af6b7a2bfcbeda19 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 1 Oct 2019 14:57:09 +0000 Subject: Fix handling of BUILD_STATIC --- generic/tcl.h | 2 +- unix/Makefile.in | 2 +- win/Makefile.in | 2 +- win/tclAppInit.c | 1 - 4 files changed, 3 insertions(+), 4 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 9598870..5af0a3d 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2260,7 +2260,7 @@ extern const char *TclStubCall(int flags, void *arg1, void *arg2); EXTERN TCL_NORETURN void Tcl_MainExW(int argc, wchar_t **argv, Tcl_AppInitProc *appInitProc, Tcl_Interp *interp); #endif -#ifdef USE_TCL_STUBS +#if defined(USE_TCL_STUBS) && !defined(STATIC_BUILD) #define Tcl_InitSubsystems() \ TclInitStubTable(TclStubCall(0, NULL, NULL)) #define Tcl_FindExecutable(argv0) \ diff --git a/unix/Makefile.in b/unix/Makefile.in index 2fe0bd6..1b74aeb 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -1100,7 +1100,7 @@ tclTestInit.o: $(UNIX_DIR)/tclAppInit.c ${TCL_EXE} fi $(CC) -c $(APP_CC_SWITCHES) \ -DTCL_BUILDTIME_LIBRARY="\"${TCL_BUILDTIME_LIBRARY}\"" \ - -DTCL_TEST $(UNIX_DIR)/tclAppInit.c + -DTCL_TEST -DUSE_TCL_STUBS $(UNIX_DIR)/tclAppInit.c @rm -f tclTestInit.o mv tclAppInit.o tclTestInit.o @if test -f tclAppInit.sav ; then \ diff --git a/win/Makefile.in b/win/Makefile.in index 08f9e6a..f6bb954 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -625,7 +625,7 @@ ${ZLIB_DLL_FILE}: ${TCL_STUB_LIB_FILE} # Special case object targets tclTestMain.${OBJEXT}: tclAppInit.c - $(CC) -c $(CC_SWITCHES) -DTCL_TEST -DUNICODE -D_UNICODE $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME) + $(CC) -c $(CC_SWITCHES) -DTCL_TEST -DUNICODE -D_UNICODE -DUSE_TCL_STUBS $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME) tclWinInit.${OBJEXT}: tclWinInit.c $(CC) -c $(CC_SWITCHES) -DBUILD_tcl $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME) diff --git a/win/tclAppInit.c b/win/tclAppInit.c index 6ba57de..5820723 100644 --- a/win/tclAppInit.c +++ b/win/tclAppInit.c @@ -14,7 +14,6 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#define USE_TCL_STUBS #include "tcl.h" #define WIN32_LEAN_AND_MEAN #define STRICT /* See MSDN Article Q83456 */ -- cgit v0.12 From 995453e1a0afa8b6b073e157677ffe6d89b3de6f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 1 Oct 2019 15:04:38 +0000 Subject: further fix handling -DBUILD_STATIC --- generic/tclStubLibTbl.c | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/generic/tclStubLibTbl.c b/generic/tclStubLibTbl.c index 37b6856..cc1bb89 100644 --- a/generic/tclStubLibTbl.c +++ b/generic/tclStubLibTbl.c @@ -35,6 +35,12 @@ TclInitStubTable( structure variable. */ { if (version) { + if (tclStubsHandle == NULL) { + /* This can only happen with -DBUILD_STATIC, so simulate + * that the loading of Tcl succeeded, although we didn't + * actually loaded it dynamically */ + tclStubsHandle = (void *)1; + } tclStubsPtr = ((const TclStubs **) version)[-1]; if (tclStubsPtr->hooks) { -- cgit v0.12 From 188942001c88da55dd9a9bc5868470d8273b985b Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 9 Mar 2020 16:39:03 +0000 Subject: Record some ideas in the comments. --- generic/tclBinary.c | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 828a373..9984139 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -434,6 +434,8 @@ Tcl_GetByteArrayFromObj( if (irPtr == NULL) { if (TCL_ERROR == SetByteArrayFromAny(NULL, objPtr)) { + + /* TODO: Reconsider claiming a length for failed conversion. */ if (lengthPtr != NULL) { *lengthPtr = 0; } @@ -488,6 +490,8 @@ Tcl_SetByteArrayLength( if (length == 0) { Tcl_SetByteArrayObj(objPtr, NULL, 0); } else if (TCL_ERROR == SetByteArrayFromAny(NULL, objPtr)) { + + /* TODO: Consider a length limit on conversion attempt. */ return NULL; } irPtr = TclFetchIntRep(objPtr, &properByteArrayType); @@ -511,6 +515,8 @@ Tcl_SetByteArrayLength( * * Generate the ByteArray internal rep from the string rep. * + * TODO: Consider length limit on conversion. + * * Results: * The return value is always TCL_OK. * @@ -580,6 +586,7 @@ SetByteArrayFromAny( Tcl_ObjIntRep ir; (void)dummy; + /* TODO: Consider imposing this check on callers. */ if (TclHasIntRep(objPtr, &properByteArrayType)) { return TCL_OK; } -- cgit v0.12 From 04cd73a528530bb02e4b94162006f34751cbdd13 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 10 Mar 2020 15:58:27 +0000 Subject: re-generate configure scripts --- unix/configure | 14 +------------- win/configure | 14 +------------- 2 files changed, 2 insertions(+), 26 deletions(-) diff --git a/unix/configure b/unix/configure index c81cef3..8fa6e42 100755 --- a/unix/configure +++ b/unix/configure @@ -744,7 +744,6 @@ infodir docdir oldincludedir includedir -runstatedir localstatedir sharedstatedir sysconfdir @@ -834,7 +833,6 @@ datadir='${datarootdir}' sysconfdir='${prefix}/etc' sharedstatedir='${prefix}/com' localstatedir='${prefix}/var' -runstatedir='${localstatedir}/run' includedir='${prefix}/include' oldincludedir='/usr/include' docdir='${datarootdir}/doc/${PACKAGE_TARNAME}' @@ -1087,15 +1085,6 @@ do | -silent | --silent | --silen | --sile | --sil) silent=yes ;; - -runstatedir | --runstatedir | --runstatedi | --runstated \ - | --runstate | --runstat | --runsta | --runst | --runs \ - | --run | --ru | --r) - ac_prev=runstatedir ;; - -runstatedir=* | --runstatedir=* | --runstatedi=* | --runstated=* \ - | --runstate=* | --runstat=* | --runsta=* | --runst=* | --runs=* \ - | --run=* | --ru=* | --r=*) - runstatedir=$ac_optarg ;; - -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) ac_prev=sbindir ;; -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ @@ -1233,7 +1222,7 @@ fi for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ datadir sysconfdir sharedstatedir localstatedir includedir \ oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ - libdir localedir mandir runstatedir + libdir localedir mandir do eval ac_val=\$$ac_var # Remove trailing slashes. @@ -1386,7 +1375,6 @@ Fine tuning of the installation directories: --sysconfdir=DIR read-only single-machine data [PREFIX/etc] --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] --localstatedir=DIR modifiable single-machine data [PREFIX/var] - --runstatedir=DIR modifiable per-process data [LOCALSTATEDIR/run] --libdir=DIR object code libraries [EPREFIX/lib] --includedir=DIR C header files [PREFIX/include] --oldincludedir=DIR C header files for non-gcc [/usr/include] diff --git a/win/configure b/win/configure index 00ec899..6ceae65 100755 --- a/win/configure +++ b/win/configure @@ -756,7 +756,6 @@ infodir docdir oldincludedir includedir -runstatedir localstatedir sharedstatedir sysconfdir @@ -834,7 +833,6 @@ datadir='${datarootdir}' sysconfdir='${prefix}/etc' sharedstatedir='${prefix}/com' localstatedir='${prefix}/var' -runstatedir='${localstatedir}/run' includedir='${prefix}/include' oldincludedir='/usr/include' docdir='${datarootdir}/doc/${PACKAGE}' @@ -1087,15 +1085,6 @@ do | -silent | --silent | --silen | --sile | --sil) silent=yes ;; - -runstatedir | --runstatedir | --runstatedi | --runstated \ - | --runstate | --runstat | --runsta | --runst | --runs \ - | --run | --ru | --r) - ac_prev=runstatedir ;; - -runstatedir=* | --runstatedir=* | --runstatedi=* | --runstated=* \ - | --runstate=* | --runstat=* | --runsta=* | --runst=* | --runs=* \ - | --run=* | --ru=* | --r=*) - runstatedir=$ac_optarg ;; - -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) ac_prev=sbindir ;; -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ @@ -1233,7 +1222,7 @@ fi for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ datadir sysconfdir sharedstatedir localstatedir includedir \ oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ - libdir localedir mandir runstatedir + libdir localedir mandir do eval ac_val=\$$ac_var # Remove trailing slashes. @@ -1386,7 +1375,6 @@ Fine tuning of the installation directories: --sysconfdir=DIR read-only single-machine data [PREFIX/etc] --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] --localstatedir=DIR modifiable single-machine data [PREFIX/var] - --runstatedir=DIR modifiable per-process data [LOCALSTATEDIR/run] --libdir=DIR object code libraries [EPREFIX/lib] --includedir=DIR C header files [PREFIX/include] --oldincludedir=DIR C header files for non-gcc [/usr/include] -- cgit v0.12 From 6cced94fed2226a3d61858a780f2c6fe07070fc6 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 13 Mar 2020 15:11:29 +0000 Subject: Fix mistaken merge. --- generic/tclBinary.c | 2 -- generic/tclTest.c | 5 ++++- tests/binary.test | 4 ++-- 3 files changed, 6 insertions(+), 5 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index c1e5fba..5d1ce03 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -512,7 +512,6 @@ Tcl_SetByteArrayLength( SET_BYTEARRAY(irPtr, byteArrayPtr); } TclInvalidateStringRep(objPtr); - objPtr->typePtr = &properByteArrayType; byteArrayPtr->used = length; return byteArrayPtr->bytes; } @@ -827,7 +826,6 @@ TclAppendBytesToByteArray( } byteArrayPtr->used += len; TclInvalidateStringRep(objPtr); - objPtr->typePtr = &properByteArrayType; } /* diff --git a/generic/tclTest.c b/generic/tclTest.c index 211e654..94c130f 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -5047,7 +5047,10 @@ TestsetbytearraylengthObjCmd( } else { obj = objv[1]; } - Tcl_SetByteArrayLength(obj, n); + if (NULL == Tcl_SetByteArrayLength(obj, n)) { + Tcl_SetResult(interp, "expected bytes", TCL_STATIC); + return TCL_ERROR; + } Tcl_SetObjResult(interp, obj); return TCL_OK; } diff --git a/tests/binary.test b/tests/binary.test index 4e0944b..e7d5114 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -2925,9 +2925,9 @@ testConstraint testsetbytearraylength \ test binary-79.1 {Tcl_SetByteArrayLength} testsetbytearraylength { testsetbytearraylength [string cat A B C] 1 } A -test binary-79.2 {Tcl_SetByteArrayLength} testsetbytearraylength { +test binary-79.2 {Tcl_SetByteArrayLength} -body { testsetbytearraylength [string cat \u0141 B C] 1 -} A +} -constraints testsetbytearraylength -returnCodes error -match glob -result * # ---------------------------------------------------------------------- -- cgit v0.12 From e8904ca052835753145f2421336a01ce4ef30c70 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 20 Mar 2020 20:23:00 +0000 Subject: Rework TIP 568 implementation for improved standard error message/code --- generic/tclBinary.c | 141 +++++++++++++++++++++++++++++++--------------------- generic/tclCmdAH.c | 3 +- generic/tclInt.h | 2 +- 3 files changed, 86 insertions(+), 60 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 00b5e4e..b4f9b22 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -434,23 +434,17 @@ unsigned char * TclGetBytesFromObj( Tcl_Interp *interp, /* For error reporting */ Tcl_Obj *objPtr, /* Value to extract from */ - int *lengthPtr) /* If non-NULL, filled with length of the + size_t *lengthPtr) /* If non-NULL, filled with length of the * array of bytes in the ByteArray object. */ { ByteArray *baPtr; const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objPtr, &properByteArrayType); if (irPtr == NULL) { - SetByteArrayFromAny(NULL, objPtr); - irPtr = TclFetchIntRep(objPtr, &properByteArrayType); - if (irPtr == NULL) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "expected bytes but got non-byte character")); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "BYTES", NULL); - } + if (TCL_ERROR == SetByteArrayFromAny(interp, objPtr)) { return NULL; } + irPtr = TclFetchIntRep(objPtr, &properByteArrayType); } baPtr = GET_BYTEARRAY(irPtr); @@ -484,17 +478,24 @@ Tcl_GetByteArrayFromObj( int *lengthPtr) /* If non-NULL, filled with length of the * array of bytes in the ByteArray object. */ { - unsigned char *result = TclGetBytesFromObj(NULL, objPtr, lengthPtr); - - if (result == NULL) { - - /* TODO: Reconsider claiming a length for failed conversion. */ - if (lengthPtr != NULL) { + size_t numBytes = 0; + unsigned char *bytes = TclGetBytesFromObj(NULL, objPtr, &numBytes); + + /* Macro TclGetByteArrayFromObj passes NULL for lengthPtr as + * a trick to get around changing size. */ + if (lengthPtr) { + if (numBytes > INT_MAX) { + /* Caller asked for an int length, but true length is outside + * the int range. This case will be developed out of existence + * in Tcl 9. As interim measure, fail. */ + *lengthPtr = 0; + return NULL; + } else { + *lengthPtr = (int) numBytes; } - return NULL; } - return result; + return bytes; } /* @@ -557,44 +558,64 @@ Tcl_SetByteArrayLength( /* *---------------------------------------------------------------------- * - * SetByteArrayFromAny -- - * - * Generate the ByteArray internal rep from the string rep. + * MakeByteArray -- * - * TODO: Consider length limit on conversion. + * Generate a ByteArray internal rep from the string rep of objPtr. + * The generated byte sequence may have no more than limit bytes. The + * value of TCL_INDEX_NONE for limit indicates no limit imposed. If + * boolean argument demandProper is true, then no byte sequence should + * be output to the caller (write NULL instead). When no bytes sequence + * is output and interp is not NULL, leave an error message and error + * code in interp explaining why a proper byte sequence could not be + * made. * * Results: - * The return value is always TCL_OK. - * - * Side effects: - * A ByteArray object is stored as the internal rep of objPtr. + * Returns a boolean indicating whether the bytes generated (up to + * limit bytes) are a proper representation of (a limited prefix of) + * the string. Writes a pointer to the generated ByteArray to + * *byteArrayPtrPtr. If not NULL it needs to be released with Tcl_Free(). * *---------------------------------------------------------------------- */ static int MakeByteArray( + Tcl_Interp *interp, Tcl_Obj *objPtr, - int earlyOut, + size_t limit, + int demandProper, ByteArray **byteArrayPtrPtr) { - int length, proper = 1; - unsigned char *dst; + size_t length; const char *src = TclGetStringFromObj(objPtr, &length); - ByteArray *byteArrayPtr = (ByteArray *)Tcl_Alloc(BYTEARRAY_SIZE(length)); + size_t numBytes + = (limit != TCL_INDEX_NONE && limit < length) ? limit : length; + ByteArray *byteArrayPtr = (ByteArray *)Tcl_Alloc(BYTEARRAY_SIZE(numBytes)); + unsigned char *dst = byteArrayPtr->bytes; + unsigned char *dstEnd = dst + numBytes; const char *srcEnd = src + length; - Tcl_UniChar ch = 0; + int proper = 1; + + for (; src < srcEnd && dst < dstEnd; ) { + Tcl_UniChar ch; + int count = TclUtfToUniChar(src, &ch); - for (dst = byteArrayPtr->bytes; src < srcEnd; ) { - src += TclUtfToUniChar(src, &ch); if (ch > 255) { - proper = 0; - if (earlyOut) { - Tcl_Free(byteArrayPtr); - *byteArrayPtrPtr = NULL; - return proper; - } + proper = 0; + if (demandProper) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected byte sequence but character %zu " + "was '%1s' (U+%06X)", dst - byteArrayPtr->bytes, + src, ch)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "BYTES", NULL); + } + Tcl_Free(byteArrayPtr); + *byteArrayPtrPtr = NULL; + return proper; + } } + src += count; *dst++ = UCHAR(ch); } byteArrayPtr->used = dst - byteArrayPtr->bytes; @@ -612,7 +633,7 @@ TclNarrowToBytes( Tcl_ObjIntRep ir; ByteArray *byteArrayPtr; - if (0 == MakeByteArray(objPtr, 0, &byteArrayPtr)) { + if (0 == MakeByteArray(NULL, objPtr, TCL_INDEX_NONE, 0, &byteArrayPtr)) { objPtr = Tcl_NewObj(); TclInvalidateStringRep(objPtr); } @@ -623,20 +644,32 @@ TclNarrowToBytes( return objPtr; } + +/* + *---------------------------------------------------------------------- + * + * SetByteArrayFromAny -- + * + * Generate the ByteArray internal rep from the string rep. + * + * Results: + * Tcl return code indicating OK or ERROR. + * + * Side effects: + * A ByteArray struct may be stored as the internal rep of objPtr. + * + *---------------------------------------------------------------------- + */ + static int SetByteArrayFromAny( - TCL_UNUSED(Tcl_Interp *), + Tcl_Interp *interp, /* For error reporting. */ Tcl_Obj *objPtr) /* The object to convert to type ByteArray. */ { ByteArray *byteArrayPtr; Tcl_ObjIntRep ir; - /* TODO: Consider imposing this check on callers. */ - if (TclHasIntRep(objPtr, &properByteArrayType)) { - return TCL_OK; - } - - if (0 == MakeByteArray(objPtr, 1, &byteArrayPtr)) { + if (0 == MakeByteArray(interp, objPtr, TCL_INDEX_NONE, 1, &byteArrayPtr)) { return TCL_ERROR; } @@ -1453,9 +1486,8 @@ BinaryScanCmd( "value formatString ?varName ...?"); return TCL_ERROR; } - buffer = TclGetByteArrayFromObj(objv[1], &length); + buffer = TclGetBytesFromObj(interp, objv[1], &length); if (buffer == NULL) { - Tcl_AppendResult(interp, "binary scan expects bytes", NULL); return TCL_ERROR; } numberCachePtr = &numberCacheHash; @@ -2510,9 +2542,8 @@ BinaryEncodeHex( return TCL_ERROR; } - data = TclGetByteArrayFromObj(objv[1], &count); + data = TclGetBytesFromObj(interp, objv[1], &count); if (data == NULL) { - Tcl_AppendResult(interp, "binary encode expects bytes", NULL); return TCL_ERROR; } @@ -2711,9 +2742,8 @@ BinaryEncode64( } } - data = TclGetByteArrayFromObj(objv[objc - 1], &count); + data = TclGetBytesFromObj(interp, objv[objc - 1], &count); if (data == NULL) { - Tcl_AppendResult(interp, "binary encode expects bytes", NULL); return TCL_ERROR; } resultObj = Tcl_NewObj(); @@ -2815,10 +2845,8 @@ BinaryEncodeUu( } break; case OPT_WRAPCHAR: - wrapchar = TclGetByteArrayFromObj(objv[i + 1], &wrapcharlen); + wrapchar = TclGetBytesFromObj(interp, objv[i + 1], &wrapcharlen); if (wrapchar == NULL) { - Tcl_AppendResult(interp, - "binary encode -wrapchar expects bytes", NULL); return TCL_ERROR; } break; @@ -2831,9 +2859,8 @@ BinaryEncodeUu( */ offset = 0; - data = TclGetByteArrayFromObj(objv[objc - 1], &count); + data = TclGetBytesFromObj(interp, objv[objc - 1], &count); if (data == NULL) { - Tcl_AppendResult(interp, "binary encode expects bytes", NULL); return TCL_ERROR; } resultObj = Tcl_NewObj(); diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 1f8a9d5..3e9b294 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -431,9 +431,8 @@ EncodingConvertfromObjCmd( /* * Convert the string into a byte array in 'ds' */ - bytesPtr = (char *) TclGetByteArrayFromObj(data, &length); + bytesPtr = (char *) TclGetBytesFromObj(interp, data, &length); if (bytesPtr == NULL) { - Tcl_AppendResult(interp, "encoding conversion expects bytes", NULL); Tcl_FreeEncoding(encoding); return TCL_ERROR; } diff --git a/generic/tclInt.h b/generic/tclInt.h index 592a03f..48bf2fd 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2957,7 +2957,7 @@ MODULE_SCOPE void TclFSUnloadTempFile(Tcl_LoadHandle loadHandle); MODULE_SCOPE int * TclGetAsyncReadyPtr(void); MODULE_SCOPE Tcl_Obj * TclGetBgErrorHandler(Tcl_Interp *interp); MODULE_SCOPE unsigned char * TclGetBytesFromObj(Tcl_Interp *interp, - Tcl_Obj *objPtr, int *lengthPtr); + Tcl_Obj *objPtr, size_t *lengthPtr); MODULE_SCOPE int TclGetChannelFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Channel *chanPtr, int *modePtr, int flags); -- cgit v0.12 From 780b1d457f63640ebbddfc144e8567c4ac7b7f88 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 25 Mar 2020 10:11:50 +0000 Subject: Simplify platform/internal stubs. Not to be merged soon, still highly experimental!!!! --- generic/tcl.decls | 8 +- generic/tclInt.decls | 219 +++++-------------------------- generic/tclIntPlatDecls.h | 319 +++------------------------------------------- generic/tclPlatDecls.h | 6 - generic/tclStubInit.c | 89 ++----------- win/tclWin32Dll.c | 2 +- win/tclWinError.c | 6 +- win/tclWinInit.c | 4 +- win/tclWinNotify.c | 6 +- win/tclWinSock.c | 4 +- 10 files changed, 75 insertions(+), 588 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 301d9ef..8555f72 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2483,10 +2483,10 @@ interface tclPlat # Added in Tcl 8.1, Removed in Tcl 9.0 (converted to macro) -#declare 0 win { +#declare 0 { # TCHAR *Tcl_WinUtfToTChar(const char *str, size_t len, Tcl_DString *dsPtr) #} -#declare 1 win { +#declare 1 { # char *Tcl_WinTCharToUtf(const TCHAR *str, size_t len, Tcl_DString *dsPtr) #} @@ -2494,12 +2494,12 @@ interface tclPlat # Mac OS X specific functions # Removed in 9.0 -#declare 0 macosx { +#declare 0 { # int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp, # const char *bundleName, int hasResourceFile, # size_t maxPathLen, char *libraryPath) #} -declare 1 macosx { +declare 1 { int Tcl_MacOSXOpenVersionedBundleResources(Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, int hasResourceFile, size_t maxPathLen, char *libraryPath) diff --git a/generic/tclInt.decls b/generic/tclInt.decls index fd3eed5..11bd196 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -1078,253 +1078,92 @@ declare 259 { interface tclIntPlat -################################ -# Windows specific functions - -declare 0 win { - void TclWinConvertError(DWORD errCode) +declare 0 { + void TclWinConvertError(int errCode) } -# Removed in 9.0: -#declare 1 win { -# void TclWinConvertWSAError(DWORD errCode) -#} -# Removed in 9.0: -#declare 2 win { -# struct servent *TclWinGetServByName(const char *nm, -# const char *proto) -#} -# Removed in 9.0: -#declare 3 win { -# int TclWinGetSockOpt(SOCKET s, int level, int optname, -# char *optval, int *optlen) -#} -declare 4 win { - HINSTANCE TclWinGetTclInstance(void) +declare 4 { + void *TclWinGetTclInstance(void) } -# new for 8.4.20+/8.5.12+ Cygwin only -declare 5 win { +declare 5 { int TclUnixWaitForFile(int fd, int mask, int timeout) } -# Removed in 8.1: -# declare 5 win { -# HINSTANCE TclWinLoadLibrary(char *name) -# } -# Removed in 9.0: -#declare 6 win { -# unsigned short TclWinNToHS(unsigned short ns) -#} -# Removed in 9.0: -#declare 7 win { -# int TclWinSetSockOpt(SOCKET s, int level, int optname, -# const char *optval, int optlen) -#} -declare 8 win { +declare 8 { size_t TclpGetPid(Tcl_Pid pid) } -# Removed in 9.0: -#declare 9 win { -# int TclWinGetPlatformId(void) -#} -# Removed in 9.0: -#declare 10 win { -# Tcl_DirEntry *TclpReaddir(TclDIR *dir) -#} -# Removed in 8.3.1 (for Win32s only): -#declare 10 win { -# int TclWinSynchSpawn(void *args, int type, void **trans, Tcl_Pid *pidPtr) -#} - -# Pipe channel functions - -declare 11 win { +declare 11 { void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan) } -declare 12 win { +declare 12 { int TclpCloseFile(TclFile file) } -declare 13 win { +declare 13 { Tcl_Channel TclpCreateCommandChannel(TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr) } -declare 14 win { +declare 14 { int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe) } -declare 15 win { +declare 15 { int TclpCreateProcess(Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr) } -# new for 8.4.20+/8.5.12+ Cygwin only -declare 16 win { +declare 16 { int TclpIsAtty(int fd) } -# Signature changed in 8.1: -# declare 16 win { -# TclFile TclpCreateTempFile(char *contents, Tcl_DString *namePtr) -# } -# declare 17 win { -# char *TclpGetTZName(void) -# } -# new for 8.5.12+ Cygwin only -declare 17 win { +declare 17 { int TclUnixCopyFile(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts) } -declare 18 win { +declare 18 { TclFile TclpMakeFile(Tcl_Channel channel, int direction) } -declare 19 win { +declare 19 { TclFile TclpOpenFile(const char *fname, int mode) } -declare 20 win { +declare 20 { void TclWinAddProcess(HANDLE hProcess, size_t id) } -# Removed in 9.0: -#declare 21 win { -# char *TclpInetNtoa(struct in_addr addr) -#} -# removed permanently for 8.4 -#declare 21 win { -# void TclpAsyncMark(Tcl_AsyncHandler async) -#} - -# Added in 8.1: -declare 22 win { +declare 22 { TclFile TclpCreateTempFile(const char *contents) } -# Removed in 8.6: -#declare 23 win { -# char *TclpGetTZName(int isdst) -#} -declare 24 win { +declare 24 { char *TclWinNoBackslash(char *path) } -# replaced by generic TclGetPlatform -#declare 25 win { -# TclPlatformType *TclWinGetPlatform(void) -#} -# Removed in 9.0: -#declare 26 win { -# void TclWinSetInterfaces(int wide) -#} - -# Added in Tcl 8.3.3 / 8.4 - -declare 27 win { +declare 27 { void TclWinFlushDirtyChannels(void) } - -# Added in 8.4.2 - -# Removed in 9.0: -#declare 28 win { -# void TclWinResetInterfaces(void) -#} - -################################ -# Unix specific functions - -# Pipe channel functions - -declare 0 unix { - void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan) -} -declare 1 unix { - int TclpCloseFile(TclFile file) -} -declare 2 unix { - Tcl_Channel TclpCreateCommandChannel(TclFile readFile, - TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr) -} -declare 3 unix { - int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe) -} -declare 4 unix { - int TclpCreateProcess(Tcl_Interp *interp, int argc, - const char **argv, TclFile inputFile, TclFile outputFile, - TclFile errorFile, Tcl_Pid *pidPtr) -} -# Signature changed in 8.1: -# declare 5 unix { -# TclFile TclpCreateTempFile(char *contents, Tcl_DString *namePtr) -# } -declare 6 unix { - TclFile TclpMakeFile(Tcl_Channel channel, int direction) -} -declare 7 unix { - TclFile TclpOpenFile(const char *fname, int mode) -} -declare 8 unix { - int TclUnixWaitForFile(int fd, int mask, int timeout) -} - -# Added in 8.1: - -declare 9 unix { - TclFile TclpCreateTempFile(const char *contents) +declare 29 { + int TclWinCPUID(int index, int *regs) } - -# Added in 8.4: - -# Removed in 9.0: -#declare 10 unix { -# Tcl_DirEntry *TclpReaddir(TclDIR *dir) -#} -# Removed in 9.0: -#declare 11 unix { -# struct tm *TclpLocaltime_unix(const time_t *clock) -#} -# Removed in 9.0: -#declare 12 unix { -# struct tm *TclpGmtime_unix(const time_t *clock) -#} -# Removed in 9.0: -#declare 13 unix { -# char *TclpInetNtoa(struct in_addr addr) -#} - -# Added in 8.5: - -declare 14 unix { - int TclUnixCopyFile(const char *src, const char *dst, - const Tcl_StatBuf *statBufPtr, int dontCopyAtts) +declare 30 { + int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, + Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj) } ################################ # Mac OS X specific functions -declare 15 {unix macosx} { +declare 31 { int TclMacOSXGetFileAttribute(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr) } -declare 16 {unix macosx} { +declare 32 { int TclMacOSXSetFileAttribute(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr) } -declare 17 {unix macosx} { +declare 33 { int TclMacOSXCopyFileAttributes(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr) } -declare 18 {unix macosx} { +declare 34 { int TclMacOSXMatchType(Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types) } -declare 19 {unix macosx} { +declare 35 { void TclMacOSXNotifierAddRunLoopMode(const void *runLoopMode) } -declare 22 {unix macosx} { - TclFile TclpCreateTempFile_(const char *contents) -} - -declare 29 {win unix} { - int TclWinCPUID(int index, int *regs) -} -# Added in 8.6; core of TclpOpenTemporaryFile -declare 30 {win unix} { - int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, - Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj) -} # Local Variables: # mode: tcl diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index 726032b..ee2155e 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -40,85 +40,13 @@ extern "C" { * Exported function declarations: */ -#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ /* 0 */ -EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, - Tcl_Channel chan); -/* 1 */ -EXTERN int TclpCloseFile(TclFile file); -/* 2 */ -EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile, - TclFile writeFile, TclFile errorFile, - int numPids, Tcl_Pid *pidPtr); -/* 3 */ -EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); -/* 4 */ -EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, - const char **argv, TclFile inputFile, - TclFile outputFile, TclFile errorFile, - Tcl_Pid *pidPtr); -/* Slot 5 is reserved */ -/* 6 */ -EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); -/* 7 */ -EXTERN TclFile TclpOpenFile(const char *fname, int mode); -/* 8 */ -EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); -/* 9 */ -EXTERN TclFile TclpCreateTempFile(const char *contents); -/* Slot 10 is reserved */ -/* Slot 11 is reserved */ -/* Slot 12 is reserved */ -/* Slot 13 is reserved */ -/* 14 */ -EXTERN int TclUnixCopyFile(const char *src, const char *dst, - const Tcl_StatBuf *statBufPtr, - int dontCopyAtts); -/* 15 */ -EXTERN int TclMacOSXGetFileAttribute(Tcl_Interp *interp, - int objIndex, Tcl_Obj *fileName, - Tcl_Obj **attributePtrPtr); -/* 16 */ -EXTERN int TclMacOSXSetFileAttribute(Tcl_Interp *interp, - int objIndex, Tcl_Obj *fileName, - Tcl_Obj *attributePtr); -/* 17 */ -EXTERN int TclMacOSXCopyFileAttributes(const char *src, - const char *dst, - const Tcl_StatBuf *statBufPtr); -/* 18 */ -EXTERN int TclMacOSXMatchType(Tcl_Interp *interp, - const char *pathName, const char *fileName, - Tcl_StatBuf *statBufPtr, - Tcl_GlobTypeData *types); -/* 19 */ -EXTERN void TclMacOSXNotifierAddRunLoopMode( - const void *runLoopMode); -/* Slot 20 is reserved */ -/* Slot 21 is reserved */ -/* 22 */ -EXTERN TclFile TclpCreateTempFile_(const char *contents); -/* Slot 23 is reserved */ -/* Slot 24 is reserved */ -/* Slot 25 is reserved */ -/* Slot 26 is reserved */ -/* Slot 27 is reserved */ -/* Slot 28 is reserved */ -/* 29 */ -EXTERN int TclWinCPUID(int index, int *regs); -/* 30 */ -EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, - Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, - Tcl_Obj *resultingNameObj); -#endif /* UNIX */ -#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ -/* 0 */ -EXTERN void TclWinConvertError(DWORD errCode); +EXTERN void TclWinConvertError(int errCode); /* Slot 1 is reserved */ /* Slot 2 is reserved */ /* Slot 3 is reserved */ /* 4 */ -EXTERN HINSTANCE TclWinGetTclInstance(void); +EXTERN void * TclWinGetTclInstance(void); /* 5 */ EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); /* Slot 6 is reserved */ @@ -172,122 +100,36 @@ EXTERN int TclWinCPUID(int index, int *regs); EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); -#endif /* WIN */ -#ifdef MAC_OSX_TCL /* MACOSX */ -/* 0 */ -EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, - Tcl_Channel chan); -/* 1 */ -EXTERN int TclpCloseFile(TclFile file); -/* 2 */ -EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile, - TclFile writeFile, TclFile errorFile, - int numPids, Tcl_Pid *pidPtr); -/* 3 */ -EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); -/* 4 */ -EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, - const char **argv, TclFile inputFile, - TclFile outputFile, TclFile errorFile, - Tcl_Pid *pidPtr); -/* Slot 5 is reserved */ -/* 6 */ -EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); -/* 7 */ -EXTERN TclFile TclpOpenFile(const char *fname, int mode); -/* 8 */ -EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); -/* 9 */ -EXTERN TclFile TclpCreateTempFile(const char *contents); -/* Slot 10 is reserved */ -/* Slot 11 is reserved */ -/* Slot 12 is reserved */ -/* Slot 13 is reserved */ -/* 14 */ -EXTERN int TclUnixCopyFile(const char *src, const char *dst, - const Tcl_StatBuf *statBufPtr, - int dontCopyAtts); -/* 15 */ +/* 31 */ EXTERN int TclMacOSXGetFileAttribute(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); -/* 16 */ +/* 32 */ EXTERN int TclMacOSXSetFileAttribute(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); -/* 17 */ +/* 33 */ EXTERN int TclMacOSXCopyFileAttributes(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); -/* 18 */ +/* 34 */ EXTERN int TclMacOSXMatchType(Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); -/* 19 */ +/* 35 */ EXTERN void TclMacOSXNotifierAddRunLoopMode( const void *runLoopMode); -/* Slot 20 is reserved */ -/* Slot 21 is reserved */ -/* 22 */ -EXTERN TclFile TclpCreateTempFile_(const char *contents); -/* Slot 23 is reserved */ -/* Slot 24 is reserved */ -/* Slot 25 is reserved */ -/* Slot 26 is reserved */ -/* Slot 27 is reserved */ -/* Slot 28 is reserved */ -/* 29 */ -EXTERN int TclWinCPUID(int index, int *regs); -/* 30 */ -EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, - Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, - Tcl_Obj *resultingNameObj); -#endif /* MACOSX */ typedef struct TclIntPlatStubs { int magic; void *hooks; -#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ - void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */ - int (*tclpCloseFile) (TclFile file); /* 1 */ - Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ - int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */ - int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */ - void (*reserved5)(void); - TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */ - TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */ - int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */ - TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */ - void (*reserved10)(void); - void (*reserved11)(void); - void (*reserved12)(void); - void (*reserved13)(void); - int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 14 */ - int (*tclMacOSXGetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); /* 15 */ - int (*tclMacOSXSetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); /* 16 */ - int (*tclMacOSXCopyFileAttributes) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); /* 17 */ - int (*tclMacOSXMatchType) (Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 18 */ - void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */ - void (*reserved20)(void); - void (*reserved21)(void); - TclFile (*tclpCreateTempFile_) (const char *contents); /* 22 */ - void (*reserved23)(void); - void (*reserved24)(void); - void (*reserved25)(void); - void (*reserved26)(void); - void (*reserved27)(void); - void (*reserved28)(void); - int (*tclWinCPUID) (int index, int *regs); /* 29 */ - int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ -#endif /* UNIX */ -#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ - void (*tclWinConvertError) (DWORD errCode); /* 0 */ + void (*tclWinConvertError) (int errCode); /* 0 */ void (*reserved1)(void); void (*reserved2)(void); void (*reserved3)(void); - HINSTANCE (*tclWinGetTclInstance) (void); /* 4 */ + void * (*tclWinGetTclInstance) (void); /* 4 */ int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 5 */ void (*reserved6)(void); void (*reserved7)(void); @@ -314,40 +156,11 @@ typedef struct TclIntPlatStubs { void (*reserved28)(void); int (*tclWinCPUID) (int index, int *regs); /* 29 */ int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ -#endif /* WIN */ -#ifdef MAC_OSX_TCL /* MACOSX */ - void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */ - int (*tclpCloseFile) (TclFile file); /* 1 */ - Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ - int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */ - int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */ - void (*reserved5)(void); - TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */ - TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */ - int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */ - TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */ - void (*reserved10)(void); - void (*reserved11)(void); - void (*reserved12)(void); - void (*reserved13)(void); - int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 14 */ - int (*tclMacOSXGetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); /* 15 */ - int (*tclMacOSXSetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); /* 16 */ - int (*tclMacOSXCopyFileAttributes) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); /* 17 */ - int (*tclMacOSXMatchType) (Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 18 */ - void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */ - void (*reserved20)(void); - void (*reserved21)(void); - TclFile (*tclpCreateTempFile_) (const char *contents); /* 22 */ - void (*reserved23)(void); - void (*reserved24)(void); - void (*reserved25)(void); - void (*reserved26)(void); - void (*reserved27)(void); - void (*reserved28)(void); - int (*tclWinCPUID) (int index, int *regs); /* 29 */ - int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ -#endif /* MACOSX */ + int (*tclMacOSXGetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); /* 31 */ + int (*tclMacOSXSetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); /* 32 */ + int (*tclMacOSXCopyFileAttributes) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); /* 33 */ + int (*tclMacOSXMatchType) (Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 34 */ + void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 35 */ } TclIntPlatStubs; extern const TclIntPlatStubs *tclIntPlatStubsPtr; @@ -362,58 +175,6 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; * Inline function declarations: */ -#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ -#define TclGetAndDetachPids \ - (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */ -#define TclpCloseFile \ - (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ -#define TclpCreateCommandChannel \ - (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */ -#define TclpCreatePipe \ - (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ -#define TclpCreateProcess \ - (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */ -/* Slot 5 is reserved */ -#define TclpMakeFile \ - (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */ -#define TclpOpenFile \ - (tclIntPlatStubsPtr->tclpOpenFile) /* 7 */ -#define TclUnixWaitForFile \ - (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */ -#define TclpCreateTempFile \ - (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */ -/* Slot 10 is reserved */ -/* Slot 11 is reserved */ -/* Slot 12 is reserved */ -/* Slot 13 is reserved */ -#define TclUnixCopyFile \ - (tclIntPlatStubsPtr->tclUnixCopyFile) /* 14 */ -#define TclMacOSXGetFileAttribute \ - (tclIntPlatStubsPtr->tclMacOSXGetFileAttribute) /* 15 */ -#define TclMacOSXSetFileAttribute \ - (tclIntPlatStubsPtr->tclMacOSXSetFileAttribute) /* 16 */ -#define TclMacOSXCopyFileAttributes \ - (tclIntPlatStubsPtr->tclMacOSXCopyFileAttributes) /* 17 */ -#define TclMacOSXMatchType \ - (tclIntPlatStubsPtr->tclMacOSXMatchType) /* 18 */ -#define TclMacOSXNotifierAddRunLoopMode \ - (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */ -/* Slot 20 is reserved */ -/* Slot 21 is reserved */ -#define TclpCreateTempFile_ \ - (tclIntPlatStubsPtr->tclpCreateTempFile_) /* 22 */ -/* Slot 23 is reserved */ -/* Slot 24 is reserved */ -/* Slot 25 is reserved */ -/* Slot 26 is reserved */ -/* Slot 27 is reserved */ -/* Slot 28 is reserved */ -#define TclWinCPUID \ - (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ -#define TclUnixOpenTemporaryFile \ - (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ -#endif /* UNIX */ -#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ #define TclWinConvertError \ (tclIntPlatStubsPtr->tclWinConvertError) /* 0 */ /* Slot 1 is reserved */ @@ -464,58 +225,16 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ #define TclUnixOpenTemporaryFile \ (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ -#endif /* WIN */ -#ifdef MAC_OSX_TCL /* MACOSX */ -#define TclGetAndDetachPids \ - (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */ -#define TclpCloseFile \ - (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ -#define TclpCreateCommandChannel \ - (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */ -#define TclpCreatePipe \ - (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ -#define TclpCreateProcess \ - (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */ -/* Slot 5 is reserved */ -#define TclpMakeFile \ - (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */ -#define TclpOpenFile \ - (tclIntPlatStubsPtr->tclpOpenFile) /* 7 */ -#define TclUnixWaitForFile \ - (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */ -#define TclpCreateTempFile \ - (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */ -/* Slot 10 is reserved */ -/* Slot 11 is reserved */ -/* Slot 12 is reserved */ -/* Slot 13 is reserved */ -#define TclUnixCopyFile \ - (tclIntPlatStubsPtr->tclUnixCopyFile) /* 14 */ #define TclMacOSXGetFileAttribute \ - (tclIntPlatStubsPtr->tclMacOSXGetFileAttribute) /* 15 */ + (tclIntPlatStubsPtr->tclMacOSXGetFileAttribute) /* 31 */ #define TclMacOSXSetFileAttribute \ - (tclIntPlatStubsPtr->tclMacOSXSetFileAttribute) /* 16 */ + (tclIntPlatStubsPtr->tclMacOSXSetFileAttribute) /* 32 */ #define TclMacOSXCopyFileAttributes \ - (tclIntPlatStubsPtr->tclMacOSXCopyFileAttributes) /* 17 */ + (tclIntPlatStubsPtr->tclMacOSXCopyFileAttributes) /* 33 */ #define TclMacOSXMatchType \ - (tclIntPlatStubsPtr->tclMacOSXMatchType) /* 18 */ + (tclIntPlatStubsPtr->tclMacOSXMatchType) /* 34 */ #define TclMacOSXNotifierAddRunLoopMode \ - (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */ -/* Slot 20 is reserved */ -/* Slot 21 is reserved */ -#define TclpCreateTempFile_ \ - (tclIntPlatStubsPtr->tclpCreateTempFile_) /* 22 */ -/* Slot 23 is reserved */ -/* Slot 24 is reserved */ -/* Slot 25 is reserved */ -/* Slot 26 is reserved */ -/* Slot 27 is reserved */ -/* Slot 28 is reserved */ -#define TclWinCPUID \ - (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ -#define TclUnixOpenTemporaryFile \ - (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ -#endif /* MACOSX */ + (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 35 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclPlatDecls.h b/generic/tclPlatDecls.h index fb46271..4c07148 100644 --- a/generic/tclPlatDecls.h +++ b/generic/tclPlatDecls.h @@ -50,7 +50,6 @@ extern "C" { * Exported function declarations: */ -#ifdef MAC_OSX_TCL /* MACOSX */ /* Slot 0 is reserved */ /* 1 */ EXTERN int Tcl_MacOSXOpenVersionedBundleResources( @@ -58,16 +57,13 @@ EXTERN int Tcl_MacOSXOpenVersionedBundleResources( const char *bundleVersion, int hasResourceFile, size_t maxPathLen, char *libraryPath); -#endif /* MACOSX */ typedef struct TclPlatStubs { int magic; void *hooks; -#ifdef MAC_OSX_TCL /* MACOSX */ void (*reserved0)(void); int (*tcl_MacOSXOpenVersionedBundleResources) (Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, int hasResourceFile, size_t maxPathLen, char *libraryPath); /* 1 */ -#endif /* MACOSX */ } TclPlatStubs; extern const TclPlatStubs *tclPlatStubsPtr; @@ -82,11 +78,9 @@ extern const TclPlatStubs *tclPlatStubsPtr; * Inline function declarations: */ -#ifdef MAC_OSX_TCL /* MACOSX */ /* Slot 0 is reserved */ #define Tcl_MacOSXOpenVersionedBundleResources \ (tclPlatStubsPtr->tcl_MacOSXOpenVersionedBundleResources) /* 1 */ -#endif /* MACOSX */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index fac9286..ba3c58f 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -143,13 +143,13 @@ static void uniCodePanic() { #define TclBN_mp_toom_mul s_mp_toom_mul #define TclBN_mp_toom_sqr s_mp_toom_sqr -#define TclpCreateTempFile_ TclpCreateTempFile -#ifndef MAC_OSX_TCL /* On UNIX, fill with other stub entries */ -#define TclMacOSXGetFileAttribute (int (*)(Tcl_Interp *, int, Tcl_Obj *, Tcl_Obj **))(void *)TclpCreateProcess -#define TclMacOSXSetFileAttribute (int (*)(Tcl_Interp *, int, Tcl_Obj *, Tcl_Obj *))(void *)isatty -#define TclMacOSXCopyFileAttributes (int (*)(const char *, const char *, const Tcl_StatBuf *))(void *)TclUnixCopyFile -#define TclMacOSXMatchType (int (*)(Tcl_Interp *, const char *, const char *, Tcl_StatBuf *, Tcl_GlobTypeData *))(void *)TclpMakeFile -#define TclMacOSXNotifierAddRunLoopMode (void (*)(const void *))TclpOpenFile +#ifndef MAC_OSX_TCL +# define Tcl_MacOSXOpenVersionedBundleResources 0 +# define TclMacOSXGetFileAttribute 0 +# define TclMacOSXSetFileAttribute 0 +# define TclMacOSXCopyFileAttributes 0 +# define TclMacOSXMatchType 0 +# define TclMacOSXNotifierAddRunLoopMode 0 #endif #ifdef _WIN32 @@ -541,40 +541,6 @@ static const TclIntStubs tclIntStubs = { static const TclIntPlatStubs tclIntPlatStubs = { TCL_STUB_MAGIC, 0, -#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ - TclGetAndDetachPids, /* 0 */ - TclpCloseFile, /* 1 */ - TclpCreateCommandChannel, /* 2 */ - TclpCreatePipe, /* 3 */ - TclpCreateProcess, /* 4 */ - 0, /* 5 */ - TclpMakeFile, /* 6 */ - TclpOpenFile, /* 7 */ - TclUnixWaitForFile, /* 8 */ - TclpCreateTempFile, /* 9 */ - 0, /* 10 */ - 0, /* 11 */ - 0, /* 12 */ - 0, /* 13 */ - TclUnixCopyFile, /* 14 */ - TclMacOSXGetFileAttribute, /* 15 */ - TclMacOSXSetFileAttribute, /* 16 */ - TclMacOSXCopyFileAttributes, /* 17 */ - TclMacOSXMatchType, /* 18 */ - TclMacOSXNotifierAddRunLoopMode, /* 19 */ - 0, /* 20 */ - 0, /* 21 */ - TclpCreateTempFile_, /* 22 */ - 0, /* 23 */ - 0, /* 24 */ - 0, /* 25 */ - 0, /* 26 */ - 0, /* 27 */ - 0, /* 28 */ - TclWinCPUID, /* 29 */ - TclUnixOpenTemporaryFile, /* 30 */ -#endif /* UNIX */ -#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ TclWinConvertError, /* 0 */ 0, /* 1 */ 0, /* 2 */ @@ -606,49 +572,18 @@ static const TclIntPlatStubs tclIntPlatStubs = { 0, /* 28 */ TclWinCPUID, /* 29 */ TclUnixOpenTemporaryFile, /* 30 */ -#endif /* WIN */ -#ifdef MAC_OSX_TCL /* MACOSX */ - TclGetAndDetachPids, /* 0 */ - TclpCloseFile, /* 1 */ - TclpCreateCommandChannel, /* 2 */ - TclpCreatePipe, /* 3 */ - TclpCreateProcess, /* 4 */ - 0, /* 5 */ - TclpMakeFile, /* 6 */ - TclpOpenFile, /* 7 */ - TclUnixWaitForFile, /* 8 */ - TclpCreateTempFile, /* 9 */ - 0, /* 10 */ - 0, /* 11 */ - 0, /* 12 */ - 0, /* 13 */ - TclUnixCopyFile, /* 14 */ - TclMacOSXGetFileAttribute, /* 15 */ - TclMacOSXSetFileAttribute, /* 16 */ - TclMacOSXCopyFileAttributes, /* 17 */ - TclMacOSXMatchType, /* 18 */ - TclMacOSXNotifierAddRunLoopMode, /* 19 */ - 0, /* 20 */ - 0, /* 21 */ - TclpCreateTempFile_, /* 22 */ - 0, /* 23 */ - 0, /* 24 */ - 0, /* 25 */ - 0, /* 26 */ - 0, /* 27 */ - 0, /* 28 */ - TclWinCPUID, /* 29 */ - TclUnixOpenTemporaryFile, /* 30 */ -#endif /* MACOSX */ + TclMacOSXGetFileAttribute, /* 31 */ + TclMacOSXSetFileAttribute, /* 32 */ + TclMacOSXCopyFileAttributes, /* 33 */ + TclMacOSXMatchType, /* 34 */ + TclMacOSXNotifierAddRunLoopMode, /* 35 */ }; static const TclPlatStubs tclPlatStubs = { TCL_STUB_MAGIC, 0, -#ifdef MAC_OSX_TCL /* MACOSX */ 0, /* 0 */ Tcl_MacOSXOpenVersionedBundleResources, /* 1 */ -#endif /* MACOSX */ }; const TclTomMathStubs tclTomMathStubs = { diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c index de0ddad..737567b 100644 --- a/win/tclWin32Dll.c +++ b/win/tclWin32Dll.c @@ -152,7 +152,7 @@ DllMain( *---------------------------------------------------------------------- */ -HINSTANCE +void * TclWinGetTclInstance(void) { return hInstance; diff --git a/win/tclWinError.c b/win/tclWinError.c index fc07b3e..f93f000 100644 --- a/win/tclWinError.c +++ b/win/tclWinError.c @@ -349,11 +349,11 @@ static const unsigned char wsaErrorTable[] = { void TclWinConvertError( - DWORD errCode) /* Win32 error code. */ + int errCode) /* Win32 error code. */ { - if (errCode >= sizeof(errorTable)/sizeof(errorTable[0])) { + if ((unsigned)errCode >= sizeof(errorTable)/sizeof(errorTable[0])) { errCode -= WSAEWOULDBLOCK; - if (errCode >= sizeof(wsaErrorTable)/sizeof(wsaErrorTable[0])) { + if ((unsigned)errCode >= sizeof(wsaErrorTable)/sizeof(wsaErrorTable[0])) { Tcl_SetErrno(errorTable[1]); } else { Tcl_SetErrno(wsaErrorTable[errCode]); diff --git a/win/tclWinInit.c b/win/tclWinInit.c index 122c4ae..7bd46cc 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -344,7 +344,7 @@ InitializeDefaultLibraryDir( size_t *lengthPtr, Tcl_Encoding *encodingPtr) { - HMODULE hModule = TclWinGetTclInstance(); + HMODULE hModule = (HMODULE)TclWinGetTclInstance(); WCHAR wName[MAX_PATH + LIBRARY_SIZE]; char name[(MAX_PATH + LIBRARY_SIZE) * 3]; char *end, *p; @@ -392,7 +392,7 @@ InitializeSourceLibraryDir( size_t *lengthPtr, Tcl_Encoding *encodingPtr) { - HMODULE hModule = TclWinGetTclInstance(); + HMODULE hModule = (HMODULE)TclWinGetTclInstance(); WCHAR wName[MAX_PATH + LIBRARY_SIZE]; char name[(MAX_PATH + LIBRARY_SIZE) * 3]; char *end, *p; diff --git a/win/tclWinNotify.c b/win/tclWinNotify.c index 2ab4efa..caab574 100644 --- a/win/tclWinNotify.c +++ b/win/tclWinNotify.c @@ -103,7 +103,7 @@ Tcl_InitNotifier(void) clazz.style = 0; clazz.cbClsExtra = 0; clazz.cbWndExtra = 0; - clazz.hInstance = TclWinGetTclInstance(); + clazz.hInstance = (HMODULE)TclWinGetTclInstance(); clazz.hbrBackground = NULL; clazz.lpszMenuName = NULL; clazz.lpszClassName = className; @@ -195,7 +195,7 @@ Tcl_FinalizeNotifier( if (notifierCount) { notifierCount--; if (notifierCount == 0) { - UnregisterClassW(className, TclWinGetTclInstance()); + UnregisterClassW(className, (HMODULE)TclWinGetTclInstance()); } } LeaveCriticalSection(¬ifierMutex); @@ -360,7 +360,7 @@ Tcl_ServiceModeHook( if (mode == TCL_SERVICE_ALL && !tsdPtr->hwnd) { tsdPtr->hwnd = CreateWindowW(className, className, - WS_TILED, 0, 0, 0, 0, NULL, NULL, TclWinGetTclInstance(), + WS_TILED, 0, 0, 0, 0, NULL, NULL, (HMODULE)TclWinGetTclInstance(), NULL); /* diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 0bdb499..bdf659a 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -2485,7 +2485,7 @@ InitSockets(void) windowClass.style = 0; windowClass.cbClsExtra = 0; windowClass.cbWndExtra = 0; - windowClass.hInstance = TclWinGetTclInstance(); + windowClass.hInstance = (HMODULE)TclWinGetTclInstance(); windowClass.hbrBackground = NULL; windowClass.lpszMenuName = NULL; windowClass.lpszClassName = className; @@ -2616,7 +2616,7 @@ SocketExitHandler( */ TclpFinalizeSockets(); - UnregisterClassW(className, TclWinGetTclInstance()); + UnregisterClassW(className, (HMODULE)TclWinGetTclInstance()); initialized = 0; Tcl_MutexUnlock(&socketMutex); } -- cgit v0.12 From f97237e4e5219db9e644adbfaea74b8c915d9c45 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 26 Mar 2020 16:25:09 +0000 Subject: Fix build on UNIX/MacOS --- generic/tclInt.decls | 2 +- generic/tclIntPlatDecls.h | 22 +++++++++++++++------- generic/tclStubInit.c | 6 ++++++ 3 files changed, 22 insertions(+), 8 deletions(-) diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 11bd196..a15cf5f 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -1122,7 +1122,7 @@ declare 19 { TclFile TclpOpenFile(const char *fname, int mode) } declare 20 { - void TclWinAddProcess(HANDLE hProcess, size_t id) + void TclWinAddProcess(void *hProcess, size_t id) } declare 22 { TclFile TclpCreateTempFile(const char *contents) diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index d027fdc..592ff92 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -82,7 +82,7 @@ EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); /* 19 */ EXTERN TclFile TclpOpenFile(const char *fname, int mode); /* 20 */ -EXTERN void TclWinAddProcess(HANDLE hProcess, size_t id); +EXTERN void TclWinAddProcess(void *hProcess, size_t id); /* Slot 21 is reserved */ /* 22 */ EXTERN TclFile TclpCreateTempFile(const char *contents); @@ -145,7 +145,7 @@ typedef struct TclIntPlatStubs { int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 17 */ TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 18 */ TclFile (*tclpOpenFile) (const char *fname, int mode); /* 19 */ - void (*tclWinAddProcess) (HANDLE hProcess, size_t id); /* 20 */ + void (*tclWinAddProcess) (void *hProcess, size_t id); /* 20 */ void (*reserved21)(void); TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */ void (*reserved23)(void); @@ -244,12 +244,20 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; #define TCL_STORAGE_CLASS DLLIMPORT #define TclWinConvertWSAError TclWinConvertError +#if !defined(_WIN32) && !defined(__CYGWIN__) +# undef TclWinConvertError /* 0 */ +# undef TclWinGetTclInstance /* 4 */ +# undef TclWinAddProcess /* 20 */ +# undef TclWinNoBackslash /* 24 */ +# undef TclWinFlushDirtyChannels /* 27 */ +#endif + #ifndef MAC_OSX_TCL /* Not accessable on UNIX */ -#undef TclMacOSXGetFileAttribute /* 15 */ -#undef TclMacOSXSetFileAttribute /* 16 */ -#undef TclMacOSXCopyFileAttributes /* 17 */ -#undef TclMacOSXMatchType /* 18 */ -#undef TclMacOSXNotifierAddRunLoopMode /* 19 */ +# undef TclMacOSXGetFileAttribute /* 15 */ +# undef TclMacOSXSetFileAttribute /* 16 */ +# undef TclMacOSXCopyFileAttributes /* 17 */ +# undef TclMacOSXMatchType /* 18 */ +# undef TclMacOSXNotifierAddRunLoopMode /* 19 */ #endif #if !defined(_WIN32) diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index f67a934..c4a24e6 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -248,6 +248,12 @@ static int utfNcasecmp(const char *s1, const char *s2, unsigned int n){ #endif /* TCL_WIDE_INT_IS_LONG */ +#else +# define TclWinConvertError 0 +# define TclWinGetTclInstance 0 +# define TclWinAddProcess 0 +# define TclWinNoBackslash 0 +# define TclWinFlushDirtyChannels 0 #endif /* __CYGWIN__ */ /* -- cgit v0.12 From 19f97be0859daec65be8b841c7fea40b9cf47f7b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 27 Mar 2020 09:02:57 +0000 Subject: 2 undefined symbols on UNIX/MacOS --- generic/tclIntPlatDecls.h | 1 + generic/tclStubInit.c | 6 ++++-- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index 592ff92..8c5a6d8 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -247,6 +247,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; #if !defined(_WIN32) && !defined(__CYGWIN__) # undef TclWinConvertError /* 0 */ # undef TclWinGetTclInstance /* 4 */ +# undef TclpIsAtty /* 16 */ # undef TclWinAddProcess /* 20 */ # undef TclWinNoBackslash /* 24 */ # undef TclWinFlushDirtyChannels /* 27 */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index c4a24e6..b84feca 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -248,13 +248,15 @@ static int utfNcasecmp(const char *s1, const char *s2, unsigned int n){ #endif /* TCL_WIDE_INT_IS_LONG */ -#else +#else /* ! WIN32 && !__CYGWIN__ */ # define TclWinConvertError 0 # define TclWinGetTclInstance 0 # define TclWinAddProcess 0 # define TclWinNoBackslash 0 # define TclWinFlushDirtyChannels 0 -#endif /* __CYGWIN__ */ +# define TclpGetPid 0 +# define TclpIsAtty 0 +#endif /* _WIN32 */ /* * WARNING: The contents of this file is automatically generated by the -- cgit v0.12 From 3d26bf2941bb78c8538f4b9e5abfdcfee819c6f3 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 30 Mar 2020 14:52:55 +0000 Subject: When Tcl_SetByteArrayLength truncates a value, demand only that the truncated range must be a proper byte sequence. --- generic/tclBinary.c | 15 ++++++--------- tests/binary.test | 12 ++++++++++++ 2 files changed, 18 insertions(+), 9 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 6d33c83..af2550d 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -64,7 +64,7 @@ static int GetFormatSpec(const char **formatPtr, char *cmdPtr, size_t *countPtr, int *flagsPtr); static Tcl_Obj * ScanNumber(unsigned char *buffer, int type, int flags, Tcl_HashTable **numberCachePtr); -static int SetByteArrayFromAny(Tcl_Interp *interp, +static int SetByteArrayFromAny(Tcl_Interp *interp, size_t limit, Tcl_Obj *objPtr); static void UpdateStringOfByteArray(Tcl_Obj *listPtr); static void DeleteScanNumberCache(Tcl_HashTable *numberCachePtr); @@ -441,7 +441,7 @@ TclGetBytesFromObj( const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objPtr, &properByteArrayType); if (irPtr == NULL) { - if (TCL_ERROR == SetByteArrayFromAny(interp, objPtr)) { + if (TCL_ERROR == SetByteArrayFromAny(interp, TCL_INDEX_NONE, objPtr)) { return NULL; } irPtr = TclFetchIntRep(objPtr, &properByteArrayType); @@ -534,11 +534,7 @@ Tcl_SetByteArrayLength( irPtr = TclFetchIntRep(objPtr, &properByteArrayType); if (irPtr == NULL) { - if (length == 0) { - Tcl_SetByteArrayObj(objPtr, NULL, 0); - } else if (TCL_ERROR == SetByteArrayFromAny(NULL, objPtr)) { - - /* TODO: Consider a length limit on conversion attempt. */ + if (TCL_ERROR == SetByteArrayFromAny(NULL, length, objPtr)) { return NULL; } irPtr = TclFetchIntRep(objPtr, &properByteArrayType); @@ -664,12 +660,13 @@ TclNarrowToBytes( static int SetByteArrayFromAny( Tcl_Interp *interp, /* For error reporting. */ + size_t limit, /* Create no more than this many bytes */ Tcl_Obj *objPtr) /* The object to convert to type ByteArray. */ { ByteArray *byteArrayPtr; Tcl_ObjIntRep ir; - if (0 == MakeByteArray(interp, objPtr, TCL_INDEX_NONE, 1, &byteArrayPtr)) { + if (0 == MakeByteArray(interp, objPtr, limit, 1, &byteArrayPtr)) { return TCL_ERROR; } @@ -839,7 +836,7 @@ TclAppendBytesToByteArray( irPtr = TclFetchIntRep(objPtr, &properByteArrayType); if (irPtr == NULL) { - if (TCL_ERROR == SetByteArrayFromAny(NULL, objPtr)) { + if (TCL_ERROR == SetByteArrayFromAny(NULL, TCL_INDEX_NONE, objPtr)) { Tcl_Panic("attempt to append bytes to non-bytearray"); } irPtr = TclFetchIntRep(objPtr, &properByteArrayType); diff --git a/tests/binary.test b/tests/binary.test index bb8560d..a764dd6 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -2934,6 +2934,18 @@ test binary-79.1 {Tcl_SetByteArrayLength} testsetbytearraylength { test binary-79.2 {Tcl_SetByteArrayLength} -body { testsetbytearraylength [string cat \u0141 B C] 1 } -constraints testsetbytearraylength -returnCodes error -match glob -result * +test binary-79.3 {Tcl_SetByteArrayLength} testsetbytearraylength { + testsetbytearraylength [string cat A B \u0141] 0 +} {} +test binary-79.4 {Tcl_SetByteArrayLength} testsetbytearraylength { + testsetbytearraylength [string cat A B \u0141] 1 +} A +test binary-79.5 {Tcl_SetByteArrayLength} testsetbytearraylength { + testsetbytearraylength [string cat A B \u0141] 2 +} AB +test binary-79.6 {Tcl_SetByteArrayLength} -body { + testsetbytearraylength [string cat A B \u0141] 3 +} -constraints testsetbytearraylength -returnCodes error -match glob -result * # ---------------------------------------------------------------------- -- cgit v0.12 From 450324bb3c7382853f8024d4cfe11b2c0b4595e9 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 1 Apr 2020 21:11:49 +0000 Subject: Implement the public Tcl_GetBytesFromObj(). --- generic/tcl.decls | 6 ++++++ generic/tclBinary.c | 29 +++++++++++++++++++++++++++++ generic/tclDecls.h | 6 ++++++ generic/tclStubInit.c | 1 + 4 files changed, 42 insertions(+) diff --git a/generic/tcl.decls b/generic/tcl.decls index 0d29ba5..7337785 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2465,6 +2465,12 @@ declare 648 { size_t length, Tcl_DString *dsPtr) } +# TIP #568 +declare 649 { + unsigned char *Tcl_GetBytesFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, + int *lengthPtr) +} + # ----- BASELINE -- FOR -- 8.7.0 ----- # ############################################################################## diff --git a/generic/tclBinary.c b/generic/tclBinary.c index b2b75a2..7848083 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -453,6 +453,35 @@ TclGetBytesFromObj( } return baPtr->bytes; } + +unsigned char * +Tcl_GetBytesFromObj( + Tcl_Interp *interp, /* For error reporting */ + Tcl_Obj *objPtr, /* Value to extract from */ + int *lengthPtr) /* If non-NULL, filled with length of the + * array of bytes in the ByteArray object. */ +{ + size_t numBytes = 0; + unsigned char *bytes = TclGetBytesFromObj(interp, objPtr, &numBytes); + + if (lengthPtr) { + if (numBytes > INT_MAX) { + /* Caller asked for an int length, but true length is outside + * the int range. This case will be developed out of existence + * in Tcl 9. As interim measure, fail. */ + + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "byte sequence length exceeds INT_MAX", -1)); + } + *lengthPtr = 0; + return NULL; + } else { + *lengthPtr = (int) numBytes; + } + } + return bytes; +} /* *---------------------------------------------------------------------- diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 66ee818..6149699 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1752,6 +1752,9 @@ EXTERN char * Tcl_UniCharToUtfDString(const int *uniStr, /* 648 */ EXTERN int * Tcl_UtfToUniCharDString(const char *src, size_t length, Tcl_DString *dsPtr); +/* 649 */ +EXTERN unsigned char * Tcl_GetBytesFromObj(Tcl_Interp *interp, + Tcl_Obj *objPtr, int *lengthPtr); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2436,6 +2439,7 @@ typedef struct TclStubs { int (*tcl_UtfToUniChar) (const char *src, int *chPtr); /* 646 */ char * (*tcl_UniCharToUtfDString) (const int *uniStr, size_t uniLength, Tcl_DString *dsPtr); /* 647 */ int * (*tcl_UtfToUniCharDString) (const char *src, size_t length, Tcl_DString *dsPtr); /* 648 */ + unsigned char * (*tcl_GetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *lengthPtr); /* 649 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3702,6 +3706,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_UniCharToUtfDString) /* 647 */ #define Tcl_UtfToUniCharDString \ (tclStubsPtr->tcl_UtfToUniCharDString) /* 648 */ +#define Tcl_GetBytesFromObj \ + (tclStubsPtr->tcl_GetBytesFromObj) /* 649 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index a7c2f38..41a88b6 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1415,6 +1415,7 @@ const TclStubs tclStubs = { Tcl_UtfToUniChar, /* 646 */ Tcl_UniCharToUtfDString, /* 647 */ Tcl_UtfToUniCharDString, /* 648 */ + Tcl_GetBytesFromObj, /* 649 */ }; /* !END!: Do not edit above this line. */ -- cgit v0.12 From 21cab9a23cb26db0e4552b1871da3fbf33ea6558 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 17 Sep 2020 14:52:02 +0000 Subject: Fix testcase binary-80.4 when TCL_UTF_MAX=3 --- generic/tclBinary.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 21c544b..ae34135 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -609,7 +609,7 @@ MakeByteArray( Tcl_Obj *objPtr, size_t limit, int demandProper, - ByteArray **byteArrayPtrPtr) + ByteArray **byteArrayPtrPtr) { size_t length; const char *src = TclGetStringFromObj(objPtr, &length); @@ -622,8 +622,8 @@ MakeByteArray( int proper = 1; for (; src < srcEnd && dst < dstEnd; ) { - Tcl_UniChar ch; - int count = TclUtfToUniChar(src, &ch); + int ch; + int count = TclUtfToUCS4(src, &ch); if (ch > 255) { proper = 0; -- cgit v0.12 From 2a86d543545b1902bc81b6ad393d4c51fbecf402 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 21 Oct 2020 15:33:24 +0000 Subject: Finish correct implementation of stubbed TclZipfs_AppHook. Looks like complete now. --- doc/zipfs.3 | 3 ++- generic/tcl.h | 18 +++++++++--------- unix/dltest/Makefile.in | 2 +- unix/dltest/embtest.c | 35 ++++++++++++++++++++++++++++++----- 4 files changed, 42 insertions(+), 16 deletions(-) diff --git a/doc/zipfs.3 b/doc/zipfs.3 index 348557f..f810ec9 100644 --- a/doc/zipfs.3 +++ b/doc/zipfs.3 @@ -10,6 +10,7 @@ .so man.macros .BS .SH NAME +const char * TclZipfs_AppHook, Tclzipfs_Mount, TclZipfs_MountBuffer, Tclzipfs_Unmount \- handle ZIP files as Tcl virtual filesystems .SH SYNOPSIS .nf @@ -87,7 +88,7 @@ it uses WCHAR instead of char. As a result, it requires your application to be compiled with the UNICODE preprocessor symbol defined (e.g., via the \fB-DUNICODE\fR compiler flag). .PP -The result of \fBTclZipfs_AppHook\fR is a Tcl result code (e.g., \fBTCL_OK\fR +The result of \fBTclZipfs_AppHook\fR is the Tcl version string(e.g., \fB"9.0"\fR when the function is successful). The function \fImay\fR modify the variables pointed to by \fIargcPtr\fR and \fIargvPtr\fR to remove arguments; the current implementation does not do so, but callers \fIshould not\fR assume diff --git a/generic/tcl.h b/generic/tcl.h index fe73018..653fc6f 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2215,22 +2215,22 @@ extern void *TclStubCall(void *arg); #define Tcl_SetPanicProc(panicProc) \ TclInitStubTable(((const char *(*)(Tcl_PanicProc *))TclStubCall((void *)panicProc))(panicProc)) #define Tcl_InitSubsystems() \ - TclInitStubTable(((const char *(*)(void))TclStubCall(INT2PTR(1)))()) + TclInitStubTable(((const char *(*)(void))TclStubCall((void *)1))()) #define Tcl_FindExecutable(argv0) \ - TclInitStubTable(((const char *(*)(const char *))TclStubCall(INT2PTR(1)))(argv0)) + TclInitStubTable(((const char *(*)(const char *))TclStubCall((void *)2))(argv0)) #if !defined(_WIN32) || !defined(UNICODE) #define Tcl_MainEx(argc, argv, appInitProc, interp) \ - ((void(*)(int, const void *, Tcl_AppInitProc *, Tcl_Interp *)) \ - TclStubCall(INT2PTR(3)))(argc, argv, appInitProc, interp) + (void)((void(*)(int, const void *, Tcl_AppInitProc *, Tcl_Interp *)) \ + TclStubCall((void *)3))(argc, argv, appInitProc, interp) #endif #define Tcl_MainExW(argc, argv, appInitProc, interp) \ - ((void(*)(int, const void *, Tcl_AppInitProc *, Tcl_Interp *)) \ - TclStubCall(INT2PTR(4)))(argc, argv, appInitProc, interp) + (void)((const char *(*)(int, const void *, Tcl_AppInitProc *, Tcl_Interp *)) \ + TclStubCall((void *)4))(argc, argv, appInitProc, interp) #define Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc) \ - ((void(*)(Tcl_Interp *, const char *, Tcl_PackageInitProc *, Tcl_PackageInitProc *)) \ - TclStubCall(INT2PTR(5)))(interp, pkgName, initProc, safeInitProc) + ((const char *(*)(Tcl_Interp *, const char *, Tcl_PackageInitProc *, Tcl_PackageInitProc *)) \ + TclStubCall((void *)5))(interp, pkgName, initProc, safeInitProc) #define TclZipfs_AppHook(argcp, argvp) \ - ((const char *(*)(int *, void *))TclStubCall(INT2PTR(6)))(argcp, argvp) + TclInitStubTable(((const char *(*)(int *, void *))TclStubCall((void *)6))(argcp, argvp)) #endif /* diff --git a/unix/dltest/Makefile.in b/unix/dltest/Makefile.in index 165b859..dfee25a 100644 --- a/unix/dltest/Makefile.in +++ b/unix/dltest/Makefile.in @@ -57,7 +57,7 @@ pkgooa.o: $(SRC_DIR)/pkgooa.c $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgooa.c embtest: embtest.o - $(SHLIB_LD) -o $@ embtest.o ${SHLIB_LD_LIBS} -lc + $(CC) -o $@ embtest.o ${SHLIB_LD_LIBS} pkga${SHLIB_SUFFIX}: pkga.o ${SHLIB_LD} -o $@ pkga.o ${SHLIB_LD_LIBS} diff --git a/unix/dltest/embtest.c b/unix/dltest/embtest.c index c6724c3..1111268 100644 --- a/unix/dltest/embtest.c +++ b/unix/dltest/embtest.c @@ -1,11 +1,36 @@ #include "tcl.h" #include -int main() { - const char *version = Tcl_SetPanicProc(Tcl_ConsolePanic); +MODULE_SCOPE const TclStubs *tclStubsPtr; - if (version != NULL) { - printf("OK. version = %s\n", version); +int main(int argc, char **argv) { + const char *version; + int exitcode = 0; + + if (tclStubsPtr != NULL) { + printf("ERROR: stub table is already initialized"); + exitcode = 1; + } + tclStubsPtr = NULL; + version = Tcl_SetPanicProc(Tcl_ConsolePanic); + if (tclStubsPtr == NULL) { + printf("ERROR: Tcl_SetPanicProc does not initialize the stub table\n"); + exitcode = 1; + } + tclStubsPtr = NULL; + version = Tcl_InitSubsystems(); + if (tclStubsPtr == NULL) { + printf("ERROR: Tcl_InitSubsystems does not initialize the stub table\n"); + exitcode = 1; + } + tclStubsPtr = NULL; + version = Tcl_FindExecutable(argv[0]); + if (tclStubsPtr == NULL) { + printf("ERROR: Tcl_FindExecutable does not initialize the stub table\n"); + exitcode = 1; + } + if (!exitcode) { + printf("All OK!\n"); } - return 0; + return exitcode; } -- cgit v0.12 From b64263906d5ccdfc8d2eb75c1bccec3aacb898fa Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 23 Oct 2020 15:44:08 +0000 Subject: Add 2 more supported funtions to TclStubCall() --- compat/zlib/win32/zlib1.dll | Bin compat/zlib/win64/zlib1.dll | Bin doc/zipfs.3 | 3 +-- generic/tcl.h | 18 +++++++++++------- generic/tclStubCall.c | 30 ++++++++++++++++++++---------- 5 files changed, 32 insertions(+), 19 deletions(-) mode change 100644 => 100755 compat/zlib/win32/zlib1.dll mode change 100644 => 100755 compat/zlib/win64/zlib1.dll diff --git a/compat/zlib/win32/zlib1.dll b/compat/zlib/win32/zlib1.dll old mode 100644 new mode 100755 diff --git a/compat/zlib/win64/zlib1.dll b/compat/zlib/win64/zlib1.dll old mode 100644 new mode 100755 diff --git a/doc/zipfs.3 b/doc/zipfs.3 index f810ec9..f1efc65 100644 --- a/doc/zipfs.3 +++ b/doc/zipfs.3 @@ -10,11 +10,10 @@ .so man.macros .BS .SH NAME -const char * TclZipfs_AppHook, Tclzipfs_Mount, TclZipfs_MountBuffer, Tclzipfs_Unmount \- handle ZIP files as Tcl virtual filesystems .SH SYNOPSIS .nf -int +const char * \fBTclZipfs_AppHook(\fIargcPtr, argvPtr\fR) .sp int diff --git a/generic/tcl.h b/generic/tcl.h index 1d6dad0..0c75a4e 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2218,19 +2218,23 @@ extern void *TclStubCall(void *arg); TclInitStubTable(((const char *(*)(void))TclStubCall((void *)1))()) #define Tcl_FindExecutable(argv0) \ TclInitStubTable(((const char *(*)(const char *))TclStubCall((void *)2))(argv0)) +#define TclZipfs_AppHook(argcp, argvp) \ + TclInitStubTable(((const char *(*)(int *, void *))TclStubCall((void *)3))(argcp, argvp)) +#define Tcl_MainExW(argc, argv, appInitProc, interp) \ + (void)((const char *(*)(int, const void *, Tcl_AppInitProc *, Tcl_Interp *)) \ + TclStubCall((void *)4))(argc, argv, appInitProc, interp) #if !defined(_WIN32) || !defined(UNICODE) #define Tcl_MainEx(argc, argv, appInitProc, interp) \ (void)((const char *(*)(int, const void *, Tcl_AppInitProc *, Tcl_Interp *)) \ - TclStubCall((void *)3))(argc, argv, appInitProc, interp) + TclStubCall((void *)5))(argc, argv, appInitProc, interp) #endif -#define Tcl_MainExW(argc, argv, appInitProc, interp) \ - (void)((const char *(*)(int, const void *, Tcl_AppInitProc *, Tcl_Interp *)) \ - TclStubCall((void *)4))(argc, argv, appInitProc, interp) #define Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc) \ (void)((const char *(*)(Tcl_Interp *, const char *, Tcl_PackageInitProc *, Tcl_PackageInitProc *)) \ - TclStubCall((void *)5))(interp, pkgName, initProc, safeInitProc) -#define TclZipfs_AppHook(argcp, argvp) \ - TclInitStubTable(((const char *(*)(int *, void *))TclStubCall((void *)6))(argcp, argvp)) + TclStubCall((void *)6))(interp, pkgName, initProc, safeInitProc) +#define Tcl_SetExitProc(proc) \ + ((Tcl_ExitProc *(*)(Tcl_ExitProc *))TclStubCall((void *)7))(proc) +#define Tcl_GetMemoryInfo(dsPtr) \ + (void)((const char *(*)(Tcl_DString *))TclStubCall((void *)8))(dsPtr) #endif /* diff --git a/generic/tclStubCall.c b/generic/tclStubCall.c index da8d47a..0036e3a 100644 --- a/generic/tclStubCall.c +++ b/generic/tclStubCall.c @@ -21,22 +21,32 @@ MODULE_SCOPE void *tclStubsHandle; * * TclStubCall -- * - * Load the Tcl core dynamically, version "9.0" (or higher, in future versions) + * Load the Tcl core dynamically, version "9.0" (or higher, in future versions). * * Results: - * Outputs a function returning the value of the "version" argument or NULL. + * Returns a function from the Tcl dynamic library or a function + * returning NULL if that function cannot be found. See PROCNAME table. + * + * The functions Tcl_MainEx and Tcl_MainExW never return. + * Tcl_GetMemoryInfo and Tcl_StaticPackage return (void) and + * Tcl_SetExitProc returns its previous exitProc. This means that + * those 5 functions cannot be used to initialize the stub-table, + * only the first 4 functions in the table can do that. * *---------------------------------------------------------------------- */ +/* Table containing which function will be returned, depending on the "arg" */ static const char PROCNAME[][24] = { - "_Tcl_SetPanicProc", - "_Tcl_InitSubsystems", - "_Tcl_FindExecutable", - "_Tcl_MainEx", - "_Tcl_MainExW", - "_Tcl_StaticPackage", - "_TclZipfs_AppHook" + "_Tcl_SetPanicProc", /* Default, whenever "arg" <= 0 or "arg" > 8 */ + "_Tcl_InitSubsystems", /* "arg" == (void *)1 */ + "_Tcl_FindExecutable", /* "arg" == (void *)2 */ + "_TclZipfs_AppHook", /* "arg" == (void *)3 */ + "_Tcl_MainExW", /* "arg" == (void *)4 */ + "_Tcl_MainEx", /* "arg" == (void *)5 */ + "_Tcl_StaticPackage", /* "arg" == (void *)6 */ + "_Tcl_SetExitProc", /* "arg" == (void *)7 */ + "_Tcl_GetMemoryInfo" /* "arg" == (void *)8 */ }; MODULE_SCOPE const void *nullVersionProc(void) { @@ -52,7 +62,7 @@ TclStubCall(void *arg) static void *stubFn[] = {NULL,NULL,NULL,NULL,NULL,NULL,NULL}; unsigned index = PTR2UINT(arg); - if (index > 6) { + if (index > sizeof(PROCNAME)/sizeof(PROCNAME[0])) { /* Any other value means Tcl_SetPanicProc() with non-null panicProc */ index = 0; } -- cgit v0.12 From 9bf0f01d3d518909dba4fddd22b5eefdad229a83 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 25 Oct 2020 19:27:54 +0000 Subject: Fix (g++) Travis build --- generic/tclStubCall.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclStubCall.c b/generic/tclStubCall.c index 42111a9..8fe7892 100644 --- a/generic/tclStubCall.c +++ b/generic/tclStubCall.c @@ -90,7 +90,7 @@ TclStubCall(void *arg) if (!stubFn[index]) { stubFn[index] = dlsym(tclStubsHandle, PROCNAME[index]); if (!stubFn[index]) { - stubFn[index] = nullVersionProc; + stubFn[index] = (void *)nullVersionProc; } } } -- cgit v0.12 From 9d4d81102579f655e9220ef0f705bb2a058d6ce3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 9 Nov 2020 16:12:37 +0000 Subject: Possible solution for [ea39ab591e], making simply everything case-insensitive. TODO: TIP, documentation, code cleanup --- generic/tclLoad.c | 27 +++++++++++++++------------ 1 file changed, 15 insertions(+), 12 deletions(-) diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 5090493..36c7457 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -226,8 +226,6 @@ Tcl_LoadObjCmd( Tcl_DStringAppend(&pkgName, packageName, -1); TclDStringClear(&tmp); Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1); - Tcl_UtfToLower(Tcl_DStringValue(&pkgName)); - Tcl_UtfToLower(Tcl_DStringValue(&tmp)); if (strcmp(Tcl_DStringValue(&tmp), Tcl_DStringValue(&pkgName)) == 0) { namesMatch = 1; @@ -321,6 +319,12 @@ Tcl_LoadObjCmd( splitPtr = Tcl_FSSplitPath(objv[1], &pElements); Tcl_ListObjIndex(NULL, splitPtr, pElements -1, &pkgGuessPtr); pkgGuess = TclGetString(pkgGuessPtr); +#if defined(_WIN32) || defined(__CYGWIN__) + if ((pkgGuess[0] == 'w') && (pkgGuess[1] == 'i') + && (pkgGuess[2] == 'n')) { + pkgGuess += 3; + } else +#endif /* __CYGWIN__ */ if ((pkgGuess[0] == 'l') && (pkgGuess[1] == 'i') && (pkgGuess[2] == 'b')) { pkgGuess += 3; @@ -351,16 +355,17 @@ Tcl_LoadObjCmd( } Tcl_DStringAppend(&pkgName, pkgGuess, p - pkgGuess); Tcl_DecrRefCount(splitPtr); - } - /* - * Fix the capitalization in the package name so that the first - * character is in caps (or title case) but the others are all - * lower-case. - */ + /* + * Fix the capitalization in the package name so that the first + * character is in caps (or title case) but the others are all + * lower-case. + */ - Tcl_DStringSetLength(&pkgName, - Tcl_UtfToTitle(Tcl_DStringValue(&pkgName))); + Tcl_DStringSetLength(&pkgName, + Tcl_UtfToTitle(Tcl_DStringValue(&pkgName))); + + } /* * Compute the names of the two initialization functions, based on the @@ -656,8 +661,6 @@ Tcl_UnloadObjCmd( Tcl_DStringAppend(&pkgName, packageName, -1); TclDStringClear(&tmp); Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1); - Tcl_UtfToLower(Tcl_DStringValue(&pkgName)); - Tcl_UtfToLower(Tcl_DStringValue(&tmp)); if (strcmp(Tcl_DStringValue(&tmp), Tcl_DStringValue(&pkgName)) == 0) { namesMatch = 1; -- cgit v0.12 From 062875b88e20fd9dea45ddd120f20df6a307ba3e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 10 Nov 2020 14:51:44 +0000 Subject: Merge 9.0. Code/documentation cleanup --- .travis.yml | 2 +- doc/PkgRequire.3 | 2 +- doc/StaticLibrary.3 | 73 ++++++++ doc/StaticPkg.3 | 73 -------- doc/load.n | 75 ++++---- generic/tcl.decls | 4 +- generic/tcl.h | 3 +- generic/tclCmdIL.c | 2 +- generic/tclInt.decls | 2 +- generic/tclInt.h | 2 +- generic/tclIntDecls.h | 16 +- generic/tclLoad.c | 354 +++++++++++++++++------------------ generic/tclStubInit.c | 6 +- generic/tclTest.c | 16 +- macosx/Tcl.xcode/project.pbxproj | 4 +- macosx/Tcl.xcodeproj/project.pbxproj | 4 +- tests/load.test | 98 +++++----- tests/safe.test | 2 +- tests/unload.test | 22 +-- unix/tclAppInit.c | 2 +- win/tcl.dsp | 2 +- win/tclAppInit.c | 6 +- 22 files changed, 381 insertions(+), 389 deletions(-) create mode 100644 doc/StaticLibrary.3 delete mode 100644 doc/StaticPkg.3 diff --git a/.travis.yml b/.travis.yml index a7c1d2f..5c5ae80 100644 --- a/.travis.yml +++ b/.travis.yml @@ -243,7 +243,7 @@ jobs: script: - cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=static,msvcrt' '-f' makefile.vc all tcltest - cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=static,msvcrt' '-f' makefile.vc test - - name: "Windows/MSVC/StaticPackage" + - name: "Windows/MSVC/StaticPkg" os: windows compiler: cl env: *vcenv diff --git a/doc/PkgRequire.3 b/doc/PkgRequire.3 index 71f3acf..f32c936 100644 --- a/doc/PkgRequire.3 +++ b/doc/PkgRequire.3 @@ -94,4 +94,4 @@ compatibility and translate their invocations to this form. .SH KEYWORDS package, present, provide, require, version .SH "SEE ALSO" -package(n), Tcl_StaticPackage(3) +package(n), Tcl_StaticLibrary(3) diff --git a/doc/StaticLibrary.3 b/doc/StaticLibrary.3 new file mode 100644 index 0000000..ecd064c --- /dev/null +++ b/doc/StaticLibrary.3 @@ -0,0 +1,73 @@ +'\" +'\" Copyright (c) 1995-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +.TH Tcl_StaticLibrary 3 7.5 Tcl "Tcl Library Procedures" +.so man.macros +.BS +.SH NAME +Tcl_StaticLibrary \- make a statically linked package available via the 'load' command +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +\fBTcl_StaticLibrary\fR(\fIinterp, pkgName, initProc, safeInitProc\fR) +.SH ARGUMENTS +.AS Tcl_PackageInitProc *safeInitProc +.AP Tcl_Interp *interp in +If not NULL, points to an interpreter into which the package has +already been loaded (i.e., the caller has already invoked the +appropriate initialization procedure). NULL means the package +has not yet been incorporated into any interpreter. +.AP "const char" *pkgName in +Name of the package; should be properly capitalized (first letter +upper-case, all others lower-case). +.AP Tcl_PackageInitProc *initProc in +Procedure to invoke to incorporate this package into a trusted +interpreter. +.AP Tcl_PackageInitProc *safeInitProc in +Procedure to call to incorporate this package into a safe interpreter +(one that will execute untrusted scripts). NULL means the package +cannot be used in safe interpreters. +.BE +.SH DESCRIPTION +.PP +This procedure may be invoked to announce that a package has been +linked statically with a Tcl application and, optionally, that it +has already been loaded into an interpreter. +Once \fBTcl_StaticLibrary\fR has been invoked for a package, it +may be loaded into interpreters using the \fBload\fR command. +\fBTcl_StaticLibrary\fR is normally invoked only by the \fBTcl_AppInit\fR +procedure for the application, not by packages for themselves +(\fBTcl_StaticLibrary\fR should only be invoked for statically +loaded packages, and code in the package itself should not need +to know whether the package is dynamically or statically loaded). +.PP +When the \fBload\fR command is used later to load the package into +an interpreter, one of \fIinitProc\fR and \fIsafeInitProc\fR will +be invoked, depending on whether the target interpreter is safe +or not. +\fIinitProc\fR and \fIsafeInitProc\fR must both match the +following prototype: +.PP +.CS +typedef int \fBTcl_PackageInitProc\fR( + Tcl_Interp *\fIinterp\fR); +.CE +.PP +The \fIinterp\fR argument identifies the interpreter in which the package +is to be loaded. The initialization procedure must return \fBTCL_OK\fR or +\fBTCL_ERROR\fR to indicate whether or not it completed successfully; in +the event of an error it should set the interpreter's result to point to an +error message. The result or error from the initialization procedure will +be returned as the result of the \fBload\fR command that caused the +initialization procedure to be invoked. +.PP +\fBTcl_StaticLibrary\fR can not be safely used by stub-enabled extensions, +so its symbol is not included in the stub table. +.SH KEYWORDS +initialization procedure, package, static linking +.SH "SEE ALSO" +load(n), package(n), Tcl_PkgRequire(3) diff --git a/doc/StaticPkg.3 b/doc/StaticPkg.3 deleted file mode 100644 index a28652e..0000000 --- a/doc/StaticPkg.3 +++ /dev/null @@ -1,73 +0,0 @@ -'\" -'\" Copyright (c) 1995-1996 Sun Microsystems, Inc. -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH Tcl_StaticPackage 3 7.5 Tcl "Tcl Library Procedures" -.so man.macros -.BS -.SH NAME -Tcl_StaticPackage \- make a statically linked package available via the 'load' command -.SH SYNOPSIS -.nf -\fB#include \fR -.sp -\fBTcl_StaticPackage\fR(\fIinterp, pkgName, initProc, safeInitProc\fR) -.SH ARGUMENTS -.AS Tcl_PackageInitProc *safeInitProc -.AP Tcl_Interp *interp in -If not NULL, points to an interpreter into which the package has -already been loaded (i.e., the caller has already invoked the -appropriate initialization procedure). NULL means the package -has not yet been incorporated into any interpreter. -.AP "const char" *pkgName in -Name of the package; should be properly capitalized (first letter -upper-case, all others lower-case). -.AP Tcl_PackageInitProc *initProc in -Procedure to invoke to incorporate this package into a trusted -interpreter. -.AP Tcl_PackageInitProc *safeInitProc in -Procedure to call to incorporate this package into a safe interpreter -(one that will execute untrusted scripts). NULL means the package -cannot be used in safe interpreters. -.BE -.SH DESCRIPTION -.PP -This procedure may be invoked to announce that a package has been -linked statically with a Tcl application and, optionally, that it -has already been loaded into an interpreter. -Once \fBTcl_StaticPackage\fR has been invoked for a package, it -may be loaded into interpreters using the \fBload\fR command. -\fBTcl_StaticPackage\fR is normally invoked only by the \fBTcl_AppInit\fR -procedure for the application, not by packages for themselves -(\fBTcl_StaticPackage\fR should only be invoked for statically -loaded packages, and code in the package itself should not need -to know whether the package is dynamically or statically loaded). -.PP -When the \fBload\fR command is used later to load the package into -an interpreter, one of \fIinitProc\fR and \fIsafeInitProc\fR will -be invoked, depending on whether the target interpreter is safe -or not. -\fIinitProc\fR and \fIsafeInitProc\fR must both match the -following prototype: -.PP -.CS -typedef int \fBTcl_PackageInitProc\fR( - Tcl_Interp *\fIinterp\fR); -.CE -.PP -The \fIinterp\fR argument identifies the interpreter in which the package -is to be loaded. The initialization procedure must return \fBTCL_OK\fR or -\fBTCL_ERROR\fR to indicate whether or not it completed successfully; in -the event of an error it should set the interpreter's result to point to an -error message. The result or error from the initialization procedure will -be returned as the result of the \fBload\fR command that caused the -initialization procedure to be invoked. -.PP -\fBTcl_StaticPackage\fR can not be safely used by stub-enabled extensions, -so its symbol is not included in the stub table. -.SH KEYWORDS -initialization procedure, package, static linking -.SH "SEE ALSO" -load(n), package(n), Tcl_PkgRequire(3) diff --git a/doc/load.n b/doc/load.n index 03b4f4e..b8a26ae 100644 --- a/doc/load.n +++ b/doc/load.n @@ -13,22 +13,21 @@ load \- Load machine code and initialize new commands .SH SYNOPSIS \fBload\fR ?\fB\-global\fR? ?\fB\-lazy\fR? ?\fB\-\-\fR? \fIfileName\fR .br -\fBload\fR ?\fB\-global\fR? ?\fB\-lazy\fR? ?\fB\-\-\fR? \fIfileName packageName\fR +\fBload\fR ?\fB\-global\fR? ?\fB\-lazy\fR? ?\fB\-\-\fR? \fIfileName prefix\fR .br -\fBload\fR ?\fB\-global\fR? ?\fB\-lazy\fR? ?\fB\-\-\fR? \fIfileName packageName interp\fR +\fBload\fR ?\fB\-global\fR? ?\fB\-lazy\fR? ?\fB\-\-\fR? \fIfileName prefix interp\fR .BE .SH DESCRIPTION .PP This command loads binary code from a file into the application's address space and calls an initialization procedure -in the package to incorporate it into an interpreter. \fIfileName\fR +in the library to incorporate it into an interpreter. \fIfileName\fR is the name of the file containing the code; its exact form varies from system to system but on most systems it is a shared library, such as a \fB.so\fR file under Solaris or a DLL under Windows. -\fIpackageName\fR is the name of the package, and is used to -compute the name of an initialization procedure. +\fIprefix\fR is used to compute the name of an initialization procedure. \fIinterp\fR is the path name of the interpreter into which to load -the package (see the \fBinterp\fR manual entry for details); +the library (see the \fBinterp\fR manual entry for details); if \fIinterp\fR is omitted, it defaults to the interpreter in which the \fBload\fR command was invoked. .PP @@ -37,21 +36,19 @@ one of two initialization procedures will be invoked in the new code. Typically the initialization procedure will add new commands to a Tcl interpreter. The name of the initialization procedure is determined by -\fIpackageName\fR and whether or not the target interpreter +\fIprefix\fR and whether or not the target interpreter is a safe one. For normal interpreters the name of the initialization -procedure will have the form \fIpkg\fB_Init\fR, where \fIpkg\fR -is the same as \fIpackageName\fR except that the first letter is -converted to upper case and all other letters -are converted to lower case. For example, if \fIpackageName\fR is -\fBfoo\fR or \fBFOo\fR, the initialization procedure's name will +procedure will have the form \fIprefix\fB_Init\fR, where \fIprefix\fR +is the same as \fIprefix\fR. For example, if \fIprefix\fR is +\fBFoo\fR, the initialization procedure's name will be \fBFoo_Init\fR. .PP If the target interpreter is a safe interpreter, then the name -of the initialization procedure will be \fIpkg\fB_SafeInit\fR -instead of \fIpkg\fB_Init\fR. -The \fIpkg\fB_SafeInit\fR function should be written carefully, so that it +of the initialization procedure will be \fIprefix\fB_SafeInit\fR +instead of \fIprefix\fB_Init\fR. +The \fIprefix\fB_SafeInit\fR function should be written carefully, so that it initializes the safe interpreter only with partial functionality provided -by the package that is safe for use by untrusted code. For more information +by the library that is safe for use by untrusted code. For more information on Safe\-Tcl, see the \fBsafe\fR manual entry. .PP The initialization procedure must match the following prototype: @@ -62,7 +59,7 @@ typedef int \fBTcl_PackageInitProc\fR( .CE .PP The \fIinterp\fR argument identifies the interpreter in which the -package is to be loaded. The initialization procedure must return +library is to be loaded. The initialization procedure must return \fBTCL_OK\fR or \fBTCL_ERROR\fR to indicate whether or not it completed successfully; in the event of an error it should set the interpreter's result to point to an error message. The result of the \fBload\fR command @@ -74,36 +71,34 @@ interpreters, then the first \fBload\fR will load the code and call the initialization procedure; subsequent \fBload\fRs will call the initialization procedure without loading the code again. For Tcl versions lower than 8.5, it is not possible to unload or reload a -package. From version 8.5 however, the \fBunload\fR command allows the unloading +library. From version 8.5 however, the \fBunload\fR command allows the unloading of libraries loaded with \fBload\fR, for libraries that are aware of the Tcl's unloading mechanism. .PP -The \fBload\fR command also supports packages that are statically -linked with the application, if those packages have been registered -by calling the \fBTcl_StaticPackage\fR procedure. -If \fIfileName\fR is an empty string, then \fIpackageName\fR must +The \fBload\fR command also supports libraries that are statically +linked with the application, if those libraries have been registered +by calling the \fBTcl_StaticLibrary\fR procedure. +If \fIfileName\fR is an empty string, then \fIprefix\fR must be specified. .PP -If \fIpackageName\fR is omitted or specified as an empty string, -Tcl tries to guess the name of the package. -This may be done differently on different platforms. -The default guess, which is used on most UNIX platforms, is to -take the last element of \fIfileName\fR, strip off the first -three characters if they are \fBlib\fR, and use any following -alphabetic and underline characters as the module name. -For example, the command \fBload libxyz4.2.so\fR uses the module -name \fBxyz\fR and the command \fBload bin/last.so {}\fR uses the -module name \fBlast\fR. -.PP -If \fIfileName\fR is an empty string, then \fIpackageName\fR must +If \fIprefix\fR is omitted or specified as an empty string, +Tcl tries to guess the prefix by taking the last element of +\fIfileName\fR, strip off the first three characters if they +are \fBlib\fR, and use any following alphabetic and underline +characters, converted to titlecase as the prefix. +For example, the command \fBload libxyz4.2.so\fR uses the prefix +\fBxyz\fR and the command \fBload bin/last.so {}\fR uses the +prefix \fBlast\fR. +.PP +If \fIfileName\fR is an empty string, then \fIprefix\fR must be specified. -The \fBload\fR command first searches for a statically loaded package -(one that has been registered by calling the \fBTcl_StaticPackage\fR +The \fBload\fR command first searches for a statically loaded library +(one that has been registered by calling the \fBTcl_StaticLibrary\fR procedure) by that name; if one is found, it is used. Otherwise, the \fBload\fR command searches for a dynamically loaded -package by that name, and uses it if it is found. If several +library by that name, and uses it if it is found. If several different files have been \fBload\fRed with different versions of -the package, Tcl picks the file that was loaded first. +the library, Tcl picks the file that was loaded first. .PP If \fB\-global\fR is specified preceding the filename, all symbols found in the shared library are exported for global use by other @@ -111,7 +106,7 @@ libraries. The option \fB\-lazy\fR delays the actual loading of symbols until their first actual use. The options may be abbreviated. The option \fB\-\-\fR indicates the end of the options, and should be used if you wish to use a filename which starts with \fB\-\fR -and you provide a packageName to the \fBload\fR command. +and you provide a prefix to the \fBload\fR command. .PP On platforms which do not support the \fB\-global\fR or \fB\-lazy\fR options, the options still exist but have no effect. Note that use @@ -188,7 +183,7 @@ switch $tcl_platform(platform) { foo .CE .SH "SEE ALSO" -info sharedlibextension, package(n), Tcl_StaticPackage(3), safe(n) +info sharedlibextension, package(n), Tcl_StaticLibrary(3), safe(n) .SH KEYWORDS binary code, dynamic library, load, safe interpreter, shared library '\"Local Variables: diff --git a/generic/tcl.decls b/generic/tcl.decls index 4a58a20..ff97dfc 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -888,7 +888,7 @@ declare 243 { } # Removed in 9.0 (stub entry only) #declare 244 { -# void Tcl_StaticPackage(Tcl_Interp *interp, const char *pkgName, +# void Tcl_StaticLibrary(Tcl_Interp *interp, const char *prefix, # Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc) #} # Removed in 9.0 (stub entry only) @@ -2514,7 +2514,7 @@ export { Tcl_Interp *interp) } export { - void Tcl_StaticPackage(Tcl_Interp *interp, const char *pkgName, + void Tcl_StaticLibrary(Tcl_Interp *interp, const char *prefix, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc) } export { diff --git a/generic/tcl.h b/generic/tcl.h index eb6d2fe..a87c5d4 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2189,10 +2189,11 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); EXTERN void Tcl_FindExecutable(const char *argv0); EXTERN void Tcl_SetPanicProc( TCL_NORETURN1 Tcl_PanicProc *panicProc); -EXTERN void Tcl_StaticPackage(Tcl_Interp *interp, +EXTERN void Tcl_StaticLibrary(Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); +#define Tcl_StaticPackage Tcl_StaticLibrary EXTERN Tcl_ExitProc *Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc); #ifdef _WIN32 EXTERN int TclZipfs_AppHook(int *argc, wchar_t ***argv); diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 5a8ef22..4536d18 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -1699,7 +1699,7 @@ InfoLoadedCmd( } else { /* Get pkgs just in specified interp. */ packageName = TclGetString(objv[2]); } - return TclGetLoadedPackagesEx(interp, interpName, packageName); + return TclGetLoadedLibraries(interp, interpName, packageName); } /* diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 5b02fb4..e764bc4 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -1058,7 +1058,7 @@ declare 256 { Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags) } declare 257 { - void TclStaticPackage(Tcl_Interp *interp, const char *pkgName, + void TclStaticLibrary(Tcl_Interp *interp, const char *prefix, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc) } diff --git a/generic/tclInt.h b/generic/tclInt.h index 2a0dfa6..cd0f148 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2975,7 +2975,7 @@ MODULE_SCOPE Tcl_Obj * TclGetSourceFromFrame(CmdFrame *cfPtr, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE char * TclGetStringStorage(Tcl_Obj *objPtr, size_t *sizePtr); -MODULE_SCOPE int TclGetLoadedPackagesEx(Tcl_Interp *interp, +MODULE_SCOPE int TclGetLoadedLibraries(Tcl_Interp *interp, const char *targetName, const char *packageName); MODULE_SCOPE int TclGetWideBitsFromObj(Tcl_Interp *, Tcl_Obj *, diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index e870aac..cf8d660 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -570,8 +570,8 @@ EXTERN int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 257 */ -EXTERN void TclStaticPackage(Tcl_Interp *interp, - const char *pkgName, +EXTERN void TclStaticLibrary(Tcl_Interp *interp, + const char *prefix, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 258 */ @@ -845,7 +845,7 @@ typedef struct TclIntStubs { Tcl_Obj * (*tclPtrIncrObjVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, const int flags); /* 254 */ int (*tclPtrObjMakeUpvar) (Tcl_Interp *interp, Tcl_Var otherPtr, Tcl_Obj *myNamePtr, int myFlags); /* 255 */ int (*tclPtrUnsetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 256 */ - void (*tclStaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 257 */ + void (*tclStaticLibrary) (Tcl_Interp *interp, const char *prefix, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 257 */ Tcl_Obj * (*tclpCreateTemporaryDirectory) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj); /* 258 */ void (*tclAppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, size_t length); /* 259 */ unsigned char * (*tclGetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, size_t *lengthPtr); /* 260 */ @@ -1260,8 +1260,8 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclPtrObjMakeUpvar) /* 255 */ #define TclPtrUnsetVar \ (tclIntStubsPtr->tclPtrUnsetVar) /* 256 */ -#define TclStaticPackage \ - (tclIntStubsPtr->tclStaticPackage) /* 257 */ +#define TclStaticLibrary \ + (tclIntStubsPtr->tclStaticLibrary) /* 257 */ #define TclpCreateTemporaryDirectory \ (tclIntStubsPtr->tclpCreateTemporaryDirectory) /* 258 */ #define TclAppendUnicodeToObj \ @@ -1274,9 +1274,9 @@ extern const TclIntStubs *tclIntStubsPtr; /* !END!: Do not edit above this line. */ #if defined(USE_TCL_STUBS) -#undef Tcl_StaticPackage -#define Tcl_StaticPackage \ - (tclIntStubsPtr->tclStaticPackage) +#undef Tcl_StaticLibrary +#define Tcl_StaticLibrary \ + (tclIntStubsPtr->tclStaticLibrary) #endif /* defined(USE_TCL_STUBS) */ #undef TCL_STORAGE_CLASS diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 36c7457..67bc2cc 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -15,19 +15,17 @@ /* * The following structure describes a package that has been loaded either * dynamically (with the "load" command) or statically (as indicated by a call - * to TclGetLoadedPackages). All such packages are linked together into a + * to TclGetLoadedLibraries). All such packages are linked together into a * single list for the process. Packages are never unloaded, until the * application exits, when TclFinalizeLoad is called, and these structures are * freed. */ -typedef struct LoadedPackage { +typedef struct LoadedLibrary { char *fileName; /* Name of the file from which the package was * loaded. An empty string means the package * is loaded statically. Malloc-ed. */ - char *packageName; /* Name of package prefix for the package, - * properly capitalized (first letter UC, - * others LC), no "_", as in "Net". + char *prefix; /* Prefix for the library. * Malloc-ed. */ Tcl_LoadHandle loadHandle; /* Token for the loaded file which should be * passed to (*unLoadProcPtr)() when the file @@ -55,23 +53,23 @@ typedef struct LoadedPackage { * in trusted interpreters. */ int safeInterpRefCount; /* How many times the package has been loaded * in safe interpreters. */ - struct LoadedPackage *nextPtr; + struct LoadedLibrary *nextPtr; /* Next in list of all packages loaded into * this application process. NULL means end of * list. */ -} LoadedPackage; +} LoadedLibrary; /* * TCL_THREADS - * There is a global list of packages that is anchored at firstPackagePtr. + * There is a global list of packages that is anchored at firstLibraryPtr. * Access to this list is governed by a mutex. */ -static LoadedPackage *firstPackagePtr = NULL; +static LoadedLibrary *firstLibraryPtr = NULL; /* First in list of all packages loaded into * this process. */ -TCL_DECLARE_MUTEX(packageMutex) +TCL_DECLARE_MUTEX(libraryMutex) /* * The following structure represents a particular package that has been @@ -82,7 +80,7 @@ TCL_DECLARE_MUTEX(packageMutex) */ typedef struct InterpPackage { - LoadedPackage *pkgPtr; /* Points to detailed information about + LoadedLibrary *libraryPtr; /* Points to detailed information about * package. */ struct InterpPackage *nextPtr; /* Next package in this interpreter, or NULL @@ -121,14 +119,14 @@ Tcl_LoadObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Interp *target; - LoadedPackage *pkgPtr, *defaultPtr; + LoadedLibrary *libraryPtr, *defaultPtr; Tcl_DString pkgName, tmp, initName, safeInitName; Tcl_DString unloadName, safeUnloadName; InterpPackage *ipFirstPtr, *ipPtr; int code, namesMatch, filesMatch, offset; const char *symbols[2]; Tcl_PackageInitProc *initProc; - const char *p, *fullFileName, *packageName; + const char *p, *fullFileName, *prefix; Tcl_LoadHandle loadHandle; Tcl_UniChar ch = 0; size_t len; @@ -159,7 +157,7 @@ Tcl_LoadObjCmd( } } if ((objc < 2) || (objc > 4)) { - Tcl_WrongNumArgs(interp, 1, savedobjv, "?-global? ?-lazy? ?--? fileName ?packageName? ?interp?"); + Tcl_WrongNumArgs(interp, 1, savedobjv, "?-global? ?-lazy? ?--? fileName ?prefix? ?interp?"); return TCL_ERROR; } if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) { @@ -174,14 +172,14 @@ Tcl_LoadObjCmd( Tcl_DStringInit(&safeUnloadName); Tcl_DStringInit(&tmp); - packageName = NULL; + prefix = NULL; if (objc >= 3) { - packageName = TclGetString(objv[2]); - if (packageName[0] == '\0') { - packageName = NULL; + prefix = TclGetString(objv[2]); + if (prefix[0] == '\0') { + prefix = NULL; } } - if ((fullFileName[0] == 0) && (packageName == NULL)) { + if ((fullFileName[0] == 0) && (prefix == NULL)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "must specify either file name or package name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOLIBRARY", @@ -215,17 +213,17 @@ Tcl_LoadObjCmd( * only no statically loaded package with the same name. */ - Tcl_MutexLock(&packageMutex); + Tcl_MutexLock(&libraryMutex); defaultPtr = NULL; - for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { - if (packageName == NULL) { + for (libraryPtr = firstLibraryPtr; libraryPtr != NULL; libraryPtr = libraryPtr->nextPtr) { + if (prefix == NULL) { namesMatch = 0; } else { TclDStringClear(&pkgName); - Tcl_DStringAppend(&pkgName, packageName, -1); + Tcl_DStringAppend(&pkgName, prefix, -1); TclDStringClear(&tmp); - Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1); + Tcl_DStringAppend(&tmp, libraryPtr->prefix, -1); if (strcmp(Tcl_DStringValue(&tmp), Tcl_DStringValue(&pkgName)) == 0) { namesMatch = 1; @@ -235,12 +233,12 @@ Tcl_LoadObjCmd( } TclDStringClear(&pkgName); - filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0); - if (filesMatch && (namesMatch || (packageName == NULL))) { + filesMatch = (strcmp(libraryPtr->fileName, fullFileName) == 0); + if (filesMatch && (namesMatch || (prefix == NULL))) { break; } if (namesMatch && (fullFileName[0] == 0)) { - defaultPtr = pkgPtr; + defaultPtr = libraryPtr; } if (filesMatch && !namesMatch && (fullFileName[0] != 0)) { /* @@ -249,17 +247,17 @@ Tcl_LoadObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "file \"%s\" is already loaded for package \"%s\"", - fullFileName, pkgPtr->packageName)); + fullFileName, libraryPtr->prefix)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "SPLITPERSONALITY", NULL); code = TCL_ERROR; - Tcl_MutexUnlock(&packageMutex); + Tcl_MutexUnlock(&libraryMutex); goto done; } } - Tcl_MutexUnlock(&packageMutex); - if (pkgPtr == NULL) { - pkgPtr = defaultPtr; + Tcl_MutexUnlock(&libraryMutex); + if (libraryPtr == NULL) { + libraryPtr = defaultPtr; } /* @@ -268,17 +266,17 @@ Tcl_LoadObjCmd( * there's nothing for us to do. */ - if (pkgPtr != NULL) { + if (libraryPtr != NULL) { ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL); for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { - if (ipPtr->pkgPtr == pkgPtr) { + if (ipPtr->libraryPtr == libraryPtr) { code = TCL_OK; goto done; } } } - if (pkgPtr == NULL) { + if (libraryPtr == NULL) { /* * The desired file isn't currently loaded, so load it. It's an error * if the desired package is a static one. @@ -286,7 +284,7 @@ Tcl_LoadObjCmd( if (fullFileName[0] == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "package \"%s\" isn't loaded statically", packageName)); + "no library with prefix \"%s\" is loaded statically", prefix)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOTSTATIC", NULL); code = TCL_ERROR; @@ -297,8 +295,8 @@ Tcl_LoadObjCmd( * Figure out the module name if it wasn't provided explicitly. */ - if (packageName != NULL) { - Tcl_DStringAppend(&pkgName, packageName, -1); + if (prefix != NULL) { + Tcl_DStringAppend(&pkgName, prefix, -1); } else { Tcl_Obj *splitPtr, *pkgGuessPtr; int pElements; @@ -389,10 +387,10 @@ Tcl_LoadObjCmd( symbols[0] = Tcl_DStringValue(&initName); symbols[1] = NULL; - Tcl_MutexLock(&packageMutex); + Tcl_MutexLock(&libraryMutex); code = Tcl_LoadFile(interp, objv[1], symbols, flags, &initProc, &loadHandle); - Tcl_MutexUnlock(&packageMutex); + Tcl_MutexUnlock(&libraryMutex); if (code != TCL_OK) { goto done; } @@ -401,31 +399,31 @@ Tcl_LoadObjCmd( * Create a new record to describe this package. */ - pkgPtr = (LoadedPackage *)Tcl_Alloc(sizeof(LoadedPackage)); + libraryPtr = (LoadedLibrary *)Tcl_Alloc(sizeof(LoadedLibrary)); len = strlen(fullFileName) + 1; - pkgPtr->fileName = (char *)Tcl_Alloc(len); - memcpy(pkgPtr->fileName, fullFileName, len); + libraryPtr->fileName = (char *)Tcl_Alloc(len); + memcpy(libraryPtr->fileName, fullFileName, len); len = Tcl_DStringLength(&pkgName) + 1; - pkgPtr->packageName = (char *)Tcl_Alloc(len); - memcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName), len); - pkgPtr->loadHandle = loadHandle; - pkgPtr->initProc = initProc; - pkgPtr->safeInitProc = (Tcl_PackageInitProc *) + libraryPtr->prefix = (char *)Tcl_Alloc(len); + memcpy(libraryPtr->prefix, Tcl_DStringValue(&pkgName), len); + libraryPtr->loadHandle = loadHandle; + libraryPtr->initProc = initProc; + libraryPtr->safeInitProc = (Tcl_PackageInitProc *) Tcl_FindSymbol(interp, loadHandle, Tcl_DStringValue(&safeInitName)); - pkgPtr->unloadProc = (Tcl_PackageUnloadProc *) + libraryPtr->unloadProc = (Tcl_PackageUnloadProc *) Tcl_FindSymbol(interp, loadHandle, Tcl_DStringValue(&unloadName)); - pkgPtr->safeUnloadProc = (Tcl_PackageUnloadProc *) + libraryPtr->safeUnloadProc = (Tcl_PackageUnloadProc *) Tcl_FindSymbol(interp, loadHandle, Tcl_DStringValue(&safeUnloadName)); - pkgPtr->interpRefCount = 0; - pkgPtr->safeInterpRefCount = 0; + libraryPtr->interpRefCount = 0; + libraryPtr->safeInterpRefCount = 0; - Tcl_MutexLock(&packageMutex); - pkgPtr->nextPtr = firstPackagePtr; - firstPackagePtr = pkgPtr; - Tcl_MutexUnlock(&packageMutex); + Tcl_MutexLock(&libraryMutex); + libraryPtr->nextPtr = firstLibraryPtr; + firstLibraryPtr = libraryPtr; + Tcl_MutexUnlock(&libraryMutex); /* * The Tcl_FindSymbol calls may have left a spurious error message in @@ -441,27 +439,27 @@ Tcl_LoadObjCmd( */ if (Tcl_IsSafe(target)) { - if (pkgPtr->safeInitProc == NULL) { + if (libraryPtr->safeInitProc == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't use package in a safe interpreter: no" - " %s_SafeInit procedure", pkgPtr->packageName)); + " %s_SafeInit procedure", libraryPtr->prefix)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "UNSAFE", NULL); code = TCL_ERROR; goto done; } - code = pkgPtr->safeInitProc(target); + code = libraryPtr->safeInitProc(target); } else { - if (pkgPtr->initProc == NULL) { + if (libraryPtr->initProc == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't attach package to interpreter: no %s_Init procedure", - pkgPtr->packageName)); + libraryPtr->prefix)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "ENTRYPOINT", NULL); code = TCL_ERROR; goto done; } - code = pkgPtr->initProc(target); + code = libraryPtr->initProc(target); } /* @@ -492,13 +490,13 @@ Tcl_LoadObjCmd( * Update the proper reference count. */ - Tcl_MutexLock(&packageMutex); + Tcl_MutexLock(&libraryMutex); if (Tcl_IsSafe(target)) { - pkgPtr->safeInterpRefCount++; + libraryPtr->safeInterpRefCount++; } else { - pkgPtr->interpRefCount++; + libraryPtr->interpRefCount++; } - Tcl_MutexUnlock(&packageMutex); + Tcl_MutexUnlock(&libraryMutex); /* * Refetch ipFirstPtr: loading the package may have introduced additional @@ -507,7 +505,7 @@ Tcl_LoadObjCmd( ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL); ipPtr = (InterpPackage *)Tcl_Alloc(sizeof(InterpPackage)); - ipPtr->pkgPtr = pkgPtr; + ipPtr->libraryPtr = libraryPtr; ipPtr->nextPtr = ipFirstPtr; Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipPtr); @@ -546,14 +544,14 @@ Tcl_UnloadObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Interp *target; /* Which interpreter to unload from. */ - LoadedPackage *pkgPtr, *defaultPtr; + LoadedLibrary *libraryPtr, *defaultPtr; Tcl_DString pkgName, tmp; Tcl_PackageUnloadProc *unloadProc; InterpPackage *ipFirstPtr, *ipPtr; int i, index, code, complain = 1, keepLibrary = 0; int trustedRefCount = -1, safeRefCount = -1; const char *fullFileName = ""; - const char *packageName; + const char *prefix; static const char *const options[] = { "-nocomplain", "-keeplibrary", "--", NULL }; @@ -597,7 +595,7 @@ Tcl_UnloadObjCmd( endOfForLoop: if ((objc-i < 1) || (objc-i > 3)) { Tcl_WrongNumArgs(interp, 1, objv, - "?-switch ...? fileName ?packageName? ?interp?"); + "?-switch ...? fileName ?prefix? ?interp?"); return TCL_ERROR; } if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) { @@ -608,14 +606,14 @@ Tcl_UnloadObjCmd( Tcl_DStringInit(&pkgName); Tcl_DStringInit(&tmp); - packageName = NULL; + prefix = NULL; if (objc - i >= 2) { - packageName = TclGetString(objv[i+1]); - if (packageName[0] == '\0') { - packageName = NULL; + prefix = TclGetString(objv[i+1]); + if (prefix[0] == '\0') { + prefix = NULL; } } - if ((fullFileName[0] == 0) && (packageName == NULL)) { + if ((fullFileName[0] == 0) && (prefix == NULL)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "must specify either file name or package name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NOLIBRARY", @@ -648,19 +646,19 @@ Tcl_UnloadObjCmd( * only no statically loaded package with the same name. */ - Tcl_MutexLock(&packageMutex); + Tcl_MutexLock(&libraryMutex); defaultPtr = NULL; - for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { + for (libraryPtr = firstLibraryPtr; libraryPtr != NULL; libraryPtr = libraryPtr->nextPtr) { int namesMatch, filesMatch; - if (packageName == NULL) { + if (prefix == NULL) { namesMatch = 0; } else { TclDStringClear(&pkgName); - Tcl_DStringAppend(&pkgName, packageName, -1); + Tcl_DStringAppend(&pkgName, prefix, -1); TclDStringClear(&tmp); - Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1); + Tcl_DStringAppend(&tmp, libraryPtr->prefix, -1); if (strcmp(Tcl_DStringValue(&tmp), Tcl_DStringValue(&pkgName)) == 0) { namesMatch = 1; @@ -670,32 +668,32 @@ Tcl_UnloadObjCmd( } TclDStringClear(&pkgName); - filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0); - if (filesMatch && (namesMatch || (packageName == NULL))) { + filesMatch = (strcmp(libraryPtr->fileName, fullFileName) == 0); + if (filesMatch && (namesMatch || (prefix == NULL))) { break; } if (namesMatch && (fullFileName[0] == 0)) { - defaultPtr = pkgPtr; + defaultPtr = libraryPtr; } if (filesMatch && !namesMatch && (fullFileName[0] != 0)) { break; } } - Tcl_MutexUnlock(&packageMutex); + Tcl_MutexUnlock(&libraryMutex); if (fullFileName[0] == 0) { /* * It's an error to try unload a static package. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "package \"%s\" is loaded statically and cannot be unloaded", - packageName)); + "library with prefix \"%s\" is loaded statically and cannot be unloaded", + prefix)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "STATIC", NULL); code = TCL_ERROR; goto done; } - if (pkgPtr == NULL) { + if (libraryPtr == NULL) { /* * The DLL pointed by the provided filename has never been loaded. */ @@ -715,10 +713,10 @@ Tcl_UnloadObjCmd( */ code = TCL_ERROR; - if (pkgPtr != NULL) { + if (libraryPtr != NULL) { ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL); for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { - if (ipPtr->pkgPtr == pkgPtr) { + if (ipPtr->libraryPtr == libraryPtr) { code = TCL_OK; break; } @@ -740,12 +738,12 @@ Tcl_UnloadObjCmd( /* * Ensure that the DLL can be unloaded. If it is a trusted interpreter, - * pkgPtr->unloadProc must not be NULL for the DLL to be unloadable. If - * the interpreter is a safe one, pkgPtr->safeUnloadProc must be non-NULL. + * libraryPtr->unloadProc must not be NULL for the DLL to be unloadable. If + * the interpreter is a safe one, libraryPtr->safeUnloadProc must be non-NULL. */ if (Tcl_IsSafe(target)) { - if (pkgPtr->safeUnloadProc == NULL) { + if (libraryPtr->safeUnloadProc == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "file \"%s\" cannot be unloaded under a safe interpreter", fullFileName)); @@ -754,9 +752,9 @@ Tcl_UnloadObjCmd( code = TCL_ERROR; goto done; } - unloadProc = pkgPtr->safeUnloadProc; + unloadProc = libraryPtr->safeUnloadProc; } else { - if (pkgPtr->unloadProc == NULL) { + if (libraryPtr->unloadProc == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "file \"%s\" cannot be unloaded under a trusted interpreter", fullFileName)); @@ -765,7 +763,7 @@ Tcl_UnloadObjCmd( code = TCL_ERROR; goto done; } - unloadProc = pkgPtr->unloadProc; + unloadProc = libraryPtr->unloadProc; } /* @@ -780,10 +778,10 @@ Tcl_UnloadObjCmd( code = TCL_UNLOAD_DETACH_FROM_INTERPRETER; if (!keepLibrary) { - Tcl_MutexLock(&packageMutex); - trustedRefCount = pkgPtr->interpRefCount; - safeRefCount = pkgPtr->safeInterpRefCount; - Tcl_MutexUnlock(&packageMutex); + Tcl_MutexLock(&libraryMutex); + trustedRefCount = libraryPtr->interpRefCount; + safeRefCount = libraryPtr->safeInterpRefCount; + Tcl_MutexUnlock(&libraryMutex); if (Tcl_IsSafe(target)) { safeRefCount--; @@ -806,34 +804,34 @@ Tcl_UnloadObjCmd( * if we unload the DLL. */ - Tcl_MutexLock(&packageMutex); + Tcl_MutexLock(&libraryMutex); if (Tcl_IsSafe(target)) { - pkgPtr->safeInterpRefCount--; + libraryPtr->safeInterpRefCount--; /* * Do not let counter get negative. */ - if (pkgPtr->safeInterpRefCount < 0) { - pkgPtr->safeInterpRefCount = 0; + if (libraryPtr->safeInterpRefCount < 0) { + libraryPtr->safeInterpRefCount = 0; } } else { - pkgPtr->interpRefCount--; + libraryPtr->interpRefCount--; /* * Do not let counter get negative. */ - if (pkgPtr->interpRefCount < 0) { - pkgPtr->interpRefCount = 0; + if (libraryPtr->interpRefCount < 0) { + libraryPtr->interpRefCount = 0; } } - trustedRefCount = pkgPtr->interpRefCount; - safeRefCount = pkgPtr->safeInterpRefCount; - Tcl_MutexUnlock(&packageMutex); + trustedRefCount = libraryPtr->interpRefCount; + safeRefCount = libraryPtr->safeInterpRefCount; + Tcl_MutexUnlock(&libraryMutex); code = TCL_OK; - if (pkgPtr->safeInterpRefCount <= 0 && pkgPtr->interpRefCount <= 0 + if (libraryPtr->safeInterpRefCount <= 0 && libraryPtr->interpRefCount <= 0 && !keepLibrary) { /* * Unload the shared library from the application memory... @@ -847,21 +845,21 @@ Tcl_UnloadObjCmd( * it's been unloaded. */ - if (pkgPtr->fileName[0] != '\0') { - Tcl_MutexLock(&packageMutex); - if (Tcl_FSUnloadFile(interp, pkgPtr->loadHandle) == TCL_OK) { + if (libraryPtr->fileName[0] != '\0') { + Tcl_MutexLock(&libraryMutex); + if (Tcl_FSUnloadFile(interp, libraryPtr->loadHandle) == TCL_OK) { /* * Remove this library from the loaded library cache. */ - defaultPtr = pkgPtr; - if (defaultPtr == firstPackagePtr) { - firstPackagePtr = pkgPtr->nextPtr; + defaultPtr = libraryPtr; + if (defaultPtr == firstLibraryPtr) { + firstLibraryPtr = libraryPtr->nextPtr; } else { - for (pkgPtr = firstPackagePtr; pkgPtr != NULL; - pkgPtr = pkgPtr->nextPtr) { - if (pkgPtr->nextPtr == defaultPtr) { - pkgPtr->nextPtr = defaultPtr->nextPtr; + for (libraryPtr = firstLibraryPtr; libraryPtr != NULL; + libraryPtr = libraryPtr->nextPtr) { + if (libraryPtr->nextPtr == defaultPtr) { + libraryPtr->nextPtr = defaultPtr->nextPtr; break; } } @@ -873,14 +871,14 @@ Tcl_UnloadObjCmd( ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL); ipPtr = ipFirstPtr; - if (ipPtr->pkgPtr == defaultPtr) { + if (ipPtr->libraryPtr == defaultPtr) { ipFirstPtr = ipFirstPtr->nextPtr; } else { InterpPackage *ipPrevPtr; for (ipPrevPtr = ipPtr; ipPtr != NULL; ipPrevPtr = ipPtr, ipPtr = ipPtr->nextPtr) { - if (ipPtr->pkgPtr == defaultPtr) { + if (ipPtr->libraryPtr == defaultPtr) { ipPrevPtr->nextPtr = ipPtr->nextPtr; break; } @@ -889,10 +887,10 @@ Tcl_UnloadObjCmd( Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipFirstPtr); Tcl_Free(defaultPtr->fileName); - Tcl_Free(defaultPtr->packageName); + Tcl_Free(defaultPtr->prefix); Tcl_Free(defaultPtr); Tcl_Free(ipPtr); - Tcl_MutexUnlock(&packageMutex); + Tcl_MutexUnlock(&libraryMutex); } else { code = TCL_ERROR; } @@ -920,7 +918,7 @@ Tcl_UnloadObjCmd( /* *---------------------------------------------------------------------- * - * Tcl_StaticPackage -- + * Tcl_StaticLibrary -- * * This function is invoked to indicate that a particular package has * been linked statically with an application. @@ -936,14 +934,12 @@ Tcl_UnloadObjCmd( */ void -Tcl_StaticPackage( +Tcl_StaticLibrary( Tcl_Interp *interp, /* If not NULL, it means that the package has * already been loaded into the given * interpreter by calling the appropriate init * proc. */ - const char *pkgName, /* Name of package (must be properly - * capitalized: first letter upper case, - * others lower case). */ + const char *prefix, /* Prefix. */ Tcl_PackageInitProc *initProc, /* Function to call to incorporate this * package into a trusted interpreter. */ @@ -954,7 +950,7 @@ Tcl_StaticPackage( * the package can't be used in safe * interpreters. */ { - LoadedPackage *pkgPtr; + LoadedLibrary *libraryPtr; InterpPackage *ipPtr, *ipFirstPtr; /* @@ -962,34 +958,34 @@ Tcl_StaticPackage( * statically loaded in the process. */ - Tcl_MutexLock(&packageMutex); - for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { - if ((pkgPtr->initProc == initProc) - && (pkgPtr->safeInitProc == safeInitProc) - && (strcmp(pkgPtr->packageName, pkgName) == 0)) { + Tcl_MutexLock(&libraryMutex); + for (libraryPtr = firstLibraryPtr; libraryPtr != NULL; libraryPtr = libraryPtr->nextPtr) { + if ((libraryPtr->initProc == initProc) + && (libraryPtr->safeInitProc == safeInitProc) + && (strcmp(libraryPtr->prefix, prefix) == 0)) { break; } } - Tcl_MutexUnlock(&packageMutex); + Tcl_MutexUnlock(&libraryMutex); /* * If the package is not yet recorded as being loaded statically, add it * to the list now. */ - if (pkgPtr == NULL) { - pkgPtr = (LoadedPackage *)Tcl_Alloc(sizeof(LoadedPackage)); - pkgPtr->fileName = (char *)Tcl_Alloc(1); - pkgPtr->fileName[0] = 0; - pkgPtr->packageName = (char *)Tcl_Alloc(strlen(pkgName) + 1); - strcpy(pkgPtr->packageName, pkgName); - pkgPtr->loadHandle = NULL; - pkgPtr->initProc = initProc; - pkgPtr->safeInitProc = safeInitProc; - Tcl_MutexLock(&packageMutex); - pkgPtr->nextPtr = firstPackagePtr; - firstPackagePtr = pkgPtr; - Tcl_MutexUnlock(&packageMutex); + if (libraryPtr == NULL) { + libraryPtr = (LoadedLibrary *)Tcl_Alloc(sizeof(LoadedLibrary)); + libraryPtr->fileName = (char *)Tcl_Alloc(1); + libraryPtr->fileName[0] = 0; + libraryPtr->prefix = (char *)Tcl_Alloc(strlen(prefix) + 1); + strcpy(libraryPtr->prefix, prefix); + libraryPtr->loadHandle = NULL; + libraryPtr->initProc = initProc; + libraryPtr->safeInitProc = safeInitProc; + Tcl_MutexLock(&libraryMutex); + libraryPtr->nextPtr = firstLibraryPtr; + firstLibraryPtr = libraryPtr; + Tcl_MutexUnlock(&libraryMutex); } if (interp != NULL) { @@ -1001,7 +997,7 @@ Tcl_StaticPackage( ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(interp, "tclLoad", NULL); for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { - if (ipPtr->pkgPtr == pkgPtr) { + if (ipPtr->libraryPtr == libraryPtr) { return; } } @@ -1012,7 +1008,7 @@ Tcl_StaticPackage( */ ipPtr = (InterpPackage *)Tcl_Alloc(sizeof(InterpPackage)); - ipPtr->pkgPtr = pkgPtr; + ipPtr->libraryPtr = libraryPtr; ipPtr->nextPtr = ipFirstPtr; Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc, ipPtr); } @@ -1021,7 +1017,7 @@ Tcl_StaticPackage( /* *---------------------------------------------------------------------- * - * TclGetLoadedPackagesEx -- + * TclGetLoadedLibraries -- * * This function returns information about all of the files that are * loaded (either in a particular interpreter, or for all interpreters). @@ -1040,33 +1036,33 @@ Tcl_StaticPackage( */ int -TclGetLoadedPackagesEx( +TclGetLoadedLibraries( Tcl_Interp *interp, /* Interpreter in which to return information * or error message. */ const char *targetName, /* Name of target interpreter or NULL. If * NULL, return info about all interps; * otherwise, just return info about this * interpreter. */ - const char *packageName) /* Package name or NULL. If NULL, return info + const char *prefix) /* Package name or NULL. If NULL, return info * for all packages. */ { Tcl_Interp *target; - LoadedPackage *pkgPtr; + LoadedLibrary *libraryPtr; InterpPackage *ipPtr; Tcl_Obj *resultObj, *pkgDesc[2]; if (targetName == NULL) { TclNewObj(resultObj); - Tcl_MutexLock(&packageMutex); - for (pkgPtr = firstPackagePtr; pkgPtr != NULL; - pkgPtr = pkgPtr->nextPtr) { - pkgDesc[0] = Tcl_NewStringObj(pkgPtr->fileName, -1); - pkgDesc[1] = Tcl_NewStringObj(pkgPtr->packageName, -1); + Tcl_MutexLock(&libraryMutex); + for (libraryPtr = firstLibraryPtr; libraryPtr != NULL; + libraryPtr = libraryPtr->nextPtr) { + pkgDesc[0] = Tcl_NewStringObj(libraryPtr->fileName, -1); + pkgDesc[1] = Tcl_NewStringObj(libraryPtr->prefix, -1); Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewListObj(2, pkgDesc)); } - Tcl_MutexUnlock(&packageMutex); + Tcl_MutexUnlock(&libraryMutex); Tcl_SetObjResult(interp, resultObj); return TCL_OK; } @@ -1080,14 +1076,14 @@ TclGetLoadedPackagesEx( /* * Return information about all of the available packages. */ - if (packageName) { + if (prefix) { resultObj = NULL; for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { - pkgPtr = ipPtr->pkgPtr; + libraryPtr = ipPtr->libraryPtr; - if (!strcmp(packageName, pkgPtr->packageName)) { - resultObj = Tcl_NewStringObj(pkgPtr->fileName, -1); + if (!strcmp(prefix, libraryPtr->prefix)) { + resultObj = Tcl_NewStringObj(libraryPtr->fileName, -1); break; } } @@ -1105,9 +1101,9 @@ TclGetLoadedPackagesEx( TclNewObj(resultObj); for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { - pkgPtr = ipPtr->pkgPtr; - pkgDesc[0] = Tcl_NewStringObj(pkgPtr->fileName, -1); - pkgDesc[1] = Tcl_NewStringObj(pkgPtr->packageName, -1); + libraryPtr = ipPtr->libraryPtr; + pkgDesc[0] = Tcl_NewStringObj(libraryPtr->fileName, -1); + pkgDesc[1] = Tcl_NewStringObj(libraryPtr->prefix, -1); Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewListObj(2, pkgDesc)); } Tcl_SetObjResult(interp, resultObj); @@ -1154,7 +1150,7 @@ LoadCleanupProc( * TclFinalizeLoad -- * * This function is invoked just before the application exits. It frees - * all of the LoadedPackage structures. + * all of the LoadedLibrary structures. * * Results: * None. @@ -1168,18 +1164,18 @@ LoadCleanupProc( void TclFinalizeLoad(void) { - LoadedPackage *pkgPtr; + LoadedLibrary *libraryPtr; /* * No synchronization here because there should just be one thread alive - * at this point. Logically, packageMutex should be grabbed at this point, + * at this point. Logically, libraryMutex should be grabbed at this point, * but the Mutexes get finalized before the call to this routine. The only * subsystem left alive at this point is the memory allocator. */ - while (firstPackagePtr != NULL) { - pkgPtr = firstPackagePtr; - firstPackagePtr = pkgPtr->nextPtr; + while (firstLibraryPtr != NULL) { + libraryPtr = firstLibraryPtr; + firstLibraryPtr = libraryPtr->nextPtr; #if defined(TCL_UNLOAD_DLLS) || defined(_WIN32) /* @@ -1189,14 +1185,14 @@ TclFinalizeLoad(void) * it has been unloaded. */ - if (pkgPtr->fileName[0] != '\0') { - Tcl_FSUnloadFile(NULL, pkgPtr->loadHandle); + if (libraryPtr->fileName[0] != '\0') { + Tcl_FSUnloadFile(NULL, libraryPtr->loadHandle); } #endif - Tcl_Free(pkgPtr->fileName); - Tcl_Free(pkgPtr->packageName); - Tcl_Free(pkgPtr); + Tcl_Free(libraryPtr->fileName); + Tcl_Free(libraryPtr->prefix); + Tcl_Free(libraryPtr); } } diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 93529d1..12e0272 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -60,9 +60,9 @@ #undef TclWinGetSockOpt #undef TclWinSetSockOpt #undef TclWinNToHS -#undef TclStaticPackage +#undef TclStaticLibrary #undef Tcl_BackgroundError -#define TclStaticPackage Tcl_StaticPackage +#define TclStaticLibrary Tcl_StaticLibrary #undef Tcl_UniCharToUtfDString #undef Tcl_UtfToUniCharDString #undef Tcl_UtfToUniChar @@ -528,7 +528,7 @@ static const TclIntStubs tclIntStubs = { TclPtrIncrObjVar, /* 254 */ TclPtrObjMakeUpvar, /* 255 */ TclPtrUnsetVar, /* 256 */ - TclStaticPackage, /* 257 */ + TclStaticLibrary, /* 257 */ TclpCreateTemporaryDirectory, /* 258 */ TclAppendUnicodeToObj, /* 259 */ TclGetBytesFromObj, /* 260 */ diff --git a/generic/tclTest.c b/generic/tclTest.c index 91e3b49..502d9c9 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -274,7 +274,7 @@ static Tcl_CmdProc Testset2Cmd; static Tcl_CmdProc TestseterrorcodeCmd; static Tcl_ObjCmdProc TestsetobjerrorcodeCmd; static Tcl_CmdProc TestsetplatformCmd; -static Tcl_CmdProc TeststaticpkgCmd; +static Tcl_CmdProc TeststaticlibraryCmd; static Tcl_CmdProc TesttranslatefilenameCmd; static Tcl_CmdProc TestupvarCmd; static Tcl_ObjCmdProc TestWrongNumArgsObjCmd; @@ -601,7 +601,7 @@ Tcltest_Init( NULL, NULL); Tcl_CreateCommand(interp, "testsocket", TestSocketCmd, NULL, NULL); - Tcl_CreateCommand(interp, "teststaticpkg", TeststaticpkgCmd, + Tcl_CreateCommand(interp, "teststaticlibrary", TeststaticlibraryCmd, NULL, NULL); Tcl_CreateCommand(interp, "testtranslatefilename", TesttranslatefilenameCmd, NULL, NULL); @@ -4217,10 +4217,10 @@ TestsetplatformCmd( /* *---------------------------------------------------------------------- * - * TeststaticpkgCmd -- + * TeststaticlibraryCmd -- * - * This procedure implements the "teststaticpkg" command. - * It is used to test the procedure Tcl_StaticPackage. + * This procedure implements the "teststaticlibrary" command. + * It is used to test the procedure Tcl_StaticLibrary. * * Results: * A standard Tcl result. @@ -4233,7 +4233,7 @@ TestsetplatformCmd( */ static int -TeststaticpkgCmd( +TeststaticlibraryCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ @@ -4243,7 +4243,7 @@ TeststaticpkgCmd( if (argc != 4) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", - argv[0], " pkgName safe loaded\"", NULL); + argv[0], " prefix safe loaded\"", NULL); return TCL_ERROR; } if (Tcl_GetInt(interp, argv[2], &safe) != TCL_OK) { @@ -4252,7 +4252,7 @@ TeststaticpkgCmd( if (Tcl_GetInt(interp, argv[3], &loaded) != TCL_OK) { return TCL_ERROR; } - Tcl_StaticPackage((loaded) ? interp : NULL, argv[1], + Tcl_StaticLibrary((loaded) ? interp : NULL, argv[1], StaticInitProc, (safe) ? StaticInitProc : NULL); return TCL_OK; } diff --git a/macosx/Tcl.xcode/project.pbxproj b/macosx/Tcl.xcode/project.pbxproj index 8004ffe..6a3b921 100644 --- a/macosx/Tcl.xcode/project.pbxproj +++ b/macosx/Tcl.xcode/project.pbxproj @@ -394,7 +394,7 @@ F96D3EA208F272A7004A47F5 /* split.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = split.n; sourceTree = ""; }; F96D3EA308F272A7004A47F5 /* SplitList.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = SplitList.3; sourceTree = ""; }; F96D3EA408F272A7004A47F5 /* SplitPath.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = SplitPath.3; sourceTree = ""; }; - F96D3EA508F272A7004A47F5 /* StaticPkg.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = StaticPkg.3; sourceTree = ""; }; + F96D3EA508F272A7004A47F5 /* StaticLibrary.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = StaticLibrary.3; sourceTree = ""; }; F96D3EA608F272A7004A47F5 /* StdChannels.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = StdChannels.3; sourceTree = ""; }; F96D3EA708F272A7004A47F5 /* string.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = string.n; sourceTree = ""; }; F96D3EA808F272A7004A47F5 /* StringObj.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = StringObj.3; sourceTree = ""; }; @@ -1149,7 +1149,7 @@ F96D3EA208F272A7004A47F5 /* split.n */, F96D3EA308F272A7004A47F5 /* SplitList.3 */, F96D3EA408F272A7004A47F5 /* SplitPath.3 */, - F96D3EA508F272A7004A47F5 /* StaticPkg.3 */, + F96D3EA508F272A7004A47F5 /* StaticLibrary.3 */, F96D3EA608F272A7004A47F5 /* StdChannels.3 */, F96D3EA708F272A7004A47F5 /* string.n */, F96D3EA808F272A7004A47F5 /* StringObj.3 */, diff --git a/macosx/Tcl.xcodeproj/project.pbxproj b/macosx/Tcl.xcodeproj/project.pbxproj index 6528616..47f522c 100644 --- a/macosx/Tcl.xcodeproj/project.pbxproj +++ b/macosx/Tcl.xcodeproj/project.pbxproj @@ -393,7 +393,7 @@ F96D3EA208F272A7004A47F5 /* split.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = split.n; sourceTree = ""; }; F96D3EA308F272A7004A47F5 /* SplitList.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = SplitList.3; sourceTree = ""; }; F96D3EA408F272A7004A47F5 /* SplitPath.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = SplitPath.3; sourceTree = ""; }; - F96D3EA508F272A7004A47F5 /* StaticPkg.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = StaticPkg.3; sourceTree = ""; }; + F96D3EA508F272A7004A47F5 /* StaticLibrary.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = StaticLibrary.3; sourceTree = ""; }; F96D3EA608F272A7004A47F5 /* StdChannels.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = StdChannels.3; sourceTree = ""; }; F96D3EA708F272A7004A47F5 /* string.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = string.n; sourceTree = ""; }; F96D3EA808F272A7004A47F5 /* StringObj.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = StringObj.3; sourceTree = ""; }; @@ -1149,7 +1149,7 @@ F96D3EA208F272A7004A47F5 /* split.n */, F96D3EA308F272A7004A47F5 /* SplitList.3 */, F96D3EA408F272A7004A47F5 /* SplitPath.3 */, - F96D3EA508F272A7004A47F5 /* StaticPkg.3 */, + F96D3EA508F272A7004A47F5 /* StaticLibrary.3 */, F96D3EA608F272A7004A47F5 /* StdChannels.3 */, F96D3EA708F272A7004A47F5 /* string.n */, F96D3EA808F272A7004A47F5 /* StringObj.3 */, diff --git a/tests/load.test b/tests/load.test index c79ddf4..eaaf7a7 100644 --- a/tests/load.test +++ b/tests/load.test @@ -36,9 +36,9 @@ testConstraint $loaded [expr {![string match *pkga* $alreadyLoaded]}] set alreadyTotalLoaded [info loaded] -# Certain tests require the 'teststaticpkg' command from tcltest +# Certain tests require the 'teststaticlibrary' command from tcltest -testConstraint teststaticpkg [llength [info commands teststaticpkg]] +testConstraint teststaticlibrary [llength [info commands teststaticlibrary]] # Test load-10.1 requires the 'testsimplefilesystem' command from tcltest @@ -47,10 +47,10 @@ testConstraint testsimplefilesystem \ test load-1.1 {basic errors} -returnCodes error -body { load -} -result {wrong # args: should be "load ?-global? ?-lazy? ?--? fileName ?packageName? ?interp?"} +} -result {wrong # args: should be "load ?-global? ?-lazy? ?--? fileName ?prefix? ?interp?"} test load-1.2 {basic errors} -returnCodes error -body { load a b c d -} -result {wrong # args: should be "load ?-global? ?-lazy? ?--? fileName ?packageName? ?interp?"} +} -result {wrong # args: should be "load ?-global? ?-lazy? ?--? fileName ?prefix? ?interp?"} test load-1.3 {basic errors} -returnCodes error -body { load a b foobar } -result {could not find interpreter "foobar"} @@ -62,7 +62,7 @@ test load-1.5 {basic errors} -returnCodes error -body { } -result {must specify either file name or package name} test load-1.6 {basic errors} -returnCodes error -body { load {} Unknown -} -result {package "Unknown" isn't loaded statically} +} -result {no library with prefix "Unknown" is loaded statically} test load-1.7 {basic errors} -returnCodes error -body { load -abc foo } -result {bad option "-abc": must be -global, -lazy, or --} @@ -78,13 +78,13 @@ test load-2.1 {basic loading, with guess for package name} \ interp create -safe child test load-2.2 {loading into a safe interpreter, with package name conversion} \ [list $dll $loaded] { - load -lazy [file join $testDir pkgb$ext] pKgB child + load -lazy [file join $testDir pkgb$ext] Pkgb child list [child eval pkgb_sub 44 13] [catch {child eval pkgb_unsafe} msg] $msg \ [catch {pkgb_sub 12 10} msg2] $msg2 } {31 1 {invalid command name "pkgb_unsafe"} 1 {invalid command name "pkgb_sub"}} test load-2.3 {loading with no _Init procedure} -constraints [list $dll $loaded] \ -body { - list [catch {load [file join $testDir pkgc$ext] foo} msg] $msg $errorCode + list [catch {load [file join $testDir pkgc$ext] Foo} msg] $msg $errorCode } -match glob \ -result [list 1 {cannot find symbol "Foo_Init"*} \ {TCL LOOKUP LOAD_SYMBOL *Foo_Init}] @@ -94,7 +94,7 @@ test load-2.4 {loading with no _SafeInit procedure} [list $dll $loaded] { test load-3.1 {error in _Init procedure, same interpreter} \ [list $dll $loaded] { - list [catch {load [file join $testDir pkge$ext] pkge} msg] \ + list [catch {load [file join $testDir pkge$ext] Pkge} msg] \ $msg $::errorInfo $::errorCode } {1 {couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory while executing @@ -102,14 +102,14 @@ test load-3.1 {error in _Init procedure, same interpreter} \ invoked from within "if 44 {open non_existent}" invoked from within -"load [file join $testDir pkge$ext] pkge"} {POSIX ENOENT {no such file or directory}}} +"load [file join $testDir pkge$ext] Pkge"} {POSIX ENOENT {no such file or directory}}} test load-3.2 {error in _Init procedure, child interpreter} \ [list $dll $loaded] { catch {interp delete x} interp create x set ::errorCode foo set ::errorInfo bar - set result [list [catch {load [file join $testDir pkge$ext] pkge x} msg] \ + set result [list [catch {load [file join $testDir pkge$ext] Pkge x} msg] \ $msg $::errorInfo $::errorCode] interp delete x set result @@ -119,23 +119,23 @@ test load-3.2 {error in _Init procedure, child interpreter} \ invoked from within "if 44 {open non_existent}" invoked from within -"load [file join $testDir pkge$ext] pkge x"} {POSIX ENOENT {no such file or directory}}} +"load [file join $testDir pkge$ext] Pkge x"} {POSIX ENOENT {no such file or directory}}} test load-4.1 {reloading package into same interpreter} [list $dll $loaded] { - list [catch {load [file join $testDir pkga$ext] pkga} msg] $msg + list [catch {load [file join $testDir pkga$ext] Pkga} msg] $msg } {0 {}} test load-4.2 {reloading package into same interpreter} -setup { catch {load [file join $testDir pkga$ext] pkga} } -constraints [list $dll $loaded] -returnCodes error -body { - load [file join $testDir pkga$ext] pkgb + load [file join $testDir pkga$ext] Pkgb } -result "file \"[file join $testDir pkga$ext]\" is already loaded for package \"Pkga\"" test load-5.1 {file name not specified and no static package: pick default} -setup { catch {interp delete x} interp create x } -constraints [list $dll $loaded] -body { - load -global [file join $testDir pkga$ext] pkga - load {} pkga x + load -global [file join $testDir pkga$ext] Pkga + load {} Pkga x info loaded x } -cleanup { interp delete x @@ -150,78 +150,78 @@ test load-6.1 {errors loading file} [list $dll $loaded] { catch {load foo foo} } {1} -test load-7.1 {Tcl_StaticPackage procedure} [list teststaticpkg] { +test load-7.1 {Tcl_StaticLibrary procedure} [list teststaticlibrary] { set x "not loaded" - teststaticpkg Test 1 0 + teststaticlibrary Test 1 0 load {} Test load {} Test child list [set x] [child eval set x] } {loaded loaded} -test load-7.2 {Tcl_StaticPackage procedure} [list teststaticpkg] { +test load-7.2 {Tcl_StaticLibrary procedure} [list teststaticlibrary] { set x "not loaded" - teststaticpkg Another 0 0 + teststaticlibrary Another 0 0 load {} Another child eval {set x "not loaded"} list [catch {load {} Another child} msg] $msg \ [child eval set x] [set x] } {1 {can't use package in a safe interpreter: no Another_SafeInit procedure} {not loaded} loaded} -test load-7.3 {Tcl_StaticPackage procedure} [list teststaticpkg] { +test load-7.3 {Tcl_StaticLibrary procedure} [list teststaticlibrary] { set x "not loaded" - teststaticpkg More 0 1 + teststaticlibrary More 0 1 load {} More set x } {not loaded} -catch {load [file join $testDir pkga$ext] pkga} -catch {load [file join $testDir pkgb$ext] pkgb} -catch {load [file join $testDir pkge$ext] pkge} +catch {load [file join $testDir pkga$ext] Pkga} +catch {load [file join $testDir pkgb$ext] Pkgb} +catch {load [file join $testDir pkge$ext] Pkge} set currentRealPackages [list [list [file join $testDir pkge$ext] Pkge] [list [file join $testDir pkgb$ext] Pkgb] [list [file join $testDir pkga$ext] Pkga]] -test load-7.4 {Tcl_StaticPackage procedure, redundant calls} -setup { - teststaticpkg Test 1 0 - teststaticpkg Another 0 0 - teststaticpkg More 0 1 -} -constraints [list teststaticpkg $dll $loaded] -body { - teststaticpkg Double 0 1 - teststaticpkg Double 0 1 +test load-7.4 {Tcl_StaticLibrary procedure, redundant calls} -setup { + teststaticlibrary Test 1 0 + teststaticlibrary Another 0 0 + teststaticlibrary More 0 1 +} -constraints [list teststaticlibrary $dll $loaded] -body { + teststaticlibrary Double 0 1 + teststaticlibrary Double 0 1 info loaded } -result [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealPackages {*}$alreadyTotalLoaded] -testConstraint teststaticpkg_8.x 0 -if {[testConstraint teststaticpkg]} { +testConstraint teststaticlibrary_8.x 0 +if {[testConstraint teststaticlibrary]} { catch { - teststaticpkg Test 1 1 - teststaticpkg Another 0 1 - teststaticpkg More 0 1 - teststaticpkg Double 0 1 - testConstraint teststaticpkg_8.x 1 + teststaticlibrary Test 1 1 + teststaticlibrary Another 0 1 + teststaticlibrary More 0 1 + teststaticlibrary Double 0 1 + testConstraint teststaticlibrary_8.x 1 } } -test load-8.1 {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] { +test load-8.1 {TclGetLoadedPackages procedure} [list teststaticlibrary_8.x $dll $loaded] { lsort -index 1 [info loaded] } [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealPackages {*}$alreadyTotalLoaded]] -test load-8.2 {TclGetLoadedPackages procedure} -constraints {teststaticpkg_8.x} -body { +test load-8.2 {TclGetLoadedPackages procedure} -constraints {teststaticlibrary_8.x} -body { info loaded gorp } -returnCodes error -result {could not find interpreter "gorp"} -test load-8.3a {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] { +test load-8.3a {TclGetLoadedPackages procedure} [list teststaticlibrary_8.x $dll $loaded] { lsort -index 1 [info loaded {}] } [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga] [list [file join $testDir pkgb$ext] Pkgb] {*}$alreadyLoaded]] -test load-8.3b {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] { +test load-8.3b {TclGetLoadedPackages procedure} [list teststaticlibrary_8.x $dll $loaded] { lsort -index 1 [info loaded child] } [lsort -index 1 [list {{} Test} [list [file join $testDir pkgb$ext] Pkgb]]] -test load-8.4 {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] { - load [file join $testDir pkgb$ext] pkgb +test load-8.4 {TclGetLoadedPackages procedure} [list teststaticlibrary_8.x $dll $loaded] { + load [file join $testDir pkgb$ext] Pkgb list [lsort -index 1 [info loaded {}]] [lsort [info commands pkgb_*]] } [list [lsort -index 1 [concat [list [list [file join $testDir pkgb$ext] Pkgb] {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded]] {pkgb_demo pkgb_sub pkgb_unsafe}] interp delete child -test load-9.1 {Tcl_StaticPackage, load already-loaded package into another interp} -setup { +test load-9.1 {Tcl_StaticLibrary, load already-loaded package into another interp} -setup { interp create child1 interp create child2 load {} Tcltest child1 load {} Tcltest child2 -} -constraints {teststaticpkg} -body { - child1 eval { teststaticpkg Loadninepointone 0 1 } - child2 eval { teststaticpkg Loadninepointone 0 1 } +} -constraints {teststaticlibrary} -body { + child1 eval { teststaticlibrary Loadninepointone 0 1 } + child2 eval { teststaticlibrary Loadninepointone 0 1 } list [child1 eval { info loaded {} }] \ [child2 eval { info loaded {} }] } -match glob -cleanup { @@ -234,7 +234,7 @@ test load-10.1 {load from vfs} -setup { cd $testDir testsimplefilesystem 1 } -constraints [list $dll $loaded testsimplefilesystem] -body { - list [catch {load simplefs:/pkgd$ext pkgd} msg] $msg + list [catch {load simplefs:/pkgd$ext Pkgd} msg] $msg } -result {0 {}} -cleanup { testsimplefilesystem 0 cd $dir diff --git a/tests/safe.test b/tests/safe.test index 1177e19..0394eb9 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -1157,7 +1157,7 @@ test safe-9.24 {interpConfigure change the access path; check module loading; st res0 res1 res2} # See comments on lsort after test safe-9.20. -catch {teststaticpkg Safepkg1 0 0} +catch {teststaticlibrary Safepkg1 0 0} test safe-10.1 {testing statics loading} -constraints TcltestPackage -setup { set i [safe::interpCreate] } -body { diff --git a/tests/unload.test b/tests/unload.test index 32767fa..f1f4580 100644 --- a/tests/unload.test +++ b/tests/unload.test @@ -53,10 +53,10 @@ proc loadIfNotPresent {pkg args} { # Basic tests: parameter testing... test unload-1.1 {basic errors} -returnCodes error -body { unload -} -result {wrong # args: should be "unload ?-switch ...? fileName ?packageName? ?interp?"} +} -result {wrong # args: should be "unload ?-switch ...? fileName ?prefix? ?interp?"} test unload-1.2 {basic errors} -returnCodes error -body { unload a b c d -} -result {wrong # args: should be "unload ?-switch ...? fileName ?packageName? ?interp?"} +} -result {wrong # args: should be "unload ?-switch ...? fileName ?prefix? ?interp?"} test unload-1.3 {basic errors} -returnCodes error -body { unload a b foobar } -result {could not find interpreter "foobar"} @@ -68,7 +68,7 @@ test unload-1.5 {basic errors} -returnCodes error -body { } -result {must specify either file name or package name} test unload-1.6 {basic errors} -returnCodes error -body { unload {} Unknown -} -result {package "Unknown" is loaded statically and cannot be unloaded} +} -result {library with prefix "Unknown" is loaded statically and cannot be unloaded} test unload-1.7 {-nocomplain switch} { unload -nocomplain {} Unknown } {} @@ -135,14 +135,14 @@ child eval { test unload-3.1 {basic loading of non-unloadable package in a safe interpreter, with package name conversion} \ [list $dll $loaded] { catch {rename pkgb_sub {}} - load [file join $testDir pkgb$ext] pKgB child + load [file join $testDir pkgb$ext] Pkgb child list [child eval pkgb_sub 44 13] [catch {child eval pkgb_unsafe} msg] $msg \ [catch {pkgb_sub 12 10} msg2] $msg2 } {31 1 {invalid command name "pkgb_unsafe"} 1 {invalid command name "pkgb_sub"}} test unload-3.2 {basic loading of unloadable package in a safe interpreter, with package name conversion} \ [list $dll $loaded] { list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ - [load [file join $testDir pkgua$ext] pKgUA child] \ + [load [file join $testDir pkgua$ext] Pkgua child] \ [child eval pkgua_eq abc def] \ [lsort [child eval info commands pkgua_*]] \ [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] @@ -154,14 +154,14 @@ test unload-3.3 {unloading of a package that has never been loaded from a safe i } -result {file "*" has never been loaded in this interpreter} test unload-3.4 {basic unloading of a non-unloadable package from a safe interpreter, with guess for package name} -setup { if {[lsearch -index 1 [info loaded child] Pkgb] < 0} { - load [file join $testDir pkgb$ext] pKgB child + load [file join $testDir pkgb$ext] Pkgb child } } -constraints [list $dll $loaded] -returnCodes error -match glob -body { unload [file join $testDir pkgb$ext] {} child } -result {file "*" cannot be unloaded under a safe interpreter} test unload-3.5 {basic unloading of an unloadable package from a safe interpreter, with guess for package name} -setup { if {[lsearch -index 1 [info loaded child] Pkgua] < 0} { - load [file join $testDir pkgua$ext] pkgua child + load [file join $testDir pkgua$ext] Pkgua child } } -constraints [list $dll $loaded] -body { list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ @@ -189,7 +189,7 @@ test unload-3.7 {basic unloading of re-loaded package from a safe interpreter, w } } -constraints [list $dll $loaded] -body { list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ - [unload [file join $testDir pkgua$ext] pKgUa child] \ + [unload [file join $testDir pkgua$ext] Pkgua child] \ [child eval info commands pkgua_*] \ [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] } -result {{.. . .} {} {} {.. .. ..}} @@ -224,7 +224,7 @@ test unload-4.2 {basic loading of unloadable package in a safe interpreter, with incr load(C) } -constraints [list $dll $loaded] -body { list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ - [load [file join $testDir pkgua$ext] pKgUA child] \ + [load [file join $testDir pkgua$ext] Pkgua child] \ [child eval pkgua_eq abc def] \ [lsort [child eval info commands pkgua_*]] \ [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] @@ -234,7 +234,7 @@ test unload-4.3 {basic loading of unloadable package in a second trusted interpr incr load(T) } -constraints [list $dll $loaded] -body { list [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ - [load [file join $testDir pkgua$ext] pkguA child-trusted] \ + [load [file join $testDir pkgua$ext] Pkgua child-trusted] \ [child-trusted eval pkgua_eq abc def] \ [lsort [child-trusted eval info commands pkgua_*]] \ [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] @@ -291,7 +291,7 @@ test unload-5.1 {unload a module loaded from vfs} \ set dir [pwd] cd $testDir testsimplefilesystem 1 - load simplefs:/pkgua$ext pkgua + load simplefs:/pkgua$ext Pkgua } \ -body { list [catch {unload simplefs:/pkgua$ext} msg] $msg diff --git a/unix/tclAppInit.c b/unix/tclAppInit.c index 3587f35..0b03d5d 100644 --- a/unix/tclAppInit.c +++ b/unix/tclAppInit.c @@ -124,7 +124,7 @@ Tcl_AppInit( if (Tcltest_Init(interp) == TCL_ERROR) { return TCL_ERROR; } - Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init, Tcltest_SafeInit); + Tcl_StaticLibrary(interp, "Tcltest", Tcltest_Init, Tcltest_SafeInit); #endif /* TCL_TEST */ /* diff --git a/win/tcl.dsp b/win/tcl.dsp index 8b20d66..02dcf32 100644 --- a/win/tcl.dsp +++ b/win/tcl.dsp @@ -824,7 +824,7 @@ SOURCE=..\doc\SplitPath.3 # End Source File # Begin Source File -SOURCE=..\doc\StaticPkg.3 +SOURCE=..\doc\StaticLibrary.3 # End Source File # Begin Source File diff --git a/win/tclAppInit.c b/win/tclAppInit.c index a9fb3bd..5c479f9 100644 --- a/win/tclAppInit.c +++ b/win/tclAppInit.c @@ -168,19 +168,19 @@ Tcl_AppInit( if (Registry_Init(interp) == TCL_ERROR) { return TCL_ERROR; } - Tcl_StaticPackage(interp, "Registry", Registry_Init, NULL); + Tcl_StaticLibrary(interp, "Registry", Registry_Init, NULL); if (Dde_Init(interp) == TCL_ERROR) { return TCL_ERROR; } - Tcl_StaticPackage(interp, "Dde", Dde_Init, Dde_SafeInit); + Tcl_StaticLibrary(interp, "Dde", Dde_Init, Dde_SafeInit); #endif #ifdef TCL_TEST if (Tcltest_Init(interp) == TCL_ERROR) { return TCL_ERROR; } - Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init, Tcltest_SafeInit); + Tcl_StaticLibrary(interp, "Tcltest", Tcltest_Init, Tcltest_SafeInit); #endif /* TCL_TEST */ /* -- cgit v0.12 From bf23a021385451ff52770191acec3f55d5c8575a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 10 Nov 2020 15:38:52 +0000 Subject: more cleanup/error-messages --- generic/tclLoad.c | 186 +++++++++++++++++++++++++++--------------------------- tests/load.test | 12 ++-- tests/safe.test | 8 +-- tests/unload.test | 4 +- 4 files changed, 104 insertions(+), 106 deletions(-) diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 67bc2cc..fe86622 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -13,17 +13,15 @@ #include "tclInt.h" /* - * The following structure describes a package that has been loaded either + * The following structure describes a library that has been loaded either * dynamically (with the "load" command) or statically (as indicated by a call - * to TclGetLoadedLibraries). All such packages are linked together into a - * single list for the process. Packages are never unloaded, until the - * application exits, when TclFinalizeLoad is called, and these structures are - * freed. + * to Tcl_StaticLibrary). All such libraries are linked together into a + * single list for the process. */ typedef struct LoadedLibrary { - char *fileName; /* Name of the file from which the package was - * loaded. An empty string means the package + char *fileName; /* Name of the file from which the library was + * loaded. An empty string means the library * is loaded statically. Malloc-ed. */ char *prefix; /* Prefix for the library. * Malloc-ed. */ @@ -33,59 +31,59 @@ typedef struct LoadedLibrary { * then this field is irrelevant. */ Tcl_PackageInitProc *initProc; /* Initialization function to call to - * incorporate this package into a trusted + * incorporate this library into a trusted * interpreter. */ Tcl_PackageInitProc *safeInitProc; /* Initialization function to call to - * incorporate this package into a safe + * incorporate this library into a safe * interpreter (one that will execute - * untrusted scripts). NULL means the package + * untrusted scripts). NULL means the library * can't be used in unsafe interpreters. */ Tcl_PackageUnloadProc *unloadProc; - /* Finalisation function to unload a package + /* Finalization function to unload a library * from a trusted interpreter. NULL means that - * the package cannot be unloaded. */ + * the library cannot be unloaded. */ Tcl_PackageUnloadProc *safeUnloadProc; - /* Finalisation function to unload a package + /* Finalization function to unload a library * from a safe interpreter. NULL means that - * the package cannot be unloaded. */ - int interpRefCount; /* How many times the package has been loaded + * the library cannot be unloaded. */ + int interpRefCount; /* How many times the library has been loaded * in trusted interpreters. */ - int safeInterpRefCount; /* How many times the package has been loaded + int safeInterpRefCount; /* How many times the library has been loaded * in safe interpreters. */ struct LoadedLibrary *nextPtr; - /* Next in list of all packages loaded into + /* Next in list of all libraries loaded into * this application process. NULL means end of * list. */ } LoadedLibrary; /* * TCL_THREADS - * There is a global list of packages that is anchored at firstLibraryPtr. + * There is a global list of libraries that is anchored at firstLibraryPtr. * Access to this list is governed by a mutex. */ static LoadedLibrary *firstLibraryPtr = NULL; - /* First in list of all packages loaded into + /* First in list of all libraries loaded into * this process. */ TCL_DECLARE_MUTEX(libraryMutex) /* - * The following structure represents a particular package that has been + * The following structure represents a particular library that has been * incorporated into a particular interpreter (by calling its initialization * function). There is a list of these structures for each interpreter, with * an AssocData value (key "load") for the interpreter that points to the - * first package (if any). + * first library (if any). */ -typedef struct InterpPackage { +typedef struct InterpLibrary { LoadedLibrary *libraryPtr; /* Points to detailed information about - * package. */ - struct InterpPackage *nextPtr; - /* Next package in this interpreter, or NULL + * library. */ + struct InterpLibrary *nextPtr; + /* Next lirary in this interpreter, or NULL * for end of list. */ -} InterpPackage; +} InterpLibrary; /* * Prototypes for functions that are private to this file: @@ -122,7 +120,7 @@ Tcl_LoadObjCmd( LoadedLibrary *libraryPtr, *defaultPtr; Tcl_DString pkgName, tmp, initName, safeInitName; Tcl_DString unloadName, safeUnloadName; - InterpPackage *ipFirstPtr, *ipPtr; + InterpLibrary *ipFirstPtr, *ipPtr; int code, namesMatch, filesMatch, offset; const char *symbols[2]; Tcl_PackageInitProc *initProc; @@ -181,7 +179,7 @@ Tcl_LoadObjCmd( } if ((fullFileName[0] == 0) && (prefix == NULL)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "must specify either file name or package name", -1)); + "must specify either file name or prefix", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOLIBRARY", NULL); code = TCL_ERROR; @@ -189,7 +187,7 @@ Tcl_LoadObjCmd( } /* - * Figure out which interpreter we're going to load the package into. + * Figure out which interpreter we're going to load the library into. */ target = interp; @@ -204,13 +202,13 @@ Tcl_LoadObjCmd( } /* - * Scan through the packages that are currently loaded to see if the - * package we want is already loaded. We'll use a loaded package if it + * Scan through the libraries that are currently loaded to see if the + * library we want is already loaded. We'll use a loaded library if it * meets any of the following conditions: * - Its name and file match the once we're looking for. * - Its file matches, and we weren't given a name. * - Its name matches, the file name was specified as empty, and there is - * only no statically loaded package with the same name. + * only no statically loaded library with the same prefix. */ Tcl_MutexLock(&libraryMutex); @@ -242,11 +240,11 @@ Tcl_LoadObjCmd( } if (filesMatch && !namesMatch && (fullFileName[0] != 0)) { /* - * Can't have two different packages loaded from the same file. + * Can't have two different libraries loaded from the same file. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "file \"%s\" is already loaded for package \"%s\"", + "file \"%s\" is already loaded for prefix \"%s\"", fullFileName, libraryPtr->prefix)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "SPLITPERSONALITY", NULL); @@ -261,13 +259,13 @@ Tcl_LoadObjCmd( } /* - * Scan through the list of packages already loaded in the target - * interpreter. If the package we want is already loaded there, then + * Scan through the list of libraries already loaded in the target + * interpreter. If the library we want is already loaded there, then * there's nothing for us to do. */ if (libraryPtr != NULL) { - ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL); + ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL); for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { if (ipPtr->libraryPtr == libraryPtr) { code = TCL_OK; @@ -279,7 +277,7 @@ Tcl_LoadObjCmd( if (libraryPtr == NULL) { /* * The desired file isn't currently loaded, so load it. It's an error - * if the desired package is a static one. + * if the desired library is a static one. */ if (fullFileName[0] == 0) { @@ -344,10 +342,10 @@ Tcl_LoadObjCmd( if (p == pkgGuess) { Tcl_DecrRefCount(splitPtr); Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't figure out package name for %s", + "couldn't figure out prefix for %s", fullFileName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", - "WHATPACKAGE", NULL); + "WHATLIBRARY", NULL); code = TCL_ERROR; goto done; } @@ -355,7 +353,7 @@ Tcl_LoadObjCmd( Tcl_DecrRefCount(splitPtr); /* - * Fix the capitalization in the package name so that the first + * Fix the capitalization in the prefix so that the first * character is in caps (or title case) but the others are all * lower-case. */ @@ -367,7 +365,7 @@ Tcl_LoadObjCmd( /* * Compute the names of the two initialization functions, based on the - * package name. + * prefix. */ TclDStringAppendDString(&initName, &pkgName); @@ -380,7 +378,7 @@ Tcl_LoadObjCmd( TclDStringAppendLiteral(&safeUnloadName, "_SafeUnload"); /* - * Call platform-specific code to load the package and find the two + * Call platform-specific code to load the library and find the two * initialization functions. */ @@ -396,7 +394,7 @@ Tcl_LoadObjCmd( } /* - * Create a new record to describe this package. + * Create a new record to describe this library. */ libraryPtr = (LoadedLibrary *)Tcl_Alloc(sizeof(LoadedLibrary)); @@ -434,14 +432,14 @@ Tcl_LoadObjCmd( } /* - * Invoke the package's initialization function (either the normal one or + * Invoke the library's initialization function (either the normal one or * the safe one, depending on whether or not the interpreter is safe). */ if (Tcl_IsSafe(target)) { if (libraryPtr->safeInitProc == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't use package in a safe interpreter: no" + "can't use library in a safe interpreter: no" " %s_SafeInit procedure", libraryPtr->prefix)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "UNSAFE", NULL); @@ -452,7 +450,7 @@ Tcl_LoadObjCmd( } else { if (libraryPtr->initProc == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't attach package to interpreter: no %s_Init procedure", + "can't attach library to interpreter: no %s_Init procedure", libraryPtr->prefix)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "ENTRYPOINT", NULL); @@ -484,7 +482,7 @@ Tcl_LoadObjCmd( } /* - * Record the fact that the package has been loaded in the target + * Record the fact that the library has been loaded in the target * interpreter. * * Update the proper reference count. @@ -499,12 +497,12 @@ Tcl_LoadObjCmd( Tcl_MutexUnlock(&libraryMutex); /* - * Refetch ipFirstPtr: loading the package may have introduced additional - * static packages at the head of the linked list! + * Refetch ipFirstPtr: loading the library may have introduced additional + * static libraries at the head of the linked list! */ - ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL); - ipPtr = (InterpPackage *)Tcl_Alloc(sizeof(InterpPackage)); + ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL); + ipPtr = (InterpLibrary *)Tcl_Alloc(sizeof(InterpLibrary)); ipPtr->libraryPtr = libraryPtr; ipPtr->nextPtr = ipFirstPtr; Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipPtr); @@ -547,7 +545,7 @@ Tcl_UnloadObjCmd( LoadedLibrary *libraryPtr, *defaultPtr; Tcl_DString pkgName, tmp; Tcl_PackageUnloadProc *unloadProc; - InterpPackage *ipFirstPtr, *ipPtr; + InterpLibrary *ipFirstPtr, *ipPtr; int i, index, code, complain = 1, keepLibrary = 0; int trustedRefCount = -1, safeRefCount = -1; const char *fullFileName = ""; @@ -615,7 +613,7 @@ Tcl_UnloadObjCmd( } if ((fullFileName[0] == 0) && (prefix == NULL)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "must specify either file name or package name", -1)); + "must specify either file name or prefix", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NOLIBRARY", NULL); code = TCL_ERROR; @@ -623,7 +621,7 @@ Tcl_UnloadObjCmd( } /* - * Figure out which interpreter we're going to load the package into. + * Figure out which interpreter we're going to load the library into. */ target = interp; @@ -637,13 +635,13 @@ Tcl_UnloadObjCmd( } /* - * Scan through the packages that are currently loaded to see if the - * package we want is already loaded. We'll use a loaded package if it + * Scan through the libraries that are currently loaded to see if the + * library we want is already loaded. We'll use a loaded library if it * meets any of the following conditions: - * - Its name and file match the once we're looking for. - * - Its file matches, and we weren't given a name. - * - Its name matches, the file name was specified as empty, and there is - * only no statically loaded package with the same name. + * - Its prefix and file match the once we're looking for. + * - Its file matches, and we weren't given a prefix. + * - Its prefix matches, the file name was specified as empty, and there is + * only no statically loaded library with the same prefix. */ Tcl_MutexLock(&libraryMutex); @@ -682,7 +680,7 @@ Tcl_UnloadObjCmd( Tcl_MutexUnlock(&libraryMutex); if (fullFileName[0] == 0) { /* - * It's an error to try unload a static package. + * It's an error to try unload a static library. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -707,14 +705,14 @@ Tcl_UnloadObjCmd( } /* - * Scan through the list of packages already loaded in the target - * interpreter. If the package we want is already loaded there, then we + * Scan through the list of libraries already loaded in the target + * interpreter. If the library we want is already loaded there, then we * should proceed with unloading. */ code = TCL_ERROR; if (libraryPtr != NULL) { - ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL); + ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL); for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { if (ipPtr->libraryPtr == libraryPtr) { code = TCL_OK; @@ -724,7 +722,7 @@ Tcl_UnloadObjCmd( } if (code != TCL_OK) { /* - * The package has not been loaded in this interpreter. + * The library has not been loaded in this interpreter. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -767,7 +765,7 @@ Tcl_UnloadObjCmd( } /* - * We are ready to unload the package. First, evaluate the unload + * We are ready to unload the library. First, evaluate the unload * function. If this fails, we cannot proceed with unload. Also, we must * specify the proper flag to pass to the unload callback. * TCL_UNLOAD_DETACH_FROM_INTERPRETER is defined when the callback should @@ -869,12 +867,12 @@ Tcl_UnloadObjCmd( * Remove this library from the interpreter's library cache. */ - ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL); + ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL); ipPtr = ipFirstPtr; if (ipPtr->libraryPtr == defaultPtr) { ipFirstPtr = ipFirstPtr->nextPtr; } else { - InterpPackage *ipPrevPtr; + InterpLibrary *ipPrevPtr; for (ipPrevPtr = ipPtr; ipPtr != NULL; ipPrevPtr = ipPtr, ipPtr = ipPtr->nextPtr) { @@ -920,14 +918,14 @@ Tcl_UnloadObjCmd( * * Tcl_StaticLibrary -- * - * This function is invoked to indicate that a particular package has + * This function is invoked to indicate that a particular library has * been linked statically with an application. * * Results: * None. * * Side effects: - * Once this function completes, the package becomes loadable via the + * Once this function completes, the library becomes loadable via the * "load" command with an empty file name. * *---------------------------------------------------------------------- @@ -935,26 +933,26 @@ Tcl_UnloadObjCmd( void Tcl_StaticLibrary( - Tcl_Interp *interp, /* If not NULL, it means that the package has + Tcl_Interp *interp, /* If not NULL, it means that the library has * already been loaded into the given * interpreter by calling the appropriate init * proc. */ const char *prefix, /* Prefix. */ Tcl_PackageInitProc *initProc, /* Function to call to incorporate this - * package into a trusted interpreter. */ + * library into a trusted interpreter. */ Tcl_PackageInitProc *safeInitProc) /* Function to call to incorporate this - * package into a safe interpreter (one that + * library into a safe interpreter (one that * will execute untrusted scripts). NULL means - * the package can't be used in safe + * the library can't be used in safe * interpreters. */ { LoadedLibrary *libraryPtr; - InterpPackage *ipPtr, *ipFirstPtr; + InterpLibrary *ipPtr, *ipFirstPtr; /* - * Check to see if someone else has already reported this package as + * Check to see if someone else has already reported this library as * statically loaded in the process. */ @@ -969,7 +967,7 @@ Tcl_StaticLibrary( Tcl_MutexUnlock(&libraryMutex); /* - * If the package is not yet recorded as being loaded statically, add it + * If the library is not yet recorded as being loaded statically, add it * to the list now. */ @@ -991,11 +989,11 @@ Tcl_StaticLibrary( if (interp != NULL) { /* - * If we're loading the package into an interpreter, determine whether + * If we're loading the library into an interpreter, determine whether * it's already loaded. */ - ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(interp, "tclLoad", NULL); + ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(interp, "tclLoad", NULL); for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { if (ipPtr->libraryPtr == libraryPtr) { return; @@ -1003,11 +1001,11 @@ Tcl_StaticLibrary( } /* - * Package isn't loaded in the current interp yet. Mark it as now being + * Lirary isn't loaded in the current interp yet. Mark it as now being * loaded. */ - ipPtr = (InterpPackage *)Tcl_Alloc(sizeof(InterpPackage)); + ipPtr = (InterpLibrary *)Tcl_Alloc(sizeof(InterpLibrary)); ipPtr->libraryPtr = libraryPtr; ipPtr->nextPtr = ipFirstPtr; Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc, ipPtr); @@ -1027,7 +1025,7 @@ Tcl_StaticLibrary( * list of lists is placed in the interp's result. Each sublist * corresponds to one loaded file; its first element is the name of the * file (or an empty string for something that's statically loaded) and - * the second element is the name of the package in that file. + * the second element is the prefix of the library in that file. * * Side effects: * None. @@ -1043,13 +1041,13 @@ TclGetLoadedLibraries( * NULL, return info about all interps; * otherwise, just return info about this * interpreter. */ - const char *prefix) /* Package name or NULL. If NULL, return info - * for all packages. + const char *prefix) /* Prefix or NULL. If NULL, return info + * for all prefixes. */ { Tcl_Interp *target; LoadedLibrary *libraryPtr; - InterpPackage *ipPtr; + InterpLibrary *ipPtr; Tcl_Obj *resultObj, *pkgDesc[2]; if (targetName == NULL) { @@ -1071,10 +1069,10 @@ TclGetLoadedLibraries( if (target == NULL) { return TCL_ERROR; } - ipPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL); + ipPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL); /* - * Return information about all of the available packages. + * Return information about all of the available libraries. */ if (prefix) { resultObj = NULL; @@ -1095,7 +1093,7 @@ TclGetLoadedLibraries( } /* - * Return information about only the packages that are loaded in a given + * Return information about only the libraries that are loaded in a given * interpreter. */ @@ -1115,7 +1113,7 @@ TclGetLoadedLibraries( * * LoadCleanupProc -- * - * This function is called to delete all of the InterpPackage structures + * This function is called to delete all of the InterpLibrary structures * for an interpreter when the interpreter is deleted. It gets invoked * via the Tcl AssocData mechanism. * @@ -1123,20 +1121,20 @@ TclGetLoadedLibraries( * None. * * Side effects: - * Storage for all of the InterpPackage functions for interp get deleted. + * Storage for all of the InterpLibrary functions for interp get deleted. * *---------------------------------------------------------------------- */ static void LoadCleanupProc( - ClientData clientData, /* Pointer to first InterpPackage structure + ClientData clientData, /* Pointer to first InterpLibrary structure * for interp. */ TCL_UNUSED(Tcl_Interp *)) { - InterpPackage *ipPtr, *nextPtr; + InterpLibrary *ipPtr, *nextPtr; - ipPtr = (InterpPackage *)clientData; + ipPtr = (InterpLibrary *)clientData; while (ipPtr != NULL) { nextPtr = ipPtr->nextPtr; Tcl_Free(ipPtr); diff --git a/tests/load.test b/tests/load.test index eaaf7a7..9bbd510 100644 --- a/tests/load.test +++ b/tests/load.test @@ -56,10 +56,10 @@ test load-1.3 {basic errors} -returnCodes error -body { } -result {could not find interpreter "foobar"} test load-1.4 {basic errors} -returnCodes error -body { load -global {} -} -result {must specify either file name or package name} +} -result {must specify either file name or prefix} test load-1.5 {basic errors} -returnCodes error -body { load -lazy {} {} -} -result {must specify either file name or package name} +} -result {must specify either file name or prefix} test load-1.6 {basic errors} -returnCodes error -body { load {} Unknown } -result {no library with prefix "Unknown" is loaded statically} @@ -68,7 +68,7 @@ test load-1.7 {basic errors} -returnCodes error -body { } -result {bad option "-abc": must be -global, -lazy, or --} test load-1.8 {basic errors} -returnCodes error -body { load -global -} -result {couldn't figure out package name for -global} +} -result {couldn't figure out prefix for -global} test load-2.1 {basic loading, with guess for package name} \ [list $dll $loaded] { @@ -90,7 +90,7 @@ test load-2.3 {loading with no _Init procedure} -constraints [list $dll $loaded] {TCL LOOKUP LOAD_SYMBOL *Foo_Init}] test load-2.4 {loading with no _SafeInit procedure} [list $dll $loaded] { list [catch {load [file join $testDir pkga$ext] {} child} msg] $msg -} {1 {can't use package in a safe interpreter: no Pkga_SafeInit procedure}} +} {1 {can't use library in a safe interpreter: no Pkga_SafeInit procedure}} test load-3.1 {error in _Init procedure, same interpreter} \ [list $dll $loaded] { @@ -128,7 +128,7 @@ test load-4.2 {reloading package into same interpreter} -setup { catch {load [file join $testDir pkga$ext] pkga} } -constraints [list $dll $loaded] -returnCodes error -body { load [file join $testDir pkga$ext] Pkgb -} -result "file \"[file join $testDir pkga$ext]\" is already loaded for package \"Pkga\"" +} -result "file \"[file join $testDir pkga$ext]\" is already loaded for prefix \"Pkga\"" test load-5.1 {file name not specified and no static package: pick default} -setup { catch {interp delete x} @@ -164,7 +164,7 @@ test load-7.2 {Tcl_StaticLibrary procedure} [list teststaticlibrary] { child eval {set x "not loaded"} list [catch {load {} Another child} msg] $msg \ [child eval set x] [set x] -} {1 {can't use package in a safe interpreter: no Another_SafeInit procedure} {not loaded} loaded} +} {1 {can't use library in a safe interpreter: no Another_SafeInit procedure} {not loaded} loaded} test load-7.3 {Tcl_StaticLibrary procedure} [list teststaticlibrary] { set x "not loaded" teststaticlibrary More 0 1 diff --git a/tests/safe.test b/tests/safe.test index 0394eb9..45a0177 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -1164,7 +1164,7 @@ test safe-10.1 {testing statics loading} -constraints TcltestPackage -setup { interp eval $i {load {} Safepkg1} } -returnCodes error -cleanup { safe::interpDelete $i -} -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} +} -result {load of binary library for package Safepkg1 failed: can't use library in a safe interpreter: no Safepkg1_SafeInit procedure} test safe-10.1.1 {testing statics loading} -constraints TcltestPackage -setup { set i [safe::interpCreate] } -body { @@ -1173,7 +1173,7 @@ test safe-10.1.1 {testing statics loading} -constraints TcltestPackage -setup { } -returnCodes ok -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure +} -result {load of binary library for package Safepkg1 failed: can't use library in a safe interpreter: no Safepkg1_SafeInit procedure invoked from within "load {} Safepkg1" invoked from within @@ -1196,7 +1196,7 @@ test safe-10.4 {testing nested statics loading / -nestedloadok} -constraints Tcl interp eval $i {interp create x; load {} Safepkg1 x} } -returnCodes error -cleanup { safe::interpDelete $i -} -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} +} -result {load of binary library for package Safepkg1 failed: can't use library in a safe interpreter: no Safepkg1_SafeInit procedure} test safe-10.4.1 {testing nested statics loading / -nestedloadok} -constraints TcltestPackage -body { set i [safe::interpCreate -nestedloadok] catch {interp eval $i {interp create x; load {} Safepkg1 x}} m o @@ -1204,7 +1204,7 @@ test safe-10.4.1 {testing nested statics loading / -nestedloadok} -constraints T } -returnCodes ok -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure +} -result {load of binary library for package Safepkg1 failed: can't use library in a safe interpreter: no Safepkg1_SafeInit procedure invoked from within "load {} Safepkg1 x" invoked from within diff --git a/tests/unload.test b/tests/unload.test index f1f4580..68cdd13 100644 --- a/tests/unload.test +++ b/tests/unload.test @@ -62,10 +62,10 @@ test unload-1.3 {basic errors} -returnCodes error -body { } -result {could not find interpreter "foobar"} test unload-1.4 {basic errors} -returnCodes error -body { unload {} -} -result {must specify either file name or package name} +} -result {must specify either file name or prefix} test unload-1.5 {basic errors} -returnCodes error -body { unload {} {} -} -result {must specify either file name or package name} +} -result {must specify either file name or prefix} test unload-1.6 {basic errors} -returnCodes error -body { unload {} Unknown } -result {library with prefix "Unknown" is loaded statically and cannot be unloaded} -- cgit v0.12 From cc7d39873fa40c42eeca9a655fa579c3feb54ab5 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 5 Dec 2020 11:28:33 +0000 Subject: Add -fextended-identifiers option to unix/dltest makefile --- unix/dltest/Makefile.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unix/dltest/Makefile.in b/unix/dltest/Makefile.in index 09b496d..fdd3e98 100644 --- a/unix/dltest/Makefile.in +++ b/unix/dltest/Makefile.in @@ -33,7 +33,7 @@ dltest_suffix: pkgπ${DLTEST_SUFFIX} pkga${DLTEST_SUFFIX} pkgb${DLTEST_SUFFIX} p @touch ../dltest.marker pkgπ.o: $(SRC_DIR)/pkgπ.c - $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgπ.c + $(CC) -c $(CC_SWITCHES) -fextended-identifiers $(SRC_DIR)/pkgπ.c pkga.o: $(SRC_DIR)/pkga.c $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkga.c -- cgit v0.12 From 3f62bdc438a97dd70b557b9c95c73ad9cddac1f6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 6 Dec 2020 13:47:42 +0000 Subject: Add -finput-charset=UTF-8 to CFLAGS --- unix/configure | 4 ++-- unix/dltest/Makefile.in | 2 +- unix/tcl.m4 | 4 ++-- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/unix/configure b/unix/configure index 3dc88a1..4a91811 100755 --- a/unix/configure +++ b/unix/configure @@ -5027,12 +5027,12 @@ fi if test "$GCC" = yes; then : CFLAGS_OPTIMIZE=-O2 - CFLAGS_WARNING="-Wall -Wextra -Wshadow -Wundef -Wwrite-strings -Wpointer-arith" + CFLAGS_WARNING="-Wall -Wextra -Wshadow -Wundef -Wwrite-strings -Wpointer-arith -finput-charset=UTF-8" case "${CC}" in *++|*++-*) ;; *) - CFLAGS_WARNING="${CFLAGS_WARNING} -Wc++-compat -Wdeclaration-after-statement" + CFLAGS_WARNING="${CFLAGS_WARNING} -Wc++-compat -fextended-identifiers -Wdeclaration-after-statement" ;; esac diff --git a/unix/dltest/Makefile.in b/unix/dltest/Makefile.in index fdd3e98..09b496d 100644 --- a/unix/dltest/Makefile.in +++ b/unix/dltest/Makefile.in @@ -33,7 +33,7 @@ dltest_suffix: pkgπ${DLTEST_SUFFIX} pkga${DLTEST_SUFFIX} pkgb${DLTEST_SUFFIX} p @touch ../dltest.marker pkgπ.o: $(SRC_DIR)/pkgπ.c - $(CC) -c $(CC_SWITCHES) -fextended-identifiers $(SRC_DIR)/pkgπ.c + $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgπ.c pkga.o: $(SRC_DIR)/pkga.c $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkga.c diff --git a/unix/tcl.m4 b/unix/tcl.m4 index 930f381..695588d 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -958,12 +958,12 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ CFLAGS_DEBUG=-g AS_IF([test "$GCC" = yes], [ CFLAGS_OPTIMIZE=-O2 - CFLAGS_WARNING="-Wall -Wextra -Wshadow -Wundef -Wwrite-strings -Wpointer-arith" + CFLAGS_WARNING="-Wall -Wextra -Wshadow -Wundef -Wwrite-strings -Wpointer-arith -finput-charset=UTF-8" case "${CC}" in *++|*++-*) ;; *) - CFLAGS_WARNING="${CFLAGS_WARNING} -Wc++-compat -Wdeclaration-after-statement" + CFLAGS_WARNING="${CFLAGS_WARNING} -Wc++-compat -fextended-identifiers -Wdeclaration-after-statement" ;; esac -- cgit v0.12 From 567b79ea315fea66d4c49ecae05c9d37f9cdf175 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 7 Dec 2020 09:16:19 +0000 Subject: Use \u???? syntax in identifiers, to make it work with gcc too --- "unix/dltest/pkg\317\200.c" | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git "a/unix/dltest/pkg\317\200.c" "b/unix/dltest/pkg\317\200.c" index faeaa46..81078fa 100644 --- "a/unix/dltest/pkg\317\200.c" +++ "b/unix/dltest/pkg\317\200.c" @@ -17,7 +17,7 @@ * Prototypes for procedures defined later in this file: */ -static int Pkgπ_ΠObjCmd(ClientData clientData, +static int Pkg\u03C0_\u03A0ObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* @@ -39,7 +39,7 @@ static int Pkgπ_ΠObjCmd(ClientData clientData, */ static int -Pkgπ_ΠObjCmd( +Pkg\u03C0_\u03A0ObjCmd( void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ @@ -77,7 +77,7 @@ Pkgπ_ΠObjCmd( */ DLLEXPORT int -Pkgπ_Init( +Pkg\u03C0_Init( Tcl_Interp *interp) /* Interpreter in which the package is to be * made available. */ { @@ -90,6 +90,6 @@ Pkgπ_Init( if (code != TCL_OK) { return code; } - Tcl_CreateObjCommand(interp, "π", Pkgπ_ΠObjCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "π", Pkg\u03C0_\u03A0ObjCmd, NULL, NULL); return TCL_OK; } -- cgit v0.12 From c42695035ce9433fed4856709e9acb518a4979ac Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 7 Dec 2020 09:21:31 +0000 Subject: =?UTF-8?q?=C2=A9?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- unix/dltest/pkga.c | 2 +- unix/dltest/pkgb.c | 2 +- unix/dltest/pkgc.c | 2 +- unix/dltest/pkgd.c | 2 +- unix/dltest/pkge.c | 2 +- unix/dltest/pkgooa.c | 2 +- unix/dltest/pkgua.c | 4 ++-- "unix/dltest/pkg\317\200.c" | 2 +- 8 files changed, 9 insertions(+), 9 deletions(-) diff --git a/unix/dltest/pkga.c b/unix/dltest/pkga.c index c2d814f..e00f996 100644 --- a/unix/dltest/pkga.c +++ b/unix/dltest/pkga.c @@ -4,7 +4,7 @@ * This file contains a simple Tcl package "pkga" that is intended for * testing the Tcl dynamic loading facilities. * - * Copyright (c) 1995 Sun Microsystems, Inc. + * Copyright © 1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/unix/dltest/pkgb.c b/unix/dltest/pkgb.c index 741b2a1..3210669 100644 --- a/unix/dltest/pkgb.c +++ b/unix/dltest/pkgb.c @@ -5,7 +5,7 @@ * testing the Tcl dynamic loading facilities. It can be used in both * safe and unsafe interpreters. * - * Copyright (c) 1995 Sun Microsystems, Inc. + * Copyright © 1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/unix/dltest/pkgc.c b/unix/dltest/pkgc.c index 46f6e86..2b46986 100644 --- a/unix/dltest/pkgc.c +++ b/unix/dltest/pkgc.c @@ -5,7 +5,7 @@ * testing the Tcl dynamic loading facilities. It can be used in both * safe and unsafe interpreters. * - * Copyright (c) 1995 Sun Microsystems, Inc. + * Copyright © 1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/unix/dltest/pkgd.c b/unix/dltest/pkgd.c index d3af83f..5c799f5 100644 --- a/unix/dltest/pkgd.c +++ b/unix/dltest/pkgd.c @@ -5,7 +5,7 @@ * testing the Tcl dynamic loading facilities. It can be used in both * safe and unsafe interpreters. * - * Copyright (c) 1995 Sun Microsystems, Inc. + * Copyright © 1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/unix/dltest/pkge.c b/unix/dltest/pkge.c index f46ca74..26a4b79 100644 --- a/unix/dltest/pkge.c +++ b/unix/dltest/pkge.c @@ -5,7 +5,7 @@ * testing the Tcl dynamic loading facilities. Its Init procedure returns * an error in order to test how this is handled. * - * Copyright (c) 1995 Sun Microsystems, Inc. + * Copyright © 1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/unix/dltest/pkgooa.c b/unix/dltest/pkgooa.c index 7d0c98b..ff1cf1f 100644 --- a/unix/dltest/pkgooa.c +++ b/unix/dltest/pkgooa.c @@ -4,7 +4,7 @@ * This file contains a simple Tcl package "pkgooa" that is intended for * testing the Tcl dynamic loading facilities. * - * Copyright (c) 1995 Sun Microsystems, Inc. + * Copyright © 1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/unix/dltest/pkgua.c b/unix/dltest/pkgua.c index c5102a8..0ab3e23 100644 --- a/unix/dltest/pkgua.c +++ b/unix/dltest/pkgua.c @@ -4,8 +4,8 @@ * This file contains a simple Tcl package "pkgua" that is intended for * testing the Tcl dynamic unloading facilities. * - * Copyright (c) 1995 Sun Microsystems, Inc. - * Copyright (c) 2004 Georgios Petasis + * Copyright © 1995 Sun Microsystems, Inc. + * Copyright © 2004 Georgios Petasis * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git "a/unix/dltest/pkg\317\200.c" "b/unix/dltest/pkg\317\200.c" index 81078fa..1cf95cf 100644 --- "a/unix/dltest/pkg\317\200.c" +++ "b/unix/dltest/pkg\317\200.c" @@ -4,7 +4,7 @@ * This file contains a simple Tcl package "pkgπ" that is intended for * testing the Tcl dynamic loading facilities. * - * Copyright (c) 1995 Sun Microsystems, Inc. + * Copyright © 1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. -- cgit v0.12 From 165061b1c46cae8e6c6f05714d9135c7c3d2395b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 9 Dec 2020 09:55:19 +0000 Subject: Fix github actions Windows build --- .github/workflows/win-build.yml | 1 - win/makefile.vc | 6 ++++-- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/.github/workflows/win-build.yml b/.github/workflows/win-build.yml index 341f7ca..5148a47 100644 --- a/.github/workflows/win-build.yml +++ b/.github/workflows/win-build.yml @@ -56,7 +56,6 @@ jobs: - "--disable-shared" - "--enable-symbols" - "--enable-symbols=mem" - - "CC=g++" # Using powershell means we need to explicitly stop on failure steps: - name: Checkout diff --git a/win/makefile.vc b/win/makefile.vc index 394bd13..2e3a080 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -587,8 +587,10 @@ $(LIBTCLZIP): .PHONY @move /y "$(LIBTCLVFS)\tcl_library\manifest.txt" "$(LIBTCLVFS)\tcl_library\pkgIndex.tcl" > NUL !if ! $(STATIC_BUILD) # Remove the registry and dde directories as the DLLS are still external - @$(RMDIR) "$(LIBTCLVFS)\tcl_library\registry" - @$(RMDIR) "$(LIBTCLVFS)\tcl_library\dde" + @del "$(LIBTCLVFS)\tcl_library\registry\pkgIndex.tcl" + @rmdir "$(LIBTCLVFS)\tcl_library\registry" + @del "$(LIBTCLVFS)\tcl_library\dde\pkgIndex.tcl" + @rmdir "$(LIBTCLVFS)\tcl_library\dde" !endif @echo file delete -force {$@} > "$(OUT_DIR)\zipper.tcl" @echo zipfs mkzip {$@} {$(LIBTCLVFS)} {$(LIBTCLVFS)} >> "$(OUT_DIR)\zipper.tcl" -- cgit v0.12 From ec714e1d4fe3c39ba19520dbf55debd3ac26cbae Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 10 Dec 2020 10:33:41 +0000 Subject: Tweak error-message --- library/safe.tcl | 24 ++++++++++++------------ tests/safe.test | 32 ++++++++++++++++---------------- 2 files changed, 28 insertions(+), 28 deletions(-) diff --git a/library/safe.tcl b/library/safe.tcl index e7760f8..9f2d007 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -1009,8 +1009,8 @@ proc ::safe::AliasLoad {child file args} { return -code error $msg } - # package name (can be empty if file is not). - set package [lindex $args 0] + # prefix (can be empty if file is not). + set prefix [lindex $args 0] namespace upvar ::safe [VarName $child] state @@ -1022,23 +1022,23 @@ proc ::safe::AliasLoad {child file args} { # authorize that. if {!$state(nestedok)} { Log $child "loading to a sub interp (nestedok)\ - disabled (trying to load $package to $target)" + disabled (trying to load $prefix to $target)" return -code error "permission denied (nested load)" } } # Determine what kind of load is requested if {$file eq ""} { - # static package loading - if {$package eq ""} { - set msg "load error: empty filename and no package name" + # static loading + if {$prefix eq ""} { + set msg "load error: empty filename and no prefix" Log $child $msg return -code error $msg } if {!$state(staticsok)} { - Log $child "static packages loading disabled\ - (trying to load $package to $target)" - return -code error "permission denied (static package)" + Log $child "static library loading disabled\ + (trying to load $prefix to $target)" + return -code error "permission denied (static library)" } } else { # file loading @@ -1061,10 +1061,10 @@ proc ::safe::AliasLoad {child file args} { } try { - return [::interp invokehidden $child load $file $package $target] + return [::interp invokehidden $child load $file $prefix $target] } on error msg { - # Some packages return no error message. - set msg0 "load of binary library for package $package failed" + # Some libraries return no error message. + set msg0 "load of binary library with prefix $prefix failed" if {$msg eq {}} { set msg $msg0 } else { diff --git a/tests/safe.test b/tests/safe.test index 454d670..ffc005c 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -1157,58 +1157,58 @@ test safe-9.24 {interpConfigure change the access path; check module loading; st res0 res1 res2} # See comments on lsort after test safe-9.20. -catch {teststaticlibrary Safepkg1 0 0} +catch {teststaticlibrary Safe1 0 0} test safe-10.1 {testing statics loading} -constraints tcl::test -setup { set i [safe::interpCreate] } -body { - interp eval $i {load {} Safepkg1} + interp eval $i {load {} Safe1} } -returnCodes error -cleanup { safe::interpDelete $i -} -result {load of binary library for package Safepkg1 failed: can't use library in a safe interpreter: no Safepkg1_SafeInit procedure} +} -result {load of binary library with prefix Safe1 failed: can't use library in a safe interpreter: no Safe1_SafeInit procedure} test safe-10.1.1 {testing statics loading} -constraints tcl::test -setup { set i [safe::interpCreate] } -body { - catch {interp eval $i {load {} Safepkg1}} m o + catch {interp eval $i {load {} Safe1}} m o dict get $o -errorinfo } -returnCodes ok -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {load of binary library for package Safepkg1 failed: can't use library in a safe interpreter: no Safepkg1_SafeInit procedure +} -result {load of binary library with prefix Safe1 failed: can't use library in a safe interpreter: no Safe1_SafeInit procedure invoked from within -"load {} Safepkg1" +"load {} Safe1" invoked from within -"interp eval $i {load {} Safepkg1}"} +"interp eval $i {load {} Safe1}"} test safe-10.2 {testing statics loading / -nostatics} -constraints tcl::test -body { set i [safe::interpCreate -nostatics] - interp eval $i {load {} Safepkg1} + interp eval $i {load {} Safe1} } -returnCodes error -cleanup { safe::interpDelete $i -} -result {permission denied (static package)} +} -result {permission denied (static library)} test safe-10.3 {testing nested statics loading / no nested by default} -setup { set i [safe::interpCreate] } -constraints tcl::test -body { - interp eval $i {interp create x; load {} Safepkg1 x} + interp eval $i {interp create x; load {} Safe1 x} } -returnCodes error -cleanup { safe::interpDelete $i } -result {permission denied (nested load)} test safe-10.4 {testing nested statics loading / -nestedloadok} -constraints tcl::test -body { set i [safe::interpCreate -nestedloadok] - interp eval $i {interp create x; load {} Safepkg1 x} + interp eval $i {interp create x; load {} Safe1 x} } -returnCodes error -cleanup { safe::interpDelete $i -} -result {load of binary library for package Safepkg1 failed: can't use library in a safe interpreter: no Safepkg1_SafeInit procedure} +} -result {load of binary library with prefix Safe1 failed: can't use library in a safe interpreter: no Safe1_SafeInit procedure} test safe-10.4.1 {testing nested statics loading / -nestedloadok} -constraints tcl::test -body { set i [safe::interpCreate -nestedloadok] - catch {interp eval $i {interp create x; load {} Safepkg1 x}} m o + catch {interp eval $i {interp create x; load {} Safe1 x}} m o dict get $o -errorinfo } -returnCodes ok -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {load of binary library for package Safepkg1 failed: can't use library in a safe interpreter: no Safepkg1_SafeInit procedure +} -result {load of binary library with prefix Safe1 failed: can't use library in a safe interpreter: no Safe1_SafeInit procedure invoked from within -"load {} Safepkg1 x" +"load {} Safe1 x" invoked from within -"interp eval $i {interp create x; load {} Safepkg1 x}"} +"interp eval $i {interp create x; load {} Safe1 x}"} test safe-11.1 {testing safe encoding} -setup { set i [safe::interpCreate] -- cgit v0.12 From 8abb212fb655d173a547e5e2dced0a3865e4fc6f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 11 Jan 2021 15:58:39 +0000 Subject: Make tclStrToD.c compile on systems without inttypes.h --- generic/tclStrToD.c | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index c0a8a65..92902da4 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -22,6 +22,11 @@ #define copysign _copysign #endif +#ifndef PRIx64 +# define PRIx64 TCL_LL_MODIFIER "x" +#endif + + /* * This code supports (at least hypothetically), IBM, Cray, VAX and IEEE-754 * floating point; of these, only IEEE-754 can represent NaN. IEEE-754 can be -- cgit v0.12 From 9e0e24e95304e0dc8d8f1ba93adf0af8b702f940 Mon Sep 17 00:00:00 2001 From: msi Date: Tue, 19 Jan 2021 20:57:04 +0000 Subject: Improve clarity of [file attributes] documentation --- doc/file.n | 33 ++++++++++++++++++--------------- 1 file changed, 18 insertions(+), 15 deletions(-) diff --git a/doc/file.n b/doc/file.n index 292c3b8..43eee9b 100644 --- a/doc/file.n +++ b/doc/file.n @@ -45,21 +45,24 @@ specific option. The third form sets one or more of the values. The values are as follows: .RS .PP -On Unix, \fB\-group\fR gets or sets the group name for the file. A group id -can be given to the command, but it returns a group name. \fB\-owner\fR gets -or sets the user name of the owner of the file. The command returns the -owner name, but the numerical id can be passed when setting the -owner. \fB\-permissions\fR sets or retrieves the octal code that chmod(1) -uses. This option also provides limited support for setting permissions -using the symbolic notation used by the Unix chmod(1) command, following the -form [ugo]?[[+-=][rwxst],[...]]. Multiple permission specifications may be -given, separated by commas. E.g., \fBu+s,go-rw\fR would set the setuid bit -for a file's owner as well as remove read and write permission for the file's -group and other users. A simplified \fBls\fR style string, of the form -rwxrwxrwx (must be 9 characters), is also supported (example: -\fBrwxr\-xr\-t\fR is equivalent to 01755). On versions of Unix supporting -file flags, \fB\-readonly\fR gives the value or sets or clears the readonly -attribute of the file, i.e. the user immutable flag \fBuchg\fR to chflags(1). +On Unix, \fB\-group\fR gets or sets the group name for the file. A +group id can be given to the command, but it returns a group name. +\fB\-owner\fR gets or sets the user name of the owner of the file. The +command returns the owner name, but the numerical id can be passed when +setting the owner. \fB\-permissions\fR retrieves or sets a file's access +permissions, using octal notation by default. This option also provides +limited support for setting permissions using the symbolic notation +accepted by the \fBchmod\fR command, following the form +[\fBugo\fR]?[[\fB+-=\fR][\fBrwxst\fR]\fB,\fR[...]]. Multiple permission +specifications may be given, separated by commas. E.g., \fBu+s,go-rw\fR +would set the setuid bit for a file's owner as well as remove read and +write permission for the file's group and other users. An +\fBls\fR-style string of the form \fBrwxrwxrwx\fR is also accepted but +must always be 9 characters long. E.g., \fBrwxr-xr-t\fR is equivalent to +\fB01755\fR. On versions of Unix supporting file flags, \fB-readonly\fR +returns the value of, or sets, or clears the readonly attribute of a +file, i.e., the user immutable flag (\fBuchg\fR) to the \fBchflags\fR +command. .PP On Windows, \fB\-archive\fR gives the value or sets or clears the archive attribute of the file. \fB\-hidden\fR gives the value or sets -- cgit v0.12 From 1edbb06e02d1a83129944d6860f3519dc5c579e4 Mon Sep 17 00:00:00 2001 From: msi Date: Wed, 20 Jan 2021 23:05:44 +0000 Subject: Improve [file attributes] documentation --- doc/file.n | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/doc/file.n b/doc/file.n index 43eee9b..c5a5eed 100644 --- a/doc/file.n +++ b/doc/file.n @@ -38,31 +38,31 @@ generated. On Windows, FAT file systems do not support access time. .TP \fBfile attributes \fIname\fR ?\fIoption value option value...\fR? . -This subcommand returns or sets platform specific values associated -with a file. The first form returns a list of the platform specific -flags and their values. The second form returns the value for the -specific option. The third form sets one or more of the values. The -values are as follows: +This subcommand returns or sets platform-specific values associated +with a file. The first form returns a list of the platform-specific +options and their values. The second form returns the value for the +given option. The third form sets one or more of the values. The values +are as follows: .RS .PP On Unix, \fB\-group\fR gets or sets the group name for the file. A group id can be given to the command, but it returns a group name. \fB\-owner\fR gets or sets the user name of the owner of the file. The command returns the owner name, but the numerical id can be passed when -setting the owner. \fB\-permissions\fR retrieves or sets a file's access -permissions, using octal notation by default. This option also provides -limited support for setting permissions using the symbolic notation -accepted by the \fBchmod\fR command, following the form +setting the owner. \fB\-permissions\fR retrieves or sets a file's +access permissions, using octal notation by default. This option also +provides limited support for setting permissions using the symbolic +notation accepted by the \fBchmod\fR command, following the form [\fBugo\fR]?[[\fB+-=\fR][\fBrwxst\fR]\fB,\fR[...]]. Multiple permission specifications may be given, separated by commas. E.g., \fBu+s,go-rw\fR would set the setuid bit for a file's owner as well as remove read and write permission for the file's group and other users. An \fBls\fR-style string of the form \fBrwxrwxrwx\fR is also accepted but -must always be 9 characters long. E.g., \fBrwxr-xr-t\fR is equivalent to -\fB01755\fR. On versions of Unix supporting file flags, \fB-readonly\fR -returns the value of, or sets, or clears the readonly attribute of a -file, i.e., the user immutable flag (\fBuchg\fR) to the \fBchflags\fR -command. +must always be 9 characters long. E.g., \fBrwxr-xr-t\fR is equivalent +to \fB01755\fR. On versions of Unix supporting file flags, +\fB-readonly\fR returns the value of, or sets, or clears the readonly +attribute of a file, i.e., the user immutable flag (\fBuchg\fR) to the +\fBchflags\fR command. .PP On Windows, \fB\-archive\fR gives the value or sets or clears the archive attribute of the file. \fB\-hidden\fR gives the value or sets -- cgit v0.12 From adae2dcc7ca1c9e8162356b4263e4bb77b083091 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 22 Jan 2021 15:31:42 +0000 Subject: Undo (for now) removal of TclMacOSXNotifierAddRunLoopMode(), we don't want an earlier compiled Tk to crash. Just wait some time, until everyone uses a newer Tk 8.7, using Tcl_MacOSXNotifierAddRunLoopMode() --- generic/tclInt.decls | 7 +++---- generic/tclIntPlatDecls.h | 19 +++++++++++++------ generic/tclStubInit.c | 5 +++-- 3 files changed, 19 insertions(+), 12 deletions(-) diff --git a/generic/tclInt.decls b/generic/tclInt.decls index add705b..303492e 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -1317,10 +1317,9 @@ declare 18 {unix macosx} { const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types) } -# Removed in 9.0: -#declare 19 {unix macosx} { -# void TclMacOSXNotifierAddRunLoopMode(const void *runLoopMode) -#} +declare 19 {unix macosx} { + void TclMacOSXNotifierAddRunLoopMode(const void *runLoopMode) +} declare 22 {unix macosx} { TclFile TclpCreateTempFile_(const char *contents) } diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index b45f25d..bc6a7e3 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -92,7 +92,9 @@ EXTERN int TclMacOSXMatchType(Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); -/* Slot 19 is reserved */ +/* 19 */ +EXTERN void TclMacOSXNotifierAddRunLoopMode( + const void *runLoopMode); /* Slot 20 is reserved */ /* Slot 21 is reserved */ /* 22 */ @@ -224,7 +226,9 @@ EXTERN int TclMacOSXMatchType(Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); -/* Slot 19 is reserved */ +/* 19 */ +EXTERN void TclMacOSXNotifierAddRunLoopMode( + const void *runLoopMode); /* Slot 20 is reserved */ /* Slot 21 is reserved */ /* 22 */ @@ -267,7 +271,7 @@ typedef struct TclIntPlatStubs { int (*tclMacOSXSetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); /* 16 */ int (*tclMacOSXCopyFileAttributes) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); /* 17 */ int (*tclMacOSXMatchType) (Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 18 */ - void (*reserved19)(void); + void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */ void (*reserved20)(void); void (*reserved21)(void); TclFile (*tclpCreateTempFile_) (const char *contents); /* 22 */ @@ -333,7 +337,7 @@ typedef struct TclIntPlatStubs { int (*tclMacOSXSetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); /* 16 */ int (*tclMacOSXCopyFileAttributes) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); /* 17 */ int (*tclMacOSXMatchType) (Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 18 */ - void (*reserved19)(void); + void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */ void (*reserved20)(void); void (*reserved21)(void); TclFile (*tclpCreateTempFile_) (const char *contents); /* 22 */ @@ -395,7 +399,8 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; (tclIntPlatStubsPtr->tclMacOSXCopyFileAttributes) /* 17 */ #define TclMacOSXMatchType \ (tclIntPlatStubsPtr->tclMacOSXMatchType) /* 18 */ -/* Slot 19 is reserved */ +#define TclMacOSXNotifierAddRunLoopMode \ + (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */ /* Slot 20 is reserved */ /* Slot 21 is reserved */ #define TclpCreateTempFile_ \ @@ -498,7 +503,8 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; (tclIntPlatStubsPtr->tclMacOSXCopyFileAttributes) /* 17 */ #define TclMacOSXMatchType \ (tclIntPlatStubsPtr->tclMacOSXMatchType) /* 18 */ -/* Slot 19 is reserved */ +#define TclMacOSXNotifierAddRunLoopMode \ + (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */ /* Slot 20 is reserved */ /* Slot 21 is reserved */ #define TclpCreateTempFile_ \ @@ -525,6 +531,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; #undef TclpCreateTempFile_ #undef TclUnixWaitForFile_ +#undef TclMacOSXNotifierAddRunLoopMode #ifndef MAC_OSX_TCL /* not accessable on Win32/UNIX */ #undef TclMacOSXGetFileAttribute /* 15 */ #undef TclMacOSXSetFileAttribute /* 16 */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 51d0a38..577c05a 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -154,6 +154,7 @@ static void uniCodePanic() { # define Tcl_MacOSXOpenVersionedBundleResources 0 # define Tcl_MacOSXNotifierAddRunLoopMode 0 #endif +#define TclMacOSXNotifierAddRunLoopMode Tcl_MacOSXNotifierAddRunLoopMode #ifdef _WIN32 # define Tcl_CreateFileHandler 0 # define Tcl_DeleteFileHandler 0 @@ -564,7 +565,7 @@ static const TclIntPlatStubs tclIntPlatStubs = { TclMacOSXSetFileAttribute, /* 16 */ TclMacOSXCopyFileAttributes, /* 17 */ TclMacOSXMatchType, /* 18 */ - 0, /* 19 */ + TclMacOSXNotifierAddRunLoopMode, /* 19 */ 0, /* 20 */ 0, /* 21 */ TclpCreateTempFile_, /* 22 */ @@ -630,7 +631,7 @@ static const TclIntPlatStubs tclIntPlatStubs = { TclMacOSXSetFileAttribute, /* 16 */ TclMacOSXCopyFileAttributes, /* 17 */ TclMacOSXMatchType, /* 18 */ - 0, /* 19 */ + TclMacOSXNotifierAddRunLoopMode, /* 19 */ 0, /* 20 */ 0, /* 21 */ TclpCreateTempFile_, /* 22 */ -- cgit v0.12 From 634ebe7c6db3115dea3f52b3aaebbe8542313ce7 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 25 Jan 2021 10:04:49 +0000 Subject: Remove many commented-out sections of tclInt.decls: Since Tcl 9.0 doesn't need to be binary compatible with Tcl 8.7, it doesn't matter any more. And we have fossil for that. --- generic/tclInt.decls | 601 +-------------------------------------------------- 1 file changed, 1 insertion(+), 600 deletions(-) diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 303492e..9eb9a71 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -23,23 +23,9 @@ interface tclInt # Use at your own risk. Note that the position of functions should not # be changed between versions to avoid gratuitous incompatibilities. -# Replaced by Tcl_FSAccess in 8.4: -#declare 0 { -# int TclAccess(const char *path, int mode) -#} -#declare 1 { -# int TclAccessDeleteProc(TclAccessProc_ *proc) -#} -#declare 2 { -# int TclAccessInsertProc(TclAccessProc_ *proc) -#} declare 3 { void TclAllocateFreeObjects(void) } -# Replaced by TclpChdir in 8.1: -# declare 4 { -# int TclChdir(Tcl_Interp *interp, char *dirName) -# } declare 5 { int TclCleanupChildren(Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan) @@ -50,14 +36,7 @@ declare 6 { declare 7 { size_t TclCopyAndCollapse(size_t count, const char *src, char *dst) } -# Removed in 9.0: -#declare 8 { -# int TclCopyChannelOld(Tcl_Interp *interp, Tcl_Channel inChan, -# Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr) -#} - # TclCreatePipeline unofficially exported for use by BLT. - declare 9 { int TclCreatePipeline(Tcl_Interp *interp, int argc, const char **argv, Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, @@ -74,37 +53,12 @@ declare 11 { declare 12 { void TclDeleteVars(Interp *iPtr, TclVarHashTable *tablePtr) } -# Removed in 8.5: -#declare 13 { -# int TclDoGlob(Tcl_Interp *interp, char *separators, -# Tcl_DString *headPtr, char *tail, Tcl_GlobTypeData *types) -#} declare 14 { int TclDumpMemoryInfo(void *clientData, int flags) } -# Removed in 8.1: -# declare 15 { -# void TclExpandParseValue(ParseValue *pvPtr, int needed) -# } declare 16 { void TclExprFloatError(Tcl_Interp *interp, double value) } -# Removed in 8.4: -#declare 17 { -# int TclFileAttrsCmd(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) -#} -#declare 18 { -# int TclFileCopyCmd(Tcl_Interp *interp, int argc, char **argv) -#} -#declare 19 { -# int TclFileDeleteCmd(Tcl_Interp *interp, int argc, char **argv) -#} -#declare 20 { -# int TclFileMakeDirsCmd(Tcl_Interp *interp, int argc, char **argv) -#} -#declare 21 { -# int TclFileRenameCmd(Tcl_Interp *interp, int argc, char **argv) -#} declare 22 { int TclFindElement(Tcl_Interp *interp, const char *listStr, int listLength, const char **elementPtr, const char **nextPtr, @@ -120,27 +74,9 @@ declare 24 { declare 25 { void TclFreePackageInfo(Interp *iPtr) } -# Removed in 8.1: -# declare 26 { -# char *TclGetCwd(Tcl_Interp *interp) -# } -# Removed in 8.5: -#declare 27 { -# int TclGetDate(char *p, unsigned long now, long zone, -# unsigned long *timePtr) -#} declare 28 { Tcl_Channel TclpGetDefaultStdChannel(int type) } -# Removed in 8.4b2: -#declare 29 { -# Tcl_Obj *TclGetElementOfIndexedArray(Tcl_Interp *interp, -# int localIndex, Tcl_Obj *elemPtr, int flags) -#} -# Replaced by char *TclGetEnv(const char *name, Tcl_DString *valuePtr) in 8.1: -# declare 30 { -# char *TclGetEnv(const char *name) -# } declare 31 { const char *TclGetExtension(const char *name) } @@ -148,28 +84,6 @@ declare 32 { int TclGetFrame(Tcl_Interp *interp, const char *str, CallFrame **framePtrPtr) } -# Removed in 8.5: -#declare 33 { -# TclCmdProcType TclGetInterpProc(void) -#} -# Removed in 9.0: -#declare 34 {deprecated {Use Tcl_GetIntForIndex}} { -# int TclGetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr, -# int endValue, int *indexPtr) -#} -# Removed in 8.4b2: -#declare 35 { -# Tcl_Obj *TclGetIndexedScalar(Tcl_Interp *interp, int localIndex, -# int flags) -#} -# Removed in 8.6a2: -#declare 36 { -# int TclGetLong(Tcl_Interp *interp, const char *str, long *longPtr) -#} -# Removed in 9.0: -#declare 37 { -# int TclGetLoadedPackages(Tcl_Interp *interp, const char *targetName) -#} declare 38 { int TclGetNamespaceForQualName(Tcl_Interp *interp, const char *qualName, Namespace *cxtNsPtr, int flags, Namespace **nsPtrPtr, @@ -188,48 +102,15 @@ declare 41 { declare 42 { const char *TclpGetUserHome(const char *name, Tcl_DString *bufferPtr) } -# Removed in 8.5a2: -#declare 43 { -# int TclGlobalInvoke(Tcl_Interp *interp, int argc, const char **argv, -# int flags) -#} -# Removed in 9.0: -#declare 44 { -# int TclGuessPackageName(const char *fileName, Tcl_DString *bufPtr) -#} declare 45 { int TclHideUnsafeCommands(Tcl_Interp *interp) } declare 46 { int TclInExit(void) } -# Removed in 8.4b2: -#declare 47 { -# Tcl_Obj *TclIncrElementOfIndexedArray(Tcl_Interp *interp, -# int localIndex, Tcl_Obj *elemPtr, long incrAmount) -#} -# Removed in 8.4b2: -#declare 48 { -# Tcl_Obj *TclIncrIndexedScalar(Tcl_Interp *interp, int localIndex, -# long incrAmount) -#} -#declare 49 { -# Tcl_Obj *TclIncrVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, -# Tcl_Obj *part2Ptr, long incrAmount, int part1NotParsed) -#} -# Removed in 9.0: -#declare 50 { -# void TclInitCompiledLocals(Tcl_Interp *interp, CallFrame *framePtr, -# Namespace *nsPtr) -#} declare 51 { int TclInterpInit(Tcl_Interp *interp) } -# Removed in 8.5a2: -#declare 52 { -# int TclInvoke(Tcl_Interp *interp, int argc, const char **argv, -# int flags) -#} declare 53 { int TclInvokeObjectCommand(void *clientData, Tcl_Interp *interp, int argc, const char **argv) @@ -241,26 +122,11 @@ declare 54 { declare 55 { Proc *TclIsProc(Command *cmdPtr) } -# Replaced with TclpLoadFile in 8.1: -# declare 56 { -# int TclLoadFile(Tcl_Interp *interp, char *fileName, char *sym1, -# char *sym2, Tcl_PackageInitProc **proc1Ptr, -# Tcl_PackageInitProc **proc2Ptr) -# } -# Signature changed to take a length in 8.1: -# declare 57 { -# int TclLooksLikeInt(char *p) -# } declare 58 { Var *TclLookupVar(Tcl_Interp *interp, const char *part1, const char *part2, int flags, const char *msg, int createPart1, int createPart2, Var **arrayPtrPtr) } -# Replaced by Tcl_FSMatchInDirectory in 8.4 -#declare 59 { -# int TclpMatchFiles(Tcl_Interp *interp, char *separators, -# Tcl_DString *dirPtr, char *pattern, char *tail) -#} declare 60 { int TclNeedSpace(const char *start, const char *end) } @@ -278,37 +144,9 @@ declare 64 { int TclObjInvoke(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags) } -# Removed in 8.5a2: -#declare 65 { -# int TclObjInvokeGlobal(Tcl_Interp *interp, int objc, -# Tcl_Obj *const objv[], int flags) -#} -#declare 66 { -# int TclOpenFileChannelDeleteProc(TclOpenFileChannelProc_ *proc) -#} -#declare 67 { -# int TclOpenFileChannelInsertProc(TclOpenFileChannelProc_ *proc) -#} -# Replaced by Tcl_FSAccess in 8.4: -#declare 68 { -# int TclpAccess(const char *path, int mode) -#} declare 69 { void *TclpAlloc(size_t size) } -#declare 70 { -# int TclpCopyFile(const char *source, const char *dest) -#} -#declare 71 { -# int TclpCopyDirectory(const char *source, const char *dest, -# Tcl_DString *errorPtr) -#} -#declare 72 { -# int TclpCreateDirectory(const char *path) -#} -#declare 73 { -# int TclpDeleteFile(const char *path) -#} declare 74 { void TclpFree(void *ptr) } @@ -318,63 +156,13 @@ declare 75 { declare 76 { Tcl_WideUInt TclpGetSeconds(void) } - -# Removed in 9.0: -#declare 77 { -# void TclpGetTime(Tcl_Time *time) -#} -# Removed in 8.6: -#declare 78 { -# int TclpGetTimeZone(unsigned long time) -#} -# Replaced by Tcl_FSListVolumes in 8.4: -#declare 79 { -# int TclpListVolumes(Tcl_Interp *interp) -#} -# Replaced by Tcl_FSOpenFileChannel in 8.4: -#declare 80 { -# Tcl_Channel TclpOpenFileChannel(Tcl_Interp *interp, char *fileName, -# char *modeString, int permissions) -#} declare 81 { void *TclpRealloc(void *ptr, size_t size) } -#declare 82 { -# int TclpRemoveDirectory(const char *path, int recursive, -# Tcl_DString *errorPtr) -#} -#declare 83 { -# int TclpRenameFile(const char *source, const char *dest) -#} -# Removed in 8.1: -# declare 84 { -# int TclParseBraces(Tcl_Interp *interp, char *str, char **termPtr, -# ParseValue *pvPtr) -# } -# declare 85 { -# int TclParseNestedCmd(Tcl_Interp *interp, char *str, int flags, -# char **termPtr, ParseValue *pvPtr) -# } -# declare 86 { -# int TclParseQuotes(Tcl_Interp *interp, char *str, int termChar, -# int flags, char **termPtr, ParseValue *pvPtr) -# } -# declare 87 { -# void TclPlatformInit(Tcl_Interp *interp) -# } -# Removed in 9.0: -#declare 88 { -# char *TclPrecTraceProc(void *clientData, Tcl_Interp *interp, -# const char *name1, const char *name2, int flags) -#} declare 89 { int TclPreventAliasLoop(Tcl_Interp *interp, Tcl_Interp *cmdInterp, Tcl_Command cmd) } -# Removed in 8.1 (only available if compiled with TCL_COMPILE_DEBUG): -# declare 90 { -# void TclPrintByteCodeObj(Tcl_Interp *interp, Tcl_Obj *objPtr) -# } declare 91 { void TclProcCleanupProc(Proc *procPtr) } @@ -386,15 +174,6 @@ declare 92 { declare 93 { void TclProcDeleteProc(void *clientData) } -# Removed in 8.5: -#declare 94 { -# int TclProcInterpProc(void *clientData, Tcl_Interp *interp, -# int argc, const char **argv) -#} -# Replaced by Tcl_FSStat in 8.4: -#declare 95 { -# int TclpStat(const char *path, Tcl_StatBuf *buf) -#} declare 96 { int TclRenameCommand(Tcl_Interp *interp, const char *oldName, const char *newName) @@ -405,16 +184,6 @@ declare 97 { declare 98 { int TclServiceIdle(void) } -# Removed in 8.4b2: -#declare 99 { -# Tcl_Obj *TclSetElementOfIndexedArray(Tcl_Interp *interp, int localIndex, -# Tcl_Obj *elemPtr, Tcl_Obj *objPtr, int flags) -#} -# Removed in 8.4b2: -#declare 100 { -# Tcl_Obj *TclSetIndexedScalar(Tcl_Interp *interp, int localIndex, -# Tcl_Obj *objPtr, int flags) -#} declare 101 { const char *TclSetPreInitScript(const char *string) } @@ -425,20 +194,6 @@ declare 103 { int TclSockGetPort(Tcl_Interp *interp, const char *str, const char *proto, int *portPtr) } -# Removed in 9.0: -#declare 104 { -# int TclSockMinimumBuffersOld(int sock, int size) -#} -# Replaced by Tcl_FSStat in 8.4: -#declare 105 { -# int TclStat(const char *path, Tcl_StatBuf *buf) -#} -#declare 106 { -# int TclStatDeleteProc(TclStatProc_ *proc) -#} -#declare 107 { -# int TclStatInsertProc(TclStatProc_ *proc) -#} declare 108 { void TclTeardownNamespace(Namespace *nsPtr) } @@ -461,35 +216,6 @@ declare 111 { Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc) } -# Removed in 9.0: -#declare 112 { -# int Tcl_AppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr, -# Tcl_Obj *objPtr) -#} -# Removed in 9.0: -#declare 113 { -# Tcl_Namespace *Tcl_CreateNamespace(Tcl_Interp *interp, const char *name, -# void *clientData, Tcl_NamespaceDeleteProc *deleteProc) -#} -# Removed in 9.0: -#declare 114 { -# void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr) -#} -# Removed in 9.0: -#declare 115 { -# int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr, -# const char *pattern, int resetListFirst) -#} -# Removed in 9.0: -#declare 116 { -# Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, const char *name, -# Tcl_Namespace *contextNsPtr, int flags) -#} -# Removed in 9.0: -#declare 117 { -# Tcl_Namespace *Tcl_FindNamespace(Tcl_Interp *interp, const char *name, -# Tcl_Namespace *contextNsPtr, int flags) -#} declare 118 { int Tcl_GetInterpResolvers(Tcl_Interp *interp, const char *name, Tcl_ResolverInfo *resInfo) @@ -502,37 +228,10 @@ declare 120 { Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags) } -# Removed in 9.0: -#declare 121 { -# int Tcl_ForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, -# const char *pattern) -#} -# Removed in 9.0: -#declare 122 { -# Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr) -#} -# Removed in 9.0: -#declare 123 { -# void Tcl_GetCommandFullName(Tcl_Interp *interp, Tcl_Command command, -# Tcl_Obj *objPtr) -#} -# Removed in 9.0: -#declare 124 { -# Tcl_Namespace *Tcl_GetCurrentNamespace(Tcl_Interp *interp) -#} -# Removed in 9.0: -#declare 125 { -# Tcl_Namespace *Tcl_GetGlobalNamespace(Tcl_Interp *interp) -#} declare 126 { void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr) } -# Removed in 9.0: -#declare 127 { -# int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr, -# const char *pattern, int allowOverwrite) -#} declare 128 { void Tcl_PopCallFrame(Tcl_Interp *interp) } @@ -551,35 +250,9 @@ declare 131 { declare 132 { int TclpHasSockets(Tcl_Interp *interp) } -# Removed in 9.0 -#declare 133 { -# struct tm *TclpGetDate(const time_t *time, int useGMT) -#} -# Removed in 8.5 -#declare 134 { -# size_t TclpStrftime(char *s, size_t maxsize, const char *format, -# const struct tm *t, int useGMT) -#} -#declare 135 { -# int TclpCheckStackSpace(void) -#} - -# Added in 8.1: - -#declare 137 { -# int TclpChdir(const char *dirName) -#} declare 138 { const char *TclGetEnv(const char *name, Tcl_DString *valuePtr) } -#declare 139 { -# int TclpLoadFile(Tcl_Interp *interp, char *fileName, char *sym1, -# char *sym2, Tcl_PackageInitProc **proc1Ptr, -# Tcl_PackageInitProc **proc2Ptr, void **clientDataPtr) -#} -#declare 140 { -# int TclLooksLikeInt(const char *bytes, int length) -#} # This is used by TclX, but should otherwise be considered private declare 141 { const char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr) @@ -611,9 +284,6 @@ declare 148 { declare 149 { void TclHandleRelease(TclHandle handle) } - -# Added for Tcl 8.2 - declare 150 { int TclRegAbout(Tcl_Interp *interp, Tcl_RegExp re) } @@ -627,17 +297,6 @@ declare 152 { declare 153 { Tcl_Obj *TclGetLibraryPath(void) } - -# moved to tclTest.c (static) in 8.3.2/8.4a2 -#declare 154 { -# int TclTestChannelCmd(void *clientData, -# Tcl_Interp *interp, int argc, char **argv) -#} -#declare 155 { -# int TclTestChannelEventCmd(void *clientData, -# Tcl_Interp *interp, int argc, char **argv) -#} - declare 156 { void TclRegError(Tcl_Interp *interp, const char *msg, int status) @@ -645,21 +304,6 @@ declare 156 { declare 157 { Var *TclVarTraceExists(Tcl_Interp *interp, const char *varName) } -# REMOVED - use public Tcl_SetStartupScript() -#declare 158 { -# void TclSetStartupScriptFileName(const char *filename) -#} -# REMOVED - use public Tcl_GetStartupScript() -#declare 159 { -# const char *TclGetStartupScriptFileName(void) -#} -#declare 160 { -# int TclpMatchFilesTypes(Tcl_Interp *interp, char *separators, -# Tcl_DString *dirPtr, char *pattern, char *tail, -# GlobTypeData *types) -#} - -# new in 8.3.2/8.4a2 declare 161 { int TclChannelTransform(Tcl_Interp *interp, Tcl_Channel chan, Tcl_Obj *cmdObjPtr) @@ -696,15 +340,6 @@ declare 166 { int index, Tcl_Obj *valuePtr) } -# VFS-aware versions of Tcl*StartupScriptFileName (158 and 159 above) -# REMOVED - use public Tcl_SetStartupScript() -#declare 167 { -# void TclSetStartupScriptPath(Tcl_Obj *pathPtr) -#} -# REMOVED - use public Tcl_GetStartupScript() -#declare 168 { -# Tcl_Obj *TclGetStartupScriptPath(void) -#} # variant of Tcl_UtfNCmp that takes n as bytes, not chars declare 169 { int TclpUtfNcmp2(const char *s1, const char *s2, size_t n) @@ -722,23 +357,10 @@ declare 171 { declare 172 { int TclInThreadExit(void) } - -# added for 8.4.2 - declare 173 { int TclUniCharMatch(const Tcl_UniChar *string, size_t strLen, const Tcl_UniChar *pattern, size_t ptnLen, int flags) } - -# added for 8.4.3 - -#declare 174 { -# Tcl_Obj *TclIncrWideVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, -# Tcl_Obj *part2Ptr, Tcl_WideInt wideIncrAmount, int part1NotParsed) -#} - -# Factoring out of trace code - declare 175 { int TclCallVarTraces(Interp *iPtr, Var *arrayPtr, Var *varPtr, const char *part1, const char *part2, int flags, int leaveErrMsg) @@ -750,95 +372,10 @@ declare 177 { void TclVarErrMsg(Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason) } -# TIP 338 made these public - now declared in tcl.h -#declare 178 { -# void Tcl_SetStartupScript(Tcl_Obj *pathPtr, const char *encodingName) -#} -#declare 179 { -# Tcl_Obj *Tcl_GetStartupScript(const char **encodingNamePtr) -#} - -# REMOVED -# Allocate lists without copying arrays -# declare 180 { -# Tcl_Obj *TclNewListObjDirect(int objc, Tcl_Obj **objv) -# } -#declare 181 { -# Tcl_Obj *TclDbNewListObjDirect(int objc, Tcl_Obj **objv, -# const char *file, int line) -#} - -# Removed in 9.0 -#declare 182 { -# struct tm *TclpLocaltime(const time_t *clock) -#} -# Removed in 9.0 -#declare 183 { -# struct tm *TclpGmtime(const time_t *clock) -#} - -# For the new "Thread Storage" subsystem. - -### REMOVED on grounds it should never have been exposed. All these -### functions are now either static in tclThreadStorage.c or -### MODULE_SCOPE. -# declare 184 { -# void TclThreadStorageLockInit(void) -# } -# declare 185 { -# void TclThreadStorageLock(void) -# } -# declare 186 { -# void TclThreadStorageUnlock(void) -# } -# declare 187 { -# void TclThreadStoragePrint(FILE *outFile, int flags) -# } -# declare 188 { -# Tcl_HashTable *TclThreadStorageGetHashTable(Tcl_ThreadId id) -# } -# declare 189 { -# Tcl_HashTable *TclThreadStorageInit(Tcl_ThreadId id, void *reserved) -# } -# declare 190 { -# void TclThreadStorageDataKeyInit(Tcl_ThreadDataKey *keyPtr) -# } -# declare 191 { -# void *TclThreadStorageDataKeyGet(Tcl_ThreadDataKey *keyPtr) -# } -# declare 192 { -# void TclThreadStorageDataKeySet(Tcl_ThreadDataKey *keyPtr, void *data) -# } -# declare 193 { -# void TclFinalizeThreadStorageThread(Tcl_ThreadId id) -# } -# declare 194 { -# void TclFinalizeThreadStorage(void) -# } -# declare 195 { -# void TclFinalizeThreadStorageData(Tcl_ThreadDataKey *keyPtr) -# } -# declare 196 { -# void TclFinalizeThreadStorageDataKey(Tcl_ThreadDataKey *keyPtr) -# } - -# -# Added in tcl8.5a5 for compiler/executor experimentation. -# Disabled in Tcl 8.5.1; experiments terminated. :/ -# -#declare 197 { -# int TclCompEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr, -# const CmdFrame *invoker, int word) -#} declare 198 { int TclObjGetFrame(Tcl_Interp *interp, Tcl_Obj *objPtr, CallFrame **framePtrPtr) } - -#declare 199 { -# int TclMatchIsTrivial(const char *pattern) -#} - # 200-208 exported for use by the test suite [Bug 1054748] declare 200 { int TclpObjRemoveDirectory(Tcl_Obj *pathPtr, int recursive, @@ -870,16 +407,6 @@ declare 208 { Tcl_Channel TclpOpenFileChannel(Tcl_Interp *interp, Tcl_Obj *pathPtr, int mode, int permissions) } -# Made public by TIP 258 -#declare 209 { -# Tcl_Obj *TclGetEncodingSearchPath(void) -#} -#declare 210 { -# int TclSetEncodingSearchPath(Tcl_Obj *searchPath) -#} -#declare 211 { -# const char *TclpGetEncodingNameFromEnvironment(Tcl_DString *bufPtr) -#} declare 212 { void TclpFindExecutable(const char *argv0) } @@ -907,8 +434,6 @@ declare 218 { declare 224 { TclPlatformType *TclGetPlatform(void) } - -# declare 225 { Tcl_Obj *TclTraceDictPath(Tcl_Interp *interp, Tcl_Obj *rootPtr, int keyc, Tcl_Obj *const keyv[], int flags) @@ -920,12 +445,6 @@ declare 227 { void TclSetNsPath(Namespace *nsPtr, size_t pathLength, Tcl_Namespace *pathAry[]) } -# Used to be needed for TclOO-extension; unneeded now that TclOO is in the -# core and NRE-enabled -# declare 228 { -# int TclObjInterpProcCore(Tcl_Interp *interp, Tcl_Obj *procNameObj, -# int skip, ProcErrorProc *errorProc) -# } declare 229 { int TclPtrMakeUpvar(Tcl_Interp *interp, Var *otherP1Ptr, const char *myName, int myFlags, int index) @@ -948,7 +467,6 @@ declare 232 { declare 233 { void TclGetSrcInfoForPc(CmdFrame *contextPtr) } - # Exports for VarReform compat: Itcl, XOTcl like to peek into our varTables :( declare 234 { Var *TclVarHashCreateVar(TclVarHashTable *tablePtr, const char *key, @@ -957,18 +475,10 @@ declare 234 { declare 235 { void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr) } - - -# TIP 337 made this one public -#declare 236 { -# void TclBackgroundException(Tcl_Interp *interp, int code) -#} - # TIP #285: Script cancellation support. declare 237 { int TclResetCancellation(Tcl_Interp *interp, int force) } - # NRE functions for "rogue" extensions to exploit NRE; they will need to # include NRE.h too. declare 238 { @@ -1057,6 +567,7 @@ declare 256 { int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags) } + declare 257 { void TclStaticPackage(Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc) @@ -1077,7 +588,6 @@ declare 260 { unsigned char *TclGetBytesFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, size_t *lengthPtr) } - ############################################################################## @@ -1092,58 +602,15 @@ interface tclIntPlat declare 0 win { void TclWinConvertError(int errCode) } -# Removed in 9.0: -#declare 1 win { -# void TclWinConvertWSAError(int errCode) -#} -# Removed in 9.0: -#declare 2 win { -# struct servent *TclWinGetServByName(const char *nm, -# const char *proto) -#} -# Removed in 9.0: -#declare 3 win { -# int TclWinGetSockOpt(SOCKET s, int level, int optname, -# char *optval, int *optlen) -#} declare 4 win { void *TclWinGetTclInstance(void) } -# new for 8.4.20+/8.5.12+ Cygwin only declare 5 win { int TclUnixWaitForFile(int fd, int mask, int timeout) } -# Removed in 8.1: -# declare 5 win { -# HINSTANCE TclWinLoadLibrary(char *name) -# } -# Removed in 9.0: -#declare 6 win { -# unsigned short TclWinNToHS(unsigned short ns) -#} -# Removed in 9.0: -#declare 7 win { -# int TclWinSetSockOpt(SOCKET s, int level, int optname, -# const char *optval, int optlen) -#} declare 8 win { size_t TclpGetPid(Tcl_Pid pid) } -# Removed in 9.0: -#declare 9 win { -# int TclWinGetPlatformId(void) -#} -# Removed in 9.0: -#declare 10 win { -# Tcl_DirEntry *TclpReaddir(TclDIR *dir) -#} -# Removed in 8.3.1 (for Win32s only): -#declare 10 win { -# int TclWinSynchSpawn(void *args, int type, void **trans, Tcl_Pid *pidPtr) -#} - -# Pipe channel functions - declare 11 win { void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan) } @@ -1162,18 +629,9 @@ declare 15 win { const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr) } -# new for 8.4.20+/8.5.12+ Cygwin only declare 16 win { int TclpIsAtty(int fd) } -# Signature changed in 8.1: -# declare 16 win { -# TclFile TclpCreateTempFile(char *contents, Tcl_DString *namePtr) -# } -# declare 17 win { -# char *TclpGetTZName(void) -# } -# new for 8.5.12+ Cygwin only declare 17 win { int TclUnixCopyFile(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts) @@ -1187,48 +645,16 @@ declare 19 win { declare 20 win { void TclWinAddProcess(void *hProcess, size_t id) } -# Removed in 9.0: -#declare 21 win { -# char *TclpInetNtoa(struct in_addr addr) -#} -# removed permanently for 8.4 -#declare 21 win { -# void TclpAsyncMark(Tcl_AsyncHandler async) -#} - -# Added in 8.1: declare 22 win { TclFile TclpCreateTempFile(const char *contents) } -# Removed in 8.6: -#declare 23 win { -# char *TclpGetTZName(int isdst) -#} declare 24 win { char *TclWinNoBackslash(char *path) } -# replaced by generic TclGetPlatform -#declare 25 win { -# TclPlatformType *TclWinGetPlatform(void) -#} -# Removed in 9.0: -#declare 26 win { -# void TclWinSetInterfaces(int wide) -#} - -# Added in Tcl 8.3.3 / 8.4 - declare 27 win { void TclWinFlushDirtyChannels(void) } -# Added in 8.4.2 - -# Removed in 9.0: -#declare 28 win { -# void TclWinResetInterfaces(void) -#} - ################################ # Unix specific functions @@ -1264,34 +690,9 @@ declare 7 unix { declare 8 unix { int TclUnixWaitForFile(int fd, int mask, int timeout) } - -# Added in 8.1: - declare 9 unix { TclFile TclpCreateTempFile(const char *contents) } - -# Added in 8.4: - -# Removed in 9.0: -#declare 10 unix { -# Tcl_DirEntry *TclpReaddir(TclDIR *dir) -#} -# Removed in 9.0: -#declare 11 unix { -# struct tm *TclpLocaltime_unix(const time_t *clock) -#} -# Removed in 9.0: -#declare 12 unix { -# struct tm *TclpGmtime_unix(const time_t *clock) -#} -# Removed in 9.0: -#declare 13 unix { -# char *TclpInetNtoa(struct in_addr addr) -#} - -# Added in 8.5: - declare 14 unix { int TclUnixCopyFile(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts) -- cgit v0.12 From b7af5cca11d2d8d1a1950ad09ddbc47d4fa1c3fc Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 25 Jan 2021 15:20:16 +0000 Subject: Remove 4 (internal, MacOS-specific) functions from internal stub table, MODULE_SCOPE should be sufficient for those. Move other internal stub-entries around, all still binary compatible) --- generic/tclInt.decls | 36 +++---- generic/tclIntPlatDecls.h | 238 ++++++++++++++++++++++------------------------ generic/tclStubInit.c | 50 +++++----- 3 files changed, 154 insertions(+), 170 deletions(-) diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 9eb9a71..59104cc 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -661,13 +661,13 @@ declare 27 win { # Pipe channel functions declare 0 unix { - void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan) + void TclGetAndDetachPids_(Tcl_Interp *interp, Tcl_Channel chan) } declare 1 unix { int TclpCloseFile(TclFile file) } declare 2 unix { - Tcl_Channel TclpCreateCommandChannel(TclFile readFile, + Tcl_Channel TclpCreateCommandChannel_(TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr) } declare 3 unix { @@ -679,7 +679,7 @@ declare 4 unix { TclFile errorFile, Tcl_Pid *pidPtr) } declare 5 unix { - int TclUnixWaitForFile_(int fd, int mask, int timeout) + int TclUnixWaitForFile(int fd, int mask, int timeout) } declare 6 unix { TclFile TclpMakeFile(Tcl_Channel channel, int direction) @@ -688,10 +688,17 @@ declare 7 unix { TclFile TclpOpenFile(const char *fname, int mode) } declare 8 unix { - int TclUnixWaitForFile(int fd, int mask, int timeout) + int TclUnixWaitForFile_(int fd, int mask, int timeout) } declare 9 unix { - TclFile TclpCreateTempFile(const char *contents) + TclFile TclpCreateTempFile_(const char *contents) +} +declare 11 unix { + void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan) +} +declare 13 unix { + Tcl_Channel TclpCreateCommandChannel(TclFile readFile, + TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr) } declare 14 unix { int TclUnixCopyFile(const char *src, const char *dst, @@ -701,28 +708,11 @@ declare 14 unix { ################################ # Mac OS X specific functions -declare 15 {unix macosx} { - int TclMacOSXGetFileAttribute(Tcl_Interp *interp, int objIndex, - Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr) -} -declare 16 {unix macosx} { - int TclMacOSXSetFileAttribute(Tcl_Interp *interp, int objIndex, - Tcl_Obj *fileName, Tcl_Obj *attributePtr) -} -declare 17 {unix macosx} { - int TclMacOSXCopyFileAttributes(const char *src, const char *dst, - const Tcl_StatBuf *statBufPtr) -} -declare 18 {unix macosx} { - int TclMacOSXMatchType(Tcl_Interp *interp, const char *pathName, - const char *fileName, Tcl_StatBuf *statBufPtr, - Tcl_GlobTypeData *types) -} declare 19 {unix macosx} { void TclMacOSXNotifierAddRunLoopMode(const void *runLoopMode) } declare 22 {unix macosx} { - TclFile TclpCreateTempFile_(const char *contents) + TclFile TclpCreateTempFile(const char *contents) } declare 29 {win unix} { diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index bc6a7e3..1ce68b3 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -42,12 +42,12 @@ extern "C" { #if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ /* 0 */ -EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, +EXTERN void TclGetAndDetachPids_(Tcl_Interp *interp, Tcl_Channel chan); /* 1 */ EXTERN int TclpCloseFile(TclFile file); /* 2 */ -EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile, +EXTERN Tcl_Channel TclpCreateCommandChannel_(TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 3 */ @@ -58,47 +58,39 @@ EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 5 */ -EXTERN int TclUnixWaitForFile_(int fd, int mask, int timeout); +EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); /* 6 */ EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); /* 7 */ EXTERN TclFile TclpOpenFile(const char *fname, int mode); /* 8 */ -EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); +EXTERN int TclUnixWaitForFile_(int fd, int mask, int timeout); /* 9 */ -EXTERN TclFile TclpCreateTempFile(const char *contents); +EXTERN TclFile TclpCreateTempFile_(const char *contents); /* Slot 10 is reserved */ -/* Slot 11 is reserved */ +/* 11 */ +EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, + Tcl_Channel chan); /* Slot 12 is reserved */ -/* Slot 13 is reserved */ +/* 13 */ +EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile, + TclFile writeFile, TclFile errorFile, + int numPids, Tcl_Pid *pidPtr); /* 14 */ EXTERN int TclUnixCopyFile(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); -/* 15 */ -EXTERN int TclMacOSXGetFileAttribute(Tcl_Interp *interp, - int objIndex, Tcl_Obj *fileName, - Tcl_Obj **attributePtrPtr); -/* 16 */ -EXTERN int TclMacOSXSetFileAttribute(Tcl_Interp *interp, - int objIndex, Tcl_Obj *fileName, - Tcl_Obj *attributePtr); -/* 17 */ -EXTERN int TclMacOSXCopyFileAttributes(const char *src, - const char *dst, - const Tcl_StatBuf *statBufPtr); -/* 18 */ -EXTERN int TclMacOSXMatchType(Tcl_Interp *interp, - const char *pathName, const char *fileName, - Tcl_StatBuf *statBufPtr, - Tcl_GlobTypeData *types); +/* Slot 15 is reserved */ +/* Slot 16 is reserved */ +/* Slot 17 is reserved */ +/* Slot 18 is reserved */ /* 19 */ EXTERN void TclMacOSXNotifierAddRunLoopMode( const void *runLoopMode); /* Slot 20 is reserved */ /* Slot 21 is reserved */ /* 22 */ -EXTERN TclFile TclpCreateTempFile_(const char *contents); +EXTERN TclFile TclpCreateTempFile(const char *contents); /* Slot 23 is reserved */ /* Slot 24 is reserved */ /* Slot 25 is reserved */ @@ -176,12 +168,12 @@ EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ /* 0 */ -EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, +EXTERN void TclGetAndDetachPids_(Tcl_Interp *interp, Tcl_Channel chan); /* 1 */ EXTERN int TclpCloseFile(TclFile file); /* 2 */ -EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile, +EXTERN Tcl_Channel TclpCreateCommandChannel_(TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 3 */ @@ -192,47 +184,39 @@ EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 5 */ -EXTERN int TclUnixWaitForFile_(int fd, int mask, int timeout); +EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); /* 6 */ EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); /* 7 */ EXTERN TclFile TclpOpenFile(const char *fname, int mode); /* 8 */ -EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); +EXTERN int TclUnixWaitForFile_(int fd, int mask, int timeout); /* 9 */ -EXTERN TclFile TclpCreateTempFile(const char *contents); +EXTERN TclFile TclpCreateTempFile_(const char *contents); /* Slot 10 is reserved */ -/* Slot 11 is reserved */ +/* 11 */ +EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, + Tcl_Channel chan); /* Slot 12 is reserved */ -/* Slot 13 is reserved */ +/* 13 */ +EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile, + TclFile writeFile, TclFile errorFile, + int numPids, Tcl_Pid *pidPtr); /* 14 */ EXTERN int TclUnixCopyFile(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); -/* 15 */ -EXTERN int TclMacOSXGetFileAttribute(Tcl_Interp *interp, - int objIndex, Tcl_Obj *fileName, - Tcl_Obj **attributePtrPtr); -/* 16 */ -EXTERN int TclMacOSXSetFileAttribute(Tcl_Interp *interp, - int objIndex, Tcl_Obj *fileName, - Tcl_Obj *attributePtr); -/* 17 */ -EXTERN int TclMacOSXCopyFileAttributes(const char *src, - const char *dst, - const Tcl_StatBuf *statBufPtr); -/* 18 */ -EXTERN int TclMacOSXMatchType(Tcl_Interp *interp, - const char *pathName, const char *fileName, - Tcl_StatBuf *statBufPtr, - Tcl_GlobTypeData *types); +/* Slot 15 is reserved */ +/* Slot 16 is reserved */ +/* Slot 17 is reserved */ +/* Slot 18 is reserved */ /* 19 */ EXTERN void TclMacOSXNotifierAddRunLoopMode( const void *runLoopMode); /* Slot 20 is reserved */ /* Slot 21 is reserved */ /* 22 */ -EXTERN TclFile TclpCreateTempFile_(const char *contents); +EXTERN TclFile TclpCreateTempFile(const char *contents); /* Slot 23 is reserved */ /* Slot 24 is reserved */ /* Slot 25 is reserved */ @@ -252,29 +236,29 @@ typedef struct TclIntPlatStubs { void *hooks; #if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ - void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */ + void (*tclGetAndDetachPids_) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */ int (*tclpCloseFile) (TclFile file); /* 1 */ - Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ + Tcl_Channel (*tclpCreateCommandChannel_) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */ int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */ - int (*tclUnixWaitForFile_) (int fd, int mask, int timeout); /* 5 */ + int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 5 */ TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */ TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */ - int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */ - TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */ + int (*tclUnixWaitForFile_) (int fd, int mask, int timeout); /* 8 */ + TclFile (*tclpCreateTempFile_) (const char *contents); /* 9 */ void (*reserved10)(void); - void (*reserved11)(void); + void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 11 */ void (*reserved12)(void); - void (*reserved13)(void); + Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 13 */ int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 14 */ - int (*tclMacOSXGetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); /* 15 */ - int (*tclMacOSXSetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); /* 16 */ - int (*tclMacOSXCopyFileAttributes) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); /* 17 */ - int (*tclMacOSXMatchType) (Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 18 */ + void (*reserved15)(void); + void (*reserved16)(void); + void (*reserved17)(void); + void (*reserved18)(void); void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */ void (*reserved20)(void); void (*reserved21)(void); - TclFile (*tclpCreateTempFile_) (const char *contents); /* 22 */ + TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */ void (*reserved23)(void); void (*reserved24)(void); void (*reserved25)(void); @@ -318,29 +302,29 @@ typedef struct TclIntPlatStubs { int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ - void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */ + void (*tclGetAndDetachPids_) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */ int (*tclpCloseFile) (TclFile file); /* 1 */ - Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ + Tcl_Channel (*tclpCreateCommandChannel_) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */ int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */ - int (*tclUnixWaitForFile_) (int fd, int mask, int timeout); /* 5 */ + int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 5 */ TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */ TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */ - int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */ - TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */ + int (*tclUnixWaitForFile_) (int fd, int mask, int timeout); /* 8 */ + TclFile (*tclpCreateTempFile_) (const char *contents); /* 9 */ void (*reserved10)(void); - void (*reserved11)(void); + void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 11 */ void (*reserved12)(void); - void (*reserved13)(void); + Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 13 */ int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 14 */ - int (*tclMacOSXGetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); /* 15 */ - int (*tclMacOSXSetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); /* 16 */ - int (*tclMacOSXCopyFileAttributes) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); /* 17 */ - int (*tclMacOSXMatchType) (Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 18 */ + void (*reserved15)(void); + void (*reserved16)(void); + void (*reserved17)(void); + void (*reserved18)(void); void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */ void (*reserved20)(void); void (*reserved21)(void); - TclFile (*tclpCreateTempFile_) (const char *contents); /* 22 */ + TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */ void (*reserved23)(void); void (*reserved24)(void); void (*reserved25)(void); @@ -365,46 +349,44 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; */ #if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ -#define TclGetAndDetachPids \ - (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */ +#define TclGetAndDetachPids_ \ + (tclIntPlatStubsPtr->tclGetAndDetachPids_) /* 0 */ #define TclpCloseFile \ (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ -#define TclpCreateCommandChannel \ - (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */ +#define TclpCreateCommandChannel_ \ + (tclIntPlatStubsPtr->tclpCreateCommandChannel_) /* 2 */ #define TclpCreatePipe \ (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ #define TclpCreateProcess \ (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */ -#define TclUnixWaitForFile_ \ - (tclIntPlatStubsPtr->tclUnixWaitForFile_) /* 5 */ +#define TclUnixWaitForFile \ + (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 5 */ #define TclpMakeFile \ (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */ #define TclpOpenFile \ (tclIntPlatStubsPtr->tclpOpenFile) /* 7 */ -#define TclUnixWaitForFile \ - (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */ -#define TclpCreateTempFile \ - (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */ +#define TclUnixWaitForFile_ \ + (tclIntPlatStubsPtr->tclUnixWaitForFile_) /* 8 */ +#define TclpCreateTempFile_ \ + (tclIntPlatStubsPtr->tclpCreateTempFile_) /* 9 */ /* Slot 10 is reserved */ -/* Slot 11 is reserved */ +#define TclGetAndDetachPids \ + (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 11 */ /* Slot 12 is reserved */ -/* Slot 13 is reserved */ +#define TclpCreateCommandChannel \ + (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 13 */ #define TclUnixCopyFile \ (tclIntPlatStubsPtr->tclUnixCopyFile) /* 14 */ -#define TclMacOSXGetFileAttribute \ - (tclIntPlatStubsPtr->tclMacOSXGetFileAttribute) /* 15 */ -#define TclMacOSXSetFileAttribute \ - (tclIntPlatStubsPtr->tclMacOSXSetFileAttribute) /* 16 */ -#define TclMacOSXCopyFileAttributes \ - (tclIntPlatStubsPtr->tclMacOSXCopyFileAttributes) /* 17 */ -#define TclMacOSXMatchType \ - (tclIntPlatStubsPtr->tclMacOSXMatchType) /* 18 */ +/* Slot 15 is reserved */ +/* Slot 16 is reserved */ +/* Slot 17 is reserved */ +/* Slot 18 is reserved */ #define TclMacOSXNotifierAddRunLoopMode \ (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */ /* Slot 20 is reserved */ /* Slot 21 is reserved */ -#define TclpCreateTempFile_ \ - (tclIntPlatStubsPtr->tclpCreateTempFile_) /* 22 */ +#define TclpCreateTempFile \ + (tclIntPlatStubsPtr->tclpCreateTempFile) /* 22 */ /* Slot 23 is reserved */ /* Slot 24 is reserved */ /* Slot 25 is reserved */ @@ -469,46 +451,44 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ -#define TclGetAndDetachPids \ - (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */ +#define TclGetAndDetachPids_ \ + (tclIntPlatStubsPtr->tclGetAndDetachPids_) /* 0 */ #define TclpCloseFile \ (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ -#define TclpCreateCommandChannel \ - (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */ +#define TclpCreateCommandChannel_ \ + (tclIntPlatStubsPtr->tclpCreateCommandChannel_) /* 2 */ #define TclpCreatePipe \ (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ #define TclpCreateProcess \ (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */ -#define TclUnixWaitForFile_ \ - (tclIntPlatStubsPtr->tclUnixWaitForFile_) /* 5 */ +#define TclUnixWaitForFile \ + (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 5 */ #define TclpMakeFile \ (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */ #define TclpOpenFile \ (tclIntPlatStubsPtr->tclpOpenFile) /* 7 */ -#define TclUnixWaitForFile \ - (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */ -#define TclpCreateTempFile \ - (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */ +#define TclUnixWaitForFile_ \ + (tclIntPlatStubsPtr->tclUnixWaitForFile_) /* 8 */ +#define TclpCreateTempFile_ \ + (tclIntPlatStubsPtr->tclpCreateTempFile_) /* 9 */ /* Slot 10 is reserved */ -/* Slot 11 is reserved */ +#define TclGetAndDetachPids \ + (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 11 */ /* Slot 12 is reserved */ -/* Slot 13 is reserved */ +#define TclpCreateCommandChannel \ + (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 13 */ #define TclUnixCopyFile \ (tclIntPlatStubsPtr->tclUnixCopyFile) /* 14 */ -#define TclMacOSXGetFileAttribute \ - (tclIntPlatStubsPtr->tclMacOSXGetFileAttribute) /* 15 */ -#define TclMacOSXSetFileAttribute \ - (tclIntPlatStubsPtr->tclMacOSXSetFileAttribute) /* 16 */ -#define TclMacOSXCopyFileAttributes \ - (tclIntPlatStubsPtr->tclMacOSXCopyFileAttributes) /* 17 */ -#define TclMacOSXMatchType \ - (tclIntPlatStubsPtr->tclMacOSXMatchType) /* 18 */ +/* Slot 15 is reserved */ +/* Slot 16 is reserved */ +/* Slot 17 is reserved */ +/* Slot 18 is reserved */ #define TclMacOSXNotifierAddRunLoopMode \ (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */ /* Slot 20 is reserved */ /* Slot 21 is reserved */ -#define TclpCreateTempFile_ \ - (tclIntPlatStubsPtr->tclpCreateTempFile_) /* 22 */ +#define TclpCreateTempFile \ + (tclIntPlatStubsPtr->tclpCreateTempFile) /* 22 */ /* Slot 23 is reserved */ /* Slot 24 is reserved */ /* Slot 25 is reserved */ @@ -532,11 +512,23 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; #undef TclpCreateTempFile_ #undef TclUnixWaitForFile_ #undef TclMacOSXNotifierAddRunLoopMode -#ifndef MAC_OSX_TCL /* not accessable on Win32/UNIX */ -#undef TclMacOSXGetFileAttribute /* 15 */ -#undef TclMacOSXSetFileAttribute /* 16 */ -#undef TclMacOSXCopyFileAttributes /* 17 */ -#undef TclMacOSXMatchType /* 18 */ +#ifdef MAC_OSX_TCL /* not accessable on Win32/UNIX */ +MODULE_SCOPE int TclMacOSXGetFileAttribute(Tcl_Interp *interp, + int objIndex, Tcl_Obj *fileName, + Tcl_Obj **attributePtrPtr); +/* 16 */ +MODULE_SCOPE int TclMacOSXSetFileAttribute(Tcl_Interp *interp, + int objIndex, Tcl_Obj *fileName, + Tcl_Obj *attributePtr); +/* 17 */ +MODULE_SCOPE int TclMacOSXCopyFileAttributes(const char *src, + const char *dst, + const Tcl_StatBuf *statBufPtr); +/* 18 */ +MODULE_SCOPE int TclMacOSXMatchType(Tcl_Interp *interp, + const char *pathName, const char *fileName, + Tcl_StatBuf *statBufPtr, + Tcl_GlobTypeData *types); #endif #if !defined(_WIN32) diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 577c05a..54001b2 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -146,6 +146,8 @@ static void uniCodePanic() { #define TclpCreateTempFile_ TclpCreateTempFile #define TclUnixWaitForFile_ TclUnixWaitForFile +#define TclGetAndDetachPids_ TclGetAndDetachPids +#define TclpCreateCommandChannel_ TclpCreateCommandChannel #ifndef MAC_OSX_TCL /* On UNIX, fill with other stub entries */ # define TclMacOSXGetFileAttribute (int (*)(Tcl_Interp *, int, Tcl_Obj *, Tcl_Obj **))(void *)TclpCreateProcess # define TclMacOSXSetFileAttribute (int (*)(Tcl_Interp *, int, Tcl_Obj *, Tcl_Obj *))(void *)isatty @@ -546,29 +548,29 @@ static const TclIntPlatStubs tclIntPlatStubs = { TCL_STUB_MAGIC, 0, #if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ - TclGetAndDetachPids, /* 0 */ + TclGetAndDetachPids_, /* 0 */ TclpCloseFile, /* 1 */ - TclpCreateCommandChannel, /* 2 */ + TclpCreateCommandChannel_, /* 2 */ TclpCreatePipe, /* 3 */ TclpCreateProcess, /* 4 */ - TclUnixWaitForFile_, /* 5 */ + TclUnixWaitForFile, /* 5 */ TclpMakeFile, /* 6 */ TclpOpenFile, /* 7 */ - TclUnixWaitForFile, /* 8 */ - TclpCreateTempFile, /* 9 */ + TclUnixWaitForFile_, /* 8 */ + TclpCreateTempFile_, /* 9 */ 0, /* 10 */ - 0, /* 11 */ + TclGetAndDetachPids, /* 11 */ 0, /* 12 */ - 0, /* 13 */ + TclpCreateCommandChannel, /* 13 */ TclUnixCopyFile, /* 14 */ - TclMacOSXGetFileAttribute, /* 15 */ - TclMacOSXSetFileAttribute, /* 16 */ - TclMacOSXCopyFileAttributes, /* 17 */ - TclMacOSXMatchType, /* 18 */ + 0, /* 15 */ + 0, /* 16 */ + 0, /* 17 */ + 0, /* 18 */ TclMacOSXNotifierAddRunLoopMode, /* 19 */ 0, /* 20 */ 0, /* 21 */ - TclpCreateTempFile_, /* 22 */ + TclpCreateTempFile, /* 22 */ 0, /* 23 */ 0, /* 24 */ 0, /* 25 */ @@ -612,29 +614,29 @@ static const TclIntPlatStubs tclIntPlatStubs = { TclUnixOpenTemporaryFile, /* 30 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ - TclGetAndDetachPids, /* 0 */ + TclGetAndDetachPids_, /* 0 */ TclpCloseFile, /* 1 */ - TclpCreateCommandChannel, /* 2 */ + TclpCreateCommandChannel_, /* 2 */ TclpCreatePipe, /* 3 */ TclpCreateProcess, /* 4 */ - TclUnixWaitForFile_, /* 5 */ + TclUnixWaitForFile, /* 5 */ TclpMakeFile, /* 6 */ TclpOpenFile, /* 7 */ - TclUnixWaitForFile, /* 8 */ - TclpCreateTempFile, /* 9 */ + TclUnixWaitForFile_, /* 8 */ + TclpCreateTempFile_, /* 9 */ 0, /* 10 */ - 0, /* 11 */ + TclGetAndDetachPids, /* 11 */ 0, /* 12 */ - 0, /* 13 */ + TclpCreateCommandChannel, /* 13 */ TclUnixCopyFile, /* 14 */ - TclMacOSXGetFileAttribute, /* 15 */ - TclMacOSXSetFileAttribute, /* 16 */ - TclMacOSXCopyFileAttributes, /* 17 */ - TclMacOSXMatchType, /* 18 */ + 0, /* 15 */ + 0, /* 16 */ + 0, /* 17 */ + 0, /* 18 */ TclMacOSXNotifierAddRunLoopMode, /* 19 */ 0, /* 20 */ 0, /* 21 */ - TclpCreateTempFile_, /* 22 */ + TclpCreateTempFile, /* 22 */ 0, /* 23 */ 0, /* 24 */ 0, /* 25 */ -- cgit v0.12 From 35fa5da02e87e55c16745e3f11a109b7aff4b559 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 26 Jan 2021 10:58:19 +0000 Subject: Sort platform-dependant entries in tclInt.decls. No change in generated tcl*Decls.h --- generic/tcl.decls | 16 +------- generic/tclInt.decls | 113 ++++++++++++++++++++------------------------------- 2 files changed, 45 insertions(+), 84 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 30f5f69..2ce6ae2 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2491,25 +2491,11 @@ interface tclPlat ################################ # Windows specific functions - -# Added in Tcl 8.1, Removed in Tcl 9.0 (converted to macro) - -#declare 0 win { -# TCHAR *Tcl_WinUtfToTChar(const char *str, size_t len, Tcl_DString *dsPtr) -#} -#declare 1 win { -# char *Tcl_WinTCharToUtf(const TCHAR *str, size_t len, Tcl_DString *dsPtr) -#} +# (none) ################################ # Mac OS X specific functions -# Removed in 9.0 -#declare 0 { -# int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp, -# const char *bundleName, int hasResourceFile, -# size_t maxPathLen, char *libraryPath) -#} declare 1 { int Tcl_MacOSXOpenVersionedBundleResources(Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 59104cc..001fc96 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -597,30 +597,64 @@ declare 260 { interface tclIntPlat ################################ -# Windows specific functions +# Platform specific functions +declare 0 unix { + void TclGetAndDetachPids_(Tcl_Interp *interp, Tcl_Channel chan) +} declare 0 win { void TclWinConvertError(int errCode) } +declare 1 unix { + int TclpCloseFile(TclFile file) +} +declare 2 unix { + Tcl_Channel TclpCreateCommandChannel_(TclFile readFile, + TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr) +} +declare 3 unix { + int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe) +} +declare 4 unix { + int TclpCreateProcess(Tcl_Interp *interp, int argc, + const char **argv, TclFile inputFile, TclFile outputFile, + TclFile errorFile, Tcl_Pid *pidPtr) +} declare 4 win { void *TclWinGetTclInstance(void) } -declare 5 win { +declare 5 {unix win} { int TclUnixWaitForFile(int fd, int mask, int timeout) } +declare 6 unix { + TclFile TclpMakeFile(Tcl_Channel channel, int direction) +} +declare 7 unix { + TclFile TclpOpenFile(const char *fname, int mode) +} +declare 8 unix { + int TclUnixWaitForFile_(int fd, int mask, int timeout) +} declare 8 win { size_t TclpGetPid(Tcl_Pid pid) } -declare 11 win { +declare 9 unix { + TclFile TclpCreateTempFile_(const char *contents) +} +declare 11 {unix win} { void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan) } declare 12 win { int TclpCloseFile(TclFile file) } -declare 13 win { +declare 13 {unix win} { Tcl_Channel TclpCreateCommandChannel(TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr) } +declare 14 unix { + int TclUnixCopyFile(const char *src, const char *dst, + const Tcl_StatBuf *statBufPtr, int dontCopyAtts) +} declare 14 win { int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe) } @@ -639,13 +673,16 @@ declare 17 win { declare 18 win { TclFile TclpMakeFile(Tcl_Channel channel, int direction) } +declare 19 unix { + void TclMacOSXNotifierAddRunLoopMode(const void *runLoopMode) +} declare 19 win { TclFile TclpOpenFile(const char *fname, int mode) } declare 20 win { void TclWinAddProcess(void *hProcess, size_t id) } -declare 22 win { +declare 22 {unix win} { TclFile TclpCreateTempFile(const char *contents) } declare 24 win { @@ -654,72 +691,10 @@ declare 24 win { declare 27 win { void TclWinFlushDirtyChannels(void) } - -################################ -# Unix specific functions - -# Pipe channel functions - -declare 0 unix { - void TclGetAndDetachPids_(Tcl_Interp *interp, Tcl_Channel chan) -} -declare 1 unix { - int TclpCloseFile(TclFile file) -} -declare 2 unix { - Tcl_Channel TclpCreateCommandChannel_(TclFile readFile, - TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr) -} -declare 3 unix { - int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe) -} -declare 4 unix { - int TclpCreateProcess(Tcl_Interp *interp, int argc, - const char **argv, TclFile inputFile, TclFile outputFile, - TclFile errorFile, Tcl_Pid *pidPtr) -} -declare 5 unix { - int TclUnixWaitForFile(int fd, int mask, int timeout) -} -declare 6 unix { - TclFile TclpMakeFile(Tcl_Channel channel, int direction) -} -declare 7 unix { - TclFile TclpOpenFile(const char *fname, int mode) -} -declare 8 unix { - int TclUnixWaitForFile_(int fd, int mask, int timeout) -} -declare 9 unix { - TclFile TclpCreateTempFile_(const char *contents) -} -declare 11 unix { - void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan) -} -declare 13 unix { - Tcl_Channel TclpCreateCommandChannel(TclFile readFile, - TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr) -} -declare 14 unix { - int TclUnixCopyFile(const char *src, const char *dst, - const Tcl_StatBuf *statBufPtr, int dontCopyAtts) -} - -################################ -# Mac OS X specific functions - -declare 19 {unix macosx} { - void TclMacOSXNotifierAddRunLoopMode(const void *runLoopMode) -} -declare 22 {unix macosx} { - TclFile TclpCreateTempFile(const char *contents) -} - -declare 29 {win unix} { +declare 29 {unix win} { int TclWinCPUID(int index, int *regs) } -# Added in 8.6; core of TclpOpenTemporaryFile -declare 30 {win unix} { +declare 30 {unix win} { int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj) } -- cgit v0.12 From 1aade032020e2bb6cc04e0e487fe0a1c5e22f31a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 26 Jan 2021 14:30:00 +0000 Subject: More more stub-entries, making the internal platform table more equal to each other. Old entries keps, so still binary compatible with Tcl 9.0a1 --- generic/tclInt.decls | 65 ++++----- generic/tclIntPlatDecls.h | 338 +++++++++++++++++++++++++--------------------- generic/tclStubInit.c | 102 +++++++------- 3 files changed, 264 insertions(+), 241 deletions(-) diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 001fc96..42e6899 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -599,96 +599,81 @@ interface tclIntPlat ################################ # Platform specific functions -declare 0 unix { - void TclGetAndDetachPids_(Tcl_Interp *interp, Tcl_Channel chan) -} -declare 0 win { +declare 0 {unix win} { void TclWinConvertError(int errCode) } -declare 1 unix { +declare 1 {unix win} { int TclpCloseFile(TclFile file) } -declare 2 unix { - Tcl_Channel TclpCreateCommandChannel_(TclFile readFile, +declare 2 {unix win} { + Tcl_Channel TclpCreateCommandChannel(TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr) } -declare 3 unix { +declare 3 {unix win} { int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe) } -declare 4 unix { - int TclpCreateProcess(Tcl_Interp *interp, int argc, - const char **argv, TclFile inputFile, TclFile outputFile, - TclFile errorFile, Tcl_Pid *pidPtr) -} -declare 4 win { +declare 4 {unix win} { void *TclWinGetTclInstance(void) } declare 5 {unix win} { int TclUnixWaitForFile(int fd, int mask, int timeout) } -declare 6 unix { +declare 6 {unix win} { TclFile TclpMakeFile(Tcl_Channel channel, int direction) } -declare 7 unix { +declare 7 {unix win} { TclFile TclpOpenFile(const char *fname, int mode) } -declare 8 unix { - int TclUnixWaitForFile_(int fd, int mask, int timeout) -} -declare 8 win { +declare 8 {unix win} { size_t TclpGetPid(Tcl_Pid pid) } -declare 9 unix { - TclFile TclpCreateTempFile_(const char *contents) +declare 9 {unix win} { + TclFile TclpCreateTempFile(const char *contents) } declare 11 {unix win} { void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan) } declare 12 win { - int TclpCloseFile(TclFile file) + int TclpCloseFile_(TclFile file) } -declare 13 {unix win} { - Tcl_Channel TclpCreateCommandChannel(TclFile readFile, +declare 13 win { + Tcl_Channel TclpCreateCommandChannel_(TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr) } -declare 14 unix { - int TclUnixCopyFile(const char *src, const char *dst, - const Tcl_StatBuf *statBufPtr, int dontCopyAtts) -} -declare 14 win { - int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe) +declare 14 {unix win} { + int TclpCreatePipe_(TclFile *readPipe, TclFile *writePipe) } -declare 15 win { +declare 15 {unix win} { int TclpCreateProcess(Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr) } -declare 16 win { +declare 16 {unix win} { int TclpIsAtty(int fd) } -declare 17 win { +declare 17 {unix win} { int TclUnixCopyFile(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts) } declare 18 win { - TclFile TclpMakeFile(Tcl_Channel channel, int direction) + TclFile TclpMakeFile_(Tcl_Channel channel, int direction) } declare 19 unix { void TclMacOSXNotifierAddRunLoopMode(const void *runLoopMode) } declare 19 win { - TclFile TclpOpenFile(const char *fname, int mode) + TclFile TclpOpenFile_(const char *fname, int mode) } -declare 20 win { +declare 20 {unix win} { void TclWinAddProcess(void *hProcess, size_t id) } declare 22 {unix win} { - TclFile TclpCreateTempFile(const char *contents) + TclFile TclpCreateTempFile_(const char *contents) } -declare 24 win { +declare 24 {unix win} { char *TclWinNoBackslash(char *path) } -declare 27 win { +declare 27 {unix win} { void TclWinFlushDirtyChannels(void) } declare 29 {unix win} { diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index 1ce68b3..c8941e5 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -42,21 +42,17 @@ extern "C" { #if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ /* 0 */ -EXTERN void TclGetAndDetachPids_(Tcl_Interp *interp, - Tcl_Channel chan); +EXTERN void TclWinConvertError(int errCode); /* 1 */ EXTERN int TclpCloseFile(TclFile file); /* 2 */ -EXTERN Tcl_Channel TclpCreateCommandChannel_(TclFile readFile, +EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 3 */ EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); /* 4 */ -EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, - const char **argv, TclFile inputFile, - TclFile outputFile, TclFile errorFile, - Tcl_Pid *pidPtr); +EXTERN void * TclWinGetTclInstance(void); /* 5 */ EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); /* 6 */ @@ -64,38 +60,45 @@ EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); /* 7 */ EXTERN TclFile TclpOpenFile(const char *fname, int mode); /* 8 */ -EXTERN int TclUnixWaitForFile_(int fd, int mask, int timeout); +EXTERN size_t TclpGetPid(Tcl_Pid pid); /* 9 */ -EXTERN TclFile TclpCreateTempFile_(const char *contents); +EXTERN TclFile TclpCreateTempFile(const char *contents); /* Slot 10 is reserved */ /* 11 */ EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan); /* Slot 12 is reserved */ -/* 13 */ -EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile, - TclFile writeFile, TclFile errorFile, - int numPids, Tcl_Pid *pidPtr); +/* Slot 13 is reserved */ /* 14 */ +EXTERN int TclpCreatePipe_(TclFile *readPipe, + TclFile *writePipe); +/* 15 */ +EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, + const char **argv, TclFile inputFile, + TclFile outputFile, TclFile errorFile, + Tcl_Pid *pidPtr); +/* 16 */ +EXTERN int TclpIsAtty(int fd); +/* 17 */ EXTERN int TclUnixCopyFile(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); -/* Slot 15 is reserved */ -/* Slot 16 is reserved */ -/* Slot 17 is reserved */ /* Slot 18 is reserved */ /* 19 */ EXTERN void TclMacOSXNotifierAddRunLoopMode( const void *runLoopMode); -/* Slot 20 is reserved */ +/* 20 */ +EXTERN void TclWinAddProcess(void *hProcess, size_t id); /* Slot 21 is reserved */ /* 22 */ -EXTERN TclFile TclpCreateTempFile(const char *contents); +EXTERN TclFile TclpCreateTempFile_(const char *contents); /* Slot 23 is reserved */ -/* Slot 24 is reserved */ +/* 24 */ +EXTERN char * TclWinNoBackslash(char *path); /* Slot 25 is reserved */ /* Slot 26 is reserved */ -/* Slot 27 is reserved */ +/* 27 */ +EXTERN void TclWinFlushDirtyChannels(void); /* Slot 28 is reserved */ /* 29 */ EXTERN int TclWinCPUID(int index, int *regs); @@ -107,30 +110,39 @@ EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ /* 0 */ EXTERN void TclWinConvertError(int errCode); -/* Slot 1 is reserved */ -/* Slot 2 is reserved */ -/* Slot 3 is reserved */ +/* 1 */ +EXTERN int TclpCloseFile(TclFile file); +/* 2 */ +EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile, + TclFile writeFile, TclFile errorFile, + int numPids, Tcl_Pid *pidPtr); +/* 3 */ +EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); /* 4 */ EXTERN void * TclWinGetTclInstance(void); /* 5 */ EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); -/* Slot 6 is reserved */ -/* Slot 7 is reserved */ +/* 6 */ +EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); +/* 7 */ +EXTERN TclFile TclpOpenFile(const char *fname, int mode); /* 8 */ EXTERN size_t TclpGetPid(Tcl_Pid pid); -/* Slot 9 is reserved */ +/* 9 */ +EXTERN TclFile TclpCreateTempFile(const char *contents); /* Slot 10 is reserved */ /* 11 */ EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan); /* 12 */ -EXTERN int TclpCloseFile(TclFile file); +EXTERN int TclpCloseFile_(TclFile file); /* 13 */ -EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile, +EXTERN Tcl_Channel TclpCreateCommandChannel_(TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 14 */ -EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); +EXTERN int TclpCreatePipe_(TclFile *readPipe, + TclFile *writePipe); /* 15 */ EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, @@ -143,14 +155,14 @@ EXTERN int TclUnixCopyFile(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 18 */ -EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); +EXTERN TclFile TclpMakeFile_(Tcl_Channel channel, int direction); /* 19 */ -EXTERN TclFile TclpOpenFile(const char *fname, int mode); +EXTERN TclFile TclpOpenFile_(const char *fname, int mode); /* 20 */ EXTERN void TclWinAddProcess(void *hProcess, size_t id); /* Slot 21 is reserved */ /* 22 */ -EXTERN TclFile TclpCreateTempFile(const char *contents); +EXTERN TclFile TclpCreateTempFile_(const char *contents); /* Slot 23 is reserved */ /* 24 */ EXTERN char * TclWinNoBackslash(char *path); @@ -168,21 +180,17 @@ EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ /* 0 */ -EXTERN void TclGetAndDetachPids_(Tcl_Interp *interp, - Tcl_Channel chan); +EXTERN void TclWinConvertError(int errCode); /* 1 */ EXTERN int TclpCloseFile(TclFile file); /* 2 */ -EXTERN Tcl_Channel TclpCreateCommandChannel_(TclFile readFile, +EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 3 */ EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); /* 4 */ -EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, - const char **argv, TclFile inputFile, - TclFile outputFile, TclFile errorFile, - Tcl_Pid *pidPtr); +EXTERN void * TclWinGetTclInstance(void); /* 5 */ EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); /* 6 */ @@ -190,38 +198,45 @@ EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); /* 7 */ EXTERN TclFile TclpOpenFile(const char *fname, int mode); /* 8 */ -EXTERN int TclUnixWaitForFile_(int fd, int mask, int timeout); +EXTERN size_t TclpGetPid(Tcl_Pid pid); /* 9 */ -EXTERN TclFile TclpCreateTempFile_(const char *contents); +EXTERN TclFile TclpCreateTempFile(const char *contents); /* Slot 10 is reserved */ /* 11 */ EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan); /* Slot 12 is reserved */ -/* 13 */ -EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile, - TclFile writeFile, TclFile errorFile, - int numPids, Tcl_Pid *pidPtr); +/* Slot 13 is reserved */ /* 14 */ +EXTERN int TclpCreatePipe_(TclFile *readPipe, + TclFile *writePipe); +/* 15 */ +EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, + const char **argv, TclFile inputFile, + TclFile outputFile, TclFile errorFile, + Tcl_Pid *pidPtr); +/* 16 */ +EXTERN int TclpIsAtty(int fd); +/* 17 */ EXTERN int TclUnixCopyFile(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); -/* Slot 15 is reserved */ -/* Slot 16 is reserved */ -/* Slot 17 is reserved */ /* Slot 18 is reserved */ /* 19 */ EXTERN void TclMacOSXNotifierAddRunLoopMode( const void *runLoopMode); -/* Slot 20 is reserved */ +/* 20 */ +EXTERN void TclWinAddProcess(void *hProcess, size_t id); /* Slot 21 is reserved */ /* 22 */ -EXTERN TclFile TclpCreateTempFile(const char *contents); +EXTERN TclFile TclpCreateTempFile_(const char *contents); /* Slot 23 is reserved */ -/* Slot 24 is reserved */ +/* 24 */ +EXTERN char * TclWinNoBackslash(char *path); /* Slot 25 is reserved */ /* Slot 26 is reserved */ -/* Slot 27 is reserved */ +/* 27 */ +EXTERN void TclWinFlushDirtyChannels(void); /* Slot 28 is reserved */ /* 29 */ EXTERN int TclWinCPUID(int index, int *regs); @@ -236,62 +251,62 @@ typedef struct TclIntPlatStubs { void *hooks; #if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ - void (*tclGetAndDetachPids_) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */ + void (*tclWinConvertError) (int errCode); /* 0 */ int (*tclpCloseFile) (TclFile file); /* 1 */ - Tcl_Channel (*tclpCreateCommandChannel_) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ + Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */ - int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */ + void * (*tclWinGetTclInstance) (void); /* 4 */ int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 5 */ TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */ TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */ - int (*tclUnixWaitForFile_) (int fd, int mask, int timeout); /* 8 */ - TclFile (*tclpCreateTempFile_) (const char *contents); /* 9 */ + size_t (*tclpGetPid) (Tcl_Pid pid); /* 8 */ + TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */ void (*reserved10)(void); void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 11 */ void (*reserved12)(void); - Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 13 */ - int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 14 */ - void (*reserved15)(void); - void (*reserved16)(void); - void (*reserved17)(void); + void (*reserved13)(void); + int (*tclpCreatePipe_) (TclFile *readPipe, TclFile *writePipe); /* 14 */ + int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 15 */ + int (*tclpIsAtty) (int fd); /* 16 */ + int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 17 */ void (*reserved18)(void); void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */ - void (*reserved20)(void); + void (*tclWinAddProcess) (void *hProcess, size_t id); /* 20 */ void (*reserved21)(void); - TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */ + TclFile (*tclpCreateTempFile_) (const char *contents); /* 22 */ void (*reserved23)(void); - void (*reserved24)(void); + char * (*tclWinNoBackslash) (char *path); /* 24 */ void (*reserved25)(void); void (*reserved26)(void); - void (*reserved27)(void); + void (*tclWinFlushDirtyChannels) (void); /* 27 */ void (*reserved28)(void); int (*tclWinCPUID) (int index, int *regs); /* 29 */ int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ #endif /* UNIX */ #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ void (*tclWinConvertError) (int errCode); /* 0 */ - void (*reserved1)(void); - void (*reserved2)(void); - void (*reserved3)(void); + int (*tclpCloseFile) (TclFile file); /* 1 */ + Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ + int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */ void * (*tclWinGetTclInstance) (void); /* 4 */ int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 5 */ - void (*reserved6)(void); - void (*reserved7)(void); + TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */ + TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */ size_t (*tclpGetPid) (Tcl_Pid pid); /* 8 */ - void (*reserved9)(void); + TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */ void (*reserved10)(void); void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 11 */ - int (*tclpCloseFile) (TclFile file); /* 12 */ - Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 13 */ - int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 14 */ + int (*tclpCloseFile_) (TclFile file); /* 12 */ + Tcl_Channel (*tclpCreateCommandChannel_) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 13 */ + int (*tclpCreatePipe_) (TclFile *readPipe, TclFile *writePipe); /* 14 */ int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 15 */ int (*tclpIsAtty) (int fd); /* 16 */ int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 17 */ - TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 18 */ - TclFile (*tclpOpenFile) (const char *fname, int mode); /* 19 */ + TclFile (*tclpMakeFile_) (Tcl_Channel channel, int direction); /* 18 */ + TclFile (*tclpOpenFile_) (const char *fname, int mode); /* 19 */ void (*tclWinAddProcess) (void *hProcess, size_t id); /* 20 */ void (*reserved21)(void); - TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */ + TclFile (*tclpCreateTempFile_) (const char *contents); /* 22 */ void (*reserved23)(void); char * (*tclWinNoBackslash) (char *path); /* 24 */ void (*reserved25)(void); @@ -302,34 +317,34 @@ typedef struct TclIntPlatStubs { int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ - void (*tclGetAndDetachPids_) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */ + void (*tclWinConvertError) (int errCode); /* 0 */ int (*tclpCloseFile) (TclFile file); /* 1 */ - Tcl_Channel (*tclpCreateCommandChannel_) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ + Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */ - int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */ + void * (*tclWinGetTclInstance) (void); /* 4 */ int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 5 */ TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */ TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */ - int (*tclUnixWaitForFile_) (int fd, int mask, int timeout); /* 8 */ - TclFile (*tclpCreateTempFile_) (const char *contents); /* 9 */ + size_t (*tclpGetPid) (Tcl_Pid pid); /* 8 */ + TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */ void (*reserved10)(void); void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 11 */ void (*reserved12)(void); - Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 13 */ - int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 14 */ - void (*reserved15)(void); - void (*reserved16)(void); - void (*reserved17)(void); + void (*reserved13)(void); + int (*tclpCreatePipe_) (TclFile *readPipe, TclFile *writePipe); /* 14 */ + int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 15 */ + int (*tclpIsAtty) (int fd); /* 16 */ + int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 17 */ void (*reserved18)(void); void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */ - void (*reserved20)(void); + void (*tclWinAddProcess) (void *hProcess, size_t id); /* 20 */ void (*reserved21)(void); - TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */ + TclFile (*tclpCreateTempFile_) (const char *contents); /* 22 */ void (*reserved23)(void); - void (*reserved24)(void); + char * (*tclWinNoBackslash) (char *path); /* 24 */ void (*reserved25)(void); void (*reserved26)(void); - void (*reserved27)(void); + void (*tclWinFlushDirtyChannels) (void); /* 27 */ void (*reserved28)(void); int (*tclWinCPUID) (int index, int *regs); /* 29 */ int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ @@ -349,49 +364,54 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; */ #if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ -#define TclGetAndDetachPids_ \ - (tclIntPlatStubsPtr->tclGetAndDetachPids_) /* 0 */ +#define TclWinConvertError \ + (tclIntPlatStubsPtr->tclWinConvertError) /* 0 */ #define TclpCloseFile \ (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ -#define TclpCreateCommandChannel_ \ - (tclIntPlatStubsPtr->tclpCreateCommandChannel_) /* 2 */ +#define TclpCreateCommandChannel \ + (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */ #define TclpCreatePipe \ (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ -#define TclpCreateProcess \ - (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */ +#define TclWinGetTclInstance \ + (tclIntPlatStubsPtr->tclWinGetTclInstance) /* 4 */ #define TclUnixWaitForFile \ (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 5 */ #define TclpMakeFile \ (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */ #define TclpOpenFile \ (tclIntPlatStubsPtr->tclpOpenFile) /* 7 */ -#define TclUnixWaitForFile_ \ - (tclIntPlatStubsPtr->tclUnixWaitForFile_) /* 8 */ -#define TclpCreateTempFile_ \ - (tclIntPlatStubsPtr->tclpCreateTempFile_) /* 9 */ +#define TclpGetPid \ + (tclIntPlatStubsPtr->tclpGetPid) /* 8 */ +#define TclpCreateTempFile \ + (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */ /* Slot 10 is reserved */ #define TclGetAndDetachPids \ (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 11 */ /* Slot 12 is reserved */ -#define TclpCreateCommandChannel \ - (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 13 */ +/* Slot 13 is reserved */ +#define TclpCreatePipe_ \ + (tclIntPlatStubsPtr->tclpCreatePipe_) /* 14 */ +#define TclpCreateProcess \ + (tclIntPlatStubsPtr->tclpCreateProcess) /* 15 */ +#define TclpIsAtty \ + (tclIntPlatStubsPtr->tclpIsAtty) /* 16 */ #define TclUnixCopyFile \ - (tclIntPlatStubsPtr->tclUnixCopyFile) /* 14 */ -/* Slot 15 is reserved */ -/* Slot 16 is reserved */ -/* Slot 17 is reserved */ + (tclIntPlatStubsPtr->tclUnixCopyFile) /* 17 */ /* Slot 18 is reserved */ #define TclMacOSXNotifierAddRunLoopMode \ (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */ -/* Slot 20 is reserved */ +#define TclWinAddProcess \ + (tclIntPlatStubsPtr->tclWinAddProcess) /* 20 */ /* Slot 21 is reserved */ -#define TclpCreateTempFile \ - (tclIntPlatStubsPtr->tclpCreateTempFile) /* 22 */ +#define TclpCreateTempFile_ \ + (tclIntPlatStubsPtr->tclpCreateTempFile_) /* 22 */ /* Slot 23 is reserved */ -/* Slot 24 is reserved */ +#define TclWinNoBackslash \ + (tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */ /* Slot 25 is reserved */ /* Slot 26 is reserved */ -/* Slot 27 is reserved */ +#define TclWinFlushDirtyChannels \ + (tclIntPlatStubsPtr->tclWinFlushDirtyChannels) /* 27 */ /* Slot 28 is reserved */ #define TclWinCPUID \ (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ @@ -401,42 +421,48 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ #define TclWinConvertError \ (tclIntPlatStubsPtr->tclWinConvertError) /* 0 */ -/* Slot 1 is reserved */ -/* Slot 2 is reserved */ -/* Slot 3 is reserved */ +#define TclpCloseFile \ + (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ +#define TclpCreateCommandChannel \ + (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */ +#define TclpCreatePipe \ + (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ #define TclWinGetTclInstance \ (tclIntPlatStubsPtr->tclWinGetTclInstance) /* 4 */ #define TclUnixWaitForFile \ (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 5 */ -/* Slot 6 is reserved */ -/* Slot 7 is reserved */ +#define TclpMakeFile \ + (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */ +#define TclpOpenFile \ + (tclIntPlatStubsPtr->tclpOpenFile) /* 7 */ #define TclpGetPid \ (tclIntPlatStubsPtr->tclpGetPid) /* 8 */ -/* Slot 9 is reserved */ +#define TclpCreateTempFile \ + (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */ /* Slot 10 is reserved */ #define TclGetAndDetachPids \ (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 11 */ -#define TclpCloseFile \ - (tclIntPlatStubsPtr->tclpCloseFile) /* 12 */ -#define TclpCreateCommandChannel \ - (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 13 */ -#define TclpCreatePipe \ - (tclIntPlatStubsPtr->tclpCreatePipe) /* 14 */ +#define TclpCloseFile_ \ + (tclIntPlatStubsPtr->tclpCloseFile_) /* 12 */ +#define TclpCreateCommandChannel_ \ + (tclIntPlatStubsPtr->tclpCreateCommandChannel_) /* 13 */ +#define TclpCreatePipe_ \ + (tclIntPlatStubsPtr->tclpCreatePipe_) /* 14 */ #define TclpCreateProcess \ (tclIntPlatStubsPtr->tclpCreateProcess) /* 15 */ #define TclpIsAtty \ (tclIntPlatStubsPtr->tclpIsAtty) /* 16 */ #define TclUnixCopyFile \ (tclIntPlatStubsPtr->tclUnixCopyFile) /* 17 */ -#define TclpMakeFile \ - (tclIntPlatStubsPtr->tclpMakeFile) /* 18 */ -#define TclpOpenFile \ - (tclIntPlatStubsPtr->tclpOpenFile) /* 19 */ +#define TclpMakeFile_ \ + (tclIntPlatStubsPtr->tclpMakeFile_) /* 18 */ +#define TclpOpenFile_ \ + (tclIntPlatStubsPtr->tclpOpenFile_) /* 19 */ #define TclWinAddProcess \ (tclIntPlatStubsPtr->tclWinAddProcess) /* 20 */ /* Slot 21 is reserved */ -#define TclpCreateTempFile \ - (tclIntPlatStubsPtr->tclpCreateTempFile) /* 22 */ +#define TclpCreateTempFile_ \ + (tclIntPlatStubsPtr->tclpCreateTempFile_) /* 22 */ /* Slot 23 is reserved */ #define TclWinNoBackslash \ (tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */ @@ -451,49 +477,54 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ -#define TclGetAndDetachPids_ \ - (tclIntPlatStubsPtr->tclGetAndDetachPids_) /* 0 */ +#define TclWinConvertError \ + (tclIntPlatStubsPtr->tclWinConvertError) /* 0 */ #define TclpCloseFile \ (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ -#define TclpCreateCommandChannel_ \ - (tclIntPlatStubsPtr->tclpCreateCommandChannel_) /* 2 */ +#define TclpCreateCommandChannel \ + (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */ #define TclpCreatePipe \ (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ -#define TclpCreateProcess \ - (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */ +#define TclWinGetTclInstance \ + (tclIntPlatStubsPtr->tclWinGetTclInstance) /* 4 */ #define TclUnixWaitForFile \ (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 5 */ #define TclpMakeFile \ (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */ #define TclpOpenFile \ (tclIntPlatStubsPtr->tclpOpenFile) /* 7 */ -#define TclUnixWaitForFile_ \ - (tclIntPlatStubsPtr->tclUnixWaitForFile_) /* 8 */ -#define TclpCreateTempFile_ \ - (tclIntPlatStubsPtr->tclpCreateTempFile_) /* 9 */ +#define TclpGetPid \ + (tclIntPlatStubsPtr->tclpGetPid) /* 8 */ +#define TclpCreateTempFile \ + (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */ /* Slot 10 is reserved */ #define TclGetAndDetachPids \ (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 11 */ /* Slot 12 is reserved */ -#define TclpCreateCommandChannel \ - (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 13 */ +/* Slot 13 is reserved */ +#define TclpCreatePipe_ \ + (tclIntPlatStubsPtr->tclpCreatePipe_) /* 14 */ +#define TclpCreateProcess \ + (tclIntPlatStubsPtr->tclpCreateProcess) /* 15 */ +#define TclpIsAtty \ + (tclIntPlatStubsPtr->tclpIsAtty) /* 16 */ #define TclUnixCopyFile \ - (tclIntPlatStubsPtr->tclUnixCopyFile) /* 14 */ -/* Slot 15 is reserved */ -/* Slot 16 is reserved */ -/* Slot 17 is reserved */ + (tclIntPlatStubsPtr->tclUnixCopyFile) /* 17 */ /* Slot 18 is reserved */ #define TclMacOSXNotifierAddRunLoopMode \ (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */ -/* Slot 20 is reserved */ +#define TclWinAddProcess \ + (tclIntPlatStubsPtr->tclWinAddProcess) /* 20 */ /* Slot 21 is reserved */ -#define TclpCreateTempFile \ - (tclIntPlatStubsPtr->tclpCreateTempFile) /* 22 */ +#define TclpCreateTempFile_ \ + (tclIntPlatStubsPtr->tclpCreateTempFile_) /* 22 */ /* Slot 23 is reserved */ -/* Slot 24 is reserved */ +#define TclWinNoBackslash \ + (tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */ /* Slot 25 is reserved */ /* Slot 26 is reserved */ -/* Slot 27 is reserved */ +#define TclWinFlushDirtyChannels \ + (tclIntPlatStubsPtr->tclWinFlushDirtyChannels) /* 27 */ /* Slot 28 is reserved */ #define TclWinCPUID \ (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ @@ -509,9 +540,6 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; #define TCL_STORAGE_CLASS DLLIMPORT #define TclWinConvertWSAError TclWinConvertError -#undef TclpCreateTempFile_ -#undef TclUnixWaitForFile_ -#undef TclMacOSXNotifierAddRunLoopMode #ifdef MAC_OSX_TCL /* not accessable on Win32/UNIX */ MODULE_SCOPE int TclMacOSXGetFileAttribute(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 54001b2..aef2d23 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -145,14 +145,12 @@ static void uniCodePanic() { #define TclBN_mp_toom_sqr s_mp_toom_sqr #define TclpCreateTempFile_ TclpCreateTempFile -#define TclUnixWaitForFile_ TclUnixWaitForFile #define TclGetAndDetachPids_ TclGetAndDetachPids #define TclpCreateCommandChannel_ TclpCreateCommandChannel +#define TclpCloseFile_ TclpCloseFile +#define TclpMakeFile_ TclpMakeFile +#define TclpOpenFile_ TclpOpenFile #ifndef MAC_OSX_TCL /* On UNIX, fill with other stub entries */ -# define TclMacOSXGetFileAttribute (int (*)(Tcl_Interp *, int, Tcl_Obj *, Tcl_Obj **))(void *)TclpCreateProcess -# define TclMacOSXSetFileAttribute (int (*)(Tcl_Interp *, int, Tcl_Obj *, Tcl_Obj *))(void *)isatty -# define TclMacOSXCopyFileAttributes (int (*)(const char *, const char *, const Tcl_StatBuf *))(void *)TclUnixCopyFile -# define TclMacOSXMatchType (int (*)(Tcl_Interp *, const char *, const char *, Tcl_StatBuf *, Tcl_GlobTypeData *))(void *)TclpMakeFile # define Tcl_MacOSXOpenVersionedBundleResources 0 # define Tcl_MacOSXNotifierAddRunLoopMode 0 #endif @@ -161,6 +159,10 @@ static void uniCodePanic() { # define Tcl_CreateFileHandler 0 # define Tcl_DeleteFileHandler 0 # define Tcl_GetOpenFile 0 +# define TclpCreatePipe_ TclpCreatePipe +#else +# define TclpIsAtty isatty +# define TclpCreatePipe_ (int (*)(TclFile *, TclFile *))(void *)TclUnixCopyFile #endif #ifdef _WIN32 @@ -168,6 +170,7 @@ static void uniCodePanic() { # define TclUnixCopyFile 0 # define TclUnixOpenTemporaryFile 0 # define TclpReaddir 0 +# undef TclpIsAtty # define TclpIsAtty 0 #elif defined(__CYGWIN__) # define TclpIsAtty isatty @@ -256,7 +259,14 @@ static int utfNcasecmp(const char *s1, const char *s2, unsigned int n){ #endif /* TCL_WIDE_INT_IS_LONG */ -#endif /* __CYGWIN__ */ +#else /* __CYGWIN__ */ +# define TclWinGetTclInstance (void *(*)(void))(void *)TclpCreateProcess +# define TclpGetPid (size_t(*)(Tcl_Pid))(void *)TclUnixWaitForFile +# define TclWinConvertError (void(*)(int))(void *)TclGetAndDetachPids +# define TclWinFlushDirtyChannels 0 +# define TclWinNoBackslash 0 +# define TclWinAddProcess 0 +#endif /* * WARNING: The contents of this file is automatically generated by the @@ -548,62 +558,62 @@ static const TclIntPlatStubs tclIntPlatStubs = { TCL_STUB_MAGIC, 0, #if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ - TclGetAndDetachPids_, /* 0 */ + TclWinConvertError, /* 0 */ TclpCloseFile, /* 1 */ - TclpCreateCommandChannel_, /* 2 */ + TclpCreateCommandChannel, /* 2 */ TclpCreatePipe, /* 3 */ - TclpCreateProcess, /* 4 */ + TclWinGetTclInstance, /* 4 */ TclUnixWaitForFile, /* 5 */ TclpMakeFile, /* 6 */ TclpOpenFile, /* 7 */ - TclUnixWaitForFile_, /* 8 */ - TclpCreateTempFile_, /* 9 */ + TclpGetPid, /* 8 */ + TclpCreateTempFile, /* 9 */ 0, /* 10 */ TclGetAndDetachPids, /* 11 */ 0, /* 12 */ - TclpCreateCommandChannel, /* 13 */ - TclUnixCopyFile, /* 14 */ - 0, /* 15 */ - 0, /* 16 */ - 0, /* 17 */ + 0, /* 13 */ + TclpCreatePipe_, /* 14 */ + TclpCreateProcess, /* 15 */ + TclpIsAtty, /* 16 */ + TclUnixCopyFile, /* 17 */ 0, /* 18 */ TclMacOSXNotifierAddRunLoopMode, /* 19 */ - 0, /* 20 */ + TclWinAddProcess, /* 20 */ 0, /* 21 */ - TclpCreateTempFile, /* 22 */ + TclpCreateTempFile_, /* 22 */ 0, /* 23 */ - 0, /* 24 */ + TclWinNoBackslash, /* 24 */ 0, /* 25 */ 0, /* 26 */ - 0, /* 27 */ + TclWinFlushDirtyChannels, /* 27 */ 0, /* 28 */ TclWinCPUID, /* 29 */ TclUnixOpenTemporaryFile, /* 30 */ #endif /* UNIX */ #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ TclWinConvertError, /* 0 */ - 0, /* 1 */ - 0, /* 2 */ - 0, /* 3 */ + TclpCloseFile, /* 1 */ + TclpCreateCommandChannel, /* 2 */ + TclpCreatePipe, /* 3 */ TclWinGetTclInstance, /* 4 */ TclUnixWaitForFile, /* 5 */ - 0, /* 6 */ - 0, /* 7 */ + TclpMakeFile, /* 6 */ + TclpOpenFile, /* 7 */ TclpGetPid, /* 8 */ - 0, /* 9 */ + TclpCreateTempFile, /* 9 */ 0, /* 10 */ TclGetAndDetachPids, /* 11 */ - TclpCloseFile, /* 12 */ - TclpCreateCommandChannel, /* 13 */ - TclpCreatePipe, /* 14 */ + TclpCloseFile_, /* 12 */ + TclpCreateCommandChannel_, /* 13 */ + TclpCreatePipe_, /* 14 */ TclpCreateProcess, /* 15 */ TclpIsAtty, /* 16 */ TclUnixCopyFile, /* 17 */ - TclpMakeFile, /* 18 */ - TclpOpenFile, /* 19 */ + TclpMakeFile_, /* 18 */ + TclpOpenFile_, /* 19 */ TclWinAddProcess, /* 20 */ 0, /* 21 */ - TclpCreateTempFile, /* 22 */ + TclpCreateTempFile_, /* 22 */ 0, /* 23 */ TclWinNoBackslash, /* 24 */ 0, /* 25 */ @@ -614,34 +624,34 @@ static const TclIntPlatStubs tclIntPlatStubs = { TclUnixOpenTemporaryFile, /* 30 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ - TclGetAndDetachPids_, /* 0 */ + TclWinConvertError, /* 0 */ TclpCloseFile, /* 1 */ - TclpCreateCommandChannel_, /* 2 */ + TclpCreateCommandChannel, /* 2 */ TclpCreatePipe, /* 3 */ - TclpCreateProcess, /* 4 */ + TclWinGetTclInstance, /* 4 */ TclUnixWaitForFile, /* 5 */ TclpMakeFile, /* 6 */ TclpOpenFile, /* 7 */ - TclUnixWaitForFile_, /* 8 */ - TclpCreateTempFile_, /* 9 */ + TclpGetPid, /* 8 */ + TclpCreateTempFile, /* 9 */ 0, /* 10 */ TclGetAndDetachPids, /* 11 */ 0, /* 12 */ - TclpCreateCommandChannel, /* 13 */ - TclUnixCopyFile, /* 14 */ - 0, /* 15 */ - 0, /* 16 */ - 0, /* 17 */ + 0, /* 13 */ + TclpCreatePipe_, /* 14 */ + TclpCreateProcess, /* 15 */ + TclpIsAtty, /* 16 */ + TclUnixCopyFile, /* 17 */ 0, /* 18 */ TclMacOSXNotifierAddRunLoopMode, /* 19 */ - 0, /* 20 */ + TclWinAddProcess, /* 20 */ 0, /* 21 */ - TclpCreateTempFile, /* 22 */ + TclpCreateTempFile_, /* 22 */ 0, /* 23 */ - 0, /* 24 */ + TclWinNoBackslash, /* 24 */ 0, /* 25 */ 0, /* 26 */ - 0, /* 27 */ + TclWinFlushDirtyChannels, /* 27 */ 0, /* 28 */ TclWinCPUID, /* 29 */ TclUnixOpenTemporaryFile, /* 30 */ -- cgit v0.12 From 0d15664cbdafeb59a53986a6e646b79f7e5124da Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 18 Feb 2021 11:31:11 +0000 Subject: Change (internal) signatures for TclpGetClicks/TclpGetSeconds to use "unsigned long long" in stead of Tcl_WideUInt as return value. --- generic/tclClock.c | 4 ++-- generic/tclInt.decls | 4 ++-- generic/tclIntDecls.h | 8 ++++---- unix/tclUnixTime.c | 16 ++++++++-------- win/tclWinTime.c | 8 ++++---- 5 files changed, 20 insertions(+), 20 deletions(-) diff --git a/generic/tclClock.c b/generic/tclClock.c index f05a7a1..8cb1b40 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -1762,13 +1762,13 @@ ClockClicksObjCmd( switch (index) { case CLICKS_MILLIS: Tcl_GetTime(&now); - clicks = (Tcl_WideInt) now.sec * 1000 + now.usec / 1000; + clicks = (Tcl_WideInt)(unsigned long)now.sec * 1000 + now.usec / 1000; break; case CLICKS_NATIVE: #ifdef TCL_WIDE_CLICKS clicks = TclpGetWideClicks(); #else - clicks = (Tcl_WideInt) TclpGetClicks(); + clicks = (Tcl_WideInt)TclpGetClicks(); #endif break; case CLICKS_MICROS: diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 42e6899..3fbc571 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -151,10 +151,10 @@ declare 74 { void TclpFree(void *ptr) } declare 75 { - Tcl_WideUInt TclpGetClicks(void) + unsigned long long TclpGetClicks(void) } declare 76 { - Tcl_WideUInt TclpGetSeconds(void) + unsigned long long TclpGetSeconds(void) } declare 81 { void *TclpRealloc(void *ptr, size_t size) diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 2969f27..23cf3e6 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -186,9 +186,9 @@ EXTERN void * TclpAlloc(size_t size); /* 74 */ EXTERN void TclpFree(void *ptr); /* 75 */ -EXTERN Tcl_WideUInt TclpGetClicks(void); +EXTERN unsigned long long TclpGetClicks(void); /* 76 */ -EXTERN Tcl_WideUInt TclpGetSeconds(void); +EXTERN unsigned long long TclpGetSeconds(void); /* Slot 77 is reserved */ /* Slot 78 is reserved */ /* Slot 79 is reserved */ @@ -663,8 +663,8 @@ typedef struct TclIntStubs { void (*reserved72)(void); void (*reserved73)(void); void (*tclpFree) (void *ptr); /* 74 */ - Tcl_WideUInt (*tclpGetClicks) (void); /* 75 */ - Tcl_WideUInt (*tclpGetSeconds) (void); /* 76 */ + unsigned long long (*tclpGetClicks) (void); /* 75 */ + unsigned long long (*tclpGetSeconds) (void); /* 76 */ void (*reserved77)(void); void (*reserved78)(void); void (*reserved79)(void); diff --git a/unix/tclUnixTime.c b/unix/tclUnixTime.c index dc48a32..990503d 100644 --- a/unix/tclUnixTime.c +++ b/unix/tclUnixTime.c @@ -49,10 +49,10 @@ void *tclTimeClientData = NULL; *---------------------------------------------------------------------- */ -Tcl_WideUInt +unsigned long long TclpGetSeconds(void) { - return time(NULL); + return (unsigned long long)time(NULL); } /* @@ -78,7 +78,7 @@ TclpGetMicroseconds(void) Tcl_Time time; tclGetTimeProcPtr(&time, tclTimeClientData); - return ((long long)time.sec)*1000000 + time.usec; + return ((long long)(unsigned long)time.sec)*1000000 + time.usec; } /* @@ -100,30 +100,30 @@ TclpGetMicroseconds(void) *---------------------------------------------------------------------- */ -Tcl_WideUInt +unsigned long long TclpGetClicks(void) { - Tcl_WideUInt now; + unsigned long long now; #ifdef NO_GETTOD if (tclGetTimeProcPtr != NativeGetTime) { Tcl_Time time; tclGetTimeProcPtr(&time, tclTimeClientData); - now = (Tcl_WideUInt)time.sec*1000000 + time.usec; + now = (unsigned long long)(unsigned long)time.sec*1000000 + time.usec; } else { /* * A semi-NativeGetTime, specialized to clicks. */ struct tms dummy; - now = (Tcl_WideUInt) times(&dummy); + now = (unsigned long long)times(&dummy); } #else Tcl_Time time; tclGetTimeProcPtr(&time, tclTimeClientData); - now = (Tcl_WideUInt)time.sec*1000000 + time.usec; + now = (unsigned long long)time.sec*1000000 + time.usec; #endif return now; diff --git a/win/tclWinTime.c b/win/tclWinTime.c index 3c52451..0bd5b7e 100644 --- a/win/tclWinTime.c +++ b/win/tclWinTime.c @@ -144,7 +144,7 @@ ClientData tclTimeClientData = NULL; *---------------------------------------------------------------------- */ -Tcl_WideUInt +unsigned long long TclpGetSeconds(void) { long long usecSincePosixEpoch; @@ -158,7 +158,7 @@ TclpGetSeconds(void) Tcl_Time t; tclGetTimeProcPtr(&t, tclTimeClientData); /* Tcl_GetTime inlined. */ - return t.sec; + return (unsigned long long)(unsigned long)t.sec; } } @@ -181,7 +181,7 @@ TclpGetSeconds(void) *---------------------------------------------------------------------- */ -Tcl_WideUInt +unsigned long long TclpGetClicks(void) { long long usecSincePosixEpoch; @@ -200,7 +200,7 @@ TclpGetClicks(void) Tcl_Time now; /* Current Tcl time */ tclGetTimeProcPtr(&now, tclTimeClientData); /* Tcl_GetTime inlined */ - return (Tcl_WideUInt)(now.sec * 1000000) + now.usec; + return ((unsigned long long)(unsigned long)now.sec * 1000000ULL) + now.usec; } } -- cgit v0.12 From bd8b8ff3b710e8ae5f4750eadc84c9d96c3ea4c7 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 24 Feb 2021 10:14:01 +0000 Subject: Final implementation tweaks, fix comments, allow Tcl to load from /lib (or /bin on win32/cygwin) even when this is not in your PATH. --- doc/zipfs.3 | 4 ++-- generic/tclStubCall.c | 22 ++++++++++++++++++---- generic/tclStubLib.c | 2 +- generic/tclStubLibTbl.c | 2 +- unix/Makefile.in | 7 +++++-- unix/configure.ac | 4 ---- win/Makefile.in | 5 ++++- win/makefile.vc | 5 ++++- 8 files changed, 35 insertions(+), 16 deletions(-) diff --git a/doc/zipfs.3 b/doc/zipfs.3 index f1efc65..2db6d67 100644 --- a/doc/zipfs.3 +++ b/doc/zipfs.3 @@ -87,8 +87,8 @@ it uses WCHAR instead of char. As a result, it requires your application to be compiled with the UNICODE preprocessor symbol defined (e.g., via the \fB-DUNICODE\fR compiler flag). .PP -The result of \fBTclZipfs_AppHook\fR is the Tcl version string(e.g., \fB"9.0"\fR -when the function is successful). The function \fImay\fR modify the variables +The result of \fBTclZipfs_AppHook\fR is the full Tcl version string(e.g., +\fB"9.0.0"\fR). The function \fImay\fR modify the variables pointed to by \fIargcPtr\fR and \fIargvPtr\fR to remove arguments; the current implementation does not do so, but callers \fIshould not\fR assume that this will be true in the future. diff --git a/generic/tclStubCall.c b/generic/tclStubCall.c index 8fe7892..96e3837 100644 --- a/generic/tclStubCall.c +++ b/generic/tclStubCall.c @@ -59,7 +59,7 @@ static const char CANNOTFIND[] = "Cannot find %s: %s\n"; MODULE_SCOPE void * TclStubCall(void *arg) { - static void *stubFn[] = {NULL,NULL,NULL,NULL,NULL,NULL,NULL}; + static void *stubFn[] = {NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL}; unsigned index = PTR2UINT(arg); if (index >= sizeof(PROCNAME)/sizeof(PROCNAME[0])) { @@ -76,12 +76,26 @@ TclStubCall(void *arg) } if (!stubFn[index]) { if (!tclStubsHandle) { - tclStubsHandle = dlopen(TCL_DLL_FILE, RTLD_NOW|RTLD_LOCAL); + tclStubsHandle = dlopen(CFG_RUNTIME_DLLFILE, RTLD_NOW|RTLD_LOCAL); + if (!tclStubsHandle) { + tclStubsHandle = dlopen( +#if defined(_WIN32) || defined(__CYGWIN__) + CFG_RUNTIME_BINDIR +#else + CFG_RUNTIME_LIBDIR +#endif +#if defined(_WIN32) + "\\" +#else + "/" +#endif + CFG_RUNTIME_DLLFILE, RTLD_NOW|RTLD_LOCAL); + } if (!tclStubsHandle) { if ((index == 0) && (arg != NULL)) { - ((Tcl_PanicProc *)arg)(CANNOTFIND, TCL_DLL_FILE, dlerror()); + ((Tcl_PanicProc *)arg)(CANNOTFIND, CFG_RUNTIME_DLLFILE, dlerror()); } else { - fprintf(stderr, CANNOTFIND, TCL_DLL_FILE, dlerror()); + fprintf(stderr, CANNOTFIND, CFG_RUNTIME_DLLFILE, dlerror()); abort(); } } diff --git a/generic/tclStubLib.c b/generic/tclStubLib.c index 32ca1f1..697d92f 100644 --- a/generic/tclStubLib.c +++ b/generic/tclStubLib.c @@ -109,7 +109,7 @@ Tcl_InitStubs( stubsPtr = (TclStubs *)pkgData; } if (tclStubsHandle == NULL) { - tclStubsHandle = (void *) -1; + tclStubsHandle = INT2PTR(-1); } tclStubsPtr = stubsPtr; diff --git a/generic/tclStubLibTbl.c b/generic/tclStubLibTbl.c index 32b3869..ad34494 100644 --- a/generic/tclStubLibTbl.c +++ b/generic/tclStubLibTbl.c @@ -40,7 +40,7 @@ TclInitStubTable( if (tclStubsHandle == NULL) { /* This can only happen with -DBUILD_STATIC, so simulate * that the loading of Tcl succeeded, although we didn't - * actually loaded it dynamically */ + * actually load it dynamically */ tclStubsHandle = (void *)1; } tclStubsPtr = ((const TclStubs **) version)[-1]; diff --git a/unix/Makefile.in b/unix/Makefile.in index 4e7b06c..936f2f2 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -201,7 +201,6 @@ BUILD_DLTEST = @BUILD_DLTEST@ TCL_LIB_FILE = @TCL_LIB_FILE@ #TCL_LIB_FILE = libtcl.a -TCL_PREV_LIB_FILE = @TCL_PREV_LIB_FILE@ # Generic lib name used in rules that apply to tcl and tk LIB_FILE = ${TCL_LIB_FILE} @@ -1914,7 +1913,11 @@ tclStubLib.o: $(GENERIC_DIR)/tclStubLib.c $(CC) -c $(STUB_CC_SWITCHES) -DSTATIC_BUILD @CFLAGS_NOLTO@ $(GENERIC_DIR)/tclStubLib.c tclStubCall.o: $(GENERIC_DIR)/tclStubCall.c - $(CC) -c $(STUB_CC_SWITCHES) -DSTATIC_BUILD -DTCL_DLL_FILE="\"$(TCL_LIB_FILE)\"" $(GENERIC_DIR)/tclStubCall.c + $(CC) -c $(STUB_CC_SWITCHES) -DSTATIC_BUILD \ + -DCFG_RUNTIME_DLLFILE="\"$(TCL_LIB_FILE)\"" \ + -DCFG_RUNTIME_LIBDIR="\"$(libdir)\"" \ + -DCFG_RUNTIME_BINDIR="\"$(bindir)\"" \ + $(GENERIC_DIR)/tclStubCall.c tclStubLibTbl.o: $(GENERIC_DIR)/tclStubLibTbl.c $(CC) -c $(STUB_CC_SWITCHES) -DSTATIC_BUILD $(GENERIC_DIR)/tclStubLibTbl.c diff --git a/unix/configure.ac b/unix/configure.ac index 08aa2b3..685a335 100644 --- a/unix/configure.ac +++ b/unix/configure.ac @@ -864,9 +864,6 @@ else TCL_BUILD_LIB_SPEC="-L`pwd | sed -e 's/ /\\\\ /g'` ${TCL_LIB_FLAG}" TCL_LIB_SPEC="-L${libdir} ${TCL_LIB_FLAG}" fi -VERSION='8.5' -eval "TCL_PREV_LIB_FILE=libtcl${TCL_SHARED_LIB_SUFFIX}" -eval "TCL_PREV_LIB_FILE=${TCL_PREV_LIB_FILE}" VERSION='${VERSION}' eval "CFG_TCL_SHARED_LIB_SUFFIX=${TCL_SHARED_LIB_SUFFIX}" eval "CFG_TCL_UNSHARED_LIB_SUFFIX=${TCL_UNSHARED_LIB_SUFFIX}" @@ -974,7 +971,6 @@ AC_SUBST(PKG_CFG_ARGS) AC_SUBST(TCL_ZIP_FILE) AC_SUBST(TCL_LIB_FILE) -AC_SUBST(TCL_PREV_LIB_FILE) AC_SUBST(TCL_LIB_FLAG) AC_SUBST(TCL_LIB_SPEC) AC_SUBST(TCL_STUB_LIB_FILE) diff --git a/win/Makefile.in b/win/Makefile.in index 57cb7ef..1ce1c9d 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -682,7 +682,10 @@ tclStubLib.${OBJEXT}: tclStubLib.c $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @CFLAGS_NOLTO@ @DEPARG@ $(CC_OBJNAME) tclStubCall.${OBJEXT}: tclStubCall.c - $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD -DTCL_DLL_FILE="\"$(TCL_DLL_FILE)\"" @DEPARG@ $(CC_OBJNAME) + $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD \ + -DCFG_RUNTIME_DLLFILE="\"$(TCL_DLL_FILE)\"" \ + -DCFG_RUNTIME_BINDIR="\"$(bindir_native)\"" \ + @DEPARG@ $(CC_OBJNAME) tclStubLibTbl.${OBJEXT}: tclStubLibTbl.c $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @DEPARG@ $(CC_OBJNAME) diff --git a/win/makefile.vc b/win/makefile.vc index 67c7c36..03a4419 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -864,7 +864,10 @@ $(TMP_DIR)\tclStubLib.obj: $(GENERICDIR)\tclStubLib.c $(cc32) $(stubscflags) -Fo$@ $? $(TMP_DIR)\tclStubCall.obj: $(GENERICDIR)\tclStubCall.c - $(cc32) $(stubscflags) -DTCL_DLL_FILE="\"tcl$(TCL_VERSION)$(SUFX:t=).dll\"" $(TCL_INCLUDES) -Fo$@ $? + $(cc32) $(stubscflags) \ + /DCFG_RUNTIME_DLLFILE="\"$(TCLLIBNAME)\"" \ + /DCFG_RUNTIME_BINDIR="\"$(BIN_INSTALL_DIR:\=\\)\"" \ + $(TCL_INCLUDES) -Fo$@ $? $(TMP_DIR)\tclStubLibTbl.obj: $(GENERICDIR)\tclStubLibTbl.c $(cc32) $(stubscflags) $(TCL_INCLUDES) -Fo$@ $? -- cgit v0.12 From 6eb27e1aaa13ae6877fde25f4d1f2110e2809cde Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 26 Feb 2021 09:10:49 +0000 Subject: Try to fix Visual Studio build --- generic/tclStubCall.c | 15 +++++---------- 1 file changed, 5 insertions(+), 10 deletions(-) diff --git a/generic/tclStubCall.c b/generic/tclStubCall.c index 96e3837..8ec3155 100644 --- a/generic/tclStubCall.c +++ b/generic/tclStubCall.c @@ -60,7 +60,7 @@ MODULE_SCOPE void * TclStubCall(void *arg) { static void *stubFn[] = {NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL}; - unsigned index = PTR2UINT(arg); + size_t index = PTR2UINT(arg); if (index >= sizeof(PROCNAME)/sizeof(PROCNAME[0])) { /* Any other value means Tcl_SetPanicProc() with non-null panicProc */ @@ -78,18 +78,13 @@ TclStubCall(void *arg) if (!tclStubsHandle) { tclStubsHandle = dlopen(CFG_RUNTIME_DLLFILE, RTLD_NOW|RTLD_LOCAL); if (!tclStubsHandle) { - tclStubsHandle = dlopen( -#if defined(_WIN32) || defined(__CYGWIN__) - CFG_RUNTIME_BINDIR -#else - CFG_RUNTIME_LIBDIR -#endif #if defined(_WIN32) - "\\" + tclStubsHandle = dlopen(CFG_RUNTIME_BINDIR "\\" CFG_RUNTIME_DLLFILE, RTLD_NOW|RTLD_LOCAL); +#elif defined(__CYGWIN__) + tclStubsHandle = dlopen(CFG_RUNTIME_BINDIR "/" CFG_RUNTIME_DLLFILE, RTLD_NOW|RTLD_LOCAL); #else - "/" + tclStubsHandle = dlopen(CFG_RUNTIME_LIBDIR "/" CFG_RUNTIME_DLLFILE, RTLD_NOW|RTLD_LOCAL); #endif - CFG_RUNTIME_DLLFILE, RTLD_NOW|RTLD_LOCAL); } if (!tclStubsHandle) { if ((index == 0) && (arg != NULL)) { -- cgit v0.12 From 3cbac4bb5be49ca8f19243442343db01c08bb733 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 10 Mar 2021 07:51:34 +0000 Subject: Move internal stub entry 260 to 259, the same place it is in 8.7. --- generic/tclInt.decls | 16 +++++++++------- generic/tclIntDecls.h | 19 ++++++++----------- generic/tclStubInit.c | 5 ++--- 3 files changed, 19 insertions(+), 21 deletions(-) diff --git a/generic/tclInt.decls b/generic/tclInt.decls index d7ea540..eb18fd8 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -468,6 +468,7 @@ declare 232 { declare 233 { void TclGetSrcInfoForPc(CmdFrame *contextPtr) } + # Exports for VarReform compat: Itcl, XOTcl like to peek into our varTables :( declare 234 { Var *TclVarHashCreateVar(TclVarHashTable *tablePtr, const char *key, @@ -476,10 +477,17 @@ declare 234 { declare 235 { void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr) } +# TIP 542 +declare 236 { + void TclAppendUnicodeToObj(Tcl_Obj *objPtr, + const Tcl_UniChar *unicode, size_t length) +} + # TIP #285: Script cancellation support. declare 237 { int TclResetCancellation(Tcl_Interp *interp, int force) } + # NRE functions for "rogue" extensions to exploit NRE; they will need to # include NRE.h too. declare 238 { @@ -568,7 +576,6 @@ declare 256 { int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags) } - declare 257 { void TclStaticPackage(Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc) @@ -579,13 +586,8 @@ declare 258 { Tcl_Obj *TclpCreateTemporaryDirectory(Tcl_Obj *dirObj, Tcl_Obj *basenameObj) } -# TIP 542 -declare 259 { - void TclAppendUnicodeToObj(Tcl_Obj *objPtr, - const Tcl_UniChar *unicode, size_t length) -} -declare 260 { +declare 259 { unsigned char *TclGetBytesFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, size_t *lengthPtr) } diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 23cf3e6..fc0a9a3 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -501,7 +501,9 @@ EXTERN Var * TclVarHashCreateVar(TclVarHashTable *tablePtr, /* 235 */ EXTERN void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr); -/* Slot 236 is reserved */ +/* 236 */ +EXTERN void TclAppendUnicodeToObj(Tcl_Obj *objPtr, + const Tcl_UniChar *unicode, size_t length); /* 237 */ EXTERN int TclResetCancellation(Tcl_Interp *interp, int force); /* 238 */ @@ -578,9 +580,6 @@ EXTERN void TclStaticPackage(Tcl_Interp *interp, EXTERN Tcl_Obj * TclpCreateTemporaryDirectory(Tcl_Obj *dirObj, Tcl_Obj *basenameObj); /* 259 */ -EXTERN void TclAppendUnicodeToObj(Tcl_Obj *objPtr, - const Tcl_UniChar *unicode, size_t length); -/* 260 */ EXTERN unsigned char * TclGetBytesFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, size_t *lengthPtr); @@ -824,7 +823,7 @@ typedef struct TclIntStubs { void (*tclGetSrcInfoForPc) (CmdFrame *contextPtr); /* 233 */ Var * (*tclVarHashCreateVar) (TclVarHashTable *tablePtr, const char *key, int *newPtr); /* 234 */ void (*tclInitVarHashTable) (TclVarHashTable *tablePtr, Namespace *nsPtr); /* 235 */ - void (*reserved236)(void); + void (*tclAppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, size_t length); /* 236 */ int (*tclResetCancellation) (Tcl_Interp *interp, int force); /* 237 */ int (*tclNRInterpProc) (void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 238 */ int (*tclNRInterpProcCore) (Tcl_Interp *interp, Tcl_Obj *procNameObj, int skip, ProcErrorProc *errorProc); /* 239 */ @@ -847,8 +846,7 @@ typedef struct TclIntStubs { int (*tclPtrUnsetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 256 */ void (*tclStaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 257 */ Tcl_Obj * (*tclpCreateTemporaryDirectory) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj); /* 258 */ - void (*tclAppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, size_t length); /* 259 */ - unsigned char * (*tclGetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, size_t *lengthPtr); /* 260 */ + unsigned char * (*tclGetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, size_t *lengthPtr); /* 259 */ } TclIntStubs; extern const TclIntStubs *tclIntStubsPtr; @@ -1219,7 +1217,8 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclVarHashCreateVar) /* 234 */ #define TclInitVarHashTable \ (tclIntStubsPtr->tclInitVarHashTable) /* 235 */ -/* Slot 236 is reserved */ +#define TclAppendUnicodeToObj \ + (tclIntStubsPtr->tclAppendUnicodeToObj) /* 236 */ #define TclResetCancellation \ (tclIntStubsPtr->tclResetCancellation) /* 237 */ #define TclNRInterpProc \ @@ -1264,10 +1263,8 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclStaticPackage) /* 257 */ #define TclpCreateTemporaryDirectory \ (tclIntStubsPtr->tclpCreateTemporaryDirectory) /* 258 */ -#define TclAppendUnicodeToObj \ - (tclIntStubsPtr->tclAppendUnicodeToObj) /* 259 */ #define TclGetBytesFromObj \ - (tclIntStubsPtr->tclGetBytesFromObj) /* 260 */ + (tclIntStubsPtr->tclGetBytesFromObj) /* 259 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index f6b8b0d..e1ba73e 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -527,7 +527,7 @@ static const TclIntStubs tclIntStubs = { TclGetSrcInfoForPc, /* 233 */ TclVarHashCreateVar, /* 234 */ TclInitVarHashTable, /* 235 */ - 0, /* 236 */ + TclAppendUnicodeToObj, /* 236 */ TclResetCancellation, /* 237 */ TclNRInterpProc, /* 238 */ TclNRInterpProcCore, /* 239 */ @@ -550,8 +550,7 @@ static const TclIntStubs tclIntStubs = { TclPtrUnsetVar, /* 256 */ TclStaticPackage, /* 257 */ TclpCreateTemporaryDirectory, /* 258 */ - TclAppendUnicodeToObj, /* 259 */ - TclGetBytesFromObj, /* 260 */ + TclGetBytesFromObj, /* 259 */ }; static const TclIntPlatStubs tclIntPlatStubs = { -- cgit v0.12 From 7429625aafffe2055c21ac133cb885cccb0b8ad2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 22 Mar 2021 12:36:02 +0000 Subject: test tweaks --- tests/load.test | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/tests/load.test b/tests/load.test index 857d1b3..c419bfb 100644 --- a/tests/load.test +++ b/tests/load.test @@ -174,7 +174,7 @@ test load-7.3 {Tcl_StaticLibrary procedure} [list teststaticlibrary] { catch {load [file join $testDir pkga$ext] Pkga} catch {load [file join $testDir pkgb$ext] Pkgb} catch {load [file join $testDir pkge$ext] Pkge} -set currentRealPackages [list [list [file join $testDir pkge$ext] Pkge] [list [file join $testDir pkgb$ext] Pkgb] [list [file join $testDir pkga$ext] Pkga]] +set currentRealLibraries [list [list [file join $testDir pkge$ext] Pkge] [list [file join $testDir pkgb$ext] Pkgb] [list [file join $testDir pkga$ext] Pkga]] test load-7.4 {Tcl_StaticLibrary procedure, redundant calls} -setup { teststaticlibrary Test 1 0 teststaticlibrary Another 0 0 @@ -183,7 +183,7 @@ test load-7.4 {Tcl_StaticLibrary procedure, redundant calls} -setup { teststaticlibrary Double 0 1 teststaticlibrary Double 0 1 info loaded -} -result [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealPackages {*}$alreadyTotalLoaded] +} -result [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealLibraries {*}$alreadyTotalLoaded] testConstraint teststaticlibrary_8.x 0 if {[testConstraint teststaticlibrary]} { @@ -196,19 +196,19 @@ if {[testConstraint teststaticlibrary]} { } } -test load-8.1 {TclGetLoadedPackages procedure} [list teststaticlibrary_8.x $dll $loaded] { +test load-8.1 {TclGetLoadedLibraries procedure} [list teststaticlibrary_8.x $dll $loaded] { lsort -index 1 [info loaded] -} [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealPackages {*}$alreadyTotalLoaded]] -test load-8.2 {TclGetLoadedPackages procedure} -constraints {teststaticlibrary_8.x} -body { +} [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealLibraries {*}$alreadyTotalLoaded]] +test load-8.2 {TclGetLoadedLibraries procedure} -constraints {teststaticlibrary_8.x} -body { info loaded gorp } -returnCodes error -result {could not find interpreter "gorp"} -test load-8.3a {TclGetLoadedPackages procedure} [list teststaticlibrary_8.x $dll $loaded] { +test load-8.3a {TclGetLoadedLibraries procedure} [list teststaticlibrary_8.x $dll $loaded] { lsort -index 1 [info loaded {}] } [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga] [list [file join $testDir pkgb$ext] Pkgb] {*}$alreadyLoaded]] -test load-8.3b {TclGetLoadedPackages procedure} [list teststaticlibrary_8.x $dll $loaded] { +test load-8.3b {TclGetLoadedLibraries procedure} [list teststaticlibrary_8.x $dll $loaded] { lsort -index 1 [info loaded child] } [lsort -index 1 [list {{} Test} [list [file join $testDir pkgb$ext] Pkgb]]] -test load-8.4 {TclGetLoadedPackages procedure} [list teststaticlibrary_8.x $dll $loaded] { +test load-8.4 {TclGetLoadedLibraries procedure} [list teststaticlibrary_8.x $dll $loaded] { load [file join $testDir pkgb$ext] Pkgb list [lsort -index 1 [info loaded {}]] [lsort [info commands pkgb_*]] } [list [lsort -index 1 [concat [list [list [file join $testDir pkgb$ext] Pkgb] {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded]] {pkgb_demo pkgb_sub pkgb_unsafe}] -- cgit v0.12 From 73019a8bbd67347ff72a37a7a57b7eb001689c8a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 22 Mar 2021 17:20:23 +0000 Subject: indenting --- generic/tclLoad.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 4ab26bd..b565eba 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -332,7 +332,7 @@ Tcl_LoadObjCmd( for (p = pkgGuess; *p != 0; p += offset) { offset = TclUtfToUniChar(p, &ch); if (!Tcl_UniCharIsWordChar(UCHAR(ch)) - || Tcl_UniCharIsDigit(UCHAR(ch))) { + || Tcl_UniCharIsDigit(UCHAR(ch))) { break; } } -- cgit v0.12 From 171ff16f7d1431ba085c9bb1dd90d64210ffb30c Mon Sep 17 00:00:00 2001 From: pooryorick Date: Fri, 2 Apr 2021 21:20:46 +0000 Subject: New test for OO cleanup: routine for object gets deleted before namespace deletion is complete. --- tests/oo.test | 37 ++++++++++++++++++++++++++++++++++++- 1 file changed, 36 insertions(+), 1 deletion(-) diff --git a/tests/oo.test b/tests/oo.test index 168baee..404c6a4 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -1734,6 +1734,7 @@ test oo-11.6.3 { } -result 0 -cleanup { } + test oo-11.6.4 { OO: cleanup ReleaseClassContents() where class is mixed into one of its instances @@ -1754,6 +1755,37 @@ test oo-11.6.4 { rename obj1 {} } + +test oo-11.7 { + When an object is deleted its namespace is deleted, and all objects it is + mixed into are also deleted. If the object has been renamed into the + namespace of one of the objects it has been mixed into, the routine for the + object might get entirely deleted before the namespace of the object is + entirely deleted, in which case the C routine the performs the namespace + either must either understand that the handle on the routine for the object + might now be gone, or it must be guaranteed that the handle does not + disappear until that routine is finished. +} -setup { +} -body { + oo::define oo::class { + export createWithNamespace + } + oo::class create class1 + + oo::object create obj1 + oo::objdefine obj1 { + mixin ::class1 + } + set obj1ns [info object namespace obj1] + set class1ns [info object namespace class1] + rename class1 ${obj1ns}::class1 + # No segmentation fault + namespace delete $class1ns +} -cleanup { + rename obj {} +} -result done + + test oo-12.1 {OO: filters} { oo::class create Aclass Aclass create Aobject @@ -1777,6 +1809,8 @@ test oo-12.1 {OO: filters} { Aclass destroy return $result } {{calling ::Aobject->logFilter 1 2 3 4 5} 1 2 3 4 5 result=12345 12345} + + test oo-12.2 {OO: filters} -setup { oo::class create Aclass Aclass create Aobject @@ -4376,12 +4410,13 @@ test oo-35.6 { } -body { rename obj2 {} rename obj1 {} - # doesn't crash + # No segmentation fault return done } -cleanup { rename obj {} } -result done + test oo-36.1 {TIP #470: introspection within oo::define} { oo::define oo::object self } ::oo::object -- cgit v0.12 From 7d6ca39c8fc1416903f2fe01216ed2d7b435feb3 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Fri, 2 Apr 2021 23:02:00 +0000 Subject: OO cleanup fix that passes test 11.7. --- generic/tclOO.c | 23 ++++++++++++----------- tests/oo.test | 13 +++++-------- 2 files changed, 17 insertions(+), 19 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 4dbe668..559cf0b 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -1184,18 +1184,19 @@ ObjectNamespaceDeleted( * freed memory. */ - if (((Command *) oPtr->command)->flags && CMD_DYING) { - /* - * Something has already started the command deletion process. We can - * go ahead and clean up the the namespace, - */ - } else { - /* - * The namespace must have been deleted directly. Delete the command - * as well. - */ + if (oPtr->command != NULL) { + if (((Command *) oPtr->command)->flags && CMD_DYING) { + /* + * The command is already (being) deleted. Proceed to clean up the the namespace, + */ + } else { + /* + * The namespace must have been deleted directly. Delete the command + * as well. + */ - Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command); + Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command); + } } if (oPtr->myclassCommand) { diff --git a/tests/oo.test b/tests/oo.test index 404c6a4..7980f9e 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -1761,15 +1761,12 @@ test oo-11.7 { mixed into are also deleted. If the object has been renamed into the namespace of one of the objects it has been mixed into, the routine for the object might get entirely deleted before the namespace of the object is - entirely deleted, in which case the C routine the performs the namespace - either must either understand that the handle on the routine for the object - might now be gone, or it must be guaranteed that the handle does not - disappear until that routine is finished. + entirely deleted, in which case the C routine that performs the namespace + deletion either must either understand that the handle on the routine for + the object might now be gone, or it must be guaranteed that the handle does + not disappear until that routine is finished. } -setup { } -body { - oo::define oo::class { - export createWithNamespace - } oo::class create class1 oo::object create obj1 @@ -1781,8 +1778,8 @@ test oo-11.7 { rename class1 ${obj1ns}::class1 # No segmentation fault namespace delete $class1ns + return done } -cleanup { - rename obj {} } -result done -- cgit v0.12 From c98ea4af2fac0552f8453c1787028523e1d19117 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Fri, 2 Apr 2021 23:21:50 +0000 Subject: Use TclCleanupCommandMacro instead of just decrementing the reference count. --- generic/tclBasic.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index b90e12d..ce8c4ed 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -3662,7 +3662,7 @@ CallCommandTraces( */ cmdPtr->flags &= ~CMD_TRACE_ACTIVE; - cmdPtr->refCount--; + TclCleanupCommandMacro(cmdPtr); iPtr->activeCmdTracePtr = active.nextPtr; Tcl_Release(iPtr); return result; -- cgit v0.12 From aef7e169a724687ab05b72273b5a7fbc2fba22cc Mon Sep 17 00:00:00 2001 From: pooryorick Date: Sat, 3 Apr 2021 10:43:53 +0000 Subject: Remove suspected inadvertent copypasta from test. --- tests/namespace.test | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/namespace.test b/tests/namespace.test index 3394824..679b468 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -3301,8 +3301,8 @@ test namespace-56.2 {bug f97d4ee020: mutually-entangled deletion} { namespace eval ::testing { namespace eval abc {proc xyz {} {}} namespace eval def {proc xyz {} {}} - trace add command abc::xyz delete "namespace delete ::testing::def {}; #" - trace add command def::xyz delete "namespace delete ::testing::abc {}; #" + trace add command abc::xyz delete "namespace delete ::testing::def; #" + trace add command def::xyz delete "namespace delete ::testing::abc; #" } namespace delete ::testing } {} -- cgit v0.12 From 02855d5980f78e6e42b3a35274a26c978f9af694 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Sat, 3 Apr 2021 12:04:21 +0000 Subject: When a namesapce is deleted delete all namespaces under it before making any modifictions to it. --- generic/tclInt.h | 1 + generic/tclNamesp.c | 142 ++++++++++++++++++++++++++++++---------------------- 2 files changed, 84 insertions(+), 59 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 2448b5a..3ac46bb 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2890,6 +2890,7 @@ MODULE_SCOPE Tcl_Command TclCreateEnsembleInNs(Tcl_Interp *interp, const char *name, Tcl_Namespace *nameNamespacePtr, Tcl_Namespace *ensembleNamespacePtr, int flags); MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr); +MODULE_SCOPE void TclDeleteNamespaceChildren(Namespace *nsPt); MODULE_SCOPE int TclFindDictElement(Tcl_Interp *interp, const char *dict, int dictLength, const char **elementPtr, const char **nextPtr, diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index b2d717b..607072b 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -917,10 +917,10 @@ Tcl_DeleteNamespace( /* * Give anyone interested - notably TclOO - a chance to use this namespace * normally despite the fact that the namespace is going to go. Allows the - * calling of destructors. Will only be called once (unless re-established + * calling of destructors. Only called once (unless re-established * by the called function). [Bug 2950259] * - * Note that setting this field requires access to the internal definition + * Setting this field requires access to the internal definition * of namespaces, so it should only be accessed by code that knows about * being careful with reentrancy. */ @@ -1065,7 +1065,7 @@ Tcl_DeleteNamespace( } TclNsDecrRefCount(nsPtr); } - + int TclNamespaceDeleted( Namespace *nsPtr) @@ -1073,6 +1073,83 @@ TclNamespaceDeleted( return (nsPtr->flags & NS_DYING) ? 1 : 0; } +void +TclDeleteNamespaceChildren( + Namespace *nsPtr /* Namespace whose children to delete */ +) +{ + Interp *iPtr = (Interp *) nsPtr->interp; + Tcl_HashEntry *entryPtr; + int i, unchecked; + Tcl_HashSearch search; + /* + * Delete all the child namespaces. + * + * BE CAREFUL: When each child is deleted, it divorces itself from its + * parent. The hash table can't be proplery traversed if its elements are + * being deleted. Because of traces (and the desire to avoid the + * quadratic problems of just using Tcl_FirstHashEntry over and over, [Bug + * f97d4ee020]) copy to a temporary array and then delete all those + * namespaces. + * + * Important: leave the hash table itself still live. + */ + +#ifndef BREAK_NAMESPACE_COMPAT + unchecked = (nsPtr->childTable.numEntries > 0); + while (nsPtr->childTable.numEntries > 0 && unchecked) { + int length = nsPtr->childTable.numEntries; + Namespace **children = (Namespace **)TclStackAlloc((Tcl_Interp *) iPtr, + sizeof(Namespace *) * length); + + i = 0; + for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); + entryPtr != NULL; + entryPtr = Tcl_NextHashEntry(&search)) { + children[i] = (Namespace *)Tcl_GetHashValue(entryPtr); + children[i]->refCount++; + i++; + } + unchecked = 0; + for (i = 0 ; i < length ; i++) { + if (!(children[i]->flags & NS_DYING)) { + unchecked = 1; + Tcl_DeleteNamespace((Tcl_Namespace *) children[i]); + TclNsDecrRefCount(children[i]); + } + } + TclStackFree((Tcl_Interp *) iPtr, children); + } +#else + if (nsPtr->childTablePtr != NULL) { + unchecked = (nsPtr->childTable.numEntries > 0); + while (nsPtr->childTable.numEntries > 0 && unchecked) { + int length = nsPtr->childTablePtr->numEntries; + Namespace **children = (Namespace **)TclStackAlloc((Tcl_Interp *) iPtr, + sizeof(Namespace *) * length); + + i = 0; + for (entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search); + entryPtr != NULL; + entryPtr = Tcl_NextHashEntry(&search)) { + children[i] = (Namespace *)Tcl_GetHashValue(entryPtr); + children[i]->refCount++; + i++; + } + unchecked = 0; + for (i = 0 ; i < length ; i++) { + if (!(children[i]->flags & NS_DYING)) { + unchecked = 1; + Tcl_DeleteNamespace((Tcl_Namespace *) children[i]); + TclNsDecrRefCount(children[i]); + } + } + TclStackFree((Tcl_Interp *) iPtr, children); + } + } +#endif +} + /* *---------------------------------------------------------------------- * @@ -1105,6 +1182,9 @@ TclTeardownNamespace( Tcl_HashSearch search; size_t i; + + TclDeleteNamespaceChildren(nsPtr); + /* * Start by destroying the namespace's variable table, since variables * might trigger traces. Variable table should be cleared but not freed! @@ -1181,62 +1261,6 @@ TclTeardownNamespace( nsPtr->commandPathSourceList = NULL; } - /* - * Delete all the child namespaces. - * - * BE CAREFUL: When each child is deleted, it will divorce itself from its - * parent. You can't traverse a hash table properly if its elements are - * being deleted. Because of traces (and the desire to avoid the - * quadratic problems of just using Tcl_FirstHashEntry over and over, [Bug - * f97d4ee020]) we copy to a temporary array and then delete all those - * namespaces. - * - * Important: leave the hash table itself still live. - */ - -#ifndef BREAK_NAMESPACE_COMPAT - while (nsPtr->childTable.numEntries > 0) { - size_t length = nsPtr->childTable.numEntries; - Namespace **children = (Namespace **)TclStackAlloc((Tcl_Interp *) iPtr, - sizeof(Namespace *) * length); - - i = 0; - for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); - entryPtr != NULL; - entryPtr = Tcl_NextHashEntry(&search)) { - children[i] = (Namespace *)Tcl_GetHashValue(entryPtr); - children[i]->refCount++; - i++; - } - for (i = 0 ; i < length ; i++) { - Tcl_DeleteNamespace((Tcl_Namespace *) children[i]); - TclNsDecrRefCount(children[i]); - } - TclStackFree((Tcl_Interp *) iPtr, children); - } -#else - if (nsPtr->childTablePtr != NULL) { - while (nsPtr->childTablePtr->numEntries > 0) { - size_t length = nsPtr->childTablePtr->numEntries; - Namespace **children = (Namespace **)TclStackAlloc((Tcl_Interp *) iPtr, - sizeof(Namespace *) * length); - - i = 0; - for (entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search); - entryPtr != NULL; - entryPtr = Tcl_NextHashEntry(&search)) { - children[i] = Tcl_GetHashValue(entryPtr); - children[i]->refCount++; - i++; - } - for (i = 0 ; i < length ; i++) { - Tcl_DeleteNamespace((Tcl_Namespace *) children[i]); - TclNsDecrRefCount(children[i]); - } - TclStackFree((Tcl_Interp *) iPtr, children); - } - } -#endif /* * Free the namespace's export pattern array. -- cgit v0.12 From 78c53b37ab0bf3c76d498a839f6659235efff3cd Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 4 Apr 2021 15:35:13 +0000 Subject: Implement support for Tcl_SetPreInitScript() --- generic/tcl.h | 2 ++ generic/tclStubCall.c | 10 ++++++---- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 6dd881d..faf0d49 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2239,6 +2239,8 @@ extern void *TclStubCall(void *arg); ((Tcl_ExitProc *(*)(Tcl_ExitProc *))TclStubCall((void *)7))(proc) #define Tcl_GetMemoryInfo(dsPtr) \ (void)((const char *(*)(Tcl_DString *))TclStubCall((void *)8))(dsPtr) +#define Tcl_SetPreInitScript(string) \ + ((const char *(*)(const char *))TclStubCall((void *)9))(string) #endif /* diff --git a/generic/tclStubCall.c b/generic/tclStubCall.c index 0eb46b6..e0d85a6 100644 --- a/generic/tclStubCall.c +++ b/generic/tclStubCall.c @@ -28,9 +28,10 @@ MODULE_SCOPE void *tclStubsHandle; * returning NULL if that function cannot be found. See PROCNAME table. * * The functions Tcl_MainEx and Tcl_MainExW never return. - * Tcl_GetMemoryInfo and Tcl_StaticLibrary return (void) and - * Tcl_SetExitProc returns its previous exitProc. This means that - * those 5 functions cannot be used to initialize the stub-table, + * Tcl_GetMemoryInfo and Tcl_StaticLibrary return (void), + * Tcl_SetExitProc returns its previous exitProc and + * Tcl_SetPreInitScript returns the previous script. This means that + * those 6 functions cannot be used to initialize the stub-table, * only the first 4 functions in the table can do that. * *---------------------------------------------------------------------- @@ -46,7 +47,8 @@ static const char PROCNAME[][24] = { "_Tcl_MainEx", /* "arg" == (void *)5 */ "_Tcl_StaticLibrary", /* "arg" == (void *)6 */ "_Tcl_SetExitProc", /* "arg" == (void *)7 */ - "_Tcl_GetMemoryInfo" /* "arg" == (void *)8 */ + "_Tcl_GetMemoryInfo", /* "arg" == (void *)8 */ + "_Tcl_SetPreInitScript" /* "arg" == (void *)9 */ }; MODULE_SCOPE const void *nullVersionProc(void) { -- cgit v0.12 From ce1a1c9f1387df9db70689527f74c37b4c3cf7c0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 6 Apr 2021 15:57:35 +0000 Subject: Update rules.vc --- win/rules.vc | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/win/rules.vc b/win/rules.vc index 2ec5292..85c37f2 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -1203,9 +1203,16 @@ TCLSH_NATIVE = $(TCLSH) !if $(DOING_TK) || $(NEED_TK) WISHNAMEPREFIX = wish WISHNAME = $(WISHNAMEPREFIX)$(TK_VERSION)$(SUFX).exe -TKLIBNAME = $(PROJECT)$(TK_VERSION)$(SUFX).$(EXT) -TKSTUBLIBNAME = tkstub$(TK_VERSION).lib +TKLIBNAME8 = tk$(TK_VERSION)$(SUFX).$(EXT) +TKLIBNAME9 = tcl9tk$(TK_VERSION)$(SUFX).$(EXT) +!if $(TCL_MAJOR_VERSION) == 8 +TKLIBNAME = tk$(TK_VERSION)$(SUFX).$(EXT) TKIMPLIBNAME = tk$(TK_VERSION)$(SUFX).lib +!else +TKLIBNAME = tcl9tk$(TK_VERSION)$(SUFX).$(EXT) +TKIMPLIBNAME = tcl9tk$(TK_VERSION)$(SUFX).lib +!endif +TKSTUBLIBNAME = tkstub$(TK_VERSION).lib !if $(DOING_TK) WISH = $(OUT_DIR)\$(WISHNAME) -- cgit v0.12 From 122c6b2c017a836a95ce18c26dfda8ae065bc1b1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 8 Apr 2021 15:04:11 +0000 Subject: Remove TclWinConvertError from internal stub table. No longer necessary, since it's in the external stub table now. --- generic/tclInt.decls | 7 ++++--- generic/tclIntPlatDecls.h | 26 +++++++++----------------- generic/tclStubInit.c | 14 +++++++------- 3 files changed, 20 insertions(+), 27 deletions(-) diff --git a/generic/tclInt.decls b/generic/tclInt.decls index e843b0e..452749e 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -602,9 +602,10 @@ interface tclIntPlat ################################ # Platform specific functions -declare 0 {unix win} { - void TclWinConvertError(unsigned errCode) -} +# Removed in 9.0 +#declare 0 {unix win} { +# void TclWinConvertError(unsigned errCode) +#} declare 1 {unix win} { int TclpCloseFile(TclFile file) } diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index 02ab5f4..3f6ee7ee 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -41,8 +41,7 @@ extern "C" { */ #if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ -/* 0 */ -EXTERN void TclWinConvertError(unsigned errCode); +/* Slot 0 is reserved */ /* 1 */ EXTERN int TclpCloseFile(TclFile file); /* 2 */ @@ -108,8 +107,7 @@ EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *resultingNameObj); #endif /* UNIX */ #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ -/* 0 */ -EXTERN void TclWinConvertError(unsigned errCode); +/* Slot 0 is reserved */ /* 1 */ EXTERN int TclpCloseFile(TclFile file); /* 2 */ @@ -179,8 +177,7 @@ EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *resultingNameObj); #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ -/* 0 */ -EXTERN void TclWinConvertError(unsigned errCode); +/* Slot 0 is reserved */ /* 1 */ EXTERN int TclpCloseFile(TclFile file); /* 2 */ @@ -251,7 +248,7 @@ typedef struct TclIntPlatStubs { void *hooks; #if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ - void (*tclWinConvertError) (unsigned errCode); /* 0 */ + void (*reserved0)(void); int (*tclpCloseFile) (TclFile file); /* 1 */ Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */ @@ -284,7 +281,7 @@ typedef struct TclIntPlatStubs { int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ #endif /* UNIX */ #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ - void (*tclWinConvertError) (unsigned errCode); /* 0 */ + void (*reserved0)(void); int (*tclpCloseFile) (TclFile file); /* 1 */ Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */ @@ -317,7 +314,7 @@ typedef struct TclIntPlatStubs { int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ - void (*tclWinConvertError) (unsigned errCode); /* 0 */ + void (*reserved0)(void); int (*tclpCloseFile) (TclFile file); /* 1 */ Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */ @@ -364,8 +361,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; */ #if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ -#define TclWinConvertError \ - (tclIntPlatStubsPtr->tclWinConvertError) /* 0 */ +/* Slot 0 is reserved */ #define TclpCloseFile \ (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ #define TclpCreateCommandChannel \ @@ -419,8 +415,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ #endif /* UNIX */ #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ -#define TclWinConvertError \ - (tclIntPlatStubsPtr->tclWinConvertError) /* 0 */ +/* Slot 0 is reserved */ #define TclpCloseFile \ (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ #define TclpCreateCommandChannel \ @@ -477,8 +472,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ -#define TclWinConvertError \ - (tclIntPlatStubsPtr->tclWinConvertError) /* 0 */ +/* Slot 0 is reserved */ #define TclpCloseFile \ (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ #define TclpCreateCommandChannel \ @@ -538,9 +532,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT -#undef TclWinConvertWSAError #define TclWinConvertWSAError Tcl_WinConvertError -#undef TclWinConvertError #define TclWinConvertError Tcl_WinConvertError #ifdef MAC_OSX_TCL /* not accessable on Win32/UNIX */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 773936e..9d8f12e 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -67,8 +67,10 @@ #undef Tcl_UtfToUniCharDString #undef Tcl_UtfToUniChar #define TclUnusedStubEntry 0 -#undef TclWinConvertError -#define TclWinConvertError 0 +#if !defined(_WIN32) && !defined(__CYGWIN__) +#undef Tcl_WinConvertError +#define Tcl_WinConvertError 0 +#endif #if TCL_UTF_MAX <= 3 @@ -270,8 +272,6 @@ static int utfNcasecmp(const char *s1, const char *s2, unsigned int n){ #else /* __CYGWIN__ */ # define TclWinGetTclInstance (void *(*)(void))(void *)TclpCreateProcess # define TclpGetPid (size_t(*)(Tcl_Pid))(void *)TclUnixWaitForFile -# undef TclWinConvertError -# define TclWinConvertError (void(*)(int))(void *)TclGetAndDetachPids # define TclWinFlushDirtyChannels 0 # define TclWinNoBackslash 0 # define TclWinAddProcess 0 @@ -566,7 +566,7 @@ static const TclIntPlatStubs tclIntPlatStubs = { TCL_STUB_MAGIC, 0, #if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ - TclWinConvertError, /* 0 */ + 0, /* 0 */ TclpCloseFile, /* 1 */ TclpCreateCommandChannel, /* 2 */ TclpCreatePipe, /* 3 */ @@ -599,7 +599,7 @@ static const TclIntPlatStubs tclIntPlatStubs = { TclUnixOpenTemporaryFile, /* 30 */ #endif /* UNIX */ #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ - TclWinConvertError, /* 0 */ + 0, /* 0 */ TclpCloseFile, /* 1 */ TclpCreateCommandChannel, /* 2 */ TclpCreatePipe, /* 3 */ @@ -632,7 +632,7 @@ static const TclIntPlatStubs tclIntPlatStubs = { TclUnixOpenTemporaryFile, /* 30 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ - TclWinConvertError, /* 0 */ + 0, /* 0 */ TclpCloseFile, /* 1 */ TclpCreateCommandChannel, /* 2 */ TclpCreatePipe, /* 3 */ -- cgit v0.12 From 8ba69750a3d5b3706fb03205f59a64e6c7539663 Mon Sep 17 00:00:00 2001 From: oehhar Date: Fri, 16 Apr 2021 11:48:02 +0000 Subject: TIP596: Document Tcl_MainEx, Tcl_MainExW, Tcl_GetMemoryInfo, Tcl_SetPreInitScript --- doc/Alloc.3 | 13 +++++++++++-- doc/Init.3 | 14 +++++++++++++- doc/Tcl_Main.3 | 14 +++++++++++++- 3 files changed, 37 insertions(+), 4 deletions(-) diff --git a/doc/Alloc.3 b/doc/Alloc.3 index 849f65e..c3c3f11 100644 --- a/doc/Alloc.3 +++ b/doc/Alloc.3 @@ -4,11 +4,11 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.TH Tcl_Alloc 3 7.5 Tcl "Tcl Library Procedures" +.TH Tcl_Alloc 3 9.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME -Tcl_Alloc, Tcl_Free, Tcl_Realloc, Tcl_AttemptAlloc, Tcl_AttemptRealloc \- allocate or free heap memory +Tcl_Alloc, Tcl_Free, Tcl_Realloc, Tcl_AttemptAlloc, Tcl_AttemptRealloc, Tcl_GetMemoryInfo \- allocate or free heap memory .SH SYNOPSIS .nf \fB#include \fR @@ -27,12 +27,17 @@ void * .sp void * \fBTcl_AttemptRealloc\fR(\fIptr, size\fR) +.sp +void +\fBTcl_GetMemoryInfo\fR(\fIdsPtr\fR) .SH ARGUMENTS .AS char *size .AP "unsigned int" size in Size in bytes of the memory block to allocate. .AP char *ptr in Pointer to memory block to free or realloc. +.AP Tcl_DString *dsPtr in +Initialized DString pointer. .BE .SH DESCRIPTION @@ -69,5 +74,9 @@ the procedures \fBTcl_Alloc\fR, \fBTcl_Free\fR, \fBTcl_Realloc\fR, \fBTcl_AttemptAlloc\fR, and \fBTcl_AttempRealloc\fR are implemented as macros, redefined to be special debugging versions of these procedures. +\fBTcl_GetMemoryInfo\fR appends a list-of-lists of memory stats to the provided DString. +This procedure may be called when the TCL library is included within an embedded application. +The stubs table must be first initialized using one of \fBTcl_InitSubsystems\fR, \fBTcl_SetPanicProc\fR, \fBTcl_FindExecutable\fR or \fBTclZipfs_AppHook\fR. + .SH KEYWORDS alloc, allocation, free, malloc, memory, realloc, TCL_MEM_DEBUG diff --git a/doc/Init.3 b/doc/Init.3 index d9fc2e1..fa87892 100644 --- a/doc/Init.3 +++ b/doc/Init.3 @@ -2,7 +2,7 @@ '\" Copyright (c) 1998-2000 Scriptics Corporation. '\" All rights reserved. '\" -.TH Tcl_Init 3 8.0 Tcl "Tcl Library Procedures" +.TH Tcl_Init 3 9.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME @@ -13,10 +13,15 @@ Tcl_Init \- find and source initialization script .sp int \fBTcl_Init\fR(\fIinterp\fR) +.sp +const char * +\fBTcl_SetPreInitScript\fR(\fIscriptPtr\fR) .SH ARGUMENTS .AS Tcl_Interp *interp .AP Tcl_Interp *interp in Interpreter to initialize. +.AP "const char" *scriptPtr in +Address of the initialization script. .BE .SH DESCRIPTION @@ -26,6 +31,13 @@ Interpreter to initialize. path. .PP \fBTcl_Init\fR is typically called from \fBTcl_AppInit\fR procedures. +.PP +\fBTcl_SetPreInitScript\fR registeres the pre-initialization script and returns the former (now replaced) script pointer. +A value of \fINULL\fR may be passed to not register any script. +The pre-initialization script is executed by \fBTcl_Init\fR before accessing the file system. +The purpose is to typically prepare a custom file system (like an embedded zip-file) to be activated before the search. + +When the TCL library is loaded within an embedded application, the stubs table must be first initialized using one of \fBTcl_InitSubsystems\fR, \fBTcl_SetPanicProc\fR, \fBTcl_FindExecutable\fR or \fBTclZipfs_AppHook\fR before \fBTcl_SetPreInitScript\fR may be called. .SH "SEE ALSO" Tcl_AppInit, Tcl_Main diff --git a/doc/Tcl_Main.3 b/doc/Tcl_Main.3 index 62ceeab..6ace8c9 100644 --- a/doc/Tcl_Main.3 +++ b/doc/Tcl_Main.3 @@ -6,7 +6,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.TH Tcl_Main 3 8.4 Tcl "Tcl Library Procedures" +.TH Tcl_Main 3 9.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME @@ -17,6 +17,10 @@ Tcl_Main, Tcl_SetStartupScript, Tcl_GetStartupScript, Tcl_SetMainLoop \- main pr .sp \fBTcl_Main\fR(\fIargc, argv, appInitProc\fR) .sp +\fBTcl_MainEx\fR(\fIargc, charargv, appInitProc\fR) +.sp +\fBTcl_MainExW\fR(\fIargc, wideargv, appInitProc\fR) +.sp \fBTcl_SetStartupScript\fR(\fIpath, encoding\fR) .sp Tcl_Obj * @@ -30,6 +34,10 @@ Number of elements in \fIargv\fR. .AP char *argv[] in Array of strings containing command-line arguments. On Windows, when using -DUNICODE, the parameter type changes to wchar_t *. +.AP char *charargv[] in +As argv, but does not change type to wchar_t. +.AP char *wideargv[] in +As argv, but type is always wchar_t. .AP Tcl_AppInitProc *appInitProc in Address of an application-specific initialization procedure. The value for this argument is usually \fBTcl_AppInit\fR. @@ -191,6 +199,10 @@ procedure (if any) returns, \fBTcl_Main\fR will also evaluate the \fBexit\fR command. .PP \fBTcl_Main\fR can not be used in stub-enabled extensions. +.PP +When the TCL library is loaded within an embedded application, \fBTcl_MainEx\fR or \fBTcl_MainExW\fR may be used to call \fBTcl_Main\fR. +The difference between Tcl_MainEx and Tcl_MainExW is that the arguments are passed as characters or wide characters. +Remark that the stubs table must be first initialized using one of \fBTcl_InitSubsystems\fR, \fBTcl_SetPanicProc\fR, \fBTcl_FindExecutable\fR or \fBTclZipfs_AppHook\fR. .SH "SEE ALSO" tclsh(1), Tcl_GetStdChannel(3), Tcl_StandardChannels(3), Tcl_AppInit(3), exit(n), encoding(n) -- cgit v0.12 From 4106570aa941dd23622fb8107e28d9702902fbe1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 28 Apr 2021 15:10:58 +0000 Subject: Fix documentation and remove unused function signature (leftover from earlier implementation) --- doc/Tcl_Main.3 | 9 +++++++++ generic/tcl.h | 2 -- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/doc/Tcl_Main.3 b/doc/Tcl_Main.3 index b7b15a9..986ebbe 100644 --- a/doc/Tcl_Main.3 +++ b/doc/Tcl_Main.3 @@ -206,6 +206,15 @@ The difference between Tcl_MainEx and Tcl_MainExW is that the arguments are passed as characters or wide characters. When used in stub-enabled embedders, the stubs table must be first initialized using one of \fBTcl_InitSubsystems\fR, \fBTcl_SetPanicProc\fR, \fBTcl_FindExecutable\fR or \fBTclZipfs_AppHook\fR. +.SH "REFERENCE COUNT MANAGEMENT" +.PP +\fBTcl_SetStartupScript\fR takes a value (or NULL) for its \fIpath\fR +argument, and will increment the reference count of it. +.PP +\fBTcl_GetStartupScript\fR returns a value with reference count at least 1, or +NULL. It's \fIencodingPtr\fR is also used (if non-NULL) to return a value with +a reference count at least 1, or NULL. In both cases, the owner of the values +is the current thread. .SH "SEE ALSO" tclsh(1), Tcl_GetStdChannel(3), Tcl_StandardChannels(3), Tcl_AppInit(3), exit(n), encoding(n) diff --git a/generic/tcl.h b/generic/tcl.h index ec8a8ef..cfc1485 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2148,8 +2148,6 @@ const char * Tcl_InitStubs(Tcl_Interp *interp, const char *version, const char * TclTomMathInitializeStubs(Tcl_Interp *interp, const char *version, int epoch, int revision); const char * TclInitStubTable(const char *version); -void TclStubMainEx(int index, int argc, const void *argv, - Tcl_AppInitProc *appInitProc, Tcl_Interp *interp); void * TclStubCall(void *arg); #if defined(_WIN32) TCL_NORETURN1 void Tcl_ConsolePanic(const char *format, ...); -- cgit v0.12 From 64524dd1b913c7b5c0c8a053d35321834e3137ed Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 30 Apr 2021 11:56:15 +0000 Subject: Keep win/rules.vc the same as in other branches --- win/rules.vc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/win/rules.vc b/win/rules.vc index 35d8356..19f0dd8 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -1382,7 +1382,7 @@ OPTDEFINES = $(OPTDEFINES) /DTCL_NO_DEPRECATED # Note we do not define USE_TCL_STUBS even when building tk since some # test targets in tk do not use stubs !if !$(DOING_TCL) -USE_STUBS_DEFS = /DUSE_TCL_STUBS=1 /DUSE_TCLOO_STUBS=1 +USE_STUBS_DEFS = /DUSE_TCL_STUBS /DUSE_TCLOO_STUBS !if $(NEED_TK) USE_STUBS_DEFS = $(USE_STUBS_DEFS) /DUSE_TK_STUBS !endif -- cgit v0.12 From aca352b62784bfe712dcdbe1fa2942399494f7ea Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 30 Apr 2021 14:29:47 +0000 Subject: Update tcl.dsp. Update documentation --- doc/FindExec.3 | 3 +++ doc/InitSubSyst.3 | 3 +++ doc/Panic.3 | 6 ++++-- doc/StaticLibrary.3 | 3 +-- doc/zipfs.3 | 10 +++++----- win/tcl.dsp | 10 +--------- 6 files changed, 17 insertions(+), 18 deletions(-) diff --git a/doc/FindExec.3 b/doc/FindExec.3 index 4b92695..3672546 100644 --- a/doc/FindExec.3 +++ b/doc/FindExec.3 @@ -35,6 +35,9 @@ Tcl. For example, it is needed on some platforms in the implementation of the \fBload\fR command. It is also returned by the \fBinfo nameofexecutable\fR command. .PP +The result of \fBTcl_InitSubsystems\fR is the full Tcl version (e.g., +\fB"9.0.0"\fR). +.PP On UNIX platforms this procedure is typically invoked as the very first thing in the application's main program; it must be passed \fIargv[0]\fR as its argument. It is important not to change the diff --git a/doc/InitSubSyst.3 b/doc/InitSubSyst.3 index 17d14b1..294861e 100644 --- a/doc/InitSubSyst.3 +++ b/doc/InitSubSyst.3 @@ -21,6 +21,9 @@ The \fBTcl_InitSubsystems\fR procedure initializes the Tcl library. This procedure is typically invoked as the very first thing in the application's main program. .PP +The result of \fBTcl_InitSubsystems\fR is the full Tcl version (e.g., +\fB"9.0.0"\fR). +.PP \fBTcl_InitSubsystems\fR is very similar in use to \fBTcl_FindExecutable\fR. It can be used when Tcl is used as utility library, no other encodings than utf-8, diff --git a/doc/Panic.3 b/doc/Panic.3 index cb4d3cb..659b2fe 100644 --- a/doc/Panic.3 +++ b/doc/Panic.3 @@ -79,12 +79,14 @@ making calls into the Tcl library, or into other libraries that may call the Tcl library, since the original call to \fBTcl_Panic\fR indicates the Tcl library is not in a state of reliable operation. .PP +The result of \fBTcl_SetPanicProc\fR is the full Tcl version (e.g., +\fB"9.0.0"\fR). +.PP The typical use of \fBTcl_SetPanicProc\fR arranges for the error message to be displayed or reported in a manner more suitable for the application or the platform. .PP -\fBTcl_SetPanicProc\fR can not be used safely by stub-enabled extensions, so its -symbol is not included in the stub table. +\fBTcl_SetPanicProc\fR can not be used in stub-enabled extensions. .PP Although the primary callers of \fBTcl_Panic\fR are the procedures of the Tcl library, \fBTcl_Panic\fR is a public function and may be called diff --git a/doc/StaticLibrary.3 b/doc/StaticLibrary.3 index 83a9a07..c5bd364 100644 --- a/doc/StaticLibrary.3 +++ b/doc/StaticLibrary.3 @@ -70,8 +70,7 @@ initialization procedure to be invoked. \fBTcl_StaticLibrary\fR was named \fBTcl_StaticPackage\fR in Tcl 8.6 and earlier, but the old name is deprecated now. .PP -\fBTcl_StaticLibrary\fR can not be safely used by stub-enabled extensions, -so its symbol is not included in the stub table. +\fBTcl_StaticLibrary\fR can not be used in stub-enabled extensions. .SH KEYWORDS initialization procedure, package, static linking .SH "SEE ALSO" diff --git a/doc/zipfs.3 b/doc/zipfs.3 index 2db6d67..f868915 100644 --- a/doc/zipfs.3 +++ b/doc/zipfs.3 @@ -87,11 +87,11 @@ it uses WCHAR instead of char. As a result, it requires your application to be compiled with the UNICODE preprocessor symbol defined (e.g., via the \fB-DUNICODE\fR compiler flag). .PP -The result of \fBTclZipfs_AppHook\fR is the full Tcl version string(e.g., -\fB"9.0.0"\fR). The function \fImay\fR modify the variables -pointed to by \fIargcPtr\fR and \fIargvPtr\fR to remove arguments; the -current implementation does not do so, but callers \fIshould not\fR assume -that this will be true in the future. +The result of \fBTclZipfs_AppHook\fR is the full Tcl version (e.g., +\fB"9.0.0"\fR). The function \fImay\fR modify +the variables pointed to by \fIargcPtr\fR and \fIargvPtr\fR to remove +arguments; the current implementation does not do so, but callers +\fIshould not\fR assume that this will be true in the future. .PP \fBTclzipfs_Mount\fR mounts the ZIP archive \fIzipname\fR on the mount point given in \fImountpoint\fR using the optional ZIP password \fIpassword\fR. diff --git a/win/tcl.dsp b/win/tcl.dsp index 3d79332..97c9000 100644 --- a/win/tcl.dsp +++ b/win/tcl.dsp @@ -1288,15 +1288,7 @@ SOURCE=..\generic\tclStubLib.c # End Source File # Begin Source File -SOURCE=..\generic\tclStubFindExecutable.c -# End Source File -# Begin Source File - -SOURCE=..\generic\tclStubInitSubsystems.c -# End Source File -# Begin Source File - -SOURCE=..\generic\tclStubSetPanicProc.c +SOURCE=..\generic\tclStubCall.c # End Source File # Begin Source File -- cgit v0.12 From 346e9e294098953ae67cf7e84b7078630d6ba2ae Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 3 May 2021 20:38:16 +0000 Subject: Bump to version 9.0a3 for release. --- README.md | 2 +- generic/tcl.h | 4 ++-- library/init.tcl | 2 +- unix/configure | 2 +- unix/configure.ac | 2 +- unix/tcl.spec | 2 +- win/configure | 2 +- win/configure.ac | 2 +- 8 files changed, 9 insertions(+), 9 deletions(-) diff --git a/README.md b/README.md index 875c7ba..a061c49 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # README: Tcl -This is the **Tcl 9.0a2** source distribution. +This is the **Tcl 9.0a3** source distribution. You can get any source release of Tcl from [our distribution site](https://sourceforge.net/projects/tcl/files/Tcl/). diff --git a/generic/tcl.h b/generic/tcl.h index cfc1485..364e930 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -50,10 +50,10 @@ extern "C" { #define TCL_MAJOR_VERSION 9 #define TCL_MINOR_VERSION 0 #define TCL_RELEASE_LEVEL TCL_ALPHA_RELEASE -#define TCL_RELEASE_SERIAL 2 +#define TCL_RELEASE_SERIAL 3 #define TCL_VERSION "9.0" -#define TCL_PATCH_LEVEL "9.0a2" +#define TCL_PATCH_LEVEL "9.0a3" #if defined(RC_INVOKED) /* diff --git a/library/init.tcl b/library/init.tcl index ece3591..c01dc97 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -19,7 +19,7 @@ if {[info commands package] == ""} { error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]" } -package require -exact tcl 9.0a2 +package require -exact tcl 9.0a3 # Compute the auto path to use in this interpreter. # The values on the path come from several locations: diff --git a/unix/configure b/unix/configure index 7c6ff95..806579c 100755 --- a/unix/configure +++ b/unix/configure @@ -2683,7 +2683,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu TCL_VERSION=9.0 TCL_MAJOR_VERSION=9 TCL_MINOR_VERSION=0 -TCL_PATCH_LEVEL="a2" +TCL_PATCH_LEVEL="a3" VERSION=${TCL_VERSION} EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"} diff --git a/unix/configure.ac b/unix/configure.ac index 685a335..d826c90 100644 --- a/unix/configure.ac +++ b/unix/configure.ac @@ -26,7 +26,7 @@ m4_ifdef([SC_USE_CONFIG_HEADERS], [ TCL_VERSION=9.0 TCL_MAJOR_VERSION=9 TCL_MINOR_VERSION=0 -TCL_PATCH_LEVEL="a2" +TCL_PATCH_LEVEL="a3" VERSION=${TCL_VERSION} EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"} diff --git a/unix/tcl.spec b/unix/tcl.spec index b0a8016..3e7f3cd 100644 --- a/unix/tcl.spec +++ b/unix/tcl.spec @@ -4,7 +4,7 @@ Name: tcl Summary: Tcl scripting language development environment -Version: 9.0a2 +Version: 9.0a3 Release: 2 License: BSD Group: Development/Languages diff --git a/win/configure b/win/configure index e3f299f..f33d950 100755 --- a/win/configure +++ b/win/configure @@ -2401,7 +2401,7 @@ SHELL=/bin/sh TCL_VERSION=9.0 TCL_MAJOR_VERSION=9 TCL_MINOR_VERSION=0 -TCL_PATCH_LEVEL="a2" +TCL_PATCH_LEVEL="a3" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 diff --git a/win/configure.ac b/win/configure.ac index b412ec2..f52df0b 100644 --- a/win/configure.ac +++ b/win/configure.ac @@ -15,7 +15,7 @@ SHELL=/bin/sh TCL_VERSION=9.0 TCL_MAJOR_VERSION=9 TCL_MINOR_VERSION=0 -TCL_PATCH_LEVEL="a2" +TCL_PATCH_LEVEL="a3" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 -- cgit v0.12 From b02cd57334865909a8622d486b47daf7439aee6c Mon Sep 17 00:00:00 2001 From: pooryorick Date: Sun, 16 May 2021 19:34:09 +0000 Subject: Replace ckfree with Tcl_Free. --- generic/tclZipfs.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index d81f5c0..4d619f0 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -5753,7 +5753,7 @@ ZipfsExitHandler( static void ZipfsFinalize(void) { Tcl_DeleteHashTable(&ZipFS.fileHash); - ckfree(ZipFS.fallbackEntryEncoding); + Tcl_Free(ZipFS.fallbackEntryEncoding); ZipFS.initialized = -1; } -- cgit v0.12 From a3bdb5abeea38e4eca31dd4691e26ea25d695d31 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Mon, 17 May 2021 20:46:36 +0000 Subject: Reinstate one line lost in last merge. --- generic/tclBasic.c | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index e96b581..cafec69 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -1799,6 +1799,7 @@ DeleteInterpProc( if (dPtr->proc != NULL) { dPtr->proc(dPtr->clientData, interp); } + Tcl_DeleteHashEntry(hPtr); Tcl_Free(dPtr); } Tcl_DeleteHashTable(hTablePtr); -- cgit v0.12 From 9cea1455ec0d8bfae73216639af0a8b78f93967c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 18 May 2021 13:03:31 +0000 Subject: Make pkgua package thread-safe --- unix/dltest/pkgua.c | 53 +++++++++++++++++++++++++++++++++-------------------- 1 file changed, 33 insertions(+), 20 deletions(-) diff --git a/unix/dltest/pkgua.c b/unix/dltest/pkgua.c index 0ab3e23..a822541 100644 --- a/unix/dltest/pkgua.c +++ b/unix/dltest/pkgua.c @@ -21,6 +21,7 @@ static int PkguaEqObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int PkguaQuoteObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +static void CommandDeleted(ClientData clientData); /* * In the following hash table we are going to store a struct that holds all @@ -30,23 +31,32 @@ static int PkguaQuoteObjCmd(ClientData clientData, * need to keep the various command tokens we have registered, as they are the * only safe way to unregister our registered commands, even if they have been * renamed. - * - * Note that this code is utterly single-threaded. */ -static Tcl_HashTable interpTokenMap; -static int interpTokenMapInitialised = 0; +typedef struct ThreadSpecificData { + int interpTokenMapInitialised; + Tcl_HashTable interpTokenMap; +} ThreadSpecificData; +static Tcl_ThreadDataKey dataKey; #define MAX_REGISTERED_COMMANDS 2 +static void +CommandDeleted(ClientData clientData) +{ + Tcl_Command *cmdToken = (Tcl_Command *)clientData; + *cmdToken = NULL; +} static void PkguaInitTokensHashTable(void) { - if (interpTokenMapInitialised) { + ThreadSpecificData *tsdPtr = (ThreadSpecificData *)Tcl_GetThreadData((&dataKey), sizeof(ThreadSpecificData)); + + if (tsdPtr->interpTokenMapInitialised) { return; } - Tcl_InitHashTable(&interpTokenMap, TCL_ONE_WORD_KEYS); - interpTokenMapInitialised = 1; + Tcl_InitHashTable(&tsdPtr->interpTokenMap, TCL_ONE_WORD_KEYS); + tsdPtr->interpTokenMapInitialised = 1; } static void @@ -54,12 +64,13 @@ PkguaFreeTokensHashTable(void) { Tcl_HashSearch search; Tcl_HashEntry *entryPtr; + ThreadSpecificData *tsdPtr = (ThreadSpecificData *)Tcl_GetThreadData((&dataKey), sizeof(ThreadSpecificData)); - for (entryPtr = Tcl_FirstHashEntry(&interpTokenMap, &search); + for (entryPtr = Tcl_FirstHashEntry(&tsdPtr->interpTokenMap, &search); entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&search)) { Tcl_Free((char *) Tcl_GetHashValue(entryPtr)); } - interpTokenMapInitialised = 0; + tsdPtr->interpTokenMapInitialised = 0; } static Tcl_Command * @@ -68,13 +79,14 @@ PkguaInterpToTokens( { int newEntry; Tcl_Command *cmdTokens; + ThreadSpecificData *tsdPtr = (ThreadSpecificData *)Tcl_GetThreadData((&dataKey), sizeof(ThreadSpecificData)); Tcl_HashEntry *entryPtr = - Tcl_CreateHashEntry(&interpTokenMap, interp, &newEntry); + Tcl_CreateHashEntry(&tsdPtr->interpTokenMap, (char *) interp, &newEntry); if (newEntry) { cmdTokens = (Tcl_Command *) - Tcl_Alloc(sizeof(Tcl_Command) * (MAX_REGISTERED_COMMANDS+1)); - for (newEntry=0 ; newEntryinterpTokenMap, (char *) interp); if (entryPtr) { Tcl_Free((char *) Tcl_GetHashValue(entryPtr)); @@ -199,7 +212,7 @@ Pkgua_Init( Tcl_Interp *interp) /* Interpreter in which the package is to be * made available. */ { - int code, cmdIndex = 0; + int code; Tcl_Command *cmdTokens; if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { @@ -207,7 +220,7 @@ Pkgua_Init( } /* - * Initialise our Hash table, where we store the registered command tokens + * Initialize our Hash table, where we store the registered command tokens * for each interpreter. */ @@ -221,12 +234,12 @@ Pkgua_Init( Tcl_SetVar2(interp, "::pkgua_loaded", NULL, ".", TCL_APPEND_VALUE); cmdTokens = PkguaInterpToTokens(interp); - cmdTokens[cmdIndex++] = - Tcl_CreateObjCommand(interp, "pkgua_eq", PkguaEqObjCmd, NULL, - NULL); - cmdTokens[cmdIndex++] = + cmdTokens[0] = + Tcl_CreateObjCommand(interp, "pkgua_eq", PkguaEqObjCmd, &cmdTokens[0], + CommandDeleted); + cmdTokens[1] = Tcl_CreateObjCommand(interp, "pkgua_quote", PkguaQuoteObjCmd, - NULL, NULL); + &cmdTokens[1], CommandDeleted); return TCL_OK; } -- cgit v0.12 From f38691efea4e8147b9699e7ba46ed8f576d1e873 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 7 Jun 2021 16:37:28 +0000 Subject: =?UTF-8?q?Temporary=20fix=20for=20[29871ea55c],=20by=20not=20buil?= =?UTF-8?q?ding=20pkg=CF=80.c=20by=20default:=20Older=20gcc=20(and=20other?= =?UTF-8?q?)=20C-compilers=20cannot=20handle=20this.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- unix/dltest/Makefile.in | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/unix/dltest/Makefile.in b/unix/dltest/Makefile.in index 55a711f..7a872c5 100644 --- a/unix/dltest/Makefile.in +++ b/unix/dltest/Makefile.in @@ -25,11 +25,11 @@ LDFLAGS = @LDFLAGS_DEFAULT@ @LDFLAGS@ CC_SWITCHES = $(CFLAGS) -I${SRC_DIR}/../../generic -DTCL_MEM_DEBUG \ ${SHLIB_CFLAGS} -DUSE_TCL_STUBS ${AC_FLAGS} -all: embtest tcl9pkgπ${SHLIB_SUFFIX} tcl9pkga${SHLIB_SUFFIX} tcl9pkgb${SHLIB_SUFFIX} tcl9pkgc${SHLIB_SUFFIX} tcl9pkgd${SHLIB_SUFFIX} tcl9pkge${SHLIB_SUFFIX} tcl9pkgua${SHLIB_SUFFIX} tcl9pkgooa${SHLIB_SUFFIX} +all: embtest tcl9pkga${SHLIB_SUFFIX} tcl9pkgb${SHLIB_SUFFIX} tcl9pkgc${SHLIB_SUFFIX} tcl9pkgd${SHLIB_SUFFIX} tcl9pkge${SHLIB_SUFFIX} tcl9pkgua${SHLIB_SUFFIX} tcl9pkgooa${SHLIB_SUFFIX} @if test -n "$(DLTEST_SUFFIX)"; then $(MAKE) dltest_suffix; fi @touch ../dltest.marker -dltest_suffix: tcl9pkgπ${DLTEST_SUFFIX} tcl9pkga${DLTEST_SUFFIX} tcl9pkgb${DLTEST_SUFFIX} tcl9pkgc${DLTEST_SUFFIX} tcl9pkgd${DLTEST_SUFFIX} tcl9pkge${DLTEST_SUFFIX} tcl9pkgua${DLTEST_SUFFIX} tcl9pkgooa${DLTEST_SUFFIX} +dltest_suffix: tcl9pkga${DLTEST_SUFFIX} tcl9pkgb${DLTEST_SUFFIX} tcl9pkgc${DLTEST_SUFFIX} tcl9pkgd${DLTEST_SUFFIX} tcl9pkge${DLTEST_SUFFIX} tcl9pkgua${DLTEST_SUFFIX} tcl9pkgooa${DLTEST_SUFFIX} @touch ../dltest.marker embtest.o: $(SRC_DIR)/embtest.c -- cgit v0.12 From fdcf06d7315d6e51133ed51339324dcaa1731707 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 22 Jun 2021 02:49:23 +0000 Subject: update changes --- changes | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/changes b/changes index 46cf762..e5ec3a8 100644 --- a/changes +++ b/changes @@ -9351,10 +9351,17 @@ Changes to 9.0a3 include all changes to the 8.7 line through 8.7a5, plus the following, which focuses on the high-level feature changes in this changeset (new major version) rather than bug fixes: +Many of the TIPs in Tcl 8.7 mentioned above are extended further in 9.0 +2020-02-28 [TIP 497] Full support for Unicode planes 1-16 +2020-08-21 (bug)[43b434] improper calls to stat64() +2021-04-08 [TIP 595] Unicode-aware loadable library handling. +2021-04-30 [TIP 596] Stubs support for embedding Tcl in apps + +Many internal changes to broaden support for sizes beyond 32-bits. - Released 9.0a3, Jun 23, 2021 --- https://core.tcl-lang.org/tcl/ for details - -- cgit v0.12 From 5d945e860c40ef1dbdcfcff14829206954b3f202 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 25 Jun 2021 13:44:58 +0000 Subject: Bump version number to distinguish from release. --- README.md | 2 +- generic/tcl.h | 4 ++-- library/init.tcl | 2 +- unix/configure | 2 +- unix/configure.ac | 2 +- unix/tcl.spec | 2 +- win/configure | 2 +- win/configure.ac | 2 +- 8 files changed, 9 insertions(+), 9 deletions(-) diff --git a/README.md b/README.md index d6785d4..1ec9c96 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # README: Tcl -This is the **Tcl 9.0a3** source distribution. +This is the **Tcl 9.0a4** source distribution. You can get any source release of Tcl from [our distribution site](https://sourceforge.net/projects/tcl/files/Tcl/). diff --git a/generic/tcl.h b/generic/tcl.h index f221b0c..c5fa9a5 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -50,10 +50,10 @@ extern "C" { #define TCL_MAJOR_VERSION 9 #define TCL_MINOR_VERSION 0 #define TCL_RELEASE_LEVEL TCL_ALPHA_RELEASE -#define TCL_RELEASE_SERIAL 3 +#define TCL_RELEASE_SERIAL 4 #define TCL_VERSION "9.0" -#define TCL_PATCH_LEVEL "9.0a3" +#define TCL_PATCH_LEVEL "9.0a4" #if defined(RC_INVOKED) /* diff --git a/library/init.tcl b/library/init.tcl index c01dc97..09b81fb 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -19,7 +19,7 @@ if {[info commands package] == ""} { error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]" } -package require -exact tcl 9.0a3 +package require -exact tcl 9.0a4 # Compute the auto path to use in this interpreter. # The values on the path come from several locations: diff --git a/unix/configure b/unix/configure index ea26d70..9e5486f 100755 --- a/unix/configure +++ b/unix/configure @@ -2683,7 +2683,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu TCL_VERSION=9.0 TCL_MAJOR_VERSION=9 TCL_MINOR_VERSION=0 -TCL_PATCH_LEVEL="a3" +TCL_PATCH_LEVEL="a4" VERSION=${TCL_VERSION} EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"} diff --git a/unix/configure.ac b/unix/configure.ac index d826c90..324399d 100644 --- a/unix/configure.ac +++ b/unix/configure.ac @@ -26,7 +26,7 @@ m4_ifdef([SC_USE_CONFIG_HEADERS], [ TCL_VERSION=9.0 TCL_MAJOR_VERSION=9 TCL_MINOR_VERSION=0 -TCL_PATCH_LEVEL="a3" +TCL_PATCH_LEVEL="a4" VERSION=${TCL_VERSION} EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"} diff --git a/unix/tcl.spec b/unix/tcl.spec index bce18b8..f2d4bd5 100644 --- a/unix/tcl.spec +++ b/unix/tcl.spec @@ -4,7 +4,7 @@ Name: tcl Summary: Tcl scripting language development environment -Version: 9.0a3 +Version: 9.0a4 Release: 2 License: BSD Group: Development/Languages diff --git a/win/configure b/win/configure index 0c2bdf7..059f619 100755 --- a/win/configure +++ b/win/configure @@ -2401,7 +2401,7 @@ SHELL=/bin/sh TCL_VERSION=9.0 TCL_MAJOR_VERSION=9 TCL_MINOR_VERSION=0 -TCL_PATCH_LEVEL="a3" +TCL_PATCH_LEVEL="a4" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 diff --git a/win/configure.ac b/win/configure.ac index f52df0b..59c9dd9 100644 --- a/win/configure.ac +++ b/win/configure.ac @@ -15,7 +15,7 @@ SHELL=/bin/sh TCL_VERSION=9.0 TCL_MAJOR_VERSION=9 TCL_MINOR_VERSION=0 -TCL_PATCH_LEVEL="a3" +TCL_PATCH_LEVEL="a4" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 -- cgit v0.12 From ba2e55da57918ca2d91334bc01e4183f391202fd Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 25 Jun 2021 16:13:55 +0000 Subject: typo --- generic/tclLoad.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 9335437..cca5b7a 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -339,7 +339,7 @@ Tcl_LoadObjCmd( } #endif /* __CYGWIN__ */ if (((pkgGuess[0] == 't') -#ifdef MAC_OS_TCL +#ifdef MAC_OSX_TCL || (pkgGuess[0] == 'T') #endif ) && (pkgGuess[1] == 'c') -- cgit v0.12 From 65dc531cf93c773f5d73b4db3cb9dce44d5386df Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 20 Aug 2021 13:10:21 +0000 Subject: Repair build failure. --- generic/tclAsync.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclAsync.c b/generic/tclAsync.c index a2ee1eb..38ea2e4 100644 --- a/generic/tclAsync.c +++ b/generic/tclAsync.c @@ -115,7 +115,7 @@ TclFinalizeAsync(void) while (toDelete != NULL) { token = toDelete; toDelete = toDelete->nextPtr; - ckfree(token); + Tcl_Free(token); } } -- cgit v0.12 From c5d86c1b291b4db986c0d8b8087bf8d679e0bdf8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 25 Aug 2021 11:06:31 +0000 Subject: Fix for TIP #430/#595 corner-case: tcl_findLibrary should use correct library name when running in Tcl 9. --- library/auto.tcl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/library/auto.tcl b/library/auto.tcl index dc37328..0d30011 100644 --- a/library/auto.tcl +++ b/library/auto.tcl @@ -108,7 +108,7 @@ proc tcl_findLibrary {basename version patch initScript enVarName varName} { catch {lappend paths [::tcl::pkgconfig get bindir,runtime]} } if {[catch {::${basename}::pkgconfig get dllfile,runtime} dllfile]} { - set dllfile "lib${basename}${version}[info sharedlibextension]" + set dllfile "libtcl9${basename}${version}[info sharedlibextension]" } set dir [file dirname [file join [pwd] [info nameofexecutable]]] lappend paths $dir -- cgit v0.12 From 00b583a57994fe50d0b67f154b398d81b4ab7561 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 27 Aug 2021 07:20:33 +0000 Subject: One more TclUnusedStubEntry -> TclOOUnusedStubEntry --- generic/tclOOStubInit.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclOOStubInit.c b/generic/tclOOStubInit.c index df3f07d..4b6559a 100644 --- a/generic/tclOOStubInit.c +++ b/generic/tclOOStubInit.c @@ -14,7 +14,7 @@ MODULE_SCOPE const TclOOStubs tclOOStubs; #pragma GCC dependency "tclOO.decls" #endif -#define TclUnusedStubEntry 0 +#define TclOOUnusedStubEntry 0 /* !BEGIN!: Do not edit below this line. */ -- cgit v0.12 From 166d3a5b6c49ef9433b4e01976d24d25534431fb Mon Sep 17 00:00:00 2001 From: pooryorick Date: Wed, 1 Sep 2021 23:13:17 +0000 Subject: Fix for [ccc448a6bfd59cbd], namespace ensemble subcommand name prefix matching and a subsequent error results in a segmentation fault --- generic/tclEnsemble.c | 20 +++++++++++++++++++- generic/tclIndexObj.c | 18 +++++------------- generic/tclInt.h | 1 + generic/tclNamesp.c | 5 +++-- tests/namespace.test | 18 ++++++++++++++++++ 5 files changed, 46 insertions(+), 16 deletions(-) diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 13408e1..799c645 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -2201,6 +2201,18 @@ TclSpellFix( TclNRAddCallback(interp, TclNRReleaseValues, fix, NULL, NULL, NULL); } +Tcl_Obj *const *TclEnsembleGetRewriteValues( + Tcl_Interp *interp /* Current interpreter. */ +) +{ + Interp *iPtr = (Interp *) interp; + Tcl_Obj *const *origObjv = iPtr->ensembleRewrite.sourceObjs; + if (origObjv[0] == NULL) { + origObjv = (Tcl_Obj *const *)origObjv[2]; + } + return origObjv; +} + /* *---------------------------------------------------------------------- * @@ -2225,12 +2237,18 @@ TclFetchEnsembleRoot( int objc, int *objcPtr) { + Tcl_Obj *const *sourceObjs; Interp *iPtr = (Interp *) interp; if (iPtr->ensembleRewrite.sourceObjs) { *objcPtr = objc + iPtr->ensembleRewrite.numRemovedObjs - iPtr->ensembleRewrite.numInsertedObjs; - return iPtr->ensembleRewrite.sourceObjs; + if (iPtr->ensembleRewrite.sourceObjs[0] == NULL) { + sourceObjs = iPtr->ensembleRewrite.sourceObjs[1]; + } else { + sourceObjs = iPtr->ensembleRewrite.sourceObjs; + } + return sourceObjs; } *objcPtr = objc; return objv; diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index b665589..f81f0b3 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -798,27 +798,19 @@ Tcl_WrongNumArgs( } /* - * Check to see if we are processing an ensemble implementation, and if so - * rewrite the results in terms of how the ensemble was invoked. + * If processing an an ensemble implementation, rewrite the results in + * terms of how the ensemble was invoked. */ if (iPtr->ensembleRewrite.sourceObjs != NULL) { int toSkip = iPtr->ensembleRewrite.numInsertedObjs; int toPrint = iPtr->ensembleRewrite.numRemovedObjs; - Tcl_Obj *const *origObjv = iPtr->ensembleRewrite.sourceObjs; + Tcl_Obj *const *origObjv = TclEnsembleGetRewriteValues(interp); /* - * Check for spelling fixes, and substitute the fixed values. - */ - - if (origObjv[0] == NULL) { - origObjv = (Tcl_Obj *const *)origObjv[2]; - } - - /* - * We only know how to do rewriting if all the replaced objects are + * Only do rewrite the command if all the replaced objects are * actually arguments (in objv) to this function. Otherwise it just - * gets too complicated and we'd be better off just giving a slightly + * gets too complicated and it's to just give a slightly * confusing error message... */ diff --git a/generic/tclInt.h b/generic/tclInt.h index 7f19a42..96bbfc5 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2924,6 +2924,7 @@ MODULE_SCOPE char * TclDStringAppendDString(Tcl_DString *dsPtr, MODULE_SCOPE Tcl_Obj * TclDStringToObj(Tcl_DString *dsPtr); MODULE_SCOPE Tcl_Obj *const *TclFetchEnsembleRoot(Tcl_Interp *interp, Tcl_Obj *const *objv, int objc, int *objcPtr); +MODULE_SCOPE Tcl_Obj *const *TclEnsembleGetRewriteValues(Tcl_Interp *interp); MODULE_SCOPE Tcl_Namespace *TclEnsureNamespace(Tcl_Interp *interp, Tcl_Namespace *namespacePtr); MODULE_SCOPE void TclFinalizeAllocSubsystem(void); diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 8f2a711..f935fa4 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -4924,8 +4924,9 @@ TclLogCommandInfo( * command (must be <= command). */ const char *command, /* First character in command that generated * the error. */ - size_t length, /* Number of bytes in command (-1 means - * use all bytes up to first null byte). */ + size_t length, /* Number of bytes in command (TCL_INDEX_NONE + * means use all bytes up to first null byte). + */ const unsigned char *pc, /* Current pc of bytecode execution context */ Tcl_Obj **tosPtr) /* Current stack of bytecode execution * context */ diff --git a/tests/namespace.test b/tests/namespace.test index 2d0c20f..ae233cb 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -1920,6 +1920,24 @@ test namespace-42.10 { unset -nocomplain lst } -returnCodes error -match glob -result {invalid command name *three*} + +test namespace-42.11 { + ensembles: prefix matching segmentation fault + + issue ccc448a6bfd59cbd +} -body { + namespace eval n1 { + namespace ensemble create + namespace export * + proc p1 args {error success} + } + # segmentation fault only occurs in the non-byte-compiled path, so avoid + # byte compilation + set cmd {namespace eva n1 {[namespace parent]::n1 p1}} + {*}$cmd +} -returnCodes error -result success + + test namespace-43.1 {ensembles: dict-driven} { namespace eval ns { namespace export x* -- cgit v0.12 From b6f6b92ae4dced8a01b700e78265a95daa0a98cd Mon Sep 17 00:00:00 2001 From: pooryorick Date: Thu, 2 Sep 2021 21:14:19 +0000 Subject: Silence warning in fix for [ccc448a6bfd5], namespace ensemble subcommand name prefix matching and a subsequent error results in a segmentation fault --- generic/tclEnsemble.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 799c645..b55489b 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -2244,7 +2244,7 @@ TclFetchEnsembleRoot( *objcPtr = objc + iPtr->ensembleRewrite.numRemovedObjs - iPtr->ensembleRewrite.numInsertedObjs; if (iPtr->ensembleRewrite.sourceObjs[0] == NULL) { - sourceObjs = iPtr->ensembleRewrite.sourceObjs[1]; + sourceObjs = (Tcl_Obj *const *)iPtr->ensembleRewrite.sourceObjs[1]; } else { sourceObjs = iPtr->ensembleRewrite.sourceObjs; } -- cgit v0.12 From 962e5966f927e1a98e7ca5255cad96c6efc45617 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Thu, 2 Sep 2021 22:15:34 +0000 Subject: Update code comments. --- generic/tclEnsemble.c | 268 +++++++++++++++++++++++--------------------------- generic/tclExecute.c | 2 +- generic/tclIndexObj.c | 4 +- generic/tclNamesp.c | 10 +- generic/tclObj.c | 13 +-- 5 files changed, 137 insertions(+), 160 deletions(-) diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index b55489b..bf3196d 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -70,8 +70,8 @@ enum EnsConfigOpts { }; /* - * This structure defines a Tcl object type that contains a reference to an - * ensemble subcommand (e.g. the "length" in [string length ab]). It is used + * ensembleCmdType is a Tcl object type that contains a reference to an + * ensemble subcommand, e.g. the "length" in [string length ab]. It is used * to cache the mapping between the subcommand itself and the real command * that implements it. */ @@ -1704,7 +1704,7 @@ NsEnsembleImplementationCmdNR( size_t subIdx; /* - * Must recheck objc, since numParameters might have changed. Cf. test + * Must recheck objc since numParameters might have changed. See test * namespace-53.9. */ @@ -1712,7 +1712,7 @@ NsEnsembleImplementationCmdNR( subIdx = 1 + ensemblePtr->numParameters; if ((size_t)objc < subIdx + 1) { /* - * We don't have a subcommand argument. Make error message. + * No subcommand argument. Make error message. */ Tcl_DString buf; /* Message being built */ @@ -1744,18 +1744,16 @@ NsEnsembleImplementationCmdNR( } /* - * Determine if the table of subcommands is right. If so, we can just look - * up in there and go straight to dispatch. + * If the table of subcommands is valid just lookup up the command there + * and go to dispatch. */ subObj = objv[subIdx]; if (ensemblePtr->epoch == ensemblePtr->nsPtr->exportLookupEpoch) { /* - * Table of subcommands is still valid; therefore there might be a - * valid cache of discovered information which we can reuse. Do the - * check here, and if we're still valid, we can jump straight to the - * part where we do the invocation of the subcommand. + * Table of subcommands is still valid so if the internal representtion + * is an ensembleCmd, just call it. */ EnsembleCmdRep *ensembleCmd; @@ -1777,8 +1775,8 @@ NsEnsembleImplementationCmdNR( } /* - * Look in the hashtable for the subcommand name; this is the fastest way - * of all if there is no cache in operation. + * Look in the hashtable for the named subcommand. This is the fastest + * path if there is no cache in operation. */ hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable, @@ -1786,26 +1784,25 @@ NsEnsembleImplementationCmdNR( if (hPtr != NULL) { /* - * Cache for later in the subcommand object. + * Cache ensemble in the subcommand object for later. */ MakeCachedEnsembleCommand(subObj, ensemblePtr, hPtr, NULL); } else if (!(ensemblePtr->flags & TCL_ENSEMBLE_PREFIX)) { /* - * Could not map, no prefixing, go to unknown/error handling. + * Could not map. No prefixing. Go to unknown/error handling. */ goto unknownOrAmbiguousSubcommand; } else { /* - * If we've not already confirmed the command with the hash as part of - * building our export table, we need to scan the sorted array for - * matches. + * If the command isn't yet confirmed with the hash as part of building + * the export table, scan the sorted array for matches. */ - const char *subcmdName; /* Name of the subcommand, or unique prefix of - * it (will be an error for a non-unique - * prefix). */ + const char *subcmdName; /* Name of the subcommand or unique prefix of + * it (a non-unique prefix produces an error). + */ char *fullName = NULL; /* Full name of the subcommand. */ size_t stringLength, i; size_t tableLength = ensemblePtr->subcommandTable.numEntries; @@ -1820,10 +1817,10 @@ NsEnsembleImplementationCmdNR( if (cmp == 0) { if (fullName != NULL) { /* - * Since there's never the exact-match case to worry about - * (hash search filters this), getting here indicates that - * our subcommand is an ambiguous prefix of (at least) two - * exported subcommands, which is an error case. + * Hash search filters out the exact-match case, so getting + * here indicates that the subcommand is an ambiguous + * prefix of at least two exported subcommands, which is an + * error case. */ goto unknownOrAmbiguousSubcommand; @@ -1831,9 +1828,8 @@ NsEnsembleImplementationCmdNR( fullName = ensemblePtr->subcommandArrayPtr[i]; } else if (cmp < 0) { /* - * Because we are searching a sorted table, we can now stop - * searching because we have gone past anything that could - * possibly match. + * The table is sorted so stop searching because a match would + * have been found already. */ break; @@ -1841,7 +1837,7 @@ NsEnsembleImplementationCmdNR( } if (fullName == NULL) { /* - * The subcommand is not a prefix of anything, so bail out! + * The subcommand is not a prefix of anything. Bail out! */ goto unknownOrAmbiguousSubcommand; @@ -1871,21 +1867,19 @@ NsEnsembleImplementationCmdNR( runResultingSubcommand: /* - * Do the real work of execution of the subcommand by building an array of - * objects (note that this is potentially not the same length as the - * number of arguments to this ensemble command), populating it and then - * feeding it back through the main command-lookup engine. In theory, we - * could look up the command in the namespace ourselves, as we already - * have the namespace in which it is guaranteed to exist, + * Execute the subcommand by populating an array of objects, which might + * not be the same length as the number of arguments to this ensemble + * command, and then handing it to the main command-lookup engine. In + * theory, the command could be looked up right here using the namespace in + * which it is guaranteed to exist, * * ((Q: That's not true if the -map option is used, is it?)) * - * but we don't do that (the cacheing of the command object used should - * help with that.) + * but don't do that because cacheing of the command object should help. */ { - Tcl_Obj *copyPtr; /* The actual list of words to dispatch to. + Tcl_Obj *copyPtr; /* The list of words to dispatch on. * Will be freed by the dispatch engine. */ Tcl_Obj **copyObjv; int copyObjc, prefixObjc; @@ -1908,8 +1902,8 @@ NsEnsembleImplementationCmdNR( TclDecrRefCount(prefixObj); /* - * Record what arguments the script sent in so that things like - * Tcl_WrongNumArgs can give the correct error message. Parameters + * Record the words of the command as given so that routines like + * Tcl_WrongNumArgs can produce the correct error message. Parameters * count both as inserted and removed arguments. */ @@ -1931,10 +1925,9 @@ NsEnsembleImplementationCmdNR( unknownOrAmbiguousSubcommand: /* - * Have not been able to match the subcommand asked for with a real - * subcommand that we export. See whether a handler has been registered - * for dealing with this situation. Will only call (at most) once for any - * particular ensemble invocation. + * The named subcommand did not match any exported command. If there is a + * handler registered unknown subcommands, call it, but not more than once + * for this call. */ if (ensemblePtr->unknownHandler != NULL && reparseCount++ < 1) { @@ -1950,10 +1943,10 @@ NsEnsembleImplementationCmdNR( } /* - * We cannot determine what subcommand to hand off to, so generate a - * (standard) failure message. Note the one odd case compared with - * standard ensemble-like command, which is where a namespace has no - * exported commands at all... + * Could not find a routine for the named subcommand so generate a standard + * failure message. The one odd case compared with a standard + * ensemble-like command is where a namespace has no exported commands at + * all... */ Tcl_ResetResult(interp); @@ -2000,8 +1993,8 @@ TclClearRootEnsemble( * * TclInitRewriteEnsemble -- * - * Applies a rewrite of arguments so that an ensemble subcommand will - * report error messages correctly for the overall command. + * Applies a rewrite of arguments so that an ensemble subcommand + * correctly reports any error messages for the overall command. * * Results: * Whether this is the first rewrite applied, a value which must be @@ -2079,7 +2072,7 @@ TclResetRewriteEnsemble( * * TclSpellFix -- * - * Record a spelling correction that needs making in the generation of + * Records a spelling correction that needs making in the generation of * the WrongNumArgs usage message. * * Results: @@ -2144,8 +2137,8 @@ TclSpellFix( if (badIdx < iPtr->ensembleRewrite.numInsertedObjs) { /* - * Misspelled value was inserted. We cannot directly jump to the bad - * value, but have to search. + * Misspelled value was inserted. Cannot directly jump to the bad + * value. Must search. */ idx = 1; @@ -2257,22 +2250,22 @@ TclFetchEnsembleRoot( /* * ---------------------------------------------------------------------- * - * EnsmebleUnknownCallback -- + * EnsembleUnknownCallback -- * - * Helper for the ensemble engine that handles the procesing of unknown - * callbacks. See the user documentation of the ensemble unknown handler - * for details; this function is only ever called when such a function is - * defined, and is only ever called once per ensemble dispatch (i.e. if a - * reparse still fails, this isn't called again). + * Helper for the ensemble engine. Calls the routine registered for + * "ensemble unknown" case. See the user documentation of the + * ensemble unknown handler for details. Only called when such a + * function is defined, and is only called once per ensemble dispatch. + * I.e. even if a reparse still fails, this isn't called again. * * Results: * TCL_OK - *prefixObjPtr contains the command words to dispatch * to. - * TCL_CONTINUE - Need to reparse (*prefixObjPtr is invalid). - * TCL_ERROR - Something went wrong! Error message in interpreter. + * TCL_CONTINUE - Need to reparse, i.e. *prefixObjPtr is invalid + * TCL_ERROR - Something went wrong. Error message in interpreter. * * Side effects: - * Calls the Tcl interpreter, so arbitrary. + * Arbitrary, due to evaluation of script provided by client. * * ---------------------------------------------------------------------- */ @@ -2289,7 +2282,7 @@ EnsembleUnknownCallback( Tcl_Obj **paramv, *unknownCmd, *ensObj; /* - * Create the unknown command callback to determine what to do. + * Create the "unknown" command callback to determine what to do. */ unknownCmd = Tcl_DuplicateObj(ensemblePtr->unknownHandler); @@ -2303,10 +2296,9 @@ EnsembleUnknownCallback( Tcl_IncrRefCount(unknownCmd); /* - * Now call the unknown handler. (We don't bother NRE-enabling this; deep - * recursing through unknown handlers is horribly perverse.) Note that it - * is always an error for an unknown handler to delete its ensemble; don't - * do that! + * Call the "unknown" handler. No attempt to NRE-enable this as deep + * recursion through unknown handlers is perverse. It is always an error + * for an unknown handler to delete its ensemble. Don't do that. */ Tcl_Preserve(ensemblePtr); @@ -2324,10 +2316,9 @@ EnsembleUnknownCallback( Tcl_Release(ensemblePtr); /* - * If we succeeded, we should either have a list of words that form the - * command to be executed, or an empty list. In the empty-list case, the - * ensemble is believed to be updated so we should ask the ensemble engine - * to reparse the original command. + * On success the result is a list of words that form the command to be + * executed. If the list is empty, the ensemble should have been updated, + * so ask the ensemble engine to reparse the original command. */ if (result == TCL_OK) { @@ -2336,11 +2327,7 @@ EnsembleUnknownCallback( TclDecrRefCount(unknownCmd); Tcl_ResetResult(interp); - /* - * Namespace is still there. Check if the result is a valid list. If - * it is, and it is non-empty, that list is what we are using as our - * replacement. - */ + /* A non-empty list is the replacement command. */ if (TclListObjLength(interp, *prefixObjPtr, &prefixObjc) != TCL_OK) { TclDecrRefCount(*prefixObjPtr); @@ -2353,7 +2340,7 @@ EnsembleUnknownCallback( } /* - * Namespace alive & empty result => reparse. + * Empty result => reparse. */ TclDecrRefCount(*prefixObjPtr); @@ -2361,7 +2348,7 @@ EnsembleUnknownCallback( } /* - * Oh no! An exceptional result. Convert to an error. + * Convert exceptional result to an error. */ if (!Tcl_InterpDeleted(interp)) { @@ -2401,16 +2388,16 @@ EnsembleUnknownCallback( * * MakeCachedEnsembleCommand -- * - * Cache what we've computed so far; it's not nice to repeatedly copy - * strings about. Note that to do this, we start by deleting any old - * representation that there was (though if it was an out of date - * ensemble rep, we can skip some of the deallocation process.) + * Caches what has been computed so far to minimize string copying. + * Starts by deleting any existing representation but reusing the existing + * structure if it is an ensembleCmd. * * Results: - * None + * None. * * Side effects: - * Alters the internal representation of the first object parameter. + * Converts the internal representation of the given object to an + * ensembleCmd. * *---------------------------------------------------------------------- */ @@ -2432,8 +2419,7 @@ MakeCachedEnsembleCommand( } } else { /* - * Kill the old internal rep, and replace it with a brand new one of - * our own. + * Replace any old internal representation with a new one. */ ensembleCmd = (EnsembleCmdRep *)Tcl_Alloc(sizeof(EnsembleCmdRep)); @@ -2459,17 +2445,16 @@ MakeCachedEnsembleCommand( * * DeleteEnsembleConfig -- * - * Destroys the data structure used to represent an ensemble. This is - * called when the ensemble's command is deleted (which happens - * automatically if the ensemble's namespace is deleted.) Maintainers - * should note that ensembles should be deleted by deleting their - * commands. + * Destroys the data structure used to represent an ensemble. Called when + * the procedure for the ensemble is deleted, which happens automatically + * if the namespace for the ensemble is deleted. Deleting the procedure + * for an ensemble is the right way to initiate cleanup. * * Results: * None. * * Side effects: - * Memory is (eventually) deallocated. + * Memory is eventually deallocated. * *---------------------------------------------------------------------- */ @@ -2501,10 +2486,7 @@ DeleteEnsembleConfig( EnsembleConfig *ensemblePtr = (EnsembleConfig *)clientData; Namespace *nsPtr = ensemblePtr->nsPtr; - /* - * Unlink from the ensemble chain if it has not been marked as having been - * done already. - */ + /* Unlink from the ensemble chain if it not already marked as unlinked. */ if (ensemblePtr->next != ensemblePtr) { EnsembleConfig *ensPtr = (EnsembleConfig *) nsPtr->ensembles; @@ -2530,7 +2512,7 @@ DeleteEnsembleConfig( ensemblePtr->flags |= ENSEMBLE_DEAD; /* - * Kill the pointer-containing fields. + * Release the fields that contain pointers. */ ClearTable(ensemblePtr); @@ -2548,10 +2530,9 @@ DeleteEnsembleConfig( } /* - * Arrange for the structure to be reclaimed. Note that this is complex - * because we have to make sure that we can react sensibly when an - * ensemble is deleted during the process of initialising the ensemble - * (especially the unknown callback.) + * Arrange for the structure to be reclaimed. This is complex because it is + * necessary to react sensibly when an ensemble is deleted during its + * initialisation, particularly in the case of an unknown callback. */ Tcl_EventuallyFree(ensemblePtr, TCL_DYNAMIC); @@ -2562,11 +2543,11 @@ DeleteEnsembleConfig( * * BuildEnsembleConfig -- * - * Create the internal data structures that describe how an ensemble - * looks, being a hash mapping from the full command name to the Tcl list - * that describes the implementation prefix words, and a sorted array of - * all the full command names to allow for reasonably efficient - * unambiguous prefix handling. + * Creates the internal data structures that describe how an ensemble + * looks. The structures are a hash map from the full command name to the + * Tcl list that describes the implementation prefix words, and a sorted + * array of all the full command names to allow for reasonably efficient + * handling of an unambiguous prefix. * * Results: * None. @@ -2574,7 +2555,7 @@ DeleteEnsembleConfig( * Side effects: * Reallocates and rebuilds the hash table and array stored at the * ensemblePtr argument. For large ensembles or large namespaces, this is - * a potentially expensive operation. + * may be an expensive operation. * *---------------------------------------------------------------------- */ @@ -2583,9 +2564,8 @@ static void BuildEnsembleConfig( EnsembleConfig *ensemblePtr) { - Tcl_HashSearch search; /* Used for scanning the set of commands in - * the namespace that backs up this - * ensemble. */ + Tcl_HashSearch search; /* Used for scanning the commands in + * the namespace for this ensemble. */ size_t i, j; int isNew; Tcl_HashTable *hash = &ensemblePtr->subcommandTable; @@ -2603,13 +2583,13 @@ BuildEnsembleConfig( /* * There is a list of exactly what subcommands go in the table. - * Must determine the target for each. + * Determine the target for each. */ Tcl_ListObjGetElements(NULL, subList, &subc, &subv); if (subList == mapDict) { /* - * Strange case where explicit list of subcommands is same value + * Unusual case where explicit list of subcommands is same value * as the dict mapping to targets. */ @@ -2658,10 +2638,10 @@ BuildEnsembleConfig( } /* - * target was not in the dictionary so map onto the namespace. - * Note in this case that we do not guarantee that the command - * is actually there; that is the programmer's responsibility - * (or [::unknown] of course). + * Target was not in the dictionary. Map onto the namespace. + * In this case there is no guarantee that the command + * is actually there. It is the responsibility of the + * programmer (or [::unknown] of course) to provide the procedure. */ cmdObj = Tcl_NewStringObj(name, -1); @@ -2672,9 +2652,9 @@ BuildEnsembleConfig( } } else if (mapDict) { /* - * No subcmd list, but we do have a mapping dictionary so we should - * use the keys of that. Convert the dictionary's contents into the - * form required for the ensemble's internal hashtable. + * No subcmd list, but there is a mapping dictionary, so + * use the keys of that. Convert the contents of the dictionary into the + * form required for the internal hashtable of the ensemble. */ Tcl_DictSearch dictSearch; @@ -2693,18 +2673,15 @@ BuildEnsembleConfig( } } else { /* - * Discover what commands are actually exported by the namespace. - * What we have is an array of patterns and a hash table whose keys - * are the command names exported by the namespace (the contents do - * not matter here.) We must find out what commands are actually - * exported by filtering each command in the namespace against each of - * the patterns in the export list. Note that we use an intermediate - * hash table to make memory management easier, and because that makes - * exact matching far easier too. + * Use the array of patterns and the hash table whose keys are the + * commands exported by the namespace. The corresponding values do not + * matter here. Filter the commands in the namespace against the + * patterns in the export list to find out what commands are actually + * exported. Use an intermediate hash table to make memory management + * easier and to make exact matching much easier. * - * Suggestion for future enhancement: compute the unique prefixes and - * place them in the hash too, which should make for even faster - * matching. + * Suggestion for future enhancement: Compute the unique prefixes and + * place them in the hash too for even faster matching. */ hPtr = Tcl_FirstHashEntry(&ensemblePtr->nsPtr->cmdTable, &search); @@ -2747,24 +2724,24 @@ BuildEnsembleConfig( } /* - * Create a sorted array of all subcommands in the ensemble; hash tables + * Create a sorted array of all subcommands in the ensemble. Hash tables * are all very well for a quick look for an exact match, but they can't - * determine things like whether a string is a prefix of another (not - * without lots of preparation anyway) and they're no good for when we're - * generating the error message either. + * determine things like whether a string is a prefix of another, at least + * not without a lot of preparation, and they're not useful for generating + * the error message either. * - * We do this by filling an array with the names (we use the hash keys - * directly to save a copy, since any time we change the array we change - * the hash too, and vice versa) and running quicksort over the array. + * Do this by filling an array with the names: Use the hash keys + * directly to save a copy since any time we change the array we change + * the hash too, and vice versa, and run quicksort over the array. */ ensemblePtr->subcommandArrayPtr = (char **)Tcl_Alloc(sizeof(char *) * hash->numEntries); /* - * Fill array from both ends as this makes us less likely to end up with - * performance problems in qsort(), which is good. Note that doing this - * makes this code much more opaque, but the naive alternatve: + * Fill the array from both ends as this reduces the likelihood of + * performance problems in qsort(). This makes this code much more opaque, + * but the naive alternatve: * * for (hPtr=Tcl_FirstHashEntry(hash,&search),i=0 ; * hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search),i++) { @@ -2772,11 +2749,11 @@ BuildEnsembleConfig( * } * * can produce long runs of precisely ordered table entries when the - * commands in the namespace are declared in a sorted fashion (an ordering - * some people like) and the hashing functions (or the command names - * themselves) are fairly unfortunate. By filling from both ends, it - * requires active malice (and probably a debugger) to get qsort() to have - * awful runtime behaviour. + * commands in the namespace are declared in a sorted fashion, which is an + * ordering some people like, and the hashing functions or the command + * names themselves are fairly unfortunate. Filling from both ends means + * that it requires active malice, and probably a debugger, to get qsort() + * to have awful runtime behaviour. */ i = 0; @@ -2802,8 +2779,7 @@ BuildEnsembleConfig( * * NsEnsembleStringOrder -- * - * Helper function to compare two pointers to two strings for use with - * qsort(). + * Helper to for uset with sort() that compares two string pointers. * * Results: * -1 if the first string is smaller, 1 if the second string is smaller, diff --git a/generic/tclExecute.c b/generic/tclExecute.c index b0a73b4..f0e6cac 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2749,7 +2749,7 @@ TEBCresume( pc += 1; /* yield next instruction */ TEBC_YIELD(); - /* add TEBCResume for object at top of stack */ + /* add TEBCresume for object at top of stack */ return TclNRExecuteByteCode(interp, TclCompileObj(interp, OBJ_AT_TOS, NULL, 0)); diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index f81f0b3..41453a5 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -826,7 +826,7 @@ Tcl_WrongNumArgs( objc -= toSkip; /* - * We assume no object is of index type. + * Assume no object is of index type. */ for (i=0 ; ierrorInfo/errorStack fields to describe the + * Invoked after an error occurs in an interpreter. + * Adds information to iPtr->errorInfo/errorStack fields to describe the * command that was being executed when the error occurred. When pc and * tosPtr are non-NULL, conveying a bytecode execution "inner context", - * and the offending instruction is suitable, that inner context is + * and the offending instruction is suitable, and that inner context is * recorded in errorStack. * * Results: @@ -4938,8 +4938,8 @@ TclLogCommandInfo( if (iPtr->flags & ERR_ALREADY_LOGGED) { /* - * Someone else has already logged error information for this command; - * we shouldn't add anything more. + * Someone else has already logged error information for this command. + * Don't add anything more. */ return; diff --git a/generic/tclObj.c b/generic/tclObj.c index 3130bdd..f264bcd 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -1857,12 +1857,11 @@ Tcl_HasStringRep( * * Tcl_StoreIntRep -- * - * This function is called to set the object's internal - * representation to match a particular type. + * Called to set the object's internal representation to match a + * particular type. * - * It is the caller's responsibility to guarantee that - * the value of the submitted IntRep is in agreement with - * the value of any existing string rep. + * It is the caller's resonsibility to ensure that the given IntRep is + * appropriate for the existing string. * * Results: * None. @@ -1880,7 +1879,9 @@ Tcl_StoreIntRep( const Tcl_ObjType *typePtr, /* New type for the object */ const Tcl_ObjIntRep *irPtr) /* New IntRep for the object */ { - /* Clear out any existing IntRep ( "shimmer" ) */ + /* Clear out any existing IntRep. This is the point where shimmering, i.e. + * repeated alteration of the type of the internal representation, may + * occur. */ TclFreeIntRep(objPtr); /* When irPtr == NULL, just leave objPtr with no IntRep for typePtr */ -- cgit v0.12 From 140696125600f86b585afee9b8b5f033602d5f20 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 19 Oct 2021 15:23:51 +0000 Subject: We can now assume that TCL_MAJOR_VERSION == 9 --- generic/tclObj.c | 4 ---- generic/tclZipfs.c | 20 -------------------- generic/tclZlib.c | 3 --- 3 files changed, 27 deletions(-) diff --git a/generic/tclObj.c b/generic/tclObj.c index fe4feca..9a3e3e4 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -1716,11 +1716,7 @@ Tcl_GetStringFromObj( } } if (lengthPtr != NULL) { -#if TCL_MAJOR_VERSION > 8 *lengthPtr = objPtr->length; -#else - *lengthPtr = ((size_t)(unsigned)(objPtr->length + 1)) - 1; -#endif } return objPtr->bytes; } diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index 1ac5578..ba63f01 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -358,10 +358,6 @@ static int ZipChannelClose(void *instanceData, static Tcl_DriverGetHandleProc ZipChannelGetFile; static int ZipChannelRead(void *instanceData, char *buf, int toRead, int *errloc); -#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9) -static int ZipChannelSeek(void *instanceData, long offset, - int mode, int *errloc); -#endif static long long ZipChannelWideSeek(void *instanceData, long long offset, int mode, int *errloc); static void ZipChannelWatchChannel(void *instanceData, @@ -417,11 +413,7 @@ static Tcl_ChannelType ZipChannelType = { TCL_CLOSE2PROC, /* Close channel, clean instance data */ ZipChannelRead, /* Handle read request */ ZipChannelWrite, /* Handle write request */ -#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9) - ZipChannelSeek, /* Move location of access point, NULL'able */ -#else NULL, /* Move location of access point, NULL'able */ -#endif NULL, /* Set options, NULL'able */ NULL, /* Get options, NULL'able */ ZipChannelWatchChannel, /* Initialize notifier */ @@ -4227,18 +4219,6 @@ ZipChannelWideSeek( info->numRead = (size_t) offset; return info->numRead; } - -#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9) -static int -ZipChannelSeek( - void *instanceData, - long offset, - int mode, - int *errloc) -{ - return ZipChannelWideSeek(instanceData, offset, mode, errloc); -} -#endif /* *------------------------------------------------------------------------- diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 85b4dc3..da88c5f 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -3969,9 +3969,6 @@ TclZlibInit( * Formally provide the package as a Tcl built-in. */ -#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9) - Tcl_PkgProvideEx(interp, "zlib", TCL_ZLIB_VERSION, NULL); -#endif return Tcl_PkgProvideEx(interp, "tcl::zlib", TCL_ZLIB_VERSION, NULL); } -- cgit v0.12 From db1bea3d4bbcb4c438e5e8bfcd0c66e6a2a2cac7 Mon Sep 17 00:00:00 2001 From: dgp Date: Sat, 6 Nov 2021 15:26:38 +0000 Subject: Repair a whitespace merge error. --- generic/tcl.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tcl.h b/generic/tcl.h index e41364b..c3db670 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -937,7 +937,7 @@ typedef struct Tcl_DString { #define TCL_LINK_CHARS 15 #define TCL_LINK_BINARY 16 #define TCL_LINK_READ_ONLY 0x80 - + /* *---------------------------------------------------------------------------- * Forward declarations of Tcl_HashTable and related types. -- cgit v0.12 From 25d340d9d8ab61af8ba8f32350c06cc87e418be0 Mon Sep 17 00:00:00 2001 From: dgp Date: Sat, 6 Nov 2021 17:10:19 +0000 Subject: Repair faulty conflict resolution from some time back. --- generic/tclZipfs.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index 7fb30fe..d9cb4ba 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -214,7 +214,7 @@ typedef struct ZipFile { typedef struct ZipEntry { char *name; /* The full pathname of the virtual file */ ZipFile *zipFilePtr; /* The ZIP file holding this virtual file */ - long long offset; /* Data offset into memory mapped ZIP file */ + size_t offset; /* Data offset into memory mapped ZIP file */ int numBytes; /* Uncompressed size of the virtual file */ int numCompressedBytes; /* Compressed size of the virtual file */ int compressMethod; /* Compress method */ @@ -4395,7 +4395,7 @@ ZipChannelOpen( * Wrap the ZipChannel into a Tcl_Channel. */ - sprintf(cname, "zipfs_%" TCL_LL_MODIFIER "x_%d", z->offset, + sprintf(cname, "zipfs_%" TCL_Z_MODIFIER "x_%d", z->offset, ZipFS.idCount++); z->zipFilePtr->numOpen++; Unlock(); -- cgit v0.12 From d5ad600360d03a4a6d07f54c1521cc9d90659ae8 Mon Sep 17 00:00:00 2001 From: dgp Date: Sat, 6 Nov 2021 17:38:17 +0000 Subject: Clean up another old failed merge. --- generic/tclTestObj.c | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index 2d94e03..654208d 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -1167,6 +1167,7 @@ TeststringobjCmd( { Tcl_UniChar *unicode; int varIndex, option, i, length; + size_t size; #define MAX_STRINGS 11 const char *index, *string, *strings[MAX_STRINGS+1]; String *strPtr; @@ -1299,12 +1300,12 @@ TeststringobjCmd( * is "copy on write". */ - string = Tcl_GetStringFromObj(objv[3], &length); + string = Tcl_GetStringFromObj(objv[3], &size); if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetStringObj(varPtr[varIndex], string, length); + Tcl_SetStringObj(varPtr[varIndex], string, size); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewStringObj(string, length)); + SetVarToObj(varPtr, varIndex, Tcl_NewStringObj(string, size)); } Tcl_SetObjResult(interp, varPtr[varIndex]); break; @@ -1356,18 +1357,18 @@ TeststringobjCmd( SetVarToObj(varPtr, varIndex, Tcl_DuplicateObj(varPtr[varIndex])); } - string = Tcl_GetStringFromObj(varPtr[varIndex], &length); + string = Tcl_GetStringFromObj(varPtr[varIndex], &size); if (Tcl_GetIntFromObj(interp, objv[3], &i) != TCL_OK) { return TCL_ERROR; } - if ((i < 0) || (i > length)) { + if ((i < 0) || ((size_t)i > size)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "index value out of range", -1)); return TCL_ERROR; } - Tcl_AppendToObj(varPtr[varIndex], string + i, length - i); + Tcl_AppendToObj(varPtr[varIndex], string + i, size - i); Tcl_SetObjResult(interp, varPtr[varIndex]); break; case 11: /* appendself2 */ @@ -1387,18 +1388,18 @@ TeststringobjCmd( SetVarToObj(varPtr, varIndex, Tcl_DuplicateObj(varPtr[varIndex])); } - unicode = Tcl_GetUnicodeFromObj(varPtr[varIndex], &length); + unicode = Tcl_GetUnicodeFromObj(varPtr[varIndex], &size); if (Tcl_GetIntFromObj(interp, objv[3], &i) != TCL_OK) { return TCL_ERROR; } - if ((i < 0) || (i > length)) { + if ((i < 0) || ((size_t)i > size)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "index value out of range", -1)); return TCL_ERROR; } - TclAppendUnicodeToObj(varPtr[varIndex], unicode + i, length - i); + TclAppendUnicodeToObj(varPtr[varIndex], unicode + i, size - i); Tcl_SetObjResult(interp, varPtr[varIndex]); break; } -- cgit v0.12 From 6574848ee46baa0fae419a52e6aa1b56dee16867 Mon Sep 17 00:00:00 2001 From: dgp Date: Sat, 6 Nov 2021 17:55:48 +0000 Subject: Eliminate more branch diffs with trunk that have no apparent connection to TIP 568. --- generic/tclFCmd.c | 2 +- generic/tclObj.c | 25 ++++++++++++++----------- generic/tclStrToD.c | 10 +++++----- generic/tclStringObj.c | 10 +++++----- 4 files changed, 25 insertions(+), 22 deletions(-) diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 23942db..4e37574 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -1541,7 +1541,7 @@ TclFileTempDirCmd( } if (objc > 1) { - size_t length; + int length; Tcl_Obj *templateObj = objv[1]; const char *string = Tcl_GetStringFromObj(templateObj, &length); const int onWindows = (tclPlatform == TCL_PLATFORM_WINDOWS); diff --git a/generic/tclObj.c b/generic/tclObj.c index c4d636a..e67dfab 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -1620,7 +1620,7 @@ Tcl_GetString( /* *---------------------------------------------------------------------- * - * Tcl_GetStringFromObj -- + * Tcl_GetStringFromObj/TclGetStringFromObj -- * * Returns the string representation's byte array pointer and length for * an object. @@ -1640,12 +1640,12 @@ Tcl_GetString( *---------------------------------------------------------------------- */ -#undef Tcl_GetStringFromObj +#undef TclGetStringFromObj char * -Tcl_GetStringFromObj( +TclGetStringFromObj( Tcl_Obj *objPtr, /* Object whose string rep byte pointer should * be returned. */ - size_t *lengthPtr) /* If non-NULL, the location where the string + int *lengthPtr) /* If non-NULL, the location where the string * rep's byte array length should * be stored. * If NULL, no length is stored. */ { @@ -1675,16 +1675,17 @@ Tcl_GetStringFromObj( } } if (lengthPtr != NULL) { - *lengthPtr = objPtr->length; + *lengthPtr = (objPtr->length < INT_MAX)? objPtr->length: INT_MAX; } return objPtr->bytes; } +#undef Tcl_GetStringFromObj char * -TclGetStringFromObj( +Tcl_GetStringFromObj( Tcl_Obj *objPtr, /* Object whose string rep byte pointer should * be returned. */ - int *lengthPtr) /* If non-NULL, the location where the string + size_t *lengthPtr) /* If non-NULL, the location where the string * rep's byte array length should * be stored. * If NULL, no length is stored. */ { @@ -1706,7 +1707,7 @@ TclGetStringFromObj( objPtr->typePtr->name); } objPtr->typePtr->updateStringProc(objPtr); - if (objPtr->bytes == NULL || objPtr->length == TCL_INDEX_NONE + if (objPtr->bytes == NULL || objPtr->bytes[objPtr->length] != '\0') { Tcl_Panic("UpdateStringProc for type '%s' " "failed to create a valid string rep", @@ -1714,11 +1715,12 @@ TclGetStringFromObj( } } if (lengthPtr != NULL) { - *lengthPtr = (objPtr->length < INT_MAX)? objPtr->length: INT_MAX; + *lengthPtr = objPtr->length; } return objPtr->bytes; } + /* *---------------------------------------------------------------------- * @@ -2484,6 +2486,7 @@ Tcl_GetIntFromObj( return TCL_OK; #endif } + /* *---------------------------------------------------------------------- @@ -3909,8 +3912,8 @@ TclHashObjKey( void *keyPtr) /* Key from which to compute hash value. */ { Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr; - const char *string = TclGetString(objPtr); - size_t length = objPtr->length; + size_t length; + const char *string = Tcl_GetStringFromObj(objPtr, &length); TCL_HASH_TYPE result = 0; /* diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index dfadf74..c428552 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -5190,23 +5190,23 @@ TclFormatNaN( #else union { double dv; - unsigned long long iv; + uint64_t iv; } bitwhack; bitwhack.dv = value; if (n770_fp) { bitwhack.iv = Nokia770Twiddle(bitwhack.iv); } - if (bitwhack.iv & (1ULL << 63)) { - bitwhack.iv &= ~ (1ULL << 63); + if (bitwhack.iv & (UINT64_C(1) << 63)) { + bitwhack.iv &= ~ (UINT64_C(1) << 63); *buffer++ = '-'; } *buffer++ = 'N'; *buffer++ = 'a'; *buffer++ = 'N'; - bitwhack.iv &= ((1ULL) << 51) - 1; + bitwhack.iv &= ((UINT64_C(1)) << 51) - 1; if (bitwhack.iv != 0) { - sprintf(buffer, "(%" TCL_LL_MODIFIER "x)", bitwhack.iv); + sprintf(buffer, "(%" PRIx64 ")", bitwhack.iv); } else { *buffer = '\0'; } diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 3b65d99..dc47f3f 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -578,7 +578,7 @@ Tcl_GetUniChar( /* *---------------------------------------------------------------------- * - * Tcl_GetUnicodeFromObj -- + * Tcl_GetUnicodeFromObj/TclGetUnicodeFromObj -- * * Get the Unicode form of the String object with length. If the object * is not already a String object, it will be converted to one. If the @@ -596,10 +596,10 @@ Tcl_GetUniChar( #undef Tcl_GetUnicodeFromObj Tcl_UniChar * -Tcl_GetUnicodeFromObj( +TclGetUnicodeFromObj( Tcl_Obj *objPtr, /* The object to find the unicode string * for. */ - size_t *lengthPtr) /* If non-NULL, the location where the string + int *lengthPtr) /* If non-NULL, the location where the string * rep's unichar length should be stored. If * NULL, no length is stored. */ { @@ -620,10 +620,10 @@ Tcl_GetUnicodeFromObj( } Tcl_UniChar * -TclGetUnicodeFromObj( +Tcl_GetUnicodeFromObj( Tcl_Obj *objPtr, /* The object to find the unicode string * for. */ - int *lengthPtr) /* If non-NULL, the location where the string + size_t *lengthPtr) /* If non-NULL, the location where the string * rep's unichar length should be stored. If * NULL, no length is stored. */ { -- cgit v0.12 From 5a30c6515f08410a8064d8ecf30a152996e7d189 Mon Sep 17 00:00:00 2001 From: dgp Date: Sat, 6 Nov 2021 18:12:01 +0000 Subject: Eliminate more branch diffs. --- generic/tclStringObj.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index dc47f3f..d66e0d0 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -614,7 +614,7 @@ TclGetUnicodeFromObj( } if (lengthPtr != NULL) { - *lengthPtr = stringPtr->numChars; + *lengthPtr = (int)stringPtr->numChars; } return stringPtr->unicode; } @@ -642,7 +642,7 @@ Tcl_GetUnicodeFromObj( } return stringPtr->unicode; } - + /* *---------------------------------------------------------------------- * -- cgit v0.12 From 084b76b92a5ec029401f05a4138c1559602c23e7 Mon Sep 17 00:00:00 2001 From: dgp Date: Sun, 7 Nov 2021 04:25:39 +0000 Subject: Updates to TIP 568 implementation for Tcl 9: Use the argument numBytes instead of length. Update the docs to the TIP spec. Clarify and simplify the code. --- doc/ByteArrObj.3 | 176 ++++++++++++++++++++++++++++++---------------- doc/binary.n | 11 +-- generic/tclBinary.c | 196 +++++++++++++++------------------------------------- generic/tclDecls.h | 4 +- 4 files changed, 181 insertions(+), 206 deletions(-) diff --git a/doc/ByteArrObj.3 b/doc/ByteArrObj.3 index 053401a..7fdaea6 100644 --- a/doc/ByteArrObj.3 +++ b/doc/ByteArrObj.3 @@ -4,87 +4,147 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.TH Tcl_ByteArrayObj 3 8.1 Tcl "Tcl Library Procedures" +.TH Tcl_ByteArrayObj 3 9.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME -Tcl_NewByteArrayObj, Tcl_SetByteArrayObj, Tcl_GetByteArrayFromObj, Tcl_SetByteArrayLength \- manipulate Tcl values as a arrays of bytes +Tcl_NewByteArrayObj, Tcl_SetByteArrayObj, Tcl_GetBytesFromObj, Tcl_GetByteArrayFromObj, Tcl_SetByteArrayLength \- manipulate a Tcl value as an array of bytes .SH SYNOPSIS .nf \fB#include \fR .sp Tcl_Obj * -\fBTcl_NewByteArrayObj\fR(\fIbytes, length\fR) +\fBTcl_NewByteArrayObj\fR(\fIbytes, numBytes\fR) .sp void -\fBTcl_SetByteArrayObj\fR(\fIobjPtr, bytes, length\fR) +\fBTcl_SetByteArrayObj\fR(\fIobjPtr, bytes, numBytes\fR) .sp +.VS TIP568 unsigned char * -\fBTcl_GetByteArrayFromObj\fR(\fIobjPtr, lengthPtr\fR) +\fBTcl_GetBytesFromObj\fR(\fIinterp, objPtr, numBytesPtr\fR) +.VE TIP568 .sp unsigned char * -\fBTcl_SetByteArrayLength\fR(\fIobjPtr, length\fR) +\fBTcl_GetByteArrayFromObj\fR(\fIobjPtr, numBytesPtr\fR) +.sp +unsigned char * +\fBTcl_SetByteArrayLength\fR(\fIobjPtr, numBytes\fR) .SH ARGUMENTS -.AS "const unsigned char" *lengthPtr in/out +.AS "const unsigned char" *numBytesPtr in/out .AP "const unsigned char" *bytes in The array of bytes used to initialize or set a byte-array value. May be NULL -even if \fIlength\fR is non-zero. -.AP size_t length in -The length of the array of bytes. +even if \fInumBytes\fR is non-zero. +.AP size_t numBytes in +The number of bytes in the array. .AP Tcl_Obj *objPtr in/out -For \fBTcl_SetByteArrayObj\fR, this points to the value to be converted to -byte-array type. For \fBTcl_GetByteArrayFromObj\fR and -\fBTcl_SetByteArrayLength\fR, this points to the value from which to get -the byte-array value; if \fIobjPtr\fR does not already point to a byte-array -value, it will be converted to one. -.AP size_t | int *lengthPtr out -Filled with the length of the array of bytes in the value. -May be (int *)NULL when not used. +For \fBTcl_SetByteArrayObj\fR, this points to an unshared value to be +overwritten by a byte-array value. For \fBTcl_GetBytesFromObj\fR, +\fBTcl_GetByteArrayFromObj\fR and \fBTcl_SetByteArrayLength\fR, this points +to the value from which to extract an array of bytes. +.AP Tcl_Interp *interp in +Interpreter to use for error reporting. +.AP "size_t | int" *numBytesPtr out +Points to space where the number of bytes in the array may be written. +Caller may pass NULL when it does not need this information. .BE .SH DESCRIPTION .PP -These procedures are used to create, modify, and read Tcl byte-array values -from C code. Byte-array values are typically used to hold the -results of binary IO operations or data structures created with the -\fBbinary\fR command. In Tcl, an array of bytes is not equivalent to a -string. Conceptually, a string is an array of Unicode characters, while a -byte-array is an array of 8-bit quantities with no implicit meaning. -Accessor functions are provided to get the string representation of a -byte-array or to convert an arbitrary value to a byte-array. Obtaining the +These routines are used to create, modify, store, transfer, and retrieve +arbitrary binary data in Tcl values. Specifically, data that can be +represented as a sequence of arbitrary byte values is supported. +This includes data read from binary channels, values created by the +\fBbinary\fR command, encrypted data, or other information representable as +a finite byte sequence. +.PP +A byte is an 8-bit quantity with no inherent meaning. When the 8 bits are +interpreted as an integer value, the range of possible values is (0-255). +The C type best suited to store a byte is the \fBunsigned char\fR. +An \fBunsigned char\fR array of size \fIN\fR stores an aribtrary binary +value of size \fIN\fR bytes. We call this representation a byte-array. +Here we document the routines that allow us to operate on Tcl values as +byte-arrays. +.PP +All Tcl values must correspond to a string representation. +When a byte-array value must be processed as a string, the sequence +of \fIN\fR bytes is transformed into the corresponding sequence +of \fIN\fR characters, where each byte value transforms to the same +character codepoint value in the range (U+0000 - U+00FF). Obtaining the string representation of a byte-array value (by calling -\fBTcl_GetStringFromObj\fR) produces a properly formed UTF-8 sequence with a -one-to-one mapping between the bytes in the internal representation and the -UTF-8 characters in the string representation. +\fBTcl_GetStringFromObj\fR) produces this string in Tcl's usual +Modified UTF-8 encoding. .PP -\fBTcl_NewByteArrayObj\fR and \fBTcl_SetByteArrayObj\fR will -create a new value of byte-array type or modify an existing value to have a -byte-array type. Both of these procedures set the value's type to be -byte-array and set the value's internal representation to a copy of the -array of bytes given by \fIbytes\fR. \fBTcl_NewByteArrayObj\fR returns a -pointer to a newly allocated value with a reference count of zero. -\fBTcl_SetByteArrayObj\fR invalidates any old string representation and, if -the value is not already a byte-array value, frees any old internal -representation. If \fIbytes\fR is NULL then the new byte array contains -arbitrary values. +\fBTcl_NewByteArrayObj\fR and \fBTcl_SetByteArrayObj\fR +create a new value or overwrite an existing unshared value, respectively, +to hold a byte-array value of \fInumBytes\fR bytes. When a caller +passes a non-NULL value of \fIbytes\fR, it must point to memory from +which \fInumBytes\fR bytes can be read. These routines +allocate \fInumBytes\fR bytes of memory, copy \fInumBytes\fR +bytes from \fIbytes\fR into it, and keep the result in the internal +representation of the new or overwritten value. +When the caller passes a NULL value of \fIbytes\fR, the data copying +step is skipped, and the bytes stored in the value are undefined. +A \fIbytes\fR value of NULL is useful only when the caller will arrange +to write known contents into the byte-array through a pointer retrieved +by a call to one of the routines explained below. \fBTcl_NewByteArrayObj\fR +returns a pointer to the created value with a reference count of zero. +\fBTcl_SetByteArrayObj\fR overwrites and invalidates any old contents +of the unshared \fIobjPtr\fR as appropriate, and keeps its reference +count (0 or 1) unchanged. The value produced by these routines has no +string representation. Any memory allocation failure may cause a panic. .PP -\fBTcl_GetByteArrayFromObj\fR converts a Tcl value to byte-array type and -returns a pointer to the value's new internal representation as an array of -bytes. The length of this array is stored in \fIlengthPtr\fR if -\fIlengthPtr\fR is non-NULL. The storage for the array of bytes is owned by -the value and should not be freed. The contents of the array may be -modified by the caller only if the value is not shared and the caller -invalidates the string representation. +\fBTcl_GetBytesFromObj\fR performs the opposite function of +\fBTcl_SetByteArrayObj\fR, providing access to read a byte-array from +a Tcl value that was previously written into it. When \fIobjPtr\fR +is a value previously produced by \fBTcl_NewByteArrayObj\fR or +\fBTcl_SetByteArrayObj\fR, then \fBTcl_GetBytesFromObj\fR returns +a pointer to the byte-array kept in the value's internal representation. +If the caller provides a non-NULL value for \fInumBytesPtr\fR, it must +point to memory where \fBTcl_GetBytesFromObj\fR can write the number +of bytes in the value's internal byte-array. With both pieces of +information, the caller is able to retrieve any information about the +contents of that byte-array that it seeks. When \fIobjPtr\fR does +not already contain an internal byte-array, \fBTcl_GetBytesFromObj\fR +will try to create one from the value's string representation. Any +string value that does not include any character codepoints outside +the range (U+0000 - U+00FF) will successfully translate to a unique +byte-array value. With the created byte-array, the routine returns +as before. For any string representation which does contain +a forbidden character codepoint, the conversion fails, and +\fBTcl_GetBytesFromObj\fR returns NULL to signal that failure. On +failure, nothing will be written to \fInumBytesPtr\fR, and if +the \fIinterp\fR argument is non-NULL, then error messages and +codes are left in it recording the error. .PP -\fBTcl_SetByteArrayLength\fR converts the Tcl value to byte-array type -and changes the length of the value's internal representation as an -array of bytes. If \fIlength\fR is greater than the space currently -allocated for the array, the array is reallocated to the new length; the -newly allocated bytes at the end of the array have arbitrary values. If -\fIlength\fR is less than the space currently allocated for the array, -the length of array is reduced to the new length. The return value is a -pointer to the value's new array of bytes. - +\fBTcl_GetByteArrayFromObj\fR performs exactly the same function as +\fBTcl_GetBytesFromObj\fR does when called with the \fIinterp\fR +argument passed the value NULL. This is incompatible with the +way \fBTcl_GetByteArrayFromObj\fR functioned in Tcl 8. +\fBTcl_GetBytesFromObj\fR is the more capable interface and should +usually be favored for use over \fBTcl_GetByteArrayFromObj\fR. +.PP +On success, both \fBTcl_GetByteFromObj\fR and \fBTcl_GetByteArrayFromObj\fR +return a pointer into the internal representation of a \fBTcl_Obj\fR. +That pointer must not be freed by the caller, and should not be retained +for use beyond the known time the internal representation of the value +has not been disturbed. The pointer may be used to overwrite the byte +contents of the internal representation, so long as the value is unshared +and any string representation is invalidated. +.PP +\fBTcl_SetByteArrayLength\fR enables a caller to change the size of a +byte-array in the internal representation of an unshared \fIobjPtr\fR to +become \fInumBytes\fR bytes. This is most often useful after the +bytes of the internal byte-array have been directly overwritten and it +has been discovered that the required size differs from the first +estimate used in the allocation. \fBTcl_SetByteArrayLength\fR returns +a pointer to the resized byte-array. Because resizing the byte-array +changes the internal representation, \fBTcl_SetByteArrayLength\fR +also invalidates any string representation in \fIobjPtr\fR. If resizing +grows the byte-array, the new byte values are undefined. If \fIobjPtr\fR +does not already possess an internal byte-array, one is produced in the +same way that \fBTcl_GetBytesFromObj\fR does, also returning NULL +when any characters of the value in \fIobjPtr\fR (up to +\fInumBytes\fR of them) are not valid bytes. .SH "REFERENCE COUNT MANAGEMENT" .PP \fBTcl_NewByteArrayObj\fR always returns a zero-reference object, much @@ -94,11 +154,11 @@ like \fBTcl_NewObj\fR. reference count of their \fIobjPtr\fR arguments, but do require that the object be unshared. .PP -\fBTcl_GetByteArrayFromObj\fR does not modify the reference count of its -\fIobjPtr\fR argument; it only reads. +\fBTcl_GetBytesFromObj\fR and \fBTcl_GetByteArrayFromObj\fR do not modify +the reference count of \fIobjPtr\fR; they only read. .SH "SEE ALSO" Tcl_GetStringFromObj, Tcl_NewObj, Tcl_IncrRefCount, Tcl_DecrRefCount .SH KEYWORDS -value, binary data, byte array, utf, unicode, internationalization +value, binary data, byte array, utf, unicode diff --git a/doc/binary.n b/doc/binary.n index 9ab694e..1a62ad6 100644 --- a/doc/binary.n +++ b/doc/binary.n @@ -44,8 +44,9 @@ the range \eu0000\-\eu00FF. When encoding binary data as a readable string, the starting binary data is passed to the \fBbinary encode\fR command, together with the name of the encoding to use and any encoding-specific options desired. Data which has been -encoded can be converted back to binary form using \fBbinary decode\fR. The -following formats and options are supported. +encoded can be converted back to binary form using \fBbinary decode\fR. +The \fBbinary encode\fR command raises an error if the \fIdata\fR argument +is not binary data. The following formats and options are supported. .TP \fBbase64\fR . @@ -607,9 +608,9 @@ will return .PP The \fBbinary scan\fR command parses fields from a binary string, returning the number of conversions performed. \fIString\fR gives the -input bytes to be parsed (one byte per character, and characters not -representable as a byte have their high bits chopped) -and \fIformatString\fR indicates how to parse it. +input bytes to be parsed and \fIformatString\fR indicates how to parse it. +An error is raised if \fIstring\fR is anything other than a valid binary +data value. Each \fIvarName\fR gives the name of a variable; when a field is scanned from \fIstring\fR the result is assigned to the corresponding variable. diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 0486521..af16ca0 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -140,84 +140,21 @@ static const EnsembleImplMap decodeMap[] = { }; /* - * The following object types represent an array of bytes. The intent is to + * The following Tcl_ObjType represents an array of bytes. The intent is to * allow arbitrary binary data to pass through Tcl as a Tcl value without loss * or damage. Such values are useful for things like encoded strings or Tk * images to name just two. * * A bytearray is an ordered sequence of bytes. Each byte is an integer value * in the range [0-255]. To be a Tcl value type, we need a way to encode each - * value in the value set as a Tcl string. The simplest encoding is to + * value in the value set as a Tcl string. A simple encoding is to * represent each byte value as the same codepoint value. A bytearray of N * bytes is encoded into a Tcl string of N characters where the codepoint of * each character is the value of corresponding byte. This approach creates a * one-to-one map between all bytearray values and a subset of Tcl string - * values. - * - * When converting a Tcl string value to the bytearray internal rep, the - * question arises what to do with strings outside that subset? That is, - * those Tcl strings containing at least one codepoint greater than 255? The - * obviously correct answer is to raise an error! That string value does not - * represent any valid bytearray value. Full Stop. The setFromAnyProc - * signature has a completion code return value for just this reason, to - * reject invalid inputs. - * - * Unfortunately this was not the path taken by the authors of the original - * tclByteArrayType. They chose to accept all Tcl string values as acceptable - * string encodings of the bytearray values that result from masking away the - * high bits of any codepoint value at all. This meant that every bytearray - * value had multiple accepted string representations. - * - * The implications of this choice are truly ugly. When a Tcl value has a - * string representation, we are required to accept that as the true value. - * Bytearray values that possess a string representation cannot be processed - * as bytearrays because we cannot know which true value that bytearray - * represents. The consequence is that we drag around an internal rep that we - * cannot make any use of. This painful price is extracted at any point after - * a string rep happens to be generated for the value. This happens even when - * the troublesome codepoints outside the byte range never show up. This - * happens rather routinely in normal Tcl operations unless we burden the - * script writer with the cognitive burden of avoiding it. The price is also - * paid by callers of the C interface. The routine - * - * unsigned char *Tcl_GetByteArrayFromObj(objPtr, lenPtr) - * - * has a guarantee to always return a non-NULL value, but that value points to - * a byte sequence that cannot be used by the caller to process the Tcl value - * absent some sideband testing that objPtr is "pure". Tcl offers no public - * interface to perform this test, so callers either break encapsulation or - * are unavoidably buggy. Tcl has defined a public interface that cannot be - * used correctly. The Tcl source code itself suffers the same problem, and - * has been buggy, but progressively less so as more and more portions of the - * code have been retrofitted with the required "purity testing". The set of - * values able to pass the purity test can be increased via the introduction - * of a "canonical" flag marker, but the only way the broken interface itself - * can be discarded is to start over and define the Tcl_ObjType properly. - * Bytearrays should simply be usable as bytearrays without a kabuki dance of - * testing. - * - * The Tcl_ObjType "properByteArrayType" is (nearly) a correct implementation - * of bytearrays. Any Tcl value with the type properByteArrayType can have - * its bytearray value fetched and used with confidence that acting on that - * value is equivalent to acting on the true Tcl string value. This still - * implies a side testing burden -- past mistakes will not let us avoid that - * immediately, but it is at least a conventional test of type, and can be - * implemented entirely by examining the objPtr fields, with no need to query - * the intrep, as a canonical flag would require. - * - * Until Tcl_GetByteArrayFromObj() and Tcl_SetByteArrayLength() can be revised - * to admit the possibility of returning NULL when the true value is not a - * valid bytearray, we need a mechanism to retain compatibility with the - * deployed callers of the broken interface. That's what the retained - * "tclByteArrayType" provides. In those unusual circumstances where we - * convert an invalid bytearray value to a bytearray type, it is to this - * legacy type. Essentially any time this legacy type gets used, it's a - * signal of a bug being ignored. A TIP should be drafted to remove this - * connection to the broken past so that Tcl 9 will no longer have any trace - * of it. Prescribing a migration path will be the key element of that work. - * The internal changes now in place are the limit of what can be done short - * of interface repair. They provide a great expansion of the histories over - * which bytearray values can be useful in the meanwhile. + * values. Tcl string values outside that subset do no represent any valid + * bytearray value. Attempts to treat those values as bytearrays will lead + * to errors. See TIP 568 for how this differs from Tcl 8. */ static const Tcl_ObjType properByteArrayType = { @@ -282,15 +219,15 @@ Tcl_Obj * Tcl_NewByteArrayObj( const unsigned char *bytes, /* The array of bytes used to initialize the * new object. */ - size_t length) /* Length of the array of bytes */ + size_t numBytes) /* Number of bytes in the array */ { #ifdef TCL_MEM_DEBUG - return Tcl_DbNewByteArrayObj(bytes, length, "unknown", 0); + return Tcl_DbNewByteArrayObj(bytes, numBytes, "unknown", 0); #else /* if not TCL_MEM_DEBUG */ Tcl_Obj *objPtr; TclNewObj(objPtr); - Tcl_SetByteArrayObj(objPtr, bytes, length); + Tcl_SetByteArrayObj(objPtr, bytes, numBytes); return objPtr; #endif /* TCL_MEM_DEBUG */ } @@ -311,7 +248,7 @@ Tcl_NewByteArrayObj( * result of calling Tcl_NewByteArrayObj. * * Results: - * The newly create object is returned. This object will have no initial + * The newly created object is returned. This object has no initial * string representation. The returned object has a ref count of 0. * * Side effects: @@ -325,7 +262,7 @@ Tcl_Obj * Tcl_DbNewByteArrayObj( const unsigned char *bytes, /* The array of bytes used to initialize the * new object. */ - size_t length, /* Length of the array of bytes. */ + size_t numBytes, /* Number of bytes in the array */ const char *file, /* The name of the source file calling this * procedure; used for debugging. */ int line) /* Line number in the source file; used for @@ -334,7 +271,7 @@ Tcl_DbNewByteArrayObj( Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); - Tcl_SetByteArrayObj(objPtr, bytes, length); + Tcl_SetByteArrayObj(objPtr, bytes, numBytes); return objPtr; } #else /* if not TCL_MEM_DEBUG */ @@ -342,12 +279,11 @@ Tcl_Obj * Tcl_DbNewByteArrayObj( const unsigned char *bytes, /* The array of bytes used to initialize the * new object. */ - size_t length, /* Length of the array of bytes, which must be - * >= 0. */ + size_t numBytes, /* Number of bytes in the array */ TCL_UNUSED(const char *) /*file*/, TCL_UNUSED(int) /*line*/) { - return Tcl_NewByteArrayObj(bytes, length); + return Tcl_NewByteArrayObj(bytes, numBytes); } #endif /* TCL_MEM_DEBUG */ @@ -373,9 +309,8 @@ void Tcl_SetByteArrayObj( Tcl_Obj *objPtr, /* Object to initialize as a ByteArray. */ const unsigned char *bytes, /* The array of bytes to use as the new value. - * May be NULL even if length > 0. */ - size_t length) /* Length of the array of bytes, which must - * be >= 0. */ + * May be NULL even if numBytes > 0. */ + size_t numBytes) /* Number of bytes in the array */ { ByteArray *byteArrayPtr; Tcl_ObjInternalRep ir; @@ -385,12 +320,12 @@ Tcl_SetByteArrayObj( } TclInvalidateStringRep(objPtr); - byteArrayPtr = (ByteArray *)Tcl_Alloc(BYTEARRAY_SIZE(length)); - byteArrayPtr->used = length; - byteArrayPtr->allocated = length; + byteArrayPtr = (ByteArray *)Tcl_Alloc(BYTEARRAY_SIZE(numBytes)); + byteArrayPtr->used = numBytes; + byteArrayPtr->allocated = numBytes; - if ((bytes != NULL) && (length > 0)) { - memcpy(byteArrayPtr->bytes, bytes, length); + if ((bytes != NULL) && (numBytes > 0)) { + memcpy(byteArrayPtr->bytes, bytes, numBytes); } SET_BYTEARRAY(&ir, byteArrayPtr); @@ -408,8 +343,8 @@ Tcl_SetByteArrayObj( * interp (if not NULL). * * Results: - * Pointer to array of bytes, or NULL. representing the ByteArray object. - * Writes number of bytes in array to *lengthPtr. + * NULL or pointer to array of bytes representing the ByteArray object. + * Writes number of bytes in array to *numBytesPtr. * *---------------------------------------------------------------------- */ @@ -419,11 +354,12 @@ unsigned char * Tcl_GetBytesFromObj( Tcl_Interp *interp, /* For error reporting */ Tcl_Obj *objPtr, /* Value to extract from */ - size_t *lengthPtr) /* If non-NULL, filled with length of the - * array of bytes in the ByteArray object. */ + size_t *numBytesPtr) /* If non-NULL, write the number of bytes + * in the array here */ { ByteArray *baPtr; - const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &properByteArrayType); + const Tcl_ObjInternalRep *irPtr + = TclFetchInternalRep(objPtr, &properByteArrayType); if (irPtr == NULL) { if (TCL_ERROR == SetByteArrayFromAny(interp, TCL_INDEX_NONE, objPtr)) { @@ -433,8 +369,8 @@ Tcl_GetBytesFromObj( } baPtr = GET_BYTEARRAY(irPtr); - if (lengthPtr != NULL) { - *lengthPtr = baPtr->used; + if (numBytesPtr != NULL) { + *numBytesPtr = baPtr->used; } return baPtr->bytes; } @@ -443,26 +379,25 @@ unsigned char * TclGetBytesFromObj( Tcl_Interp *interp, /* For error reporting */ Tcl_Obj *objPtr, /* Value to extract from */ - int *lengthPtr) /* If non-NULL, filled with length of the - * array of bytes in the ByteArray object. */ + int *numBytesPtr) /* If non-NULL, write the number of bytes + * in the array here */ { size_t numBytes = 0; unsigned char *bytes = Tcl_GetBytesFromObj(interp, objPtr, &numBytes); - if (lengthPtr) { + if (bytes && numBytesPtr) { if (numBytes > INT_MAX) { - /* Caller asked for an int length, but true length is outside - * the int range. This case will be developed out of existence - * in Tcl 9. As interim measure, fail. */ + /* Caller asked for numBytes to be written to an int, but the + * value is outside the int range. */ if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "byte sequence length exceeds INT_MAX", -1)); + Tcl_SetErrorCode(interp, "TCL", "API", "OUTDATED", NULL); } - *lengthPtr = 0; return NULL; } else { - *lengthPtr = (int) numBytes; + *numBytesPtr = (int) numBytes; } } return bytes; @@ -490,42 +425,19 @@ TclGetBytesFromObj( unsigned char * TclGetByteArrayFromObj( Tcl_Obj *objPtr, /* The ByteArray object. */ - int *lengthPtr) /* If non-NULL, filled with length of the - * array of bytes in the ByteArray object. */ + int *numBytesPtr) /* If non-NULL, write the number of bytes + * in the array here */ { - size_t numBytes = 0; - unsigned char *bytes = Tcl_GetBytesFromObj(NULL, objPtr, &numBytes); - - /* Macro TclGetByteArrayFromObj passes NULL for lengthPtr as - * a trick to get around changing size. */ - if (lengthPtr) { - if (numBytes > INT_MAX) { - /* Caller asked for an int length, but true length is outside - * the int range. */ - *lengthPtr = 0; - return NULL; - } else { - *lengthPtr = (int) numBytes; - } - } - return bytes; + return TclGetBytesFromObj(NULL, objPtr, numBytesPtr); } unsigned char * Tcl_GetByteArrayFromObj( Tcl_Obj *objPtr, /* The ByteArray object. */ - size_t *lengthPtr) /* If non-NULL, filled with length of the - * array of bytes in the ByteArray object. */ + size_t *numBytesPtr) /* If non-NULL, write the number of bytes + * in the array here */ { - size_t numBytes = 0; - unsigned char *bytes = Tcl_GetBytesFromObj(NULL, objPtr, &numBytes); - - /* Macro TclGetByteArrayFromObj passes NULL for lengthPtr as - * a trick to get around changing size. */ - if (lengthPtr) { - *lengthPtr = numBytes; - } - return bytes; + return Tcl_GetBytesFromObj(NULL, objPtr, numBytesPtr); } /* @@ -553,7 +465,7 @@ Tcl_GetByteArrayFromObj( unsigned char * Tcl_SetByteArrayLength( Tcl_Obj *objPtr, /* The ByteArray object. */ - size_t length) /* New length for internal byte array. */ + size_t numBytes) /* Number of bytes in resized array */ { ByteArray *byteArrayPtr; Tcl_ObjInternalRep *irPtr; @@ -564,20 +476,21 @@ Tcl_SetByteArrayLength( irPtr = TclFetchInternalRep(objPtr, &properByteArrayType); if (irPtr == NULL) { - if (TCL_ERROR == SetByteArrayFromAny(NULL, length, objPtr)) { + if (TCL_ERROR == SetByteArrayFromAny(NULL, numBytes, objPtr)) { return NULL; } irPtr = TclFetchInternalRep(objPtr, &properByteArrayType); } byteArrayPtr = GET_BYTEARRAY(irPtr); - if (length > byteArrayPtr->allocated) { - byteArrayPtr = (ByteArray *)Tcl_Realloc(byteArrayPtr, BYTEARRAY_SIZE(length)); - byteArrayPtr->allocated = length; + if (numBytes > byteArrayPtr->allocated) { + byteArrayPtr = (ByteArray *)Tcl_Realloc(byteArrayPtr, + BYTEARRAY_SIZE(numBytes)); + byteArrayPtr->allocated = numBytes; SET_BYTEARRAY(irPtr, byteArrayPtr); } TclInvalidateStringRep(objPtr); - byteArrayPtr->used = length; + byteArrayPtr->used = numBytes; return byteArrayPtr->bytes; } @@ -645,7 +558,7 @@ MakeByteArray( *dst++ = UCHAR(ch); } byteArrayPtr->used = dst - byteArrayPtr->bytes; - byteArrayPtr->allocated = length; + byteArrayPtr->allocated = numBytes; *byteArrayPtrPtr = byteArrayPtr; return proper; @@ -873,9 +786,14 @@ TclAppendBytesToByteArray( } byteArrayPtr = GET_BYTEARRAY(irPtr); + /* Size limit check now commented out. Used to protect calls to + * Tcl_*Alloc*() limited by unsigned int arguments. + * if (len > UINT_MAX - byteArrayPtr->used) { Tcl_Panic("max size for a Tcl value (%u bytes) exceeded", UINT_MAX); } + * + */ needed = byteArrayPtr->used + len; /* @@ -899,11 +817,7 @@ TclAppendBytesToByteArray( * Try to allocate double the increment that is needed (plus). */ - size_t limit = UINT_MAX - needed; - size_t extra = len + TCL_MIN_GROWTH; - size_t growth = (extra > limit) ? limit : extra; - - attempt = needed + growth; + attempt = needed + len + TCL_MIN_GROWTH; ptr = (ByteArray *)Tcl_AttemptRealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt)); } if (ptr == NULL) { diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 71e49c4..459ddc5 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -3839,14 +3839,14 @@ extern const TclStubs *tclStubsPtr; #define Tcl_GetStringFromObj(objPtr, sizePtr) \ (sizeof(*sizePtr) <= sizeof(int) ? tclStubsPtr->tclGetStringFromObj(objPtr, (int *)sizePtr) : tclStubsPtr->tcl_GetStringFromObj(objPtr, (size_t *)sizePtr)) #define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ - (sizeof(*sizePtr) <= sizeof(int) ? tclStubsPtr->tclGetByteArrayFromObj(objPtr, (int *)sizePtr) : tclStubsPtr->tcl_GetByteArrayFromObj(objPtr, (size_t *)sizePtr)) + (sizeof(*sizePtr) <= sizeof(int) ? tclStubsPtr->tclGetBytesFromObj(NULL, objPtr, (int *)sizePtr) : tclStubsPtr->tcl_GetBytesFromObj(NULL, objPtr, (size_t *)sizePtr)) #define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \ (sizeof(*sizePtr) <= sizeof(int) ? tclStubsPtr->tclGetUnicodeFromObj(objPtr, (int *)sizePtr) : tclStubsPtr->tcl_GetUnicodeFromObj(objPtr, (size_t *)sizePtr)) #else #define Tcl_GetStringFromObj(objPtr, sizePtr) \ (sizeof(*sizePtr) <= sizeof(int) ? (TclGetStringFromObj)(objPtr, (int *)sizePtr) : (Tcl_GetStringFromObj)(objPtr, (size_t *)sizePtr)) #define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ - (sizeof(*sizePtr) <= sizeof(int) ? (TclGetByteArrayFromObj)(objPtr, (int *)sizePtr) : Tcl_GetByteArrayFromObj(objPtr, (size_t *)sizePtr)) + (sizeof(*sizePtr) <= sizeof(int) ? (TclGetBytesFromObj)(NULL, objPtr, (int *)sizePtr) : Tcl_GetBytesFromObj(NULL, objPtr, (size_t *)sizePtr)) #define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \ (sizeof(*sizePtr) <= sizeof(int) ? (TclGetUnicodeFromObj)(objPtr, (int *)sizePtr) : Tcl_GetUnicodeFromObj(objPtr, (size_t *)sizePtr)) #endif -- cgit v0.12 From 2c7899f9eaac69983a697b016a7b6262ed2aa5cf Mon Sep 17 00:00:00 2001 From: dgp Date: Sun, 7 Nov 2021 14:52:29 +0000 Subject: Dodge a few macro games. --- generic/tclExecute.c | 2 +- generic/tclIO.c | 2 +- generic/tclStringObj.c | 6 +++--- generic/tclZipfs.c | 2 +- generic/tclZlib.c | 8 ++++---- 5 files changed, 10 insertions(+), 10 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 3cba67a..a216a56 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5113,7 +5113,7 @@ TEBCresume( TclNewObj(objResultPtr); } else if (TclIsPureByteArray(valuePtr)) { objResultPtr = Tcl_NewByteArrayObj( - Tcl_GetByteArrayFromObj(valuePtr, (size_t *)NULL)+index, 1); + (Tcl_GetBytesFromObj)(NULL, valuePtr, NULL)+index, 1); } else if (valuePtr->bytes && slength == valuePtr->length) { objResultPtr = Tcl_NewStringObj((const char *) valuePtr->bytes+index, 1); diff --git a/generic/tclIO.c b/generic/tclIO.c index cce7f64..9f6fc1d 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -4564,7 +4564,7 @@ Tcl_GetsObj( if ((statePtr->encoding == NULL) && ((statePtr->inputTranslation == TCL_TRANSLATE_LF) || (statePtr->inputTranslation == TCL_TRANSLATE_CR)) - && Tcl_GetByteArrayFromObj(objPtr, (size_t *)NULL) != NULL) { + && (Tcl_GetBytesFromObj)(NULL, objPtr, NULL) != NULL) { return TclGetsObjBinary(chan, objPtr); } diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index d66e0d0..cde9a1d 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -1344,7 +1344,7 @@ Tcl_AppendObjToObj( */ TclAppendBytesToByteArray(objPtr, - Tcl_GetByteArrayFromObj(appendObjPtr, (size_t *)NULL), lengthSrc); + (Tcl_GetBytesFromObj)(NULL, appendObjPtr, NULL), lengthSrc); return; } @@ -2855,7 +2855,7 @@ TclStringRepeat( done *= 2; } TclAppendBytesToByteArray(objResultPtr, - Tcl_GetByteArrayFromObj(objResultPtr, (size_t *)NULL), + (Tcl_GetBytesFromObj)(NULL, objResultPtr, NULL), (count - done) * length); } else if (unichar) { /* @@ -3732,7 +3732,7 @@ TclStringReverse( if (!inPlace || Tcl_IsShared(objPtr)) { objPtr = Tcl_NewByteArrayObj(NULL, numBytes); } - ReverseBytes(Tcl_GetByteArrayFromObj(objPtr, (size_t *)NULL), from, numBytes); + ReverseBytes((Tcl_GetBytesFromObj)(NULL, objPtr, NULL), from, numBytes); return objPtr; } diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index d9cb4ba..bfd594c 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -2412,7 +2412,7 @@ ZipFSMkKeyObjCmd( } passObj = Tcl_NewByteArrayObj(NULL, 264); - passBuf = Tcl_GetByteArrayFromObj(passObj, (int *)NULL); + passBuf = Tcl_GetBytesFromObj(NULL, passObj, NULL); while (len > 0) { int ch = pw[len - 1]; diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 6944ff6..ab42ddd 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -2351,7 +2351,7 @@ ZlibStreamSubcmd( } if (compDictObj) { - if (NULL == Tcl_GetBytesFromObj(interp, compDictObj, NULL)) { + if (NULL == (Tcl_GetBytesFromObj)(interp, compDictObj, NULL)) { return TCL_ERROR; } } @@ -2533,7 +2533,7 @@ ZlibPushSubcmd( } } - if (compDictObj && (NULL == Tcl_GetBytesFromObj(interp, compDictObj, NULL))) { + if (compDictObj && (NULL == (Tcl_GetBytesFromObj)(interp, compDictObj, NULL))) { return TCL_ERROR; } @@ -3330,7 +3330,7 @@ ZlibTransformSetOption( /* not used */ TclNewStringObj(compDictObj, value, strlen(value)); Tcl_IncrRefCount(compDictObj); - if (NULL == Tcl_GetBytesFromObj(interp, compDictObj, NULL)) { + if (NULL == (Tcl_GetBytesFromObj)(interp, compDictObj, NULL)) { Tcl_DecrRefCount(compDictObj); return TCL_ERROR; } @@ -3721,7 +3721,7 @@ ZlibStackChannelTransform( if (compDictObj != NULL) { cd->compDictObj = Tcl_DuplicateObj(compDictObj); Tcl_IncrRefCount(cd->compDictObj); - Tcl_GetByteArrayFromObj(cd->compDictObj, (size_t *)NULL); + (Tcl_GetBytesFromObj)(NULL, cd->compDictObj, NULL); } if (format == TCL_ZLIB_FORMAT_RAW) { -- cgit v0.12 From 4a0e8877b7088f635557ae59f44a7eec07eac424 Mon Sep 17 00:00:00 2001 From: dgp Date: Sun, 7 Nov 2021 21:34:20 +0000 Subject: Document the flexibility of numBytesPtr to point to int or size_t space. --- doc/ByteArrObj.3 | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/doc/ByteArrObj.3 b/doc/ByteArrObj.3 index 7fdaea6..ad1eb32 100644 --- a/doc/ByteArrObj.3 +++ b/doc/ByteArrObj.3 @@ -131,6 +131,18 @@ has not been disturbed. The pointer may be used to overwrite the byte contents of the internal representation, so long as the value is unshared and any string representation is invalidated. .PP +On success, both \fBTcl_GetBytesFromObj\fR and \fBTcl_GetByteArrayFromObj\fR +write the number of bytes in the byte-array value of \fIobjPtr\fR +to the space pointed to by \fInumBytesPtr\fR. This space may be of type +\fBsize_t\fR or of type \fBint\fR. It is recommended that callers provide +a \fBsize_t\fR space for this purpose. If the caller provides only +an \fBint\fR space and the number of bytes in the byte-array value of +\fIobjPtr\fR is greater than \fBINT_MAX\fR, the routine will fail due +to being unable to correctly report the byte-array size to the caller. +The ability to provide an \fBint\fR space is best considered a migration +aid for codebases constrained to continue operating with Tcl releases +older than 8.7. +.PP \fBTcl_SetByteArrayLength\fR enables a caller to change the size of a byte-array in the internal representation of an unshared \fIobjPtr\fR to become \fInumBytes\fR bytes. This is most often useful after the -- cgit v0.12 From 5a18f3341176bbf31f4d49e29fbb08fecc10323b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 8 Nov 2021 10:19:09 +0000 Subject: Doc fix for Tcl_GetIntForIndex() --- doc/IntObj.3 | 6 ++++-- generic/tclInt.h | 2 +- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/doc/IntObj.3 b/doc/IntObj.3 index d640dbb..703f2ce 100644 --- a/doc/IntObj.3 +++ b/doc/IntObj.3 @@ -32,7 +32,7 @@ int \fBTcl_GetIntFromObj\fR(\fIinterp, objPtr, intPtr\fR) .sp int -\fBTcl_GetIntForIndex\fR(\fIinterp, objPtr, endValue, intPtr\fR) +\fBTcl_GetIntForIndex\fR(\fIinterp, objPtr, endValue, indexPtr\fR) .sp int \fBTcl_GetLongFromObj\fR(\fIinterp, objPtr, longPtr\fR) @@ -58,7 +58,7 @@ int \fBTcl_InitBignumFromDouble\fR(\fIinterp, doubleValue, bigValue\fR) .SH ARGUMENTS .AS Tcl_WideInt doubleValue in/out -.AP int endValue in +.AP size_t endValue in \fBTcl_GetIntForIndex\fR will return this when the input value is "end". .AP int intValue in Integer value used to initialize or set a Tcl value. @@ -80,6 +80,8 @@ retrieval fails. Points to place to store the integer value retrieved from \fIobjPtr\fR. .AP long *longPtr out Points to place to store the long integer value retrieved from \fIobjPtr\fR. +.AP size_t *indexPtr out +Points to place to store the size_t value retrieved from \fIobjPtr\fR. .AP Tcl_WideInt *widePtr out Points to place to store the wide integer value retrieved from \fIobjPtr\fR. .AP mp_int *bigValue in/out diff --git a/generic/tclInt.h b/generic/tclInt.h index c2478fc..6aa7415 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4435,7 +4435,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, * already has a string representation. The caller must use * this macro properly. Improper use can lead to dangerous results. * Because "len" is referenced multiple times, take care that it is an - * expression with the same value each use. + * expression with the same value each use. * * The ANSI C "prototype" for this macro is: * -- cgit v0.12 From c5ed34e7e6933f734555cbc8eea44eaae31be32c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 4 Dec 2021 18:10:07 +0000 Subject: Rename some function argument names from "length" to "numBytes", as they are named in 8.7 --- generic/tcl.decls | 22 +++++++++++----------- generic/tclDecls.h | 28 ++++++++++++++-------------- 2 files changed, 25 insertions(+), 25 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 5b013e6..40598e9 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -109,7 +109,7 @@ declare 21 { # Tcl_Obj *Tcl_DbNewBooleanObj(int boolValue, const char *file, int line) #} declare 23 { - Tcl_Obj *Tcl_DbNewByteArrayObj(const unsigned char *bytes, size_t length, + Tcl_Obj *Tcl_DbNewByteArrayObj(const unsigned char *bytes, size_t numBytes, const char *file, int line) } declare 24 { @@ -206,7 +206,7 @@ declare 48 { # Tcl_Obj *Tcl_NewBooleanObj(int boolValue) #} declare 50 { - Tcl_Obj *Tcl_NewByteArrayObj(const unsigned char *bytes, size_t length) + Tcl_Obj *Tcl_NewByteArrayObj(const unsigned char *bytes, size_t numBytes) } declare 51 { Tcl_Obj *Tcl_NewDoubleObj(double doubleValue) @@ -233,11 +233,11 @@ declare 56 { # void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue) #} declare 58 { - unsigned char *Tcl_SetByteArrayLength(Tcl_Obj *objPtr, size_t length) + unsigned char *Tcl_SetByteArrayLength(Tcl_Obj *objPtr, size_t numBytes) } declare 59 { void Tcl_SetByteArrayObj(Tcl_Obj *objPtr, const unsigned char *bytes, - size_t length) + size_t numBytes) } declare 60 { void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue) @@ -1294,12 +1294,12 @@ declare 351 { } # Removed in 9.0: #declare 352 { -# size_t Tcl_UniCharLen(const Tcl_UniChar *uniStr) +# int Tcl_UniCharLen(const Tcl_UniChar *uniStr) #} # Removed in 9.0: #declare 353 { # int Tcl_UniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, -# size_t numChars) +# unsigned long numChars) #} declare 354 { char *Tcl_Char16ToUtfDString(const unsigned short *uniStr, @@ -1412,7 +1412,7 @@ declare 383 { # Removed in 9.0 #declare 384 { # void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, -# size_t length) +# int length) #} declare 385 { int Tcl_RegExpMatchObj(Tcl_Interp *interp, Tcl_Obj *textObj, @@ -1541,7 +1541,7 @@ declare 418 { # Removed in 9.0: #declare 419 { # int Tcl_UniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, -# size_t numChars) +# unsigned long numChars) #} # Removed in 9.0: #declare 420 { @@ -2468,11 +2468,11 @@ declare 648 { # TIP #568 declare 649 { unsigned char *TclGetBytesFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - int *lengthPtr) + int *numBytesPtr) } declare 650 { unsigned char *Tcl_GetBytesFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - size_t *lengthPtr) + size_t *numBytesPtr) } # TIP #481 @@ -2483,7 +2483,7 @@ declare 652 { Tcl_UniChar *Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, size_t *lengthPtr) } declare 653 { - unsigned char *Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, size_t *lengthPtr) + unsigned char *Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, size_t *numBytesPtr) } # TIP #575 diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 459ddc5..503823e 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -108,7 +108,7 @@ EXTERN int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file, /* Slot 22 is reserved */ /* 23 */ EXTERN Tcl_Obj * Tcl_DbNewByteArrayObj(const unsigned char *bytes, - size_t length, const char *file, int line); + size_t numBytes, const char *file, int line); /* 24 */ EXTERN Tcl_Obj * Tcl_DbNewDoubleObj(double doubleValue, const char *file, int line); @@ -180,7 +180,7 @@ EXTERN int Tcl_ListObjReplace(Tcl_Interp *interp, /* Slot 49 is reserved */ /* 50 */ EXTERN Tcl_Obj * Tcl_NewByteArrayObj(const unsigned char *bytes, - size_t length); + size_t numBytes); /* 51 */ EXTERN Tcl_Obj * Tcl_NewDoubleObj(double doubleValue); /* Slot 52 is reserved */ @@ -194,10 +194,10 @@ EXTERN Tcl_Obj * Tcl_NewStringObj(const char *bytes, size_t length); /* Slot 57 is reserved */ /* 58 */ EXTERN unsigned char * Tcl_SetByteArrayLength(Tcl_Obj *objPtr, - size_t length); + size_t numBytes); /* 59 */ EXTERN void Tcl_SetByteArrayObj(Tcl_Obj *objPtr, - const unsigned char *bytes, size_t length); + const unsigned char *bytes, size_t numBytes); /* 60 */ EXTERN void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue); /* Slot 61 is reserved */ @@ -1731,10 +1731,10 @@ EXTERN int * Tcl_UtfToUniCharDString(const char *src, size_t length, Tcl_DString *dsPtr); /* 649 */ EXTERN unsigned char * TclGetBytesFromObj(Tcl_Interp *interp, - Tcl_Obj *objPtr, int *lengthPtr); + Tcl_Obj *objPtr, int *numBytesPtr); /* 650 */ EXTERN unsigned char * Tcl_GetBytesFromObj(Tcl_Interp *interp, - Tcl_Obj *objPtr, size_t *lengthPtr); + Tcl_Obj *objPtr, size_t *numBytesPtr); /* 651 */ EXTERN char * Tcl_GetStringFromObj(Tcl_Obj *objPtr, size_t *lengthPtr); @@ -1743,7 +1743,7 @@ EXTERN Tcl_UniChar * Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, size_t *lengthPtr); /* 653 */ EXTERN unsigned char * Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, - size_t *lengthPtr); + size_t *numBytesPtr); /* 654 */ EXTERN int Tcl_UtfCharComplete(const char *src, size_t length); /* 655 */ @@ -1791,7 +1791,7 @@ typedef struct TclStubs { void (*tcl_DbIncrRefCount) (Tcl_Obj *objPtr, const char *file, int line); /* 20 */ int (*tcl_DbIsShared) (Tcl_Obj *objPtr, const char *file, int line); /* 21 */ void (*reserved22)(void); - Tcl_Obj * (*tcl_DbNewByteArrayObj) (const unsigned char *bytes, size_t length, const char *file, int line); /* 23 */ + Tcl_Obj * (*tcl_DbNewByteArrayObj) (const unsigned char *bytes, size_t numBytes, const char *file, int line); /* 23 */ Tcl_Obj * (*tcl_DbNewDoubleObj) (double doubleValue, const char *file, int line); /* 24 */ Tcl_Obj * (*tcl_DbNewListObj) (int objc, Tcl_Obj *const *objv, const char *file, int line); /* 25 */ void (*reserved26)(void); @@ -1818,7 +1818,7 @@ typedef struct TclStubs { int (*tcl_ListObjLength) (Tcl_Interp *interp, Tcl_Obj *listPtr, int *lengthPtr); /* 47 */ int (*tcl_ListObjReplace) (Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, int objc, Tcl_Obj *const objv[]); /* 48 */ void (*reserved49)(void); - Tcl_Obj * (*tcl_NewByteArrayObj) (const unsigned char *bytes, size_t length); /* 50 */ + Tcl_Obj * (*tcl_NewByteArrayObj) (const unsigned char *bytes, size_t numBytes); /* 50 */ Tcl_Obj * (*tcl_NewDoubleObj) (double doubleValue); /* 51 */ void (*reserved52)(void); Tcl_Obj * (*tcl_NewListObj) (int objc, Tcl_Obj *const objv[]); /* 53 */ @@ -1826,8 +1826,8 @@ typedef struct TclStubs { Tcl_Obj * (*tcl_NewObj) (void); /* 55 */ Tcl_Obj * (*tcl_NewStringObj) (const char *bytes, size_t length); /* 56 */ void (*reserved57)(void); - unsigned char * (*tcl_SetByteArrayLength) (Tcl_Obj *objPtr, size_t length); /* 58 */ - void (*tcl_SetByteArrayObj) (Tcl_Obj *objPtr, const unsigned char *bytes, size_t length); /* 59 */ + unsigned char * (*tcl_SetByteArrayLength) (Tcl_Obj *objPtr, size_t numBytes); /* 58 */ + void (*tcl_SetByteArrayObj) (Tcl_Obj *objPtr, const unsigned char *bytes, size_t numBytes); /* 59 */ void (*tcl_SetDoubleObj) (Tcl_Obj *objPtr, double doubleValue); /* 60 */ void (*reserved61)(void); void (*tcl_SetListObj) (Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[]); /* 62 */ @@ -2417,11 +2417,11 @@ typedef struct TclStubs { int (*tcl_UtfToUniChar) (const char *src, int *chPtr); /* 646 */ char * (*tcl_UniCharToUtfDString) (const int *uniStr, size_t uniLength, Tcl_DString *dsPtr); /* 647 */ int * (*tcl_UtfToUniCharDString) (const char *src, size_t length, Tcl_DString *dsPtr); /* 648 */ - unsigned char * (*tclGetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *lengthPtr); /* 649 */ - unsigned char * (*tcl_GetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, size_t *lengthPtr); /* 650 */ + unsigned char * (*tclGetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *numBytesPtr); /* 649 */ + unsigned char * (*tcl_GetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, size_t *numBytesPtr); /* 650 */ char * (*tcl_GetStringFromObj) (Tcl_Obj *objPtr, size_t *lengthPtr); /* 651 */ Tcl_UniChar * (*tcl_GetUnicodeFromObj) (Tcl_Obj *objPtr, size_t *lengthPtr); /* 652 */ - unsigned char * (*tcl_GetByteArrayFromObj) (Tcl_Obj *objPtr, size_t *lengthPtr); /* 653 */ + unsigned char * (*tcl_GetByteArrayFromObj) (Tcl_Obj *objPtr, size_t *numBytesPtr); /* 653 */ int (*tcl_UtfCharComplete) (const char *src, size_t length); /* 654 */ const char * (*tcl_UtfNext) (const char *src); /* 655 */ const char * (*tcl_UtfPrev) (const char *src, const char *start); /* 656 */ -- cgit v0.12 From 60f5d30e4406df3a2d80e61d7d9972dce3293133 Mon Sep 17 00:00:00 2001 From: bch Date: Fri, 28 Jan 2022 08:29:14 +0000 Subject: rejig argv/argc Tcl_MainEx() handling, prompted by outside discussion re: current [https://arstechnica.com/information-technology/2022/01/a-bug-lurking-for-12-years-gives-attackers-root-on-every-major-linux-distro/|polkit] issues, and comparisons of execve(2) abuse/mitigation (esp wrt OpenBSD); Probably most importantly, the access to argv has been limited to indexing, not swapping back/forth between indexing and advancing argv; pls review --- generic/tclMain.c | 24 +++++++++++++++--------- 1 file changed, 15 insertions(+), 9 deletions(-) diff --git a/generic/tclMain.c b/generic/tclMain.c index f175319..c2eee13 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -288,6 +288,7 @@ Tcl_MainEx( * but before starting to execute commands. */ Tcl_Interp *interp) { + int i=0; /* argv[i] index */ Tcl_Obj *path, *resultPtr, *argvPtr, *appName; const char *encodingName = NULL; int code, exitCode = 0; @@ -296,7 +297,13 @@ Tcl_MainEx( InteractiveState is; TclpSetInitialEncodings(); - TclpFindExecutable((const char *)argv[0]); + if (0 < argc) { + --argc; /* consume argv[0] */ + ++i; + } + TclpFindExecutable((const char *)argv[0]); /* nb: this could be NULL + * w/ (eg) a malformed + * execve() */ Tcl_InitMemory(interp); @@ -318,36 +325,35 @@ Tcl_MainEx( * FILENAME */ - if ((argc > 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1])) + /* mind argc is being adjusted as we proceed */ + if ((argc >= 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1])) && ('-' != argv[3][0])) { Tcl_Obj *value = NewNativeObj(argv[2]); Tcl_SetStartupScript(NewNativeObj(argv[3]), TclGetString(value)); Tcl_DecrRefCount(value); argc -= 3; - argv += 3; - } else if ((argc > 1) && ('-' != argv[1][0])) { + i += 3; + } else if ((argc >= 1) && ('-' != argv[1][0])) { Tcl_SetStartupScript(NewNativeObj(argv[1]), NULL); argc--; - argv++; + i++; } } path = Tcl_GetStartupScript(&encodingName); if (path == NULL) { - appName = NewNativeObj(argv[0]); + appName = NewNativeObj(argv[0]); // nb: argv is _not_ advanced here... } else { appName = path; } Tcl_SetVar2Ex(interp, "argv0", NULL, appName, TCL_GLOBAL_ONLY); - argc--; - argv++; Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewWideIntObj(argc), TCL_GLOBAL_ONLY); argvPtr = Tcl_NewListObj(0, NULL); while (argc--) { - Tcl_ListObjAppendElement(NULL, argvPtr, NewNativeObj(*argv++)); + Tcl_ListObjAppendElement(NULL, argvPtr, NewNativeObj(argv[i++])); } Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY); -- cgit v0.12 From 43b31960b76a22c951489e76a812d22fae7582e2 Mon Sep 17 00:00:00 2001 From: bch Date: Fri, 28 Jan 2022 10:46:06 +0000 Subject: be more strict about using argv[0] --- generic/tclMain.c | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/generic/tclMain.c b/generic/tclMain.c index c2eee13..de745bd 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -288,6 +288,7 @@ Tcl_MainEx( * but before starting to execute commands. */ Tcl_Interp *interp) { + char *progname = NULL; /* may/may-not be able to use argv[0] */ int i=0; /* argv[i] index */ Tcl_Obj *path, *resultPtr, *argvPtr, *appName; const char *encodingName = NULL; @@ -298,10 +299,11 @@ Tcl_MainEx( TclpSetInitialEncodings(); if (0 < argc) { + progname = argv[0]; --argc; /* consume argv[0] */ ++i; } - TclpFindExecutable((const char *)argv[0]); /* nb: this could be NULL + TclpFindExecutable ((const char *)progname); /* nb: this could be NULL * w/ (eg) a malformed * execve() */ @@ -343,7 +345,7 @@ Tcl_MainEx( path = Tcl_GetStartupScript(&encodingName); if (path == NULL) { - appName = NewNativeObj(argv[0]); // nb: argv is _not_ advanced here... + appName = NewNativeObj(progname); } else { appName = path; } -- cgit v0.12 From 7fc2a5ab3094bee1c0945f828ab784d9d04af625 Mon Sep 17 00:00:00 2001 From: bch Date: Sat, 29 Jan 2022 00:13:14 +0000 Subject: take advantage of what we know re: argv guarantees [https://www.iso-9899.info/n1570.html#5.1.2.2.1|argv spec] (per @cousteau on #tcl) --- generic/tclMain.c | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/generic/tclMain.c b/generic/tclMain.c index de745bd..a26577e 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -288,7 +288,6 @@ Tcl_MainEx( * but before starting to execute commands. */ Tcl_Interp *interp) { - char *progname = NULL; /* may/may-not be able to use argv[0] */ int i=0; /* argv[i] index */ Tcl_Obj *path, *resultPtr, *argvPtr, *appName; const char *encodingName = NULL; @@ -299,13 +298,12 @@ Tcl_MainEx( TclpSetInitialEncodings(); if (0 < argc) { - progname = argv[0]; --argc; /* consume argv[0] */ ++i; } - TclpFindExecutable ((const char *)progname); /* nb: this could be NULL - * w/ (eg) a malformed - * execve() */ + TclpFindExecutable ((const char *)argv [0]); /* nb: this could be NULL + * w/ (eg) an empty argv + * supplied to execve() */ Tcl_InitMemory(interp); @@ -345,7 +343,7 @@ Tcl_MainEx( path = Tcl_GetStartupScript(&encodingName); if (path == NULL) { - appName = NewNativeObj(progname); + appName = NewNativeObj(argv[0]); } else { appName = path; } -- cgit v0.12 From bf552f0a4d5c314940d025c46551b4e5062c59ac Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 17 Feb 2022 14:16:59 +0000 Subject: More int -> size_t in internal API --- generic/tclBasic.c | 2 +- generic/tclDictObj.c | 4 ++-- generic/tclInt.decls | 20 ++++++++++---------- generic/tclIntDecls.h | 39 +++++++++++++++++++-------------------- generic/tclIntPlatDecls.h | 4 ++-- generic/tclPipe.c | 13 +++++++------ generic/tclProc.c | 3 ++- unix/tclUnixPipe.c | 5 +++-- win/tclWinPipe.c | 2 +- 9 files changed, 47 insertions(+), 45 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index c8a285e..b277c5c 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4245,7 +4245,7 @@ int TclNREvalObjv( Tcl_Interp *interp, /* Interpreter in which to evaluate the * command. Also used for error reporting. */ - int objc, /* Number of words in command. */ + size_t objc, /* Number of words in command. */ Tcl_Obj *const objv[], /* An array of pointers to objects that are * the words that make up the command. */ int flags, /* Collection of OR-ed bits that control the diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 68049d0..c316d4d 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -777,12 +777,12 @@ Tcl_Obj * TclTraceDictPath( Tcl_Interp *interp, Tcl_Obj *dictPtr, - int keyc, + size_t keyc, Tcl_Obj *const keyv[], int flags) { Dict *dict, *newDict; - int i; + size_t i; DictGetInternalRep(dictPtr, dict); if (dict == NULL) { diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 817aba4..ff1f546 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -39,7 +39,7 @@ declare 7 { } # TclCreatePipeline unofficially exported for use by BLT. declare 9 { - int TclCreatePipeline(Tcl_Interp *interp, int argc, const char **argv, + size_t TclCreatePipeline(Tcl_Interp *interp, size_t argc, const char **argv, Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, TclFile *errFilePtr) } @@ -438,7 +438,7 @@ declare 224 { } declare 225 { Tcl_Obj *TclTraceDictPath(Tcl_Interp *interp, Tcl_Obj *rootPtr, - int keyc, Tcl_Obj *const keyv[], int flags) + size_t keyc, Tcl_Obj *const keyv[], int flags) } declare 226 { int TclObjBeingDeleted(Tcl_Obj *objPtr) @@ -454,7 +454,7 @@ declare 229 { declare 230 { Var *TclObjLookupVar(Tcl_Interp *interp, Tcl_Obj *part1Ptr, const char *part2, int flags, const char *msg, - const int createPart1, const int createPart2, Var **arrayPtrPtr) + int createPart1, int createPart2, Var **arrayPtrPtr) } declare 231 { int TclGetNamespaceFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, @@ -497,7 +497,7 @@ declare 238 { } declare 239 { int TclNRInterpProcCore(Tcl_Interp *interp, Tcl_Obj *procNameObj, - int skip, ProcErrorProc *errorProc) + size_t skip, ProcErrorProc *errorProc) } declare 240 { int TclNRRunCallbacks(Tcl_Interp *interp, int result, @@ -508,7 +508,7 @@ declare 241 { const CmdFrame *invoker, int word) } declare 242 { - int TclNREvalObjv(Tcl_Interp *interp, int objc, + int TclNREvalObjv(Tcl_Interp *interp, size_t objc, Tcl_Obj *const objv[], int flags, Command *cmdPtr) } @@ -557,17 +557,17 @@ declare 251 { declare 252 { Tcl_Obj *TclPtrGetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, - const int flags) + int flags) } declare 253 { Tcl_Obj *TclPtrSetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, - Tcl_Obj *newValuePtr, const int flags) + Tcl_Obj *newValuePtr, int flags) } declare 254 { Tcl_Obj *TclPtrIncrObjVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, - Tcl_Obj *incrPtr, const int flags) + Tcl_Obj *incrPtr, int flags) } declare 255 { int TclPtrObjMakeUpvar(Tcl_Interp *interp, Tcl_Var otherPtr, @@ -575,7 +575,7 @@ declare 255 { } declare 256 { int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, - Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags) + Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags) } declare 257 { void TclStaticLibrary(Tcl_Interp *interp, const char *prefix, @@ -635,7 +635,7 @@ declare 11 { void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan) } declare 15 { - int TclpCreateProcess(Tcl_Interp *interp, int argc, + int TclpCreateProcess(Tcl_Interp *interp, size_t argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr) } diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 8182676..101aedb 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -59,7 +59,7 @@ EXTERN size_t TclCopyAndCollapse(size_t count, const char *src, char *dst); /* Slot 8 is reserved */ /* 9 */ -EXTERN int TclCreatePipeline(Tcl_Interp *interp, int argc, +EXTERN size_t TclCreatePipeline(Tcl_Interp *interp, size_t argc, const char **argv, Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, TclFile *errFilePtr); @@ -469,7 +469,7 @@ EXTERN void TclPopStackFrame(Tcl_Interp *interp); EXTERN TclPlatformType * TclGetPlatform(void); /* 225 */ EXTERN Tcl_Obj * TclTraceDictPath(Tcl_Interp *interp, - Tcl_Obj *rootPtr, int keyc, + Tcl_Obj *rootPtr, size_t keyc, Tcl_Obj *const keyv[], int flags); /* 226 */ EXTERN int TclObjBeingDeleted(Tcl_Obj *objPtr); @@ -483,9 +483,8 @@ EXTERN int TclPtrMakeUpvar(Tcl_Interp *interp, Var *otherP1Ptr, /* 230 */ EXTERN Var * TclObjLookupVar(Tcl_Interp *interp, Tcl_Obj *part1Ptr, const char *part2, - int flags, const char *msg, - const int createPart1, const int createPart2, - Var **arrayPtrPtr); + int flags, const char *msg, int createPart1, + int createPart2, Var **arrayPtrPtr); /* 231 */ EXTERN int TclGetNamespaceFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); @@ -510,7 +509,7 @@ EXTERN int TclNRInterpProc(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 239 */ EXTERN int TclNRInterpProcCore(Tcl_Interp *interp, - Tcl_Obj *procNameObj, int skip, + Tcl_Obj *procNameObj, size_t skip, ProcErrorProc *errorProc); /* 240 */ EXTERN int TclNRRunCallbacks(Tcl_Interp *interp, int result, @@ -519,7 +518,7 @@ EXTERN int TclNRRunCallbacks(Tcl_Interp *interp, int result, EXTERN int TclNREvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); /* 242 */ -EXTERN int TclNREvalObjv(Tcl_Interp *interp, int objc, +EXTERN int TclNREvalObjv(Tcl_Interp *interp, size_t objc, Tcl_Obj *const objv[], int flags, Command *cmdPtr); /* 243 */ @@ -551,17 +550,17 @@ EXTERN int TclRegisterLiteral(void *envPtr, const char *bytes, /* 252 */ EXTERN Tcl_Obj * TclPtrGetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, - Tcl_Obj *part2Ptr, const int flags); + Tcl_Obj *part2Ptr, int flags); /* 253 */ EXTERN Tcl_Obj * TclPtrSetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, - const int flags); + int flags); /* 254 */ EXTERN Tcl_Obj * TclPtrIncrObjVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, - const int flags); + int flags); /* 255 */ EXTERN int TclPtrObjMakeUpvar(Tcl_Interp *interp, Tcl_Var otherPtr, Tcl_Obj *myNamePtr, @@ -569,7 +568,7 @@ EXTERN int TclPtrObjMakeUpvar(Tcl_Interp *interp, /* 256 */ EXTERN int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, - Tcl_Obj *part2Ptr, const int flags); + Tcl_Obj *part2Ptr, int flags); /* 257 */ EXTERN void TclStaticLibrary(Tcl_Interp *interp, const char *prefix, @@ -592,7 +591,7 @@ typedef struct TclIntStubs { void (*tclCleanupCommand) (Command *cmdPtr); /* 6 */ size_t (*tclCopyAndCollapse) (size_t count, const char *src, char *dst); /* 7 */ void (*reserved8)(void); - int (*tclCreatePipeline) (Tcl_Interp *interp, int argc, const char **argv, Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, TclFile *errFilePtr); /* 9 */ + size_t (*tclCreatePipeline) (Tcl_Interp *interp, size_t argc, const char **argv, Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, TclFile *errFilePtr); /* 9 */ int (*tclCreateProc) (Tcl_Interp *interp, Namespace *nsPtr, const char *procName, Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr, Proc **procPtrPtr); /* 10 */ void (*tclDeleteCompiledLocalVars) (Interp *iPtr, CallFrame *framePtr); /* 11 */ void (*tclDeleteVars) (Interp *iPtr, TclVarHashTable *tablePtr); /* 12 */ @@ -808,12 +807,12 @@ typedef struct TclIntStubs { void (*reserved222)(void); void (*reserved223)(void); TclPlatformType * (*tclGetPlatform) (void); /* 224 */ - Tcl_Obj * (*tclTraceDictPath) (Tcl_Interp *interp, Tcl_Obj *rootPtr, int keyc, Tcl_Obj *const keyv[], int flags); /* 225 */ + Tcl_Obj * (*tclTraceDictPath) (Tcl_Interp *interp, Tcl_Obj *rootPtr, size_t keyc, Tcl_Obj *const keyv[], int flags); /* 225 */ int (*tclObjBeingDeleted) (Tcl_Obj *objPtr); /* 226 */ void (*tclSetNsPath) (Namespace *nsPtr, size_t pathLength, Tcl_Namespace *pathAry[]); /* 227 */ void (*reserved228)(void); int (*tclPtrMakeUpvar) (Tcl_Interp *interp, Var *otherP1Ptr, const char *myName, int myFlags, int index); /* 229 */ - Var * (*tclObjLookupVar) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, const char *part2, int flags, const char *msg, const int createPart1, const int createPart2, Var **arrayPtrPtr); /* 230 */ + Var * (*tclObjLookupVar) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, const char *part2, int flags, const char *msg, int createPart1, int createPart2, Var **arrayPtrPtr); /* 230 */ int (*tclGetNamespaceFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); /* 231 */ int (*tclEvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); /* 232 */ void (*tclGetSrcInfoForPc) (CmdFrame *contextPtr); /* 233 */ @@ -822,10 +821,10 @@ typedef struct TclIntStubs { void (*tclAppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, size_t length); /* 236 */ int (*tclResetCancellation) (Tcl_Interp *interp, int force); /* 237 */ int (*tclNRInterpProc) (void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 238 */ - int (*tclNRInterpProcCore) (Tcl_Interp *interp, Tcl_Obj *procNameObj, int skip, ProcErrorProc *errorProc); /* 239 */ + int (*tclNRInterpProcCore) (Tcl_Interp *interp, Tcl_Obj *procNameObj, size_t skip, ProcErrorProc *errorProc); /* 239 */ int (*tclNRRunCallbacks) (Tcl_Interp *interp, int result, struct NRE_callback *rootPtr); /* 240 */ int (*tclNREvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); /* 241 */ - int (*tclNREvalObjv) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags, Command *cmdPtr); /* 242 */ + int (*tclNREvalObjv) (Tcl_Interp *interp, size_t objc, Tcl_Obj *const objv[], int flags, Command *cmdPtr); /* 242 */ void (*tclDbDumpActiveObjects) (FILE *outFile); /* 243 */ Tcl_HashTable * (*tclGetNamespaceChildTable) (Tcl_Namespace *nsPtr); /* 244 */ Tcl_HashTable * (*tclGetNamespaceCommandTable) (Tcl_Namespace *nsPtr); /* 245 */ @@ -835,11 +834,11 @@ typedef struct TclIntStubs { char * (*tclDoubleDigits) (double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 249 */ void (*tclSetChildCancelFlags) (Tcl_Interp *interp, int flags, int force); /* 250 */ int (*tclRegisterLiteral) (void *envPtr, const char *bytes, size_t length, int flags); /* 251 */ - Tcl_Obj * (*tclPtrGetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 252 */ - Tcl_Obj * (*tclPtrSetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, const int flags); /* 253 */ - Tcl_Obj * (*tclPtrIncrObjVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, const int flags); /* 254 */ + Tcl_Obj * (*tclPtrGetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 252 */ + Tcl_Obj * (*tclPtrSetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags); /* 253 */ + Tcl_Obj * (*tclPtrIncrObjVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags); /* 254 */ int (*tclPtrObjMakeUpvar) (Tcl_Interp *interp, Tcl_Var otherPtr, Tcl_Obj *myNamePtr, int myFlags); /* 255 */ - int (*tclPtrUnsetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 256 */ + int (*tclPtrUnsetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 256 */ void (*tclStaticLibrary) (Tcl_Interp *interp, const char *prefix, Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc); /* 257 */ Tcl_Obj * (*tclpCreateTemporaryDirectory) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj); /* 258 */ } TclIntStubs; diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index 2da327f..03a009e 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -69,7 +69,7 @@ EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, /* Slot 13 is reserved */ /* Slot 14 is reserved */ /* 15 */ -EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, +EXTERN int TclpCreateProcess(Tcl_Interp *interp, size_t argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); @@ -119,7 +119,7 @@ typedef struct TclIntPlatStubs { void (*reserved12)(void); void (*reserved13)(void); void (*reserved14)(void); - int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 15 */ + int (*tclpCreateProcess) (Tcl_Interp *interp, size_t argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 15 */ int (*tclpIsAtty) (int fd); /* 16 */ int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 17 */ void (*reserved18)(void); diff --git a/generic/tclPipe.c b/generic/tclPipe.c index 84b3646..b9c37e0 100644 --- a/generic/tclPipe.c +++ b/generic/tclPipe.c @@ -378,7 +378,7 @@ TclCleanupChildren( * * Results: * The return value is a count of the number of new processes created, or - * -1 if an error occurred while creating the pipeline. *pidArrayPtr is + * TCL_INDEX_NONE if an error occurred while creating the pipeline. *pidArrayPtr is * filled in with the address of a dynamically allocated array giving the * ids of all of the processes. It is up to the caller to free this array * when it isn't needed anymore. If inPipePtr is non-NULL, *inPipePtr is @@ -395,10 +395,10 @@ TclCleanupChildren( *---------------------------------------------------------------------- */ -int +size_t TclCreatePipeline( Tcl_Interp *interp, /* Interpreter to use for error reporting. */ - int argc, /* Number of entries in argv. */ + size_t argc, /* Number of entries in argv. */ const char **argv, /* Array of strings describing commands in * pipeline plus I/O redirection with <, <<, * >, etc. Argv[argc] must be NULL. */ @@ -431,7 +431,7 @@ TclCreatePipeline( { Tcl_Pid *pidPtr = NULL; /* Points to malloc-ed array holding all the * pids of child processes. */ - int numPids; /* Actual number of processes that exist at + size_t numPids; /* Actual number of processes that exist at * *pidPtr right now. */ int cmdCount; /* Count of number of distinct commands found * in argc/argv. */ @@ -460,7 +460,8 @@ TclCreatePipeline( int errorRelease = 0; const char *p; const char *nextArg; - int skip, lastBar, lastArg, i, j, atOK, flags, needCmd, errorToOutput = 0; + int skip, atOK, flags, needCmd, errorToOutput = 0; + size_t i, j, lastArg, lastBar; Tcl_DString execBuffer; TclFile pipeIn; TclFile curInFile, curOutFile, curErrFile; @@ -496,7 +497,7 @@ TclCreatePipeline( * list. */ - lastBar = -1; + lastBar = TCL_INDEX_NONE; cmdCount = 1; needCmd = 1; for (i = 0; i < argc; i++) { diff --git a/generic/tclProc.c b/generic/tclProc.c index 4efcf48..9b5d163 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -1649,7 +1649,7 @@ TclNRInterpProcCore( Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ Tcl_Obj *procNameObj, /* Procedure name for error reporting. */ - int skip, /* Number of initial arguments to be skipped, + size_t skip1, /* Number of initial arguments to be skipped, * i.e., words in the "command name". */ ProcErrorProc *errorProc) /* How to convert results from the script into * results of the overall procedure. */ @@ -1659,6 +1659,7 @@ TclNRInterpProcCore( int result; CallFrame *freePtr; ByteCode *codePtr; + int skip = skip1; result = InitArgsAndLocals(interp, skip); if (result != TCL_OK) { diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c index 85692c9..e1825c7 100644 --- a/unix/tclUnixPipe.c +++ b/unix/tclUnixPipe.c @@ -381,7 +381,7 @@ TclpCreateProcess( * occurred when creating the child process. * Error messages from the child process * itself are sent to errorFile. */ - int argc, /* Number of arguments in following array. */ + size_t argc, /* Number of arguments in following array. */ const char **argv, /* Array of argument strings in UTF-8. * argv[0] contains the name of the executable * translated using Tcl_TranslateFileName @@ -410,7 +410,8 @@ TclpCreateProcess( char errSpace[200 + TCL_INTEGER_SPACE]; Tcl_DString *dsArray; char **newArgv; - int pid, i; + int pid; + size_t i; errPipeIn = NULL; errPipeOut = NULL; diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index baef81e..2477778 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -911,7 +911,7 @@ TclpCreateProcess( * occurred when creating the child process. * Error messages from the child process * itself are sent to errorFile. */ - int argc, /* Number of arguments in following array. */ + size_t argc, /* Number of arguments in following array. */ const char **argv, /* Array of argument strings. argv[0] contains * the name of the executable converted to * native format (using the -- cgit v0.12 From 25560ed141b47b6a80a25134b44b6b174aa2f84d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 20 Feb 2022 19:57:04 +0000 Subject: Eliminate dead code and fix a comment --- generic/tclBasic.c | 11 ----------- generic/tclProc.c | 2 +- win/tclWinInit.c | 14 -------------- 3 files changed, 1 insertion(+), 26 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index a21f633..2d86e9c 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -1220,17 +1220,6 @@ Tcl_CreateInterp(void) Tcl_SetVar2(interp, "tcl_version", NULL, TCL_VERSION, TCL_GLOBAL_ONLY); TclpSetVariables(interp); -#if TCL_THREADS && !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 - /* - * The existence of the "threaded" element of the tcl_platform array - * indicates that this particular Tcl shell has been compiled with threads - * turned on. Using "info exists tcl_platform(threaded)" a Tcl script can - * introspect on the interpreter level of thread safety. - */ - - Tcl_SetVar2(interp, "tcl_platform", "threaded", "1", TCL_GLOBAL_ONLY); -#endif - /* * Register Tcl's version number. * TIP #268: Full patchlevel instead of just major.minor diff --git a/generic/tclProc.c b/generic/tclProc.c index 9b5d163..adc015f 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -84,7 +84,7 @@ const Tcl_ObjType tclProcBodyType = { } while (0) /* - * The [upvar]/[uplevel] level reference type. Uses the longValue field + * The [upvar]/[uplevel] level reference type. Uses the wideValue field * to remember the integer value of a parsed # format. * * Uses the default behaviour throughout, and never disposes of the string diff --git a/win/tclWinInit.c b/win/tclWinInit.c index 64b3b5a..1ddd518 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -493,20 +493,6 @@ TclpSetVariables( TCL_GLOBAL_ONLY); } -#if !defined(NDEBUG) && !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 - - /* - * The existence of the "debug" element of the tcl_platform array - * indicates that this particular Tcl shell has been compiled with debug - * information. Using "info exists tcl_platform(debug)" a Tcl script can - * direct the interpreter to load debug versions of DLLs with the load - * command. - */ - - Tcl_SetVar2(interp, "tcl_platform", "debug", "1", - TCL_GLOBAL_ONLY); -#endif - /* * Set up the HOME environment variable from the HOMEDRIVE & HOMEPATH * environment variables, if necessary. -- cgit v0.12 From ac7d65a8345455832dbb0ba384437e2953e23bdd Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 23 Feb 2022 14:04:36 +0000 Subject: Some more int -> size_t in internal API --- generic/tclIOSock.c | 6 +++++- generic/tclInt.decls | 10 +++++----- generic/tclIntDecls.h | 19 ++++++++++--------- generic/tclIntPlatDecls.h | 4 ++-- generic/tclPipe.c | 6 +++--- generic/tclTrace.c | 4 ++-- unix/tclUnixPipe.c | 14 +++++++------- win/tclWinPipe.c | 11 ++++++----- 8 files changed, 40 insertions(+), 34 deletions(-) diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c index cfb0454..8f86257 100644 --- a/generic/tclIOSock.c +++ b/generic/tclIOSock.c @@ -117,11 +117,15 @@ TclSockGetPort( int TclSockMinimumBuffers( void *sock, /* Socket file descriptor */ - int size) /* Minimum buffer size */ + size_t size1) /* Minimum buffer size */ { int current; socklen_t len; + int size = size1; + if ((size_t)size != size1) { + return TCL_ERROR; + } len = sizeof(int); getsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_SNDBUF, (char *) ¤t, &len); diff --git a/generic/tclInt.decls b/generic/tclInt.decls index ff1f546..2d91d0a 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -28,7 +28,7 @@ declare 3 { void TclAllocateFreeObjects(void) } declare 5 { - int TclCleanupChildren(Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, + int TclCleanupChildren(Tcl_Interp *interp, size_t numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan) } declare 6 { @@ -203,7 +203,7 @@ declare 109 { int TclUpdateReturnInfo(Interp *iPtr) } declare 110 { - int TclSockMinimumBuffers(void *sock, int size) + int TclSockMinimumBuffers(void *sock, size_t size) } # Removed in 8.1: # declare 110 { @@ -349,12 +349,12 @@ declare 169 { declare 170 { int TclCheckInterpTraces(Tcl_Interp *interp, const char *command, size_t numChars, Command *cmdPtr, int result, int traceFlags, - int objc, Tcl_Obj *const objv[]) + size_t objc, Tcl_Obj *const objv[]) } declare 171 { int TclCheckExecutionTraces(Tcl_Interp *interp, const char *command, size_t numChars, Command *cmdPtr, int result, int traceFlags, - int objc, Tcl_Obj *const objv[]) + size_t objc, Tcl_Obj *const objv[]) } declare 172 { int TclInThreadExit(void) @@ -608,7 +608,7 @@ declare 1 { } declare 2 { Tcl_Channel TclpCreateCommandChannel(TclFile readFile, - TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr) + TclFile writeFile, TclFile errorFile, size_t numPids, Tcl_Pid *pidPtr) } declare 3 { int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe) diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 101aedb..48cec3d 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -50,8 +50,9 @@ extern "C" { EXTERN void TclAllocateFreeObjects(void); /* Slot 4 is reserved */ /* 5 */ -EXTERN int TclCleanupChildren(Tcl_Interp *interp, int numPids, - Tcl_Pid *pidPtr, Tcl_Channel errorChan); +EXTERN int TclCleanupChildren(Tcl_Interp *interp, + size_t numPids, Tcl_Pid *pidPtr, + Tcl_Channel errorChan); /* 6 */ EXTERN void TclCleanupCommand(Command *cmdPtr); /* 7 */ @@ -242,7 +243,7 @@ EXTERN void TclTeardownNamespace(Namespace *nsPtr); /* 109 */ EXTERN int TclUpdateReturnInfo(Interp *iPtr); /* 110 */ -EXTERN int TclSockMinimumBuffers(void *sock, int size); +EXTERN int TclSockMinimumBuffers(void *sock, size_t size); /* 111 */ EXTERN void Tcl_AddInterpResolvers(Tcl_Interp *interp, const char *name, @@ -368,12 +369,12 @@ EXTERN int TclpUtfNcmp2(const char *s1, const char *s2, EXTERN int TclCheckInterpTraces(Tcl_Interp *interp, const char *command, size_t numChars, Command *cmdPtr, int result, int traceFlags, - int objc, Tcl_Obj *const objv[]); + size_t objc, Tcl_Obj *const objv[]); /* 171 */ EXTERN int TclCheckExecutionTraces(Tcl_Interp *interp, const char *command, size_t numChars, Command *cmdPtr, int result, int traceFlags, - int objc, Tcl_Obj *const objv[]); + size_t objc, Tcl_Obj *const objv[]); /* 172 */ EXTERN int TclInThreadExit(void); /* 173 */ @@ -587,7 +588,7 @@ typedef struct TclIntStubs { void (*reserved2)(void); void (*tclAllocateFreeObjects) (void); /* 3 */ void (*reserved4)(void); - int (*tclCleanupChildren) (Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan); /* 5 */ + int (*tclCleanupChildren) (Tcl_Interp *interp, size_t numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan); /* 5 */ void (*tclCleanupCommand) (Command *cmdPtr); /* 6 */ size_t (*tclCopyAndCollapse) (size_t count, const char *src, char *dst); /* 7 */ void (*reserved8)(void); @@ -692,7 +693,7 @@ typedef struct TclIntStubs { void (*reserved107)(void); void (*tclTeardownNamespace) (Namespace *nsPtr); /* 108 */ int (*tclUpdateReturnInfo) (Interp *iPtr); /* 109 */ - int (*tclSockMinimumBuffers) (void *sock, int size); /* 110 */ + int (*tclSockMinimumBuffers) (void *sock, size_t size); /* 110 */ void (*tcl_AddInterpResolvers) (Tcl_Interp *interp, const char *name, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 111 */ void (*reserved112)(void); void (*reserved113)(void); @@ -752,8 +753,8 @@ typedef struct TclIntStubs { void (*reserved167)(void); void (*reserved168)(void); int (*tclpUtfNcmp2) (const char *s1, const char *s2, size_t n); /* 169 */ - int (*tclCheckInterpTraces) (Tcl_Interp *interp, const char *command, size_t numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 170 */ - int (*tclCheckExecutionTraces) (Tcl_Interp *interp, const char *command, size_t numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 171 */ + int (*tclCheckInterpTraces) (Tcl_Interp *interp, const char *command, size_t numChars, Command *cmdPtr, int result, int traceFlags, size_t objc, Tcl_Obj *const objv[]); /* 170 */ + int (*tclCheckExecutionTraces) (Tcl_Interp *interp, const char *command, size_t numChars, Command *cmdPtr, int result, int traceFlags, size_t objc, Tcl_Obj *const objv[]); /* 171 */ int (*tclInThreadExit) (void); /* 172 */ int (*tclUniCharMatch) (const Tcl_UniChar *string, size_t strLen, const Tcl_UniChar *pattern, size_t ptnLen, int flags); /* 173 */ void (*reserved174)(void); diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index 03a009e..0e51eef 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -46,7 +46,7 @@ EXTERN int TclpCloseFile(TclFile file); /* 2 */ EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile, TclFile writeFile, TclFile errorFile, - int numPids, Tcl_Pid *pidPtr); + size_t numPids, Tcl_Pid *pidPtr); /* 3 */ EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); /* 4 */ @@ -106,7 +106,7 @@ typedef struct TclIntPlatStubs { void (*reserved0)(void); int (*tclpCloseFile) (TclFile file); /* 1 */ - Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ + Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, size_t numPids, Tcl_Pid *pidPtr); /* 2 */ int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */ void * (*tclWinGetTclInstance) (void); /* 4 */ int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 5 */ diff --git a/generic/tclPipe.c b/generic/tclPipe.c index b9c37e0..5a71446 100644 --- a/generic/tclPipe.c +++ b/generic/tclPipe.c @@ -269,16 +269,16 @@ Tcl_ReapDetachedProcs(void) int TclCleanupChildren( Tcl_Interp *interp, /* Used for error messages. */ - int numPids, /* Number of entries in pidPtr array. */ + size_t numPids, /* Number of entries in pidPtr array. */ Tcl_Pid *pidPtr, /* Array of process ids of children. */ Tcl_Channel errorChan) /* Channel for file containing stderr output * from pipeline. NULL means there isn't any * stderr output. */ { int result = TCL_OK; - int i, abnormalExit, anyErrorInfo; + int code, abnormalExit, anyErrorInfo; TclProcessWaitStatus waitStatus; - int code; + size_t i; Tcl_Obj *msg, *error; abnormalExit = 0; diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 1794723..bc4cbfc 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -1423,7 +1423,7 @@ TclCheckExecutionTraces( Command *cmdPtr, /* Points to command's Command struct. */ int code, /* The current result code. */ int traceFlags, /* Current tracing situation. */ - int objc, /* Number of arguments for the command. */ + size_t objc, /* Number of arguments for the command. */ Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */ { Interp *iPtr = (Interp *) interp; @@ -1529,7 +1529,7 @@ TclCheckInterpTraces( Command *cmdPtr, /* Points to command's Command struct. */ int code, /* The current result code. */ int traceFlags, /* Current tracing situation. */ - int objc, /* Number of arguments for the command. */ + size_t objc, /* Number of arguments for the command. */ Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */ { Interp *iPtr = (Interp *) interp; diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c index e1825c7..bb0943a 100644 --- a/unix/tclUnixPipe.c +++ b/unix/tclUnixPipe.c @@ -35,7 +35,7 @@ typedef struct { TclFile inFile; /* Output from pipe. */ TclFile outFile; /* Input to pipe. */ TclFile errorFile; /* Error output from pipe. */ - int numPids; /* How many processes are attached to this + size_t numPids; /* How many processes are attached to this * pipe? */ Tcl_Pid *pidPtr; /* The process IDs themselves. Allocated by * the creator of the pipe. */ @@ -381,7 +381,7 @@ TclpCreateProcess( * occurred when creating the child process. * Error messages from the child process * itself are sent to errorFile. */ - size_t argc, /* Number of arguments in following array. */ + size_t argc1, /* Number of arguments in following array. */ const char **argv, /* Array of argument strings in UTF-8. * argv[0] contains the name of the executable * translated using Tcl_TranslateFileName @@ -410,8 +410,8 @@ TclpCreateProcess( char errSpace[200 + TCL_INTEGER_SPACE]; Tcl_DString *dsArray; char **newArgv; - int pid; - size_t i; + int pid, i; + int argc = argc1; errPipeIn = NULL; errPipeOut = NULL; @@ -737,7 +737,7 @@ TclpCreateCommandChannel( TclFile writeFile, /* If non-null, gives the file for writing. */ TclFile errorFile, /* If non-null, gives the file where errors * can be read. */ - int numPids, /* The number of pids in the pid array. */ + size_t numPids, /* The number of pids in the pid array. */ Tcl_Pid *pidPtr) /* An array of process identifiers. Allocated * by the caller, freed when the channel is * closed or the processes are detached (in a @@ -859,7 +859,7 @@ TclGetAndDetachPids( PipeState *pipePtr; const Tcl_ChannelType *chanTypePtr; Tcl_Obj *pidsObj; - int i; + size_t i; /* * Punt if the channel is not a command channel. @@ -1258,7 +1258,7 @@ Tcl_PidObjCmd( { Tcl_Channel chan; PipeState *pipePtr; - int i; + size_t i; Tcl_Obj *resultPtr; if (objc > 2) { diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index 2477778..41692a5 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -104,7 +104,7 @@ typedef struct PipeInfo { TclFile readFile; /* Output from pipe. */ TclFile writeFile; /* Input from pipe. */ TclFile errorFile; /* Error output from pipe. */ - int numPids; /* Number of processes attached to pipe. */ + size_t numPids; /* Number of processes attached to pipe. */ Tcl_Pid *pidPtr; /* Pids of attached processes. */ Tcl_ThreadId threadId; /* Thread to which events should be reported. * This value is used by the reader/writer @@ -911,7 +911,7 @@ TclpCreateProcess( * occurred when creating the child process. * Error messages from the child process * itself are sent to errorFile. */ - size_t argc, /* Number of arguments in following array. */ + size_t argc1, /* Number of arguments in following array. */ const char **argv, /* Array of argument strings. argv[0] contains * the name of the executable converted to * native format (using the @@ -943,6 +943,7 @@ TclpCreateProcess( HANDLE hProcess, h, inputHandle, outputHandle, errorHandle; char execPath[MAX_PATH * 3]; WinFile *filePtr; + int argc = argc1; PipeInit(); @@ -1759,7 +1760,7 @@ TclpCreateCommandChannel( TclFile writeFile, /* If non-null, gives the file for writing. */ TclFile errorFile, /* If non-null, gives the file where errors * can be read. */ - int numPids, /* The number of pids in the pid array. */ + size_t numPids, /* The number of pids in the pid array. */ Tcl_Pid *pidPtr) /* An array of process identifiers. */ { char channelName[16 + TCL_INTEGER_SPACE]; @@ -1906,7 +1907,7 @@ TclGetAndDetachPids( PipeInfo *pipePtr; const Tcl_ChannelType *chanTypePtr; Tcl_Obj *pidsObj; - int i; + size_t i; /* * Punt if the channel is not a command channel. @@ -2750,7 +2751,7 @@ Tcl_PidObjCmd( Tcl_Channel chan; const Tcl_ChannelType *chanTypePtr; PipeInfo *pipePtr; - int i; + size_t i; Tcl_Obj *resultPtr; if (objc > 2) { -- cgit v0.12 From 20b89e16049a89c0fba39bf0762494140bd14663 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 24 Feb 2022 12:59:55 +0000 Subject: More (internal) size_t usage in TclOO --- generic/tclExecute.c | 6 +++--- generic/tclOO.c | 4 ++-- generic/tclOOBasic.c | 6 +++--- generic/tclOOCall.c | 13 +++++++------ generic/tclOOInt.h | 6 +++--- generic/tclOOMethod.c | 3 ++- 6 files changed, 20 insertions(+), 18 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 3876ff7..bea9798 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4349,7 +4349,7 @@ TEBCresume( Object *oPtr; CallFrame *framePtr; CallContext *contextPtr; - int skip, newDepth; + size_t skip, newDepth; case INST_TCLOO_SELF: framePtr = iPtr->varFramePtr; @@ -4401,7 +4401,7 @@ TEBCresume( } else { Class *classPtr = oPtr->classPtr; struct MInvoke *miPtr; - int i; + size_t i; const char *methodType; if (classPtr == NULL) { @@ -4450,7 +4450,7 @@ TEBCresume( TRACE_APPEND(("ERROR: \"%.30s\" not on reachable chain\n", O2S(valuePtr))); - for (i=contextPtr->index ; i>=0 ; i--) { + for (i=contextPtr->index ; i != TCL_INDEX_NONE ; i--) { miPtr = contextPtr->callPtr->chain + i; if (miPtr->isFilter || miPtr->mPtr->declaringClassPtr != classPtr) { diff --git a/generic/tclOO.c b/generic/tclOO.c index b9c976e..f90025d 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -2799,8 +2799,8 @@ Tcl_ObjectContextInvokeNext( int skip) { CallContext *contextPtr = (CallContext *) context; - int savedIndex = contextPtr->index; - int savedSkip = contextPtr->skip; + size_t savedIndex = contextPtr->index; + size_t savedSkip = contextPtr->skip; int result; if (contextPtr->index + 1 >= contextPtr->callPtr->numChain) { diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index eb929c8..41ce034 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -909,7 +909,7 @@ TclOONextToObjCmd( CallFrame *framePtr = iPtr->varFramePtr; Class *classPtr; CallContext *contextPtr; - int i; + size_t i; Tcl_Object object; const char *methodType; @@ -985,7 +985,7 @@ TclOONextToObjCmd( methodType = "method"; } - for (i=contextPtr->index ; i>=0 ; i--) { + for (i=contextPtr->index ; i != TCL_INDEX_NONE ; i--) { struct MInvoke *miPtr = contextPtr->callPtr->chain + i; if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) { @@ -1218,7 +1218,7 @@ TclOOSelfObjCmd( } else { Method *mPtr; Object *declarerPtr; - int i; + size_t i; for (i=contextPtr->index ; icallPtr->numChain ; i++){ if (!contextPtr->callPtr->chain[i].isFilter) { diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index 60666f4..dbc4789 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -24,7 +24,7 @@ struct ChainBuilder { CallChain *callChainPtr; /* The call chain being built. */ - int filterLength; /* Number of entries in the call chain that + size_t filterLength; /* Number of entries in the call chain that * are due to processing filters and not the * main call chain. */ Object *oPtr; /* The object that we are building the chain @@ -326,7 +326,7 @@ TclOOInvokeContext( */ if (contextPtr->index == 0) { - int i; + size_t i; for (i = 0 ; i < contextPtr->callPtr->numChain ; i++) { AddRef(contextPtr->callPtr->chain[i].mPtr); @@ -404,7 +404,7 @@ FinalizeMethodRefs( int result) { CallContext *contextPtr = (CallContext *)data[0]; - int i; + size_t i; for (i = 0 ; i < contextPtr->callPtr->numChain ; i++) { TclOODelMethodRef(contextPtr->callPtr->chain[i].mPtr); @@ -969,7 +969,7 @@ AddMethodToCallChain( * not passed a mixin. */ { CallChain *callPtr = cbPtr->callChainPtr; - int i; + size_t i; /* * Return if this is just an entry used to record whether this is a public @@ -1408,7 +1408,7 @@ TclOOGetStereotypeCallChain( { CallChain *callPtr; struct ChainBuilder cb; - int i, count; + size_t count; Foundation *fPtr = clsPtr->thisPtr->fPtr; Tcl_HashEntry *hPtr; Tcl_HashTable doneFilters; @@ -1504,12 +1504,13 @@ TclOOGetStereotypeCallChain( } } else { if (hPtr == NULL) { + int isNew; if (clsPtr->classChainCache == NULL) { clsPtr->classChainCache = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); Tcl_InitObjHashTable(clsPtr->classChainCache); } hPtr = Tcl_CreateHashEntry(clsPtr->classChainCache, - (char *) methodNameObj, &i); + (char *) methodNameObj, &isNew); } callPtr->refCount++; Tcl_SetHashValue(hPtr, callPtr); diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 342def6..4ad84a6 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -396,7 +396,7 @@ typedef struct CallChain { * snapshot. */ int flags; /* Assorted flags, see below. */ size_t refCount; /* Reference count. */ - int numChain; /* Size of the call chain. */ + size_t numChain; /* Size of the call chain. */ struct MInvoke *chain; /* Array of call chain entries. May point to * staticChain if the number of entries is * small. */ @@ -405,9 +405,9 @@ typedef struct CallChain { typedef struct CallContext { Object *oPtr; /* The object associated with this call. */ - int index; /* Index into the call chain of the currently + size_t index; /* Index into the call chain of the currently * executing method implementation. */ - int skip; /* Current number of arguments to skip; can + size_t skip; /* Current number of arguments to skip; can * vary depending on whether it is a direct * method call or a continuation via the * [next] command. */ diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index b205043..a09ae1b 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -1468,7 +1468,8 @@ InvokeForwardMethod( CallContext *contextPtr = (CallContext *) context; ForwardMethod *fmPtr = (ForwardMethod *)clientData; Tcl_Obj **argObjs, **prefixObjs; - int numPrefixes, len, skip = contextPtr->skip; + size_t numPrefixes, skip = contextPtr->skip; + int len; /* * Build the real list of arguments to use. Note that we know that the -- cgit v0.12 From edce3d6cb3d79f53d997bc44c3d487428d9f3aca Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 24 Feb 2022 14:00:52 +0000 Subject: Fix compiler warnings (caused by previous commit) --- generic/tclOOCall.c | 10 ++++++---- generic/tclOOMethod.c | 4 ++-- 2 files changed, 8 insertions(+), 6 deletions(-) diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index dbc4789..0c2c5e2 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -1149,7 +1149,8 @@ TclOOGetCallContext( CallContext *contextPtr; CallChain *callPtr; struct ChainBuilder cb; - int i, count, doFilters, donePrivate = 0; + size_t count; + int i, doFilters, donePrivate = 0; Tcl_HashEntry *hPtr; Tcl_HashTable doneFilters; @@ -1332,6 +1333,7 @@ TclOOGetCallContext( } } else if (doFilters && !donePrivate) { if (hPtr == NULL) { + int isNew; if (oPtr->flags & USE_CLASS_CACHE) { if (oPtr->selfCls->classChainCache == NULL) { oPtr->selfCls->classChainCache = @@ -1340,7 +1342,7 @@ TclOOGetCallContext( Tcl_InitObjHashTable(oPtr->selfCls->classChainCache); } hPtr = Tcl_CreateHashEntry(oPtr->selfCls->classChainCache, - (char *) methodNameObj, &i); + (char *) methodNameObj, &isNew); } else { if (oPtr->chainCache == NULL) { oPtr->chainCache = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); @@ -1348,7 +1350,7 @@ TclOOGetCallContext( Tcl_InitObjHashTable(oPtr->chainCache); } hPtr = Tcl_CreateHashEntry(oPtr->chainCache, - (char *) methodNameObj, &i); + (char *) methodNameObj, &isNew); } } callPtr->refCount++; @@ -1795,7 +1797,7 @@ TclOORenderCallChain( Tcl_Obj *filterLiteral, *methodLiteral, *objectLiteral, *privateLiteral; Tcl_Obj *resultObj, *descObjs[4], **objv; Foundation *fPtr = TclOOGetFoundation(interp); - int i; + size_t i; /* * Allocate the literals (potentially) used in our description. diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index a09ae1b..ca2b642 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -1468,8 +1468,8 @@ InvokeForwardMethod( CallContext *contextPtr = (CallContext *) context; ForwardMethod *fmPtr = (ForwardMethod *)clientData; Tcl_Obj **argObjs, **prefixObjs; - size_t numPrefixes, skip = contextPtr->skip; - int len; + size_t skip = contextPtr->skip; + int numPrefixes, len; /* * Build the real list of arguments to use. Note that we know that the -- cgit v0.12 From 2d07a092e5512407f7e484e7a4f058bd31264c0a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 27 Feb 2022 18:29:55 +0000 Subject: More size_t usage, e.g. for "foreach" --- generic/tclCmdAH.c | 6 +++--- generic/tclCompCmds.c | 37 ++++++++++++++++++------------------- generic/tclCompile.h | 20 ++++++++++---------- generic/tclDisassemble.c | 17 +++++++++-------- generic/tclExecute.c | 20 ++++++++++---------- 5 files changed, 50 insertions(+), 50 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 9bab9bf..00bcdff 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -2474,9 +2474,9 @@ EachloopCmd( int objc, /* The arguments being passed in... */ Tcl_Obj *const objv[]) { - int numLists = (objc-2) / 2; + size_t i, j, numLists = (objc-2) / 2; struct ForeachState *statePtr; - int i, j, result; + int result; if (objc < 4 || (objc%2 != 0)) { Tcl_WrongNumArgs(interp, 1, objv, @@ -2558,7 +2558,7 @@ EachloopCmd( if ((statePtr->argcList[i] % statePtr->varcList[i]) != 0) { j++; } - if (j > statePtr->maxj) { + if (j > (size_t)statePtr->maxj) { statePtr->maxj = j; } } diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 82d09ac..39a21c8 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -2845,9 +2845,9 @@ CompileEachloopCmd( * body's code. Misuse loopCtTemp for storing the jump size. */ - jumpBackOffset = envPtr->exceptArrayPtr[range].continueOffset - - envPtr->exceptArrayPtr[range].codeOffset; - infoPtr->loopCtTemp = -jumpBackOffset; + jumpBackOffset = envPtr->exceptArrayPtr[range].codeOffset - + envPtr->exceptArrayPtr[range].continueOffset; + infoPtr->loopCtTemp = jumpBackOffset; /* * The command's result is an empty string if not collecting. If @@ -2895,7 +2895,7 @@ DupForeachInfo( ForeachInfo *srcPtr = (ForeachInfo *)clientData; ForeachInfo *dupPtr; ForeachVarList *srcListPtr, *dupListPtr; - int numVars, i, j, numLists = srcPtr->numLists; + size_t numVars, i, j, numLists = srcPtr->numLists; dupPtr = (ForeachInfo *)Tcl_Alloc(offsetof(ForeachInfo, varLists) + numLists * sizeof(ForeachVarList *)); @@ -2943,8 +2943,7 @@ FreeForeachInfo( { ForeachInfo *infoPtr = (ForeachInfo *)clientData; ForeachVarList *listPtr; - int numLists = infoPtr->numLists; - int i; + size_t i, numLists = infoPtr->numLists; for (i = 0; i < numLists; i++) { listPtr = infoPtr->varLists[i]; @@ -2979,7 +2978,7 @@ PrintForeachInfo( { ForeachInfo *infoPtr = (ForeachInfo *)clientData; ForeachVarList *varsPtr; - int i, j; + size_t i, j; Tcl_AppendToObj(appendObj, "data=[", -1); @@ -2987,24 +2986,24 @@ PrintForeachInfo( if (i) { Tcl_AppendToObj(appendObj, ", ", -1); } - Tcl_AppendPrintfToObj(appendObj, "%%v%u", - (unsigned) (infoPtr->firstValueTemp + i)); + Tcl_AppendPrintfToObj(appendObj, "%%v%" TCL_Z_MODIFIER "u", + (infoPtr->firstValueTemp + i)); } - Tcl_AppendPrintfToObj(appendObj, "], loop=%%v%u", - (unsigned) infoPtr->loopCtTemp); + Tcl_AppendPrintfToObj(appendObj, "], loop=%%v%" TCL_Z_MODIFIER "u", + infoPtr->loopCtTemp); for (i=0 ; inumLists ; i++) { if (i) { Tcl_AppendToObj(appendObj, ",", -1); } - Tcl_AppendPrintfToObj(appendObj, "\n\t\t it%%v%u\t[", - (unsigned) (infoPtr->firstValueTemp + i)); + Tcl_AppendPrintfToObj(appendObj, "\n\t\t it%%v%" TCL_Z_MODIFIER "u\t[", + (infoPtr->firstValueTemp + i)); varsPtr = infoPtr->varLists[i]; for (j=0 ; jnumVars ; j++) { if (j) { Tcl_AppendToObj(appendObj, ", ", -1); } - Tcl_AppendPrintfToObj(appendObj, "%%v%u", - (unsigned) varsPtr->varIndexes[j]); + Tcl_AppendPrintfToObj(appendObj, "%%v%" TCL_Z_MODIFIER "u", + (size_t)varsPtr->varIndexes[j]); } Tcl_AppendToObj(appendObj, "]", -1); } @@ -3019,9 +3018,9 @@ PrintNewForeachInfo( { ForeachInfo *infoPtr = (ForeachInfo *)clientData; ForeachVarList *varsPtr; - int i, j; + size_t i, j; - Tcl_AppendPrintfToObj(appendObj, "jumpOffset=%+d, vars=", + Tcl_AppendPrintfToObj(appendObj, "jumpOffset=%+" TCL_Z_MODIFIER "d, vars=", infoPtr->loopCtTemp); for (i=0 ; inumLists ; i++) { if (i) { @@ -3049,7 +3048,7 @@ DisassembleForeachInfo( { ForeachInfo *infoPtr = (ForeachInfo *)clientData; ForeachVarList *varsPtr; - int i, j; + size_t i, j; Tcl_Obj *objPtr, *innerPtr; /* @@ -3096,7 +3095,7 @@ DisassembleNewForeachInfo( { ForeachInfo *infoPtr = (ForeachInfo *)clientData; ForeachVarList *varsPtr; - int i, j; + size_t i, j; Tcl_Obj *objPtr, *innerPtr; /* diff --git a/generic/tclCompile.h b/generic/tclCompile.h index b7d98b6..c24150d 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -871,7 +871,7 @@ typedef struct InstructionDesc { * computations. The value INT_MIN signals * that the instruction's worst case effect is * (1-opnd1). */ - int numOperands; /* Number of operands. */ + size_t numOperands; /* Number of operands. */ InstOperandType opTypes[MAX_INSTRUCTION_OPERANDS]; /* The type of each operand. */ } InstructionDesc; @@ -934,14 +934,14 @@ typedef enum { typedef struct JumpFixup { TclJumpType jumpType; /* Indicates the kind of jump. */ - unsigned int codeOffset; /* Offset of the first byte of the one-byte + size_t codeOffset; /* Offset of the first byte of the one-byte * forward jump's code. */ - int cmdIndex; /* Index of the first command after the one + size_t cmdIndex; /* Index of the first command after the one * for which the jump was emitted. Used to * update the code offsets for subsequent * commands if the two-byte jump at jumpPc * must be replaced with a five-byte one. */ - int exceptIndex; /* Index of the first range entry in the + size_t exceptIndex; /* Index of the first range entry in the * ExceptionRange array after the current one. * This field is used to adjust the code * offsets in subsequent ExceptionRange @@ -953,8 +953,8 @@ typedef struct JumpFixup { typedef struct JumpFixupArray { JumpFixup *fixup; /* Points to start of jump fixup array. */ - int next; /* Index of next free array entry. */ - int end; /* Index of last usable entry in array. */ + size_t next; /* Index of next free array entry. */ + size_t end; /* Index of last usable entry in array. */ int mallocedArray; /* 1 if array was expanded and fixups points * into the heap, else 0. */ JumpFixup staticFixupSpace[JUMPFIXUP_INIT_ENTRIES]; @@ -969,7 +969,7 @@ typedef struct JumpFixupArray { */ typedef struct ForeachVarList { - int numVars; /* The number of variables in the list. */ + size_t numVars; /* The number of variables in the list. */ int varIndexes[TCLFLEXARRAY];/* An array of the indexes ("slot numbers") * for each variable in the procedure's array * of local variables. Only scalar variables @@ -986,11 +986,11 @@ typedef struct ForeachVarList { */ typedef struct ForeachInfo { - int numLists; /* The number of both the variable and value + size_t numLists; /* The number of both the variable and value * lists of the foreach command. */ - int firstValueTemp; /* Index of the first temp var in a proc frame + size_t firstValueTemp; /* Index of the first temp var in a proc frame * used to point to a value list. */ - int loopCtTemp; /* Index of temp var in a proc frame holding + size_t loopCtTemp; /* Index of temp var in a proc frame holding * the loop's iteration count. Used to * determine next value list element to assign * each loop var. */ diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index f946221..4839586 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -541,7 +541,8 @@ FormatInstruction( const InstructionDesc *instDesc = &tclInstructionTable[opCode]; unsigned char *codeStart = codePtr->codeStart; unsigned pcOffset = pc - codeStart; - int opnd = 0, i, j, numBytes = 1; + int opnd = 0, j, numBytes = 1; + size_t i; int localCt = procPtr ? procPtr->numCompiledLocals : 0; CompiledLocal *localPtr = procPtr ? procPtr->firstLocalPtr : NULL; char suffixBuffer[128]; /* Additional info to print after main opcode @@ -941,8 +942,8 @@ DisassembleByteCodeAsDicts( Tcl_Obj *description, *literals, *variables, *instructions, *inst; Tcl_Obj *aux, *exn, *commands, *file; unsigned char *pc, *opnd, *codeOffPtr, *codeLenPtr, *srcOffPtr, *srcLenPtr; - int codeOffset, codeLength, sourceOffset, sourceLength; - int i, val, line; + int val, line, codeOffset, codeLength, sourceOffset, sourceLength; + size_t i; ByteCodeGetInternalRep(objPtr, &tclByteCodeType, codePtr); @@ -951,7 +952,7 @@ DisassembleByteCodeAsDicts( */ TclNewObj(literals); - for (i=0 ; inumLitObjects ; i++) { + for (i=0 ; i<(size_t)codePtr->numLitObjects ; i++) { Tcl_ListObjAppendElement(NULL, literals, codePtr->objArrayPtr[i]); } @@ -961,7 +962,7 @@ DisassembleByteCodeAsDicts( TclNewObj(variables); if (codePtr->procPtr) { - int localCount = codePtr->procPtr->numCompiledLocals; + size_t localCount = codePtr->procPtr->numCompiledLocals; CompiledLocal *localPtr = codePtr->procPtr->firstLocalPtr; for (i=0 ; inextPtr) { @@ -1111,7 +1112,7 @@ DisassembleByteCodeAsDicts( */ TclNewObj(aux); - for (i=0 ; inumAuxDataItems ; i++) { + for (i=0 ; i<(size_t)codePtr->numAuxDataItems ; i++) { AuxData *auxData = &codePtr->auxDataArrayPtr[i]; Tcl_Obj *auxDesc = Tcl_NewStringObj(auxData->type->name, -1); @@ -1138,7 +1139,7 @@ DisassembleByteCodeAsDicts( */ TclNewObj(exn); - for (i=0 ; inumExceptRanges ; i++) { + for (i=0 ; i<(size_t)codePtr->numExceptRanges ; i++) { ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i]; switch (rangePtr->type) { @@ -1178,7 +1179,7 @@ DisassembleByteCodeAsDicts( srcOffPtr = codePtr->srcDeltaStart; srcLenPtr = codePtr->srcLengthStart; codeOffset = sourceOffset = 0; - for (i=0 ; inumCommands ; i++) { + for (i=0 ; i<(size_t)codePtr->numCommands ; i++) { Tcl_Obj *cmd; codeOffset += Decode(codeOffPtr); diff --git a/generic/tclExecute.c b/generic/tclExecute.c index bea9798..ab4aef7 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4424,11 +4424,11 @@ TEBCresume( if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); } else { - fprintf(stdout, "%d: (%u) invoking ", + fprintf(stdout, "%d: (%" TCL_Z_MODIFIER "u) invoking ", iPtr->numLevels, - (unsigned)(pc - codePtr->codeStart)); + (size_t)(pc - codePtr->codeStart)); } - for (i = 0; i < opnd; i++) { + for (i = 0; i < (size_t)opnd; i++) { TclPrintObject(stdout, objv[i], 15); fprintf(stdout, " "); } @@ -6218,11 +6218,11 @@ TEBCresume( ForeachInfo *infoPtr; Tcl_Obj *listPtr, **elements; ForeachVarList *varListPtr; - int numLists, listLen, numVars; - int listTmpDepth; + size_t numLists, numVars; + int listTmpDepth, listLen; size_t iterNum, iterMax, iterTmp; - int varIndex, valIndex, j; - long i; + size_t varIndex, valIndex, j; + size_t i; case INST_FOREACH_START: /* @@ -6330,7 +6330,7 @@ TEBCresume( valIndex = (iterNum * numVars); for (j = 0; j < numVars; j++) { - if (valIndex >= listLen) { + if (valIndex >= (size_t)listLen) { TclNewObj(valuePtr); } else { valuePtr = elements[valIndex]; @@ -6355,7 +6355,7 @@ TEBCresume( if (TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL, valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){ CACHE_STACK_INFO(); - TRACE_APPEND(("ERROR init. index temp %d: %.30s", + TRACE_APPEND(("ERROR init. index temp %" TCL_Z_MODIFIER "d: %.30s", varIndex, O2S(Tcl_GetObjResult(interp)))); goto gotError; } @@ -6402,7 +6402,7 @@ TEBCresume( tmpPtr = OBJ_AT_DEPTH(1); infoPtr = (ForeachInfo *)tmpPtr->internalRep.twoPtrValue.ptr1; numLists = infoPtr->numLists; - TRACE_APPEND(("=> appending to list at depth %d\n", 3 + numLists)); + TRACE_APPEND(("=> appending to list at depth %" TCL_Z_MODIFIER "d\n", 3 + numLists)); objPtr = OBJ_AT_DEPTH(3 + numLists); Tcl_ListObjAppendElement(NULL, objPtr, OBJ_AT_TOS); -- cgit v0.12 From 33eea6856d85ce80c6097dd8d3673632e57b38bf Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 28 Feb 2022 11:43:20 +0000 Subject: Backout part of previous commit, making compile.test work again with --enable-symbols=all --- generic/tclCmdAH.c | 6 +++--- generic/tclCompCmds.c | 12 ++++++------ generic/tclCompile.h | 12 ++++++------ generic/tclDisassemble.c | 17 ++++++++--------- generic/tclExecute.c | 18 +++++++++--------- 5 files changed, 32 insertions(+), 33 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 00bcdff..9bab9bf 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -2474,9 +2474,9 @@ EachloopCmd( int objc, /* The arguments being passed in... */ Tcl_Obj *const objv[]) { - size_t i, j, numLists = (objc-2) / 2; + int numLists = (objc-2) / 2; struct ForeachState *statePtr; - int result; + int i, j, result; if (objc < 4 || (objc%2 != 0)) { Tcl_WrongNumArgs(interp, 1, objv, @@ -2558,7 +2558,7 @@ EachloopCmd( if ((statePtr->argcList[i] % statePtr->varcList[i]) != 0) { j++; } - if (j > (size_t)statePtr->maxj) { + if (j > statePtr->maxj) { statePtr->maxj = j; } } diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 39a21c8..a44e7dd 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -2845,9 +2845,9 @@ CompileEachloopCmd( * body's code. Misuse loopCtTemp for storing the jump size. */ - jumpBackOffset = envPtr->exceptArrayPtr[range].codeOffset - - envPtr->exceptArrayPtr[range].continueOffset; - infoPtr->loopCtTemp = jumpBackOffset; + jumpBackOffset = envPtr->exceptArrayPtr[range].continueOffset - + envPtr->exceptArrayPtr[range].codeOffset; + infoPtr->loopCtTemp = -jumpBackOffset; /* * The command's result is an empty string if not collecting. If @@ -2895,7 +2895,7 @@ DupForeachInfo( ForeachInfo *srcPtr = (ForeachInfo *)clientData; ForeachInfo *dupPtr; ForeachVarList *srcListPtr, *dupListPtr; - size_t numVars, i, j, numLists = srcPtr->numLists; + int numVars, i, j, numLists = srcPtr->numLists; dupPtr = (ForeachInfo *)Tcl_Alloc(offsetof(ForeachInfo, varLists) + numLists * sizeof(ForeachVarList *)); @@ -3002,8 +3002,8 @@ PrintForeachInfo( if (j) { Tcl_AppendToObj(appendObj, ", ", -1); } - Tcl_AppendPrintfToObj(appendObj, "%%v%" TCL_Z_MODIFIER "u", - (size_t)varsPtr->varIndexes[j]); + Tcl_AppendPrintfToObj(appendObj, "%%v%u", + (unsigned) varsPtr->varIndexes[j]); } Tcl_AppendToObj(appendObj, "]", -1); } diff --git a/generic/tclCompile.h b/generic/tclCompile.h index c24150d..0d37c6b 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -871,7 +871,7 @@ typedef struct InstructionDesc { * computations. The value INT_MIN signals * that the instruction's worst case effect is * (1-opnd1). */ - size_t numOperands; /* Number of operands. */ + int numOperands; /* Number of operands. */ InstOperandType opTypes[MAX_INSTRUCTION_OPERANDS]; /* The type of each operand. */ } InstructionDesc; @@ -934,14 +934,14 @@ typedef enum { typedef struct JumpFixup { TclJumpType jumpType; /* Indicates the kind of jump. */ - size_t codeOffset; /* Offset of the first byte of the one-byte + unsigned int codeOffset; /* Offset of the first byte of the one-byte * forward jump's code. */ - size_t cmdIndex; /* Index of the first command after the one + int cmdIndex; /* Index of the first command after the one * for which the jump was emitted. Used to * update the code offsets for subsequent * commands if the two-byte jump at jumpPc * must be replaced with a five-byte one. */ - size_t exceptIndex; /* Index of the first range entry in the + int exceptIndex; /* Index of the first range entry in the * ExceptionRange array after the current one. * This field is used to adjust the code * offsets in subsequent ExceptionRange @@ -953,8 +953,8 @@ typedef struct JumpFixup { typedef struct JumpFixupArray { JumpFixup *fixup; /* Points to start of jump fixup array. */ - size_t next; /* Index of next free array entry. */ - size_t end; /* Index of last usable entry in array. */ + int next; /* Index of next free array entry. */ + int end; /* Index of last usable entry in array. */ int mallocedArray; /* 1 if array was expanded and fixups points * into the heap, else 0. */ JumpFixup staticFixupSpace[JUMPFIXUP_INIT_ENTRIES]; diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 4839586..f946221 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -541,8 +541,7 @@ FormatInstruction( const InstructionDesc *instDesc = &tclInstructionTable[opCode]; unsigned char *codeStart = codePtr->codeStart; unsigned pcOffset = pc - codeStart; - int opnd = 0, j, numBytes = 1; - size_t i; + int opnd = 0, i, j, numBytes = 1; int localCt = procPtr ? procPtr->numCompiledLocals : 0; CompiledLocal *localPtr = procPtr ? procPtr->firstLocalPtr : NULL; char suffixBuffer[128]; /* Additional info to print after main opcode @@ -942,8 +941,8 @@ DisassembleByteCodeAsDicts( Tcl_Obj *description, *literals, *variables, *instructions, *inst; Tcl_Obj *aux, *exn, *commands, *file; unsigned char *pc, *opnd, *codeOffPtr, *codeLenPtr, *srcOffPtr, *srcLenPtr; - int val, line, codeOffset, codeLength, sourceOffset, sourceLength; - size_t i; + int codeOffset, codeLength, sourceOffset, sourceLength; + int i, val, line; ByteCodeGetInternalRep(objPtr, &tclByteCodeType, codePtr); @@ -952,7 +951,7 @@ DisassembleByteCodeAsDicts( */ TclNewObj(literals); - for (i=0 ; i<(size_t)codePtr->numLitObjects ; i++) { + for (i=0 ; inumLitObjects ; i++) { Tcl_ListObjAppendElement(NULL, literals, codePtr->objArrayPtr[i]); } @@ -962,7 +961,7 @@ DisassembleByteCodeAsDicts( TclNewObj(variables); if (codePtr->procPtr) { - size_t localCount = codePtr->procPtr->numCompiledLocals; + int localCount = codePtr->procPtr->numCompiledLocals; CompiledLocal *localPtr = codePtr->procPtr->firstLocalPtr; for (i=0 ; inextPtr) { @@ -1112,7 +1111,7 @@ DisassembleByteCodeAsDicts( */ TclNewObj(aux); - for (i=0 ; i<(size_t)codePtr->numAuxDataItems ; i++) { + for (i=0 ; inumAuxDataItems ; i++) { AuxData *auxData = &codePtr->auxDataArrayPtr[i]; Tcl_Obj *auxDesc = Tcl_NewStringObj(auxData->type->name, -1); @@ -1139,7 +1138,7 @@ DisassembleByteCodeAsDicts( */ TclNewObj(exn); - for (i=0 ; i<(size_t)codePtr->numExceptRanges ; i++) { + for (i=0 ; inumExceptRanges ; i++) { ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i]; switch (rangePtr->type) { @@ -1179,7 +1178,7 @@ DisassembleByteCodeAsDicts( srcOffPtr = codePtr->srcDeltaStart; srcLenPtr = codePtr->srcLengthStart; codeOffset = sourceOffset = 0; - for (i=0 ; i<(size_t)codePtr->numCommands ; i++) { + for (i=0 ; inumCommands ; i++) { Tcl_Obj *cmd; codeOffset += Decode(codeOffPtr); diff --git a/generic/tclExecute.c b/generic/tclExecute.c index ab4aef7..0eb971f 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4424,9 +4424,9 @@ TEBCresume( if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); } else { - fprintf(stdout, "%d: (%" TCL_Z_MODIFIER "u) invoking ", + fprintf(stdout, "%d: (%u) invoking ", iPtr->numLevels, - (size_t)(pc - codePtr->codeStart)); + (unsigned)(pc - codePtr->codeStart)); } for (i = 0; i < (size_t)opnd; i++) { TclPrintObject(stdout, objv[i], 15); @@ -6218,11 +6218,11 @@ TEBCresume( ForeachInfo *infoPtr; Tcl_Obj *listPtr, **elements; ForeachVarList *varListPtr; - size_t numLists, numVars; - int listTmpDepth, listLen; + int numLists, listLen, numVars; + int listTmpDepth; size_t iterNum, iterMax, iterTmp; - size_t varIndex, valIndex, j; - size_t i; + int varIndex, valIndex, j; + long i; case INST_FOREACH_START: /* @@ -6330,7 +6330,7 @@ TEBCresume( valIndex = (iterNum * numVars); for (j = 0; j < numVars; j++) { - if (valIndex >= (size_t)listLen) { + if (valIndex >= listLen) { TclNewObj(valuePtr); } else { valuePtr = elements[valIndex]; @@ -6355,7 +6355,7 @@ TEBCresume( if (TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL, valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){ CACHE_STACK_INFO(); - TRACE_APPEND(("ERROR init. index temp %" TCL_Z_MODIFIER "d: %.30s", + TRACE_APPEND(("ERROR init. index temp %d: %.30s", varIndex, O2S(Tcl_GetObjResult(interp)))); goto gotError; } @@ -6402,7 +6402,7 @@ TEBCresume( tmpPtr = OBJ_AT_DEPTH(1); infoPtr = (ForeachInfo *)tmpPtr->internalRep.twoPtrValue.ptr1; numLists = infoPtr->numLists; - TRACE_APPEND(("=> appending to list at depth %" TCL_Z_MODIFIER "d\n", 3 + numLists)); + TRACE_APPEND(("=> appending to list at depth %d\n", 3 + numLists)); objPtr = OBJ_AT_DEPTH(3 + numLists); Tcl_ListObjAppendElement(NULL, objPtr, OBJ_AT_TOS); -- cgit v0.12 From 9a1c1f5e11679feeaafd9c788631fc98faf6945e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 1 Mar 2022 08:42:33 +0000 Subject: Use size_t in AuxDataPrintProc --- generic/tclBinary.c | 6 ++--- generic/tclCompCmds.c | 12 +++++----- generic/tclCompCmdsSZ.c | 8 +++---- generic/tclCompile.h | 6 ++--- generic/tclExecute.c | 62 ++++++++++++++++++++++++------------------------- unix/tclUnixPipe.c | 2 +- win/tclWinPipe.c | 4 ++-- 7 files changed, 50 insertions(+), 50 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index c1569d5..dd8bbc0 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2292,9 +2292,9 @@ ScanNumber( if (flags & BINARY_UNSIGNED) { return Tcl_NewWideIntObj((Tcl_WideInt)(unsigned long)value); } - if ((value & (((unsigned) 1) << 31)) && (value > 0)) { - value -= (((unsigned) 1) << 31); - value -= (((unsigned) 1) << 31); + if ((value & (1U << 31)) && (value > 0)) { + value -= (1U << 31); + value -= (1U << 31); } returnNumericObject: diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index a44e7dd..e95b1fb 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -2292,7 +2292,7 @@ PrintDictUpdateInfo( ClientData clientData, Tcl_Obj *appendObj, TCL_UNUSED(ByteCode *), - TCL_UNUSED(unsigned int)) + TCL_UNUSED(size_t)) { DictUpdateInfo *duiPtr = (DictUpdateInfo *)clientData; size_t i; @@ -2310,7 +2310,7 @@ DisassembleDictUpdateInfo( ClientData clientData, Tcl_Obj *dictObj, TCL_UNUSED(ByteCode *), - TCL_UNUSED(unsigned int)) + TCL_UNUSED(size_t)) { DictUpdateInfo *duiPtr = (DictUpdateInfo *)clientData; size_t i; @@ -2974,7 +2974,7 @@ PrintForeachInfo( ClientData clientData, Tcl_Obj *appendObj, TCL_UNUSED(ByteCode *), - TCL_UNUSED(unsigned int)) + TCL_UNUSED(size_t)) { ForeachInfo *infoPtr = (ForeachInfo *)clientData; ForeachVarList *varsPtr; @@ -3014,7 +3014,7 @@ PrintNewForeachInfo( ClientData clientData, Tcl_Obj *appendObj, TCL_UNUSED(ByteCode *), - TCL_UNUSED(unsigned int)) + TCL_UNUSED(size_t)) { ForeachInfo *infoPtr = (ForeachInfo *)clientData; ForeachVarList *varsPtr; @@ -3044,7 +3044,7 @@ DisassembleForeachInfo( ClientData clientData, Tcl_Obj *dictObj, TCL_UNUSED(ByteCode *), - TCL_UNUSED(unsigned int)) + TCL_UNUSED(size_t)) { ForeachInfo *infoPtr = (ForeachInfo *)clientData; ForeachVarList *varsPtr; @@ -3091,7 +3091,7 @@ DisassembleNewForeachInfo( ClientData clientData, Tcl_Obj *dictObj, TCL_UNUSED(ByteCode *), - TCL_UNUSED(unsigned int)) + TCL_UNUSED(size_t)) { ForeachInfo *infoPtr = (ForeachInfo *)clientData; ForeachVarList *varsPtr; diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index dc07e49..0dad757 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -2586,13 +2586,13 @@ PrintJumptableInfo( ClientData clientData, Tcl_Obj *appendObj, TCL_UNUSED(ByteCode *), - unsigned int pcOffset) + size_t pcOffset) { JumptableInfo *jtPtr = (JumptableInfo *)clientData; Tcl_HashEntry *hPtr; Tcl_HashSearch search; const char *keyPtr; - int offset, i = 0; + size_t offset, i = 0; hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search); for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) { @@ -2605,7 +2605,7 @@ PrintJumptableInfo( Tcl_AppendToObj(appendObj, "\n\t\t", -1); } } - Tcl_AppendPrintfToObj(appendObj, "\"%s\"->pc %d", + Tcl_AppendPrintfToObj(appendObj, "\"%s\"->pc %" TCL_Z_MODIFIER "u", keyPtr, pcOffset + offset); } } @@ -2615,7 +2615,7 @@ DisassembleJumptableInfo( ClientData clientData, Tcl_Obj *dictObj, TCL_UNUSED(ByteCode *), - TCL_UNUSED(unsigned int)) + TCL_UNUSED(size_t)) { JumptableInfo *jtPtr = (JumptableInfo *)clientData; Tcl_Obj *mapping; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 0d37c6b..fce7111 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -221,7 +221,7 @@ typedef void *(AuxDataDupProc) (void *clientData); typedef void (AuxDataFreeProc) (void *clientData); typedef void (AuxDataPrintProc)(void *clientData, Tcl_Obj *appendObj, struct ByteCode *codePtr, - unsigned int pcOffset); + size_t pcOffset); /* * We define a separate AuxDataType struct to hold type-related information @@ -1805,8 +1805,8 @@ MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, const char **args, int *argsi); FILE *tclDTraceDebugLog = NULL; \ void TclDTraceOpenDebugLog(void) { \ char n[35]; \ - sprintf(n, "/tmp/tclDTraceDebug-%" TCL_Z_MODIFIER "u.log", \ - (size_t) getpid()); \ + sprintf(n, "/tmp/tclDTraceDebug-%d.log", \ + getpid()); \ tclDTraceDebugLog = fopen(n, "a"); \ } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 0eb971f..47b48fb 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -379,9 +379,9 @@ VarHashCreateVar( #ifdef TCL_COMPILE_DEBUG # define TRACE(a) \ while (traceInstructions) { \ - fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \ + fprintf(stdout, "%2d: %2d (%" TCL_Z_MODIFIER "u) %s ", iPtr->numLevels, \ (int) CURR_DEPTH, \ - (unsigned) (pc - codePtr->codeStart), \ + (size_t) (pc - codePtr->codeStart), \ GetOpcodeName(pc)); \ printf a; \ break; \ @@ -395,9 +395,9 @@ VarHashCreateVar( TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); # define TRACE_WITH_OBJ(a, objPtr) \ while (traceInstructions) { \ - fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \ + fprintf(stdout, "%2d: %2d (%" TCL_Z_MODIFIER "u) %s ", iPtr->numLevels, \ (int) CURR_DEPTH, \ - (unsigned) (pc - codePtr->codeStart), \ + (size_t) (pc - codePtr->codeStart), \ GetOpcodeName(pc)); \ printf a; \ TclPrintObject(stdout, objPtr, 30); \ @@ -2389,8 +2389,8 @@ TEBCresume( if (traceInstructions) { TRACE_APPEND(("YIELD...\n")); } else { - fprintf(stdout, "%d: (%u) yielding value \"%.30s\"\n", - iPtr->numLevels, (unsigned)(pc - codePtr->codeStart), + fprintf(stdout, "%d: (%" TCL_Z_MODIFIER "u) yielding value \"%.30s\"\n", + iPtr->numLevels, (size_t)(pc - codePtr->codeStart), Tcl_GetString(OBJ_AT_TOS)); } fflush(stdout); @@ -2432,8 +2432,8 @@ TEBCresume( TRACE(("[%.30s] => YIELD...\n", O2S(valuePtr))); } else { /* FIXME: What is the right thing to trace? */ - fprintf(stdout, "%d: (%u) yielding to [%.30s]\n", - iPtr->numLevels, (unsigned)(pc - codePtr->codeStart), + fprintf(stdout, "%d: (%" TCL_Z_MODIFIER "u) yielding to [%.30s]\n", + iPtr->numLevels, (size_t)(pc - codePtr->codeStart), TclGetString(valuePtr)); } fflush(stdout); @@ -2791,8 +2791,8 @@ TEBCresume( strncpy(cmdNameBuf, TclGetString(objv[0]), 20); TRACE(("%u => call ", objc)); } else { - fprintf(stdout, "%d: (%u) invoking ", iPtr->numLevels, - (unsigned)(pc - codePtr->codeStart)); + fprintf(stdout, "%d: (%" TCL_Z_MODIFIER "u) invoking ", iPtr->numLevels, + (size_t)(pc - codePtr->codeStart)); } for (i = 0; i < objc; i++) { TclPrintObject(stdout, objv[i], 15); @@ -2839,8 +2839,8 @@ TEBCresume( TRACE(("%u => call (implementation %s) ", objc, O2S(objPtr))); } else { fprintf(stdout, - "%d: (%u) invoking (using implementation %s) ", - iPtr->numLevels, (unsigned)(pc - codePtr->codeStart), + "%d: (%" TCL_Z_MODIFIER "u) invoking (using implementation %s) ", + iPtr->numLevels, (size_t)(pc - codePtr->codeStart), O2S(objPtr)); } for (i = 0; i < objc; i++) { @@ -4139,15 +4139,15 @@ TEBCresume( case INST_JUMP1: opnd = TclGetInt1AtPtr(pc+1); - TRACE(("%d => new pc %u\n", opnd, - (unsigned)(pc + opnd - codePtr->codeStart))); + TRACE(("%d => new pc %" TCL_Z_MODIFIER "u\n", opnd, + (size_t)(pc + opnd - codePtr->codeStart))); NEXT_INST_F(opnd, 0, 0); break; case INST_JUMP4: opnd = TclGetInt4AtPtr(pc+1); - TRACE(("%d => new pc %u\n", opnd, - (unsigned)(pc + opnd - codePtr->codeStart))); + TRACE(("%d => new pc %" TCL_Z_MODIFIER "u\n", opnd, + (size_t)(pc + opnd - codePtr->codeStart))); NEXT_INST_F(opnd, 0, 0); { @@ -4189,8 +4189,8 @@ TEBCresume( #ifdef TCL_COMPILE_DEBUG if (b) { if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) { - TRACE_APPEND(("%.20s true, new pc %u\n", O2S(valuePtr), - (unsigned)(pc + jmpOffset[1] - codePtr->codeStart))); + TRACE_APPEND(("%.20s true, new pc %" TCL_Z_MODIFIER "u\n", O2S(valuePtr), + (size_t)(pc + jmpOffset[1] - codePtr->codeStart))); } else { TRACE_APPEND(("%.20s true\n", O2S(valuePtr))); } @@ -4198,8 +4198,8 @@ TEBCresume( if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) { TRACE_APPEND(("%.20s false\n", O2S(valuePtr))); } else { - TRACE_APPEND(("%.20s false, new pc %u\n", O2S(valuePtr), - (unsigned)(pc + jmpOffset[0] - codePtr->codeStart))); + TRACE_APPEND(("%.20s false, new pc %" TCL_Z_MODIFIER "u\n", O2S(valuePtr), + (size_t)(pc + jmpOffset[0] - codePtr->codeStart))); } } #endif @@ -4223,8 +4223,8 @@ TEBCresume( if (hPtr != NULL) { int jumpOffset = PTR2INT(Tcl_GetHashValue(hPtr)); - TRACE_APPEND(("found in table, new pc %u\n", - (unsigned)(pc - codePtr->codeStart + jumpOffset))); + TRACE_APPEND(("found in table, new pc %" TCL_Z_MODIFIER "u\n", + (size_t)(pc - codePtr->codeStart + jumpOffset))); NEXT_INST_F(jumpOffset, 1, 0); } else { TRACE_APPEND(("not found in table\n")); @@ -4424,9 +4424,9 @@ TEBCresume( if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); } else { - fprintf(stdout, "%d: (%u) invoking ", + fprintf(stdout, "%d: (%" TCL_Z_MODIFIER "u) invoking ", iPtr->numLevels, - (unsigned)(pc - codePtr->codeStart)); + (size_t)(pc - codePtr->codeStart)); } for (i = 0; i < (size_t)opnd; i++) { TclPrintObject(stdout, objv[i], 15); @@ -4526,8 +4526,8 @@ TEBCresume( if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); } else { - fprintf(stdout, "%d: (%u) invoking ", - iPtr->numLevels, (unsigned)(pc - codePtr->codeStart)); + fprintf(stdout, "%d: (%" TCL_Z_MODIFIER "u) invoking ", + iPtr->numLevels, (size_t)(pc - codePtr->codeStart)); } for (i = 0; i < opnd; i++) { TclPrintObject(stdout, objv[i], 15); @@ -7412,9 +7412,9 @@ TEBCresume( #ifdef TCL_COMPILE_DEBUG if (traceInstructions) { fprintf(stdout, " ... found catch at %d, catchTop=%d, " - "unwound to %ld, new pc %u\n", + "unwound to %ld, new pc %" TCL_Z_MODIFIER "u\n", rangePtr->codeOffset, (int) (catchTop - initCatchTop - 1), - (long)*catchTop, (unsigned) rangePtr->catchOffset); + (long)*catchTop, (size_t) rangePtr->catchOffset); } #endif pc = (codePtr->codeStart + rangePtr->catchOffset); @@ -7450,10 +7450,10 @@ TEBCresume( if (tosPtr < initTosPtr) { fprintf(stderr, - "\nTclNRExecuteByteCode: abnormal return at pc %u: " + "\nTclNRExecuteByteCode: abnormal return at pc %" TCL_Z_MODIFIER "u: " "stack top %d < entry stack top %d\n", - (unsigned)(pc - codePtr->codeStart), - (unsigned) CURR_DEPTH, (unsigned) 0); + (size_t)(pc - codePtr->codeStart), + (int) CURR_DEPTH, 0); Tcl_Panic("TclNRExecuteByteCode execution failure: end stack top < start stack top"); } CLANG_ASSERT(bcFramePtr); diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c index bb0943a..27e8182 100644 --- a/unix/tclUnixPipe.c +++ b/unix/tclUnixPipe.c @@ -1289,7 +1289,7 @@ Tcl_PidObjCmd( TclNewObj(resultPtr); for (i = 0; i < pipePtr->numPids; i++) { Tcl_ListObjAppendElement(NULL, resultPtr, - Tcl_NewWideIntObj(PTR2INT(TclpGetPid(pipePtr->pidPtr[i])))); + Tcl_NewWideIntObj(TclpGetPid(pipePtr->pidPtr[i]))); } Tcl_SetObjResult(interp, resultPtr); } diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index 41692a5..b4f9ff0 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -2759,7 +2759,7 @@ Tcl_PidObjCmd( return TCL_ERROR; } if (objc == 1) { - Tcl_SetObjResult(interp, Tcl_NewWideIntObj((unsigned) getpid())); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(getpid())); } else { chan = Tcl_GetChannel(interp, TclGetString(objv[1]), NULL); @@ -2775,7 +2775,7 @@ Tcl_PidObjCmd( TclNewObj(resultPtr); for (i = 0; i < pipePtr->numPids; i++) { Tcl_ListObjAppendElement(/*interp*/ NULL, resultPtr, - Tcl_NewWideIntObj((unsigned) + Tcl_NewWideIntObj( TclpGetPid(pipePtr->pidPtr[i]))); } Tcl_SetObjResult(interp, resultPtr); -- cgit v0.12 From 6dc1f8021ed597b13289a02c41c2e9660525a81a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 2 Mar 2022 16:00:19 +0000 Subject: Use TIP #613's Tcl_GetIndexFromObj() to eliminate typecasts which are no longer necessary --- generic/regc_locale.c | 48 ++++++++++++++++++++++++------------------------ generic/tclCmdMZ.c | 28 ++++++++++++---------------- generic/tclCompCmdsSZ.c | 10 +++++++--- generic/tclConfig.c | 6 +++--- generic/tclDictObj.c | 6 +++--- generic/tclDisassemble.c | 6 +++--- generic/tclEnsemble.c | 5 +++-- generic/tclEvent.c | 5 ++--- generic/tclFileName.c | 6 +++--- generic/tclIOCmd.c | 12 ++++++------ generic/tclLoad.c | 14 +++++++------- generic/tclOOBasic.c | 5 ++--- generic/tclOOInfo.c | 20 ++++++++++---------- generic/tclPkg.c | 6 +++--- generic/tclProcess.c | 6 +++--- generic/tclTest.c | 29 ++++++++++++++--------------- generic/tclThreadTest.c | 5 ++--- generic/tclTrace.c | 5 ++--- generic/tclVar.c | 12 ++++++------ generic/tclZlib.c | 24 ++++++++++++------------ 20 files changed, 127 insertions(+), 131 deletions(-) diff --git a/generic/regc_locale.c b/generic/regc_locale.c index cf751ba..56a7ae7 100644 --- a/generic/regc_locale.c +++ b/generic/regc_locale.c @@ -999,12 +999,12 @@ cclass( const chr *endp, /* just past the end of the name */ int cases) /* case-independent? */ { - size_t len; + size_t i, len; struct cvec *cv = NULL; Tcl_DString ds; const char *np; const char *const *namePtr; - int i, index; + int index; /* * The following arrays define the valid character class names. @@ -1062,14 +1062,14 @@ cclass( case CC_ALNUM: cv = getcvec(v, NUM_ALPHA_CHAR, NUM_DIGIT_RANGE + NUM_ALPHA_RANGE); if (cv) { - for (i=0 ; (size_t)i 6) { Tcl_WrongNumArgs(interp, 1, objv, @@ -1563,13 +1561,11 @@ StringIsCmd( if (objc != 3) { for (i = 2; i < objc-1; i++) { - int idx2; - if (Tcl_GetIndexFromObj(interp, objv[i], isOptions, "option", 0, &idx2) != TCL_OK) { return TCL_ERROR; } - switch ((enum isOptionsEnum) idx2) { + switch (idx2) { case OPT_STRICT: strict = 1; break; @@ -1598,7 +1594,7 @@ StringIsCmd( * When entering here, result == 1 and failat == 0. */ - switch ((enum isClassesEnum) index) { + switch (index) { case STR_IS_ALNUM: chcomp = Tcl_UniCharIsAlnum; break; @@ -3459,7 +3455,7 @@ TclNRSwitchObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int i,j, index, mode, foundmode, splitObjs, numMatchesSaved; + int i,j, mode, foundmode, splitObjs, numMatchesSaved; int noCase, patternLength; const char *pattern; Tcl_Obj *stringObj, *indexVarObj, *matchVarObj; @@ -3484,7 +3480,7 @@ TclNRSwitchObjCmd( enum switchOptionsEnum { OPT_EXACT, OPT_GLOB, OPT_INDEXV, OPT_MATCHV, OPT_NOCASE, OPT_REGEXP, OPT_LAST - }; + } index; typedef int (*strCmpFn_t)(const char *, const char *); strCmpFn_t strCmpFn = TclUtfCmp; @@ -3502,7 +3498,7 @@ TclNRSwitchObjCmd( &index) != TCL_OK) { return TCL_ERROR; } - switch ((enum switchOptionsEnum) index) { + switch (index) { /* * General options. */ diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index aa2d13e..4c01771 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -518,8 +518,8 @@ TclCompileStringIsCmd( STR_IS_LIST, STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE, STR_IS_TRUE, STR_IS_UPPER, STR_IS_UNICODE, STR_IS_WIDE, STR_IS_WORD, STR_IS_XDIGIT - }; - int t, range, allowEmpty = 0, end; + } t; + int range, allowEmpty = 0, end; InstStringClassType strClassType; Tcl_Obj *isClass; @@ -575,7 +575,7 @@ TclCompileStringIsCmd( CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1); - switch ((enum isClassesEnum) t) { + switch (t) { case STR_IS_ALNUM: strClassType = STR_CLASS_ALNUM; goto compileStrClass; @@ -683,6 +683,8 @@ TclCompileStringIsCmd( FIXJUMP1( over); OP( LNOT); return TCL_OK; + default: + break; } break; @@ -748,6 +750,8 @@ TclCompileStringIsCmd( PUSH( "3"); OP( LE); break; + default: + break; } FIXJUMP1( end); return TCL_OK; diff --git a/generic/tclConfig.c b/generic/tclConfig.c index a145bac..cfa7596 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -199,13 +199,13 @@ QueryConfigObjCmd( QCCD *cdPtr = (QCCD *)clientData; Tcl_Obj *pkgName = cdPtr->pkg; Tcl_Obj *pDB, *pkgDict, *val, *listPtr; - int n, index; + int n; static const char *const subcmdStrings[] = { "get", "list", NULL }; enum subcmds { CFG_GET, CFG_LIST - }; + } index; Tcl_DString conv; Tcl_Encoding venc = NULL; const char *value; @@ -233,7 +233,7 @@ QueryConfigObjCmd( return TCL_ERROR; } - switch ((enum subcmds) index) { + switch (index) { case CFG_GET: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "key"); diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index b93b141..7feb8b9 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -2996,11 +2996,11 @@ DictFilterCmd( }; enum FilterTypes { FILTER_KEYS, FILTER_SCRIPT, FILTER_VALUES - }; + } index; Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj; Tcl_Obj **varv, *keyObj = NULL, *valueObj = NULL, *resultObj, *boolObj; Tcl_DictSearch search; - int index, varc, done, result, satisfied; + int varc, done, result, satisfied; const char *pattern; if (objc < 3) { @@ -3012,7 +3012,7 @@ DictFilterCmd( return TCL_ERROR; } - switch ((enum FilterTypes) index) { + switch (index) { case FILTER_KEYS: /* * Create a dictionary whose keys all match a certain pattern. diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 6f45be1..3b6b7b7 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -1280,8 +1280,8 @@ Tcl_DisassembleObjCmd( DISAS_CLASS_CONSTRUCTOR, DISAS_CLASS_DESTRUCTOR, DISAS_LAMBDA, DISAS_CLASS_METHOD, DISAS_OBJECT_METHOD, DISAS_PROC, DISAS_SCRIPT - }; - int idx, result; + } idx; + int result; Tcl_Obj *codeObjPtr = NULL; Proc *procPtr = NULL; Tcl_HashEntry *hPtr; @@ -1297,7 +1297,7 @@ Tcl_DisassembleObjCmd( return TCL_ERROR; } - switch ((enum Types) idx) { + switch (idx) { case DISAS_LAMBDA: { Command cmd; Tcl_Obj *nsObjPtr; diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 9ee4982..435fd58 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -163,7 +163,8 @@ TclNamespaceEnsembleCmd( Tcl_DictSearch search; Tcl_Obj *listObj; const char *simpleName; - int index, done; + enum EnsSubcmds index; + int done; if (nsPtr == NULL || nsPtr->flags & NS_DEAD) { if (!Tcl_InterpDeleted(interp)) { @@ -184,7 +185,7 @@ TclNamespaceEnsembleCmd( return TCL_ERROR; } - switch ((enum EnsSubcmds) index) { + switch (index) { case ENS_CREATE: { const char *name; int len, allocatedMapFlag = 0; diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 71ca814..e3eca2c 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -1583,10 +1583,9 @@ Tcl_UpdateObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int optionIndex; int flags = 0; /* Initialized to avoid compiler warning. */ static const char *const updateOptions[] = {"idletasks", NULL}; - enum updateOptionsEnum {OPT_IDLETASKS}; + enum updateOptionsEnum {OPT_IDLETASKS} optionIndex; if (objc == 1) { flags = TCL_ALL_EVENTS|TCL_DONT_WAIT; @@ -1595,7 +1594,7 @@ Tcl_UpdateObjCmd( "option", 0, &optionIndex) != TCL_OK) { return TCL_ERROR; } - switch ((enum updateOptionsEnum) optionIndex) { + switch (optionIndex) { case OPT_IDLETASKS: flags = TCL_IDLE_EVENTS|TCL_DONT_WAIT; break; diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 1603951..5b61153 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -1228,7 +1228,7 @@ Tcl_GlobObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int index, i, globFlags, length, join, dir, result; + int i, globFlags, length, join, dir, result; char *string; const char *separators; Tcl_Obj *typePtr, *look; @@ -1241,7 +1241,7 @@ Tcl_GlobObjCmd( enum globOptionsEnum { GLOB_DIR, GLOB_JOIN, GLOB_NOCOMPLAIN, GLOB_PATH, GLOB_TAILS, GLOB_TYPE, GLOB_LAST - }; + } index; enum pathDirOptions {PATH_NONE = -1 , PATH_GENERAL = 0, PATH_DIR = 1}; Tcl_GlobTypeData *globTypes = NULL; @@ -1271,7 +1271,7 @@ Tcl_GlobObjCmd( } } - switch ((enum globOptionsEnum) index) { + switch (index) { case GLOB_NOCOMPLAIN: /* -nocomplain */ globFlags |= TCL_GLOBMODE_NO_COMPLAIN; break; diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 2ab31e4..550ee17 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -1473,8 +1473,8 @@ Tcl_SocketObjCmd( enum socketOptionsEnum { SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_REUSEADDR, SKT_REUSEPORT, SKT_SERVER - }; - int optionIndex, a, server = 0, myport = 0, async = 0, reusep = -1, + } optionIndex; + int a, server = 0, myport = 0, async = 0, reusep = -1, reusea = -1; unsigned int flags = 0; const char *host, *port, *myaddr = NULL; @@ -1495,7 +1495,7 @@ Tcl_SocketObjCmd( TCL_EXACT, &optionIndex) != TCL_OK) { return TCL_ERROR; } - switch ((enum socketOptionsEnum) optionIndex) { + switch (optionIndex) { case SKT_ASYNC: if (server == 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -1804,9 +1804,9 @@ ChanPendingObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Channel chan; - int index, mode; + int mode; static const char *const options[] = {"input", "output", NULL}; - enum pendingOptionsEnum {PENDING_INPUT, PENDING_OUTPUT}; + enum pendingOptionsEnum {PENDING_INPUT, PENDING_OUTPUT} index; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "mode channelId"); @@ -1822,7 +1822,7 @@ ChanPendingObjCmd( return TCL_ERROR; } - switch ((enum pendingOptionsEnum) index) { + switch (index) { case PENDING_INPUT: if (!(mode & TCL_READABLE)) { Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-1)); diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 7ea1ebd..b678d20 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -145,14 +145,14 @@ Tcl_LoadObjCmd( Tcl_LoadHandle loadHandle; Tcl_UniChar ch = 0; unsigned len; - int index, flags = 0; + int flags = 0; Tcl_Obj *const *savedobjv = objv; static const char *const options[] = { "-global", "-lazy", "--", NULL }; enum loadOptionsEnum { LOAD_GLOBAL, LOAD_LAZY, LOAD_LAST - }; + } index; while (objc > 2) { if (TclGetString(objv[1])[0] != '-') { @@ -163,9 +163,9 @@ Tcl_LoadObjCmd( return TCL_ERROR; } ++objv; --objc; - if (LOAD_GLOBAL == (enum loadOptionsEnum) index) { + if (LOAD_GLOBAL == index) { flags |= TCL_LOAD_GLOBAL; - } else if (LOAD_LAZY == (enum loadOptionsEnum) index) { + } else if (LOAD_LAZY == index) { flags |= TCL_LOAD_LAZY; } else { break; @@ -567,7 +567,7 @@ Tcl_UnloadObjCmd( LoadedLibrary *libraryPtr; Tcl_DString pfx, tmp; InterpLibrary *ipFirstPtr, *ipPtr; - int i, index, code, complain = 1, keepLibrary = 0; + int i, code, complain = 1, keepLibrary = 0; const char *fullFileName = ""; const char *prefix; static const char *const options[] = { @@ -575,7 +575,7 @@ Tcl_UnloadObjCmd( }; enum unloadOptionsEnum { UNLOAD_NOCOMPLAIN, UNLOAD_KEEPLIB, UNLOAD_LAST - }; + } index; for (i = 1; i < objc; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, @@ -598,7 +598,7 @@ Tcl_UnloadObjCmd( break; } } - switch ((enum unloadOptionsEnum)index) { + switch (index) { case UNLOAD_NOCOMPLAIN: /* -nocomplain */ complain = 0; break; diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 6ea4681..ad79fde 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -1045,12 +1045,11 @@ TclOOSelfObjCmd( enum SelfCmds { SELF_CALL, SELF_CALLER, SELF_CLASS, SELF_FILTER, SELF_METHOD, SELF_NS, SELF_NEXT, SELF_OBJECT, SELF_TARGET - }; + } index; Interp *iPtr = (Interp *) interp; CallFrame *framePtr = iPtr->varFramePtr; CallContext *contextPtr; Tcl_Obj *result[3]; - int index; #define CurrentlyInvoked(contextPtr) \ ((contextPtr)->callPtr->chain[(contextPtr)->index]) @@ -1084,7 +1083,7 @@ TclOOSelfObjCmd( return TCL_ERROR; } - switch ((enum SelfCmds) index) { + switch (index) { case SELF_OBJECT: Tcl_SetObjResult(interp, TclOOObjectName(interp, contextPtr->oPtr)); return TCL_OK; diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index 4e5b55b..95682cb 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -408,9 +408,9 @@ InfoObjectIsACmd( }; enum IsACats { IsClass, IsMetaclass, IsMixin, IsObject, IsType - }; + } idx; Object *oPtr, *o2Ptr; - int idx, i, result = 0; + int i, result = 0; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "category objName ?arg ...?"); @@ -426,7 +426,7 @@ InfoObjectIsACmd( * number of arguments. */ - switch ((enum IsACats) idx) { + switch (idx) { case IsObject: case IsClass: case IsMetaclass: @@ -454,7 +454,7 @@ InfoObjectIsACmd( goto failPrecondition; } - switch ((enum IsACats) idx) { + switch (idx) { case IsObject: result = 1; break; @@ -532,7 +532,7 @@ InfoObjectMethodsCmd( }; enum Options { OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE, OPT_SCOPE - }; + } idx; static const char *const scopes[] = { "private", "public", "unexported" }; @@ -550,14 +550,14 @@ InfoObjectMethodsCmd( return TCL_ERROR; } if (objc != 2) { - int i, idx; + int i; for (i=2 ; i 1) { if (TclGetString(objv[1])[0] != '-') { @@ -485,7 +485,7 @@ ProcessStatusObjCmd( return TCL_ERROR; } ++objv; --objc; - if (STATUS_WAIT == (enum switchesEnum) index) { + if (STATUS_WAIT == index) { options = 0; } else { break; diff --git a/generic/tclTest.c b/generic/tclTest.c index 009c95f..d1c211d 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -1834,7 +1834,7 @@ TestencodingObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Encoding encoding; - int index, length; + int length; const char *string; TclEncoding *encodingPtr; static const char *const optionStrings[] = { @@ -1842,14 +1842,14 @@ TestencodingObjCmd( }; enum options { ENC_CREATE, ENC_DELETE - }; + } index; if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } - switch ((enum options) index) { + switch (index) { case ENC_CREATE: { Tcl_EncodingType type; @@ -3201,7 +3201,7 @@ TestlinkarrayCmd( static const char *LinkOption[] = { "update", "remove", "create", NULL }; - enum LinkOptionEnum { LINK_UPDATE, LINK_REMOVE, LINK_CREATE }; + enum LinkOptionEnum {LINK_UPDATE, LINK_REMOVE, LINK_CREATE} optionIndex; static const char *LinkType[] = { "char", "uchar", "short", "ushort", "int", "uint", "long", "ulong", "wide", "uwide", "float", "double", "string", "char*", "binary", NULL @@ -3214,7 +3214,7 @@ TestlinkarrayCmd( TCL_LINK_FLOAT, TCL_LINK_DOUBLE, TCL_LINK_STRING, TCL_LINK_CHARS, TCL_LINK_BINARY }; - int optionIndex, typeIndex, readonly, i, size, length; + int typeIndex, readonly, i, size, length; char *name, *arg; Tcl_WideInt addr; @@ -3226,7 +3226,7 @@ TestlinkarrayCmd( &optionIndex) != TCL_OK) { return TCL_ERROR; } - switch ((enum LinkOptionEnum) optionIndex) { + switch (optionIndex) { case LINK_UPDATE: for (i=2; ifreeProc == TestsaveresultFree) ^ freeCount; diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c index 9f08d83..0e33075 100644 --- a/generic/tclThreadTest.c +++ b/generic/tclThreadTest.c @@ -211,7 +211,6 @@ ThreadObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - int option; static const char *const threadOptions[] = { "cancel", "create", "event", "exit", "id", "join", "names", "send", "wait", "errorproc", @@ -221,7 +220,7 @@ ThreadObjCmd( THREAD_CANCEL, THREAD_CREATE, THREAD_EVENT, THREAD_EXIT, THREAD_ID, THREAD_JOIN, THREAD_NAMES, THREAD_SEND, THREAD_WAIT, THREAD_ERRORPROC - }; + } option; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); @@ -244,7 +243,7 @@ ThreadObjCmd( Tcl_MutexUnlock(&threadMutex); } - switch ((enum options)option) { + switch (option) { case THREAD_CANCEL: { Tcl_WideInt id; const char *result; diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 535e2c2..2465aec 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -188,7 +188,6 @@ Tcl_TraceObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int optionIndex; #ifndef TCL_REMOVE_OBSOLETE_TRACES const char *name; const char *flagOps, *p; @@ -207,7 +206,7 @@ Tcl_TraceObjCmd( #ifndef TCL_REMOVE_OBSOLETE_TRACES TRACE_OLD_VARIABLE, TRACE_OLD_VDELETE, TRACE_OLD_VINFO #endif - }; + } optionIndex; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); @@ -218,7 +217,7 @@ Tcl_TraceObjCmd( &optionIndex) != TCL_OK) { return TCL_ERROR; } - switch ((enum traceOptionsEnum) optionIndex) { + switch (optionIndex) { case TRACE_ADD: case TRACE_REMOVE: { /* diff --git a/generic/tclVar.c b/generic/tclVar.c index 5a59fde..8abb1e8 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -3917,12 +3917,12 @@ ArrayNamesCmd( static const char *const options[] = { "-exact", "-glob", "-regexp", NULL }; - enum arrayNamesOptionsEnum { OPT_EXACT, OPT_GLOB, OPT_REGEXP }; + enum arrayNamesOptionsEnum {OPT_EXACT, OPT_GLOB, OPT_REGEXP} mode = OPT_GLOB; Var *varPtr, *varPtr2; Tcl_Obj *nameObj, *resultObj, *patternObj; Tcl_HashSearch search; const char *pattern = NULL; - int isArray, mode = OPT_GLOB; + int isArray; if ((objc < 2) || (objc > 4)) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName ?mode? ?pattern?"); @@ -3985,7 +3985,7 @@ ArrayNamesCmd( const char *name = TclGetString(nameObj); int matched = 0; - switch ((enum arrayNamesOptionsEnum) mode) { + switch (mode) { case OPT_EXACT: Tcl_Panic("exact matching shouldn't get here"); case OPT_GLOB: @@ -6635,10 +6635,10 @@ ArrayDefaultCmd( static const char *const options[] = { "get", "set", "exists", "unset", NULL }; - enum arrayDefaultOptionsEnum { OPT_GET, OPT_SET, OPT_EXISTS, OPT_UNSET }; + enum arrayDefaultOptionsEnum { OPT_GET, OPT_SET, OPT_EXISTS, OPT_UNSET } option; Tcl_Obj *arrayNameObj, *defaultValueObj; Var *varPtr, *arrayPtr; - int isArray, option; + int isArray; /* * Parse arguments. @@ -6659,7 +6659,7 @@ ArrayDefaultCmd( return TCL_ERROR; } - switch ((enum arrayDefaultOptionsEnum)option) { + switch (option) { case OPT_GET: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 6a9a38a..8ab0661 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -2390,7 +2390,7 @@ ZlibPushSubcmd( FMT_INFLATE }; Tcl_Channel chan; - int chanMode, format, mode = 0, level, i, option; + int chanMode, format, mode = 0, level, i; static const char *const pushCompressOptions[] = { "-dictionary", "-header", "-level", NULL }; @@ -2398,7 +2398,7 @@ ZlibPushSubcmd( "-dictionary", "-header", "-level", "-limit", NULL }; const char *const *pushOptions = pushDecompressOptions; - enum pushOptionsEnum {poDictionary, poHeader, poLevel, poLimit}; + enum pushOptionsEnum {poDictionary, poHeader, poLevel, poLimit} option; Tcl_Obj *headerObj = NULL, *compDictObj = NULL; int limit = DEFAULT_BUFFER_SIZE, dummy; @@ -2480,7 +2480,7 @@ ZlibPushSubcmd( Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); return TCL_ERROR; } - switch ((enum pushOptionsEnum) option) { + switch (option) { case poHeader: headerObj = objv[i]; if (Tcl_DictObjSize(interp, headerObj, &dummy) != TCL_OK) { @@ -2560,7 +2560,7 @@ ZlibStreamCmd( Tcl_Obj *const objv[]) { Tcl_ZlibStream zstream = (Tcl_ZlibStream)cd; - int command, count, code; + int count, code; Tcl_Obj *obj; static const char *const cmds[] = { "add", "checksum", "close", "eof", "finalize", "flush", @@ -2570,7 +2570,7 @@ ZlibStreamCmd( enum zlibStreamCommands { zs_add, zs_checksum, zs_close, zs_eof, zs_finalize, zs_flush, zs_fullflush, zs_get, zs_header, zs_put, zs_reset - }; + } command; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option data ?...?"); @@ -2582,7 +2582,7 @@ ZlibStreamCmd( return TCL_ERROR; } - switch ((enum zlibStreamCommands) command) { + switch (command) { case zs_add: /* $strm add ?$flushopt? $data */ return ZlibStreamAddCmd(zstream, interp, objc, objv); case zs_header: /* $strm header */ @@ -2686,14 +2686,14 @@ ZlibStreamAddCmd( Tcl_Obj *const objv[]) { Tcl_ZlibStream zstream = (Tcl_ZlibStream)cd; - int index, code, buffersize = -1, flush = -1, i; + int code, buffersize = -1, flush = -1, i; Tcl_Obj *obj, *compDictObj = NULL; static const char *const add_options[] = { "-buffer", "-dictionary", "-finalize", "-flush", "-fullflush", NULL }; enum addOptions { ao_buffer, ao_dictionary, ao_finalize, ao_flush, ao_fullflush - }; + } index; for (i=2; i= 0) { flush = -2; @@ -2813,14 +2813,14 @@ ZlibStreamPutCmd( Tcl_Obj *const objv[]) { Tcl_ZlibStream zstream = (Tcl_ZlibStream)cd; - int index, flush = -1, i; + int flush = -1, i; Tcl_Obj *compDictObj = NULL; static const char *const put_options[] = { "-dictionary", "-finalize", "-flush", "-fullflush", NULL }; enum putOptions { po_dictionary, po_finalize, po_flush, po_fullflush - }; + } index; for (i=2; i= 0) { flush = -2; -- cgit v0.12 From 67bfd66650822acaa58c1afef5576e8b4760592a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 3 Mar 2022 15:58:46 +0000 Subject: =?UTF-8?q?Fix=20warning=20when=20compiling=20with=20-DTCL=5FUTF?= =?UTF-8?q?=5FMAX=3D3:=20tclDecls.h:3921:27:=20warning:=20initialization?= =?UTF-8?q?=20of=20=E2=80=98size=5Ft=20(*)(const=20int=20*)=E2=80=99=20{ak?= =?UTF-8?q?a=20=E2=80=98long=20unsigned=20int=20(*)(const=20int=20*)?= =?UTF-8?q?=E2=80=99}=20from=20incompatible=20pointer=20type=20=E2=80=98si?= =?UTF-8?q?ze=5Ft=20(*)(const=20short=20unsigned=20int=20*)=E2=80=99=20{ak?= =?UTF-8?q?a=20=E2=80=98long=20unsigned=20int=20(*)(const=20short=20unsign?= =?UTF-8?q?ed=20int=20*)=E2=80=99}=20[-Wincompatible-pointer-types]=20=203?= =?UTF-8?q?921=20|=20#=20=20=20define=20Tcl=5FUniCharLen=20Tcl=5FChar16Len?= =?UTF-8?q?=20=20=20=20=20=20=20|=20=20=20=20=20=20=20=20=20=20=20=20=20?= =?UTF-8?q?=20=20=20=20=20=20=20=20=20=20=20=20=20=20^~~~~~~~~~~~~?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- generic/tclStubInit.c | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 044da51..3121f55 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -66,6 +66,7 @@ #undef Tcl_UniCharToUtfDString #undef Tcl_UtfToUniCharDString #undef Tcl_UtfToUniChar +#undef Tcl_UniCharLen #if !defined(_WIN32) && !defined(__CYGWIN__) #undef Tcl_WinConvertError #define Tcl_WinConvertError 0 -- cgit v0.12 From 4fae186836bab8e7fef53fb7d4344fa2d344b815 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 6 Mar 2022 15:40:05 +0000 Subject: Prepare for Tcl_Parse's commentSize/numTokens to become size_t --- generic/tclTest.c | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index f3f2879..7dd6d44 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -3519,10 +3519,10 @@ PrintParse( Tcl_Obj *objPtr; const char *typeString; Tcl_Token *tokenPtr; - int i; + size_t i; objPtr = Tcl_GetObjResult(interp); - if (parsePtr->commentSize > 0) { + if (parsePtr->commentSize + 1 > 1) { Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewStringObj(parsePtr->commentStart, parsePtr->commentSize)); @@ -3532,8 +3532,8 @@ PrintParse( Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewStringObj(parsePtr->commandStart, parsePtr->commandSize)); Tcl_ListObjAppendElement(NULL, objPtr, - Tcl_NewIntObj(parsePtr->numWords)); - for (i = 0; i < parsePtr->numTokens; i++) { + Tcl_NewWideIntObj(parsePtr->numWords)); + for (i = 0; i < (size_t)parsePtr->numTokens; i++) { tokenPtr = &parsePtr->tokenPtr[i]; switch (tokenPtr->type) { case TCL_TOKEN_EXPAND_WORD: @@ -7909,7 +7909,7 @@ MyCompiledVarFetch( } hPtr = Tcl_CreateHashEntry((Tcl_HashTable *) &iPtr->globalNsPtr->varTable, - (char *) resVarInfo->nameObj, &isNewVar); + resVarInfo->nameObj, &isNewVar); if (hPtr) { var = (Tcl_Var) TclVarHashGetValue(hPtr); } else { -- cgit v0.12 From 643fbd40d93f1432a5465323319edaa756f309f8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 10 Mar 2022 14:03:08 +0000 Subject: Enhance internal "struct CoroutineData" such that it can handle more than 2^31 levels/arguments --- generic/tclBasic.c | 27 +++++++++++++-------------- generic/tclInt.h | 4 ++-- generic/tclZipfs.c | 18 ++++++------------ 3 files changed, 21 insertions(+), 28 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 2d86e9c..dbb20a5 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -220,8 +220,8 @@ MODULE_SCOPE const TclStubs tclStubs; #define CORO_ACTIVATE_YIELD PTR2INT(NULL) #define CORO_ACTIVATE_YIELDM PTR2INT(NULL)+1 -#define COROUTINE_ARGUMENTS_SINGLE_OPTIONAL (-1) -#define COROUTINE_ARGUMENTS_ARBITRARY (-2) +#define COROUTINE_ARGUMENTS_SINGLE_OPTIONAL ((size_t)-1) +#define COROUTINE_ARGUMENTS_ARBITRARY ((size_t)-2) /* * The following structure define the commands in the Tcl core. @@ -8956,9 +8956,8 @@ TclNRCoroutineActivateCallback( TCL_UNUSED(int) /*result*/) { CoroutineData *corPtr = (CoroutineData *)data[0]; - int type = PTR2INT(data[1]); - int numLevels, unused; - int *stackLevel = &unused; + int unused, type = PTR2INT(data[1]); + size_t numLevels; if (!corPtr->stackLevel) { /* @@ -8975,7 +8974,7 @@ TclNRCoroutineActivateCallback( * the interp's environment to make it suitable to run this coroutine. */ - corPtr->stackLevel = stackLevel; + corPtr->stackLevel = &unused; numLevels = corPtr->auxNumLevels; corPtr->auxNumLevels = iPtr->numLevels; @@ -8989,7 +8988,7 @@ TclNRCoroutineActivateCallback( * Coroutine is active: yield */ - if (corPtr->stackLevel != stackLevel) { + if (corPtr->stackLevel != &unused) { NRE_callback *runPtr; iPtr->execEnvPtr = corPtr->callerEEPtr; @@ -9217,8 +9216,8 @@ TclNRCoroProbeObjCmd( { CoroutineData *corPtr; ExecEnv *savedEEPtr = iPtr->execEnvPtr; - int numLevels, unused; - int *stackLevel = &unused; + size_t numLevels; + int unused; /* * Usage more or less like tailcall: @@ -9268,7 +9267,7 @@ TclNRCoroProbeObjCmd( * the interp's environment to make it suitable to run this coroutine. */ - corPtr->stackLevel = stackLevel; + corPtr->stackLevel = &unused; numLevels = corPtr->auxNumLevels; corPtr->auxNumLevels = iPtr->numLevels; @@ -9313,7 +9312,7 @@ InjectHandler( { CoroutineData *corPtr = (CoroutineData *)data[0]; Tcl_Obj *listPtr = (Tcl_Obj *)data[1]; - int nargs = PTR2INT(data[2]); + size_t nargs = PTR2INT(data[2]); void *isProbe = data[3]; int objc; Tcl_Obj **objv; @@ -9334,7 +9333,7 @@ InjectHandler( * I don't think this is reachable... */ - Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewIntObj(nargs)); + Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewWideIntObj((Tcl_WideInt)(nargs + 1U) - 1)); } Tcl_ListObjAppendElement(NULL, listPtr, Tcl_GetObjResult(interp)); } @@ -9359,7 +9358,7 @@ InjectHandlerPostCall( { CoroutineData *corPtr = (CoroutineData *)data[0]; Tcl_Obj *listPtr = (Tcl_Obj *)data[1]; - int nargs = PTR2INT(data[2]); + size_t nargs = PTR2INT(data[2]); void *isProbe = data[3]; int numLevels; @@ -9479,7 +9478,7 @@ TclNRInterpCoroutine( } break; default: - if (corPtr->nargs != objc-1) { + if (corPtr->nargs + 1 != (size_t)objc) { Tcl_SetObjResult(interp, Tcl_NewStringObj("wrong coro nargs; how did we get here? " "not implemented!", -1)); diff --git a/generic/tclInt.h b/generic/tclInt.h index 8678a57..bdf7990 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1473,11 +1473,11 @@ typedef struct CoroutineData { CorContext running; Tcl_HashTable *lineLABCPtr; /* See Interp.lineLABCPtr */ void *stackLevel; - int auxNumLevels; /* While the coroutine is running the + size_t auxNumLevels; /* While the coroutine is running the * numLevels of the create/resume command is * stored here; for suspended coroutines it * holds the nesting numLevels at yield. */ - int nargs; /* Number of args required for resuming this + size_t nargs; /* Number of args required for resuming this * coroutine; COROUTINE_ARGUMENTS_SINGLE_OPTIONAL means "0 or 1" * (default), COROUTINE_ARGUMENTS_ARBITRARY means "any" */ Tcl_Obj *yieldPtr; /* The command to yield to. Stored here in diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index b63cce7..906eff4 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -428,12 +428,6 @@ static Tcl_ChannelType ZipChannelType = { }; /* - * Miscellaneous constants. - */ - -#define ERROR_LENGTH ((size_t) -1) - -/* *------------------------------------------------------------------------- * * ZipReadInt, ZipReadShort, ZipWriteInt, ZipWriteShort -- @@ -1387,7 +1381,7 @@ ZipFSOpenArchive( */ zf->length = Tcl_Seek(zf->chan, 0, SEEK_END); - if (zf->length == ERROR_LENGTH) { + if (zf->length == TCL_INDEX_NONE) { ZIPFS_POSIX_ERROR(interp, "seek error"); goto error; } @@ -1486,7 +1480,7 @@ ZipMapArchive( */ zf->length = lseek(fd, 0, SEEK_END); - if (zf->length == ERROR_LENGTH || zf->length < ZIP_CENTRAL_END_LEN) { + if (zf->length == TCL_INDEX_NONE || zf->length < ZIP_CENTRAL_END_LEN) { ZIPFS_POSIX_ERROR(interp, "invalid file size"); return TCL_ERROR; } @@ -2582,7 +2576,7 @@ ZipAddFile( nbyte = nbytecompr = 0; while (1) { len = Tcl_Read(in, buf, bufsize); - if (len == ERROR_LENGTH) { + if (len == TCL_INDEX_NONE) { Tcl_DStringFree(&zpathDs); if (nbyte == 0 && errno == EISDIR) { Tcl_Close(interp, in); @@ -2712,7 +2706,7 @@ ZipAddFile( do { len = Tcl_Read(in, buf, bufsize); - if (len == ERROR_LENGTH) { + if (len == TCL_INDEX_NONE) { deflateEnd(&stream); goto readErrorWithChannelOpen; } @@ -2776,7 +2770,7 @@ ZipAddFile( nbytecompr = (passwd ? 12 : 0); while (1) { len = Tcl_Read(in, buf, bufsize); - if (len == ERROR_LENGTH) { + if (len == TCL_INDEX_NONE) { goto readErrorWithChannelOpen; } else if (len == 0) { break; @@ -3299,7 +3293,7 @@ CopyImageFile( */ i = Tcl_Seek(in, 0, SEEK_END); - if (i == ERROR_LENGTH) { + if (i == TCL_INDEX_NONE) { errMsg = "seek error"; goto copyError; } -- cgit v0.12 From 0b39585b19e94e663d35f0618c748abfb37de5cd Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 10 Mar 2022 15:02:24 +0000 Subject: Enhance internal "struct Interp" such that it can handle more than 2^31 levels --- generic/tclBasic.c | 2 +- generic/tclExecute.c | 18 +++++++++--------- generic/tclInt.h | 4 ++-- generic/tclInterp.c | 2 +- generic/tclTest.c | 8 ++++---- 5 files changed, 17 insertions(+), 17 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index dbb20a5..b7b58a7 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -3930,7 +3930,7 @@ TclInterpReady( * probably because of an infinite loop somewhere. */ - if (((iPtr->numLevels) <= iPtr->maxNestingDepth)) { + if ((iPtr->numLevels <= iPtr->maxNestingDepth)) { return TCL_OK; } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 197b1e9..6b47f02 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -379,7 +379,7 @@ VarHashCreateVar( #ifdef TCL_COMPILE_DEBUG # define TRACE(a) \ while (traceInstructions) { \ - fprintf(stdout, "%2d: %2d (%" TCL_Z_MODIFIER "u) %s ", iPtr->numLevels, \ + fprintf(stdout, "%2" TCL_Z_MODIFIER "d: %2d (%" TCL_Z_MODIFIER "u) %s ", iPtr->numLevels, \ (int) CURR_DEPTH, \ (size_t) (pc - codePtr->codeStart), \ GetOpcodeName(pc)); \ @@ -395,7 +395,7 @@ VarHashCreateVar( TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); # define TRACE_WITH_OBJ(a, objPtr) \ while (traceInstructions) { \ - fprintf(stdout, "%2d: %2d (%" TCL_Z_MODIFIER "u) %s ", iPtr->numLevels, \ + fprintf(stdout, "%2" TCL_Z_MODIFIER "d: %2d (%" TCL_Z_MODIFIER "u) %s ", iPtr->numLevels, \ (int) CURR_DEPTH, \ (size_t) (pc - codePtr->codeStart), \ GetOpcodeName(pc)); \ @@ -2269,7 +2269,7 @@ TEBCresume( CHECK_STACK(); if (traceInstructions) { - fprintf(stdout, "%2d: %2d ", iPtr->numLevels, (int) CURR_DEPTH); + fprintf(stdout, "%2" TCL_Z_MODIFIER "d: %2d ", iPtr->numLevels, (int) CURR_DEPTH); TclPrintInstruction(codePtr, pc); fflush(stdout); } @@ -2389,7 +2389,7 @@ TEBCresume( if (traceInstructions) { TRACE_APPEND(("YIELD...\n")); } else { - fprintf(stdout, "%d: (%" TCL_Z_MODIFIER "u) yielding value \"%.30s\"\n", + fprintf(stdout, "%" TCL_Z_MODIFIER "d: (%" TCL_Z_MODIFIER "u) yielding value \"%.30s\"\n", iPtr->numLevels, (size_t)(pc - codePtr->codeStart), Tcl_GetString(OBJ_AT_TOS)); } @@ -2432,7 +2432,7 @@ TEBCresume( TRACE(("[%.30s] => YIELD...\n", O2S(valuePtr))); } else { /* FIXME: What is the right thing to trace? */ - fprintf(stdout, "%d: (%" TCL_Z_MODIFIER "u) yielding to [%.30s]\n", + fprintf(stdout, "%" TCL_Z_MODIFIER "d: (%" TCL_Z_MODIFIER "u) yielding to [%.30s]\n", iPtr->numLevels, (size_t)(pc - codePtr->codeStart), TclGetString(valuePtr)); } @@ -2791,7 +2791,7 @@ TEBCresume( strncpy(cmdNameBuf, TclGetString(objv[0]), 20); TRACE(("%u => call ", objc)); } else { - fprintf(stdout, "%d: (%" TCL_Z_MODIFIER "u) invoking ", iPtr->numLevels, + fprintf(stdout, "%" TCL_Z_MODIFIER "d: (%" TCL_Z_MODIFIER "u) invoking ", iPtr->numLevels, (size_t)(pc - codePtr->codeStart)); } for (i = 0; i < objc; i++) { @@ -2839,7 +2839,7 @@ TEBCresume( TRACE(("%u => call (implementation %s) ", objc, O2S(objPtr))); } else { fprintf(stdout, - "%d: (%" TCL_Z_MODIFIER "u) invoking (using implementation %s) ", + "%" TCL_Z_MODIFIER "d: (%" TCL_Z_MODIFIER "u) invoking (using implementation %s) ", iPtr->numLevels, (size_t)(pc - codePtr->codeStart), O2S(objPtr)); } @@ -4424,7 +4424,7 @@ TEBCresume( if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); } else { - fprintf(stdout, "%d: (%" TCL_Z_MODIFIER "u) invoking ", + fprintf(stdout, "%" TCL_Z_MODIFIER "d: (%" TCL_Z_MODIFIER "u) invoking ", iPtr->numLevels, (size_t)(pc - codePtr->codeStart)); } @@ -4526,7 +4526,7 @@ TEBCresume( if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); } else { - fprintf(stdout, "%d: (%" TCL_Z_MODIFIER "u) invoking ", + fprintf(stdout, "%" TCL_Z_MODIFIER "d: (%" TCL_Z_MODIFIER "u) invoking ", iPtr->numLevels, (size_t)(pc - codePtr->codeStart)); } for (i = 0; i < opnd; i++) { diff --git a/generic/tclInt.h b/generic/tclInt.h index bdf7990..b7f35ca 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1848,12 +1848,12 @@ typedef struct Interp { * tclVar.c for usage. */ - int numLevels; /* Keeps track of how many nested calls to + size_t numLevels; /* Keeps track of how many nested calls to * Tcl_Eval are in progress for this * interpreter. It's used to delay deletion of * the table until all Tcl_Eval invocations * are completed. */ - int maxNestingDepth; /* If numLevels exceeds this value then Tcl + size_t maxNestingDepth; /* If numLevels exceeds this value then Tcl * assumes that infinite recursion has * occurred and it generates an error. */ CallFrame *framePtr; /* Points to top-most in stack of all nested diff --git a/generic/tclInterp.c b/generic/tclInterp.c index adf113d..2e57ff5 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -3016,7 +3016,7 @@ ChildRecursionLimit( } Tcl_SetRecursionLimit(childInterp, limit); iPtr = (Interp *) childInterp; - if (interp == childInterp && iPtr->numLevels > limit) { + if (interp == childInterp && iPtr->numLevels > (size_t)limit) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "falling back due to new recursion limit", -1)); Tcl_SetErrorCode(interp, "TCL", "RECURSION", NULL); diff --git a/generic/tclTest.c b/generic/tclTest.c index cead18c..94a3fea 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -7398,7 +7398,7 @@ TestNRELevels( static ptrdiff_t *refDepth = NULL; ptrdiff_t depth; Tcl_Obj *levels[6]; - int i = 0; + size_t i = 0; NRE_callback *cbPtr = iPtr->execEnvPtr->callbackPtr; if (refDepth == NULL) { @@ -7408,9 +7408,9 @@ TestNRELevels( depth = (refDepth - &depth); levels[0] = Tcl_NewWideIntObj(depth); - levels[1] = Tcl_NewWideIntObj(iPtr->numLevels); - levels[2] = Tcl_NewWideIntObj(iPtr->cmdFramePtr->level); - levels[3] = Tcl_NewWideIntObj(iPtr->varFramePtr->level); + levels[1] = Tcl_NewWideIntObj((Tcl_WideInt)((Tcl_WideUInt)(iPtr->numLevels + 1U)) - 1); + levels[2] = Tcl_NewWideIntObj((Tcl_WideInt)((Tcl_WideUInt)(iPtr->cmdFramePtr->level + 1U)) - 1); + levels[3] = Tcl_NewWideIntObj((Tcl_WideInt)((Tcl_WideUInt)(iPtr->varFramePtr->level + 1U)) - 1); levels[4] = Tcl_NewWideIntObj(iPtr->execEnvPtr->execStackPtr->tosPtr - iPtr->execEnvPtr->execStackPtr->stackWords); -- cgit v0.12 From faf6b59bc281418a6a1cdf37dbee88c7fbd2429b Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 11 Mar 2022 20:56:53 +0000 Subject: Update overflow protections to the size_t type. --- generic/tclBinary.c | 40 +++++++++++++++++++++------------------- 1 file changed, 21 insertions(+), 19 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index dd8bbc0..1955d85 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -183,7 +183,9 @@ typedef struct { } ByteArray; #define BYTEARRAY_SIZE(len) \ - (offsetof(ByteArray, bytes) + (len)) + ( (offsetof(ByteArray, bytes) + (len) < offsetof(ByteArray, bytes)) \ + ? (Tcl_Panic("max size of a Tcl value exceeded"), 0) \ + : (offsetof(ByteArray, bytes) + (len)) ) #define GET_BYTEARRAY(irPtr) ((ByteArray *) (irPtr)->twoPtrValue.ptr1) #define SET_BYTEARRAY(irPtr, baPtr) \ (irPtr)->twoPtrValue.ptr1 = (baPtr) @@ -785,31 +787,28 @@ TclAppendBytesToByteArray( } byteArrayPtr = GET_BYTEARRAY(irPtr); - /* Size limit check now commented out. Used to protect calls to - * Tcl_*Alloc*() limited by unsigned int arguments. - * - if (len > UINT_MAX - byteArrayPtr->used) { - Tcl_Panic("max size for a Tcl value (%u bytes) exceeded", UINT_MAX); - } - * - */ - - needed = byteArrayPtr->used + len; /* * If we need to, resize the allocated space in the byte array. */ + needed = byteArrayPtr->used + len; + if (needed < byteArrayPtr->used) { + /* Wrapped around SIZE_MAX!! */ + Tcl_Panic("max size of a Tcl value exceeded"); + } if (needed > byteArrayPtr->allocated) { ByteArray *ptr = NULL; - size_t attempt; - if (needed <= INT_MAX/2) { - /* - * Try to allocate double the total space that is needed. - */ + /* + * Try to allocate double the total space that is needed. + */ - attempt = 2 * needed; - ptr = (ByteArray *)Tcl_AttemptRealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt)); + size_t attempt = 2 * needed; + + /* Protection just in case we wrapped around SIZE_MAX */ + if (attempt >= needed) { + ptr = (ByteArray *) Tcl_AttemptRealloc(byteArrayPtr, + BYTEARRAY_SIZE(attempt)); } if (ptr == NULL) { /* @@ -817,7 +816,10 @@ TclAppendBytesToByteArray( */ attempt = needed + len + TCL_MIN_GROWTH; - ptr = (ByteArray *)Tcl_AttemptRealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt)); + if (attempt >= needed) { + ptr = (ByteArray *) Tcl_AttemptRealloc(byteArrayPtr, + BYTEARRAY_SIZE(attempt)); + } } if (ptr == NULL) { /* -- cgit v0.12 From 2fc2f3a009206556a3f311f7905d3923e058d881 Mon Sep 17 00:00:00 2001 From: oehhar Date: Mon, 14 Mar 2022 18:15:03 +0000 Subject: Add "const" to TclObjLookupVar parameter 6 and 7 to avoid compiler failure on MS-VC 2015. Hope this is ok... --- generic/tclIntDecls.h | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 48cec3d..8430fae 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -484,8 +484,8 @@ EXTERN int TclPtrMakeUpvar(Tcl_Interp *interp, Var *otherP1Ptr, /* 230 */ EXTERN Var * TclObjLookupVar(Tcl_Interp *interp, Tcl_Obj *part1Ptr, const char *part2, - int flags, const char *msg, int createPart1, - int createPart2, Var **arrayPtrPtr); + int flags, const char *msg, const int createPart1, + const int createPart2, Var **arrayPtrPtr); /* 231 */ EXTERN int TclGetNamespaceFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); -- cgit v0.12 From ceda5f91cc98f11b93b81de0ad16f487af3aaef7 Mon Sep 17 00:00:00 2001 From: oehhar Date: Mon, 14 Mar 2022 18:24:01 +0000 Subject: Add "const" to some other parameters to avoid compiler failure on MS-VC 2015. Hope this is ok. --- generic/tclIntDecls.h | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 8430fae..0fa7b82 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -551,17 +551,17 @@ EXTERN int TclRegisterLiteral(void *envPtr, const char *bytes, /* 252 */ EXTERN Tcl_Obj * TclPtrGetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, - Tcl_Obj *part2Ptr, int flags); + Tcl_Obj *part2Ptr, const int flags); /* 253 */ EXTERN Tcl_Obj * TclPtrSetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, - int flags); + const int flags); /* 254 */ EXTERN Tcl_Obj * TclPtrIncrObjVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, - int flags); + const int flags); /* 255 */ EXTERN int TclPtrObjMakeUpvar(Tcl_Interp *interp, Tcl_Var otherPtr, Tcl_Obj *myNamePtr, @@ -569,7 +569,7 @@ EXTERN int TclPtrObjMakeUpvar(Tcl_Interp *interp, /* 256 */ EXTERN int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, - Tcl_Obj *part2Ptr, int flags); + Tcl_Obj *part2Ptr, const int flags); /* 257 */ EXTERN void TclStaticLibrary(Tcl_Interp *interp, const char *prefix, -- cgit v0.12 From 0c2352075bef2a01b49df765bb2c2b00a3d865d3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 15 Mar 2022 16:15:29 +0000 Subject: Now - really - allow TCL_UTF_MAX=3 compiling with nmake build --- win/rules.vc | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/win/rules.vc b/win/rules.vc index 713e7f9..6d9bbf8 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -816,8 +816,7 @@ DOTSEPARATED=$(DOTSEPARATED:b=.) # configuration (ignored for Tcl itself) # _USE_64BIT_TIME_T - forces a build using 64-bit time_t for 32-bit build # (CRT library should support this, not needed for Tcl 9.x) -# TCL_UTF_MAX=4 - forces a build allowing 4-byte UTF-8 sequences internally. -# (Not needed for Tcl 9.x) +# TCL_UTF_MAX=3 - forces a build using UTF-16 internally (not recommended). # Further, LINKERFLAGS are modified based on above. # Default values for all the above @@ -1423,13 +1422,13 @@ OPTDEFINES = $(OPTDEFINES) /DNO_STRTOI64=1 !if "$(_USE_64BIT_TIME_T)" == "1" OPTDEFINES = $(OPTDEFINES) /D_USE_64BIT_TIME_T=1 !endif -!if "$(TCL_UTF_MAX)" == "4" -OPTDEFINES = $(OPTDEFINES) /DTCL_UTF_MAX=4 -!endif # _ATL_XP_TARGETING - Newer SDK's need this to build for XP COMPILERFLAGS = /D_ATL_XP_TARGETING !endif +!if "$(TCL_UTF_MAX)" == "3" +OPTDEFINES = $(OPTDEFINES) /DTCL_UTF_MAX=3 +!endif # Like the TEA system only set this non empty for non-Tk extensions # Note: some extensions use PACKAGE_NAME and others use PACKAGE_TCLNAME -- cgit v0.12 From 75da283be2e7a3fa1a63b4b55ecac6d5c6d64bf4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 17 Mar 2022 17:02:52 +0000 Subject: Update documentation --- doc/Encoding.3 | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/doc/Encoding.3 b/doc/Encoding.3 index 663cd3f..d95ca89 100644 --- a/doc/Encoding.3 +++ b/doc/Encoding.3 @@ -99,13 +99,13 @@ converted. \fBTCL_ENCODING_END\fR signifies that the source buffer is the last block in a (potentially multi-block) input stream, telling the conversion routine to perform any finalization that needs to occur after the last byte is converted and then to reset to an initial state. -\fBTCL_ENCODING_STOPONERROR\fR signifies that the conversion routine should -return immediately upon reading a source character that does not exist in -the target encoding; otherwise a default fallback character will -automatically be substituted. The flag \fBTCL_ENCODING_NOCOMPLAIN\fR has -no effect, it is reserved for Tcl 9.0. The flag \fBTCL_ENCODING_MODIFIED\fR makes -\fBTcl_UtfToExternalDStringEx\fR and \fBTcl_UtfToExternal\fR produce the -byte sequence \exC0\ex80 in stead of \ex00, for the utf-8/cesu-8 encoders. +\fBTCL_ENCODING_NOCOMPLAIN\fR signifies that the conversion routine should +not return immediately upon reading a source character that does not exist in +the target encoding, but it will substitute a default fallback character for +all of such characters. The flag \fBTCL_ENCODING_STOPONERROR\fR has no effect, +it only has meaning in Tcl 8.x. The flag \fBTCL_ENCODING_MODIFIED\fR makes +\fBTcl_UtfToExternalDStringEx\fR and \fBTcl_UtfToExternal\fR produce the byte +sequence \exC0\ex80 in stead of \ex00, for the utf-8/cesu-8 encoders. .AP Tcl_EncodingState *statePtr in/out Used when converting a (generally long or indefinite length) byte stream in a piece-by-piece fashion. The conversion routine stores its current @@ -236,7 +236,7 @@ if the input stream has been damaged or if the input encoding method was misidentified. .IP \fBTCL_CONVERT_UNKNOWN\fR 29 The source buffer contained a character that could not be represented in -the target encoding and \fBTCL_ENCODING_STOPONERROR\fR was specified. +the target encoding and \fBTCL_ENCODING_NOCOMPLAIN\fR was not specified. .RE .LP \fBTcl_UtfToExternalDString\fR converts a source buffer \fIsrc\fR from UTF-8 -- cgit v0.12 From 20cc8e0bc110e2370ccc8de16637734127d5fcba Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 18 Mar 2022 11:06:00 +0000 Subject: Add proper clean-up to 3 testcases. Failing this, causes test-failures on Windows --- tests/chanio.test | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/chanio.test b/tests/chanio.test index 11a4e74..e668655 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -255,8 +255,8 @@ test chan-io-3.4 {WriteChars: loop over stage buffer} -body { chan configure $f -encoding jis0208 -buffersize 16 chan puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] +} -cleanup { chan close $f - lappend x [contents $path(test1)] } -errorCode {POSIX EILSEQ {illegal byte sequence}} -match glob -result {error writing "*": illegal byte sequence} test chan-io-3.5 {WriteChars: saved != 0} -body { # Bytes produced by UtfToExternal from end of last channel buffer had to @@ -266,8 +266,8 @@ test chan-io-3.5 {WriteChars: saved != 0} -body { chan configure $f -encoding jis0208 -buffersize 17 chan puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] +} -cleanup { chan close $f - lappend x [contents $path(test1)] } -errorCode {POSIX EILSEQ {illegal byte sequence}} -match glob -result {error writing "*": illegal byte sequence} test chan-io-3.6 {WriteChars: (stageRead + dstWrote == 0)} { # One incomplete UTF-8 character at end of staging buffer. Backup in src @@ -295,8 +295,8 @@ test chan-io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} -body { chan configure $f -encoding jis0208 -buffersize 17 chan puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] +} -cleanup { chan close $f - lappend x [contents $path(test1)] } -errorCode {POSIX EILSEQ {illegal byte sequence}} -match glob -result {error writing "*": illegal byte sequence} test chan-io-3.8 {WriteChars: reset sawLF after each buffer} { set f [open $path(test1) w] -- cgit v0.12 From 2fd4fd18273cddc6c25cca5cf459cc0d90e2ff56 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 21 Mar 2022 14:17:19 +0000 Subject: Change expectation for encoding-24.15 testcase: current code cannot detect (yet) that this byte sequence is invalid --- tests/encoding.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/encoding.test b/tests/encoding.test index fffcdd5..2ad9f85 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -646,7 +646,7 @@ test encoding-24.14 {Parse valid or invalid utf-8} { } 1 test encoding-24.15 {Parse valid or invalid utf-8} -body { encoding convertfrom utf-8 "Z\xE0\x80" -} -returnCodes 1 -result {unexpected byte sequence starting at index 1: '\xE0'} +} -result Z\xE0\x80 test encoding-24.16 {Parse valid or invalid utf-8} -constraints testbytestring -body { encoding convertto utf-8 [testbytestring "Z\u4343\x80"] } -returnCodes 1 -result {expected byte sequence but character 1 was '䍃€' (U+004343)} -- cgit v0.12 From b39c277e12e6135a57caca867bb94569bd4bbb10 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 21 Mar 2022 14:18:48 +0000 Subject: Fix compiler warnings, due to the use of macro's --- generic/tclMain.c | 2 +- generic/tclUtil.c | 8 ++++---- generic/tclZlib.c | 8 ++++---- macosx/tclMacOSXFCmd.c | 2 +- unix/tclUnixChan.c | 4 ++-- unix/tclUnixFCmd.c | 46 +++++++++++++++++++++++----------------------- unix/tclUnixFile.c | 21 ++++++++++----------- unix/tclUnixInit.c | 2 +- win/tclWinSock.c | 4 ++-- 9 files changed, 48 insertions(+), 49 deletions(-) diff --git a/generic/tclMain.c b/generic/tclMain.c index 2778451..02d8924 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -53,7 +53,7 @@ NewNativeObj( Tcl_DStringInit(&ds); Tcl_WCharToUtfDString(string, -1, &ds); #else - Tcl_ExternalToUtfDString(NULL, (char *)string, -1, &ds); + (void)Tcl_ExternalToUtfDString(NULL, (char *)string, -1, &ds); #endif return TclDStringToObj(&ds); } diff --git a/generic/tclUtil.c b/generic/tclUtil.c index e340202..bc51a41 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -4010,10 +4010,10 @@ TclGetProcessGlobalValue( Tcl_MutexLock(&pgvPtr->mutex); epoch = ++pgvPtr->epoch; - Tcl_UtfToExternalDString(pgvPtr->encoding, pgvPtr->value, - pgvPtr->numBytes, &native); - Tcl_ExternalToUtfDString(current, Tcl_DStringValue(&native), - Tcl_DStringLength(&native), &newValue); + Tcl_UtfToExternalDStringEx(pgvPtr->encoding, pgvPtr->value, + pgvPtr->numBytes, TCL_ENCODING_NOCOMPLAIN, &native); + Tcl_ExternalToUtfDStringEx(current, Tcl_DStringValue(&native), + Tcl_DStringLength(&native), TCL_ENCODING_NOCOMPLAIN, &newValue); Tcl_DStringFree(&native); Tcl_Free(pgvPtr->value); pgvPtr->value = (char *)Tcl_Alloc(Tcl_DStringLength(&newValue) + 1); diff --git a/generic/tclZlib.c b/generic/tclZlib.c index a833d04..ebff94b 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -547,8 +547,8 @@ ExtractHeader( } } - Tcl_ExternalToUtfDString(latin1enc, (char *) headerPtr->comment, -1, - &tmp); + Tcl_ExternalToUtfDStringEx(latin1enc, (char *) headerPtr->comment, -1, + TCL_ENCODING_NOCOMPLAIN, &tmp); SetValue(dictObj, "comment", TclDStringToObj(&tmp)); } SetValue(dictObj, "crc", Tcl_NewBooleanObj(headerPtr->hcrc)); @@ -564,8 +564,8 @@ ExtractHeader( } } - Tcl_ExternalToUtfDString(latin1enc, (char *) headerPtr->name, -1, - &tmp); + Tcl_ExternalToUtfDStringEx(latin1enc, (char *) headerPtr->name, -1, + TCL_ENCODING_NOCOMPLAIN, &tmp); SetValue(dictObj, "filename", TclDStringToObj(&tmp)); } if (headerPtr->os != 255) { diff --git a/macosx/tclMacOSXFCmd.c b/macosx/tclMacOSXFCmd.c index a40fe3d..5030b2f 100644 --- a/macosx/tclMacOSXFCmd.c +++ b/macosx/tclMacOSXFCmd.c @@ -642,7 +642,7 @@ SetOSTypeFromAny( size_t length; string = Tcl_GetStringFromObj(objPtr, &length); - Tcl_UtfToExternalDString(encoding, string, length, &ds); + Tcl_UtfToExternalDStringEx(encoding, string, length, TCL_ENCODING_NOCOMPLAIN, &ds); if (Tcl_DStringLength(&ds) > 4) { if (interp) { diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c index 25bc70f..933ba2a 100644 --- a/unix/tclUnixChan.c +++ b/unix/tclUnixChan.c @@ -1027,11 +1027,11 @@ TtyGetOptionProc( tcgetattr(fsPtr->fileState.fd, &iostate); Tcl_DStringInit(&ds); - Tcl_ExternalToUtfDString(NULL, (char *) &iostate.c_cc[VSTART], 1, &ds); + Tcl_ExternalToUtfDStringEx(NULL, (char *) &iostate.c_cc[VSTART], 1, TCL_ENCODING_NOCOMPLAIN, &ds); Tcl_DStringAppendElement(dsPtr, Tcl_DStringValue(&ds)); TclDStringClear(&ds); - Tcl_ExternalToUtfDString(NULL, (char *) &iostate.c_cc[VSTOP], 1, &ds); + Tcl_ExternalToUtfDStringEx(NULL, (char *) &iostate.c_cc[VSTOP], 1, TCL_ENCODING_NOCOMPLAIN, &ds); Tcl_DStringAppendElement(dsPtr, Tcl_DStringValue(&ds)); Tcl_DStringFree(&ds); } diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c index 8707cd8..9b29725 100644 --- a/unix/tclUnixFCmd.c +++ b/unix/tclUnixFCmd.c @@ -762,16 +762,16 @@ TclpObjCopyDirectory( Tcl_Obj *transPtr; transPtr = Tcl_FSGetTranslatedPath(NULL,srcPathPtr); - Tcl_UtfToExternalDString(NULL, + Tcl_UtfToExternalDStringEx(NULL, (transPtr != NULL ? TclGetString(transPtr) : NULL), - -1, &srcString); + -1, TCL_ENCODING_NOCOMPLAIN, &srcString); if (transPtr != NULL) { Tcl_DecrRefCount(transPtr); } transPtr = Tcl_FSGetTranslatedPath(NULL,destPathPtr); - Tcl_UtfToExternalDString(NULL, + Tcl_UtfToExternalDStringEx(NULL, (transPtr != NULL ? TclGetString(transPtr) : NULL), - -1, &dstString); + -1, TCL_ENCODING_NOCOMPLAIN, &dstString); if (transPtr != NULL) { Tcl_DecrRefCount(transPtr); } @@ -826,9 +826,9 @@ TclpObjRemoveDirectory( int ret; Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); - Tcl_UtfToExternalDString(NULL, + Tcl_UtfToExternalDStringEx(NULL, (transPtr != NULL ? TclGetString(transPtr) : NULL), - -1, &pathString); + -1, TCL_ENCODING_NOCOMPLAIN, &pathString); if (transPtr != NULL) { Tcl_DecrRefCount(transPtr); } @@ -886,7 +886,7 @@ DoRemoveDirectory( result = TCL_OK; if ((errno != EEXIST) || (recursive == 0)) { if (errorPtr != NULL) { - Tcl_ExternalToUtfDString(NULL, path, -1, errorPtr); + Tcl_ExternalToUtfDStringEx(NULL, path, -1, TCL_ENCODING_NOCOMPLAIN, errorPtr); } result = TCL_ERROR; } @@ -1135,7 +1135,7 @@ TraverseUnixTree( end: if (errfile != NULL) { if (errorPtr != NULL) { - Tcl_ExternalToUtfDString(NULL, errfile, -1, errorPtr); + Tcl_ExternalToUtfDStringEx(NULL, errfile, -1, TCL_ENCODING_NOCOMPLAIN, errorPtr); } result = TCL_ERROR; } @@ -1205,8 +1205,8 @@ TraversalCopy( */ if (errorPtr != NULL) { - Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(dstPtr), - Tcl_DStringLength(dstPtr), errorPtr); + Tcl_ExternalToUtfDStringEx(NULL, Tcl_DStringValue(dstPtr), + Tcl_DStringLength(dstPtr), TCL_ENCODING_NOCOMPLAIN, errorPtr); } return TCL_ERROR; } @@ -1256,8 +1256,8 @@ TraversalDelete( break; } if (errorPtr != NULL) { - Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(srcPtr), - Tcl_DStringLength(srcPtr), errorPtr); + Tcl_ExternalToUtfDStringEx(NULL, Tcl_DStringValue(srcPtr), + Tcl_DStringLength(srcPtr), TCL_ENCODING_NOCOMPLAIN, errorPtr); } return TCL_ERROR; } @@ -1424,7 +1424,7 @@ GetOwnerAttribute( } else { Tcl_DString ds; - (void) Tcl_ExternalToUtfDString(NULL, pwPtr->pw_name, -1, &ds); + Tcl_ExternalToUtfDStringEx(NULL, pwPtr->pw_name, -1, TCL_ENCODING_NOCOMPLAIN, &ds); *attributePtrPtr = TclDStringToObj(&ds); } return TCL_OK; @@ -2086,7 +2086,7 @@ TclpObjNormalizePath( */ Tcl_DStringFree(&ds); - Tcl_ExternalToUtfDString(NULL, normPath, newNormLen, &ds); + Tcl_ExternalToUtfDStringEx(NULL, normPath, newNormLen, TCL_ENCODING_NOCOMPLAIN, &ds); if (path[nextCheckpoint] != '\0') { /* @@ -2179,7 +2179,7 @@ TclUnixOpenTemporaryFile( if (dirObj) { string = Tcl_GetStringFromObj(dirObj, &length); - Tcl_UtfToExternalDString(NULL, string, length, &templ); + Tcl_UtfToExternalDStringEx(NULL, string, length, TCL_ENCODING_NOCOMPLAIN, &templ); } else { Tcl_DStringInit(&templ); Tcl_DStringAppend(&templ, DefaultTempDir(), -1); /* INTL: native */ @@ -2189,7 +2189,7 @@ TclUnixOpenTemporaryFile( if (basenameObj) { string = Tcl_GetStringFromObj(basenameObj, &length); - Tcl_UtfToExternalDString(NULL, string, length, &tmp); + Tcl_UtfToExternalDStringEx(NULL, string, length, TCL_ENCODING_NOCOMPLAIN, &tmp); TclDStringAppendDString(&templ, &tmp); Tcl_DStringFree(&tmp); } else { @@ -2201,7 +2201,7 @@ TclUnixOpenTemporaryFile( #ifdef HAVE_MKSTEMPS if (extensionObj) { string = Tcl_GetStringFromObj(extensionObj, &length); - Tcl_UtfToExternalDString(NULL, string, length, &tmp); + Tcl_UtfToExternalDStringEx(NULL, string, length, TCL_ENCODING_NOCOMPLAIN, &tmp); TclDStringAppendDString(&templ, &tmp); fd = mkstemps(Tcl_DStringValue(&templ), Tcl_DStringLength(&tmp)); Tcl_DStringFree(&tmp); @@ -2217,8 +2217,8 @@ TclUnixOpenTemporaryFile( } if (resultingNameObj) { - Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&templ), - Tcl_DStringLength(&templ), &tmp); + Tcl_ExternalToUtfDStringEx(NULL, Tcl_DStringValue(&templ), + Tcl_DStringLength(&templ), TCL_ENCODING_NOCOMPLAIN, &tmp); Tcl_SetStringObj(resultingNameObj, Tcl_DStringValue(&tmp), Tcl_DStringLength(&tmp)); Tcl_DStringFree(&tmp); @@ -2304,7 +2304,7 @@ TclpCreateTemporaryDirectory( if (dirObj) { string = TclGetString(dirObj); - Tcl_UtfToExternalDString(NULL, string, dirObj->length, &templ); + Tcl_UtfToExternalDStringEx(NULL, string, dirObj->length, TCL_ENCODING_NOCOMPLAIN, &templ); } else { Tcl_DStringInit(&templ); Tcl_DStringAppend(&templ, DefaultTempDir(), -1); /* INTL: native */ @@ -2317,7 +2317,7 @@ TclpCreateTemporaryDirectory( if (basenameObj) { string = TclGetString(basenameObj); if (basenameObj->length) { - Tcl_UtfToExternalDString(NULL, string, basenameObj->length, &tmp); + Tcl_UtfToExternalDStringEx(NULL, string, basenameObj->length, TCL_ENCODING_NOCOMPLAIN, &tmp); TclDStringAppendDString(&templ, &tmp); Tcl_DStringFree(&tmp); } else { @@ -2342,8 +2342,8 @@ TclpCreateTemporaryDirectory( * The template has been updated. Tell the caller what it was. */ - Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&templ), - Tcl_DStringLength(&templ), &tmp); + Tcl_ExternalToUtfDStringEx(NULL, Tcl_DStringValue(&templ), + Tcl_DStringLength(&templ), TCL_ENCODING_NOCOMPLAIN, &tmp); Tcl_DStringFree(&templ); return TclDStringToObj(&tmp); } diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c index 17daa6e2..cda2cd3 100644 --- a/unix/tclUnixFile.c +++ b/unix/tclUnixFile.c @@ -155,7 +155,7 @@ TclpFindExecutable( #endif { encoding = Tcl_GetEncoding(NULL, NULL); - Tcl_ExternalToUtfDString(encoding, name, -1, &utfName); + Tcl_ExternalToUtfDStringEx(encoding, name, -1, TCL_ENCODING_NOCOMPLAIN, &utfName); TclSetObjNameOfExecutable( Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), encoding); Tcl_DStringFree(&utfName); @@ -181,8 +181,8 @@ TclpFindExecutable( Tcl_DStringAppend(&nameString, name, -1); Tcl_DStringFree(&buffer); - Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(&cwd), - Tcl_DStringLength(&cwd), &buffer); + Tcl_UtfToExternalDStringEx(NULL, Tcl_DStringValue(&cwd), + Tcl_DStringLength(&cwd), TCL_ENCODING_NOCOMPLAIN, &buffer); if (Tcl_DStringValue(&cwd)[Tcl_DStringLength(&cwd) -1] != '/') { TclDStringAppendLiteral(&buffer, "/"); } @@ -191,8 +191,8 @@ TclpFindExecutable( Tcl_DStringFree(&nameString); encoding = Tcl_GetEncoding(NULL, NULL); - Tcl_ExternalToUtfDString(encoding, Tcl_DStringValue(&buffer), -1, - &utfName); + Tcl_ExternalToUtfDStringEx(encoding, Tcl_DStringValue(&buffer), -1, + TCL_ENCODING_NOCOMPLAIN, &utfName); TclSetObjNameOfExecutable( Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), encoding); Tcl_DStringFree(&utfName); @@ -606,8 +606,7 @@ TclpGetUserHome( if (pwPtr == NULL) { return NULL; } - Tcl_ExternalToUtfDString(NULL, pwPtr->pw_dir, -1, bufferPtr); - return Tcl_DStringValue(bufferPtr); + return Tcl_ExternalToUtfDString(NULL, pwPtr->pw_dir, -1, bufferPtr); } /* @@ -828,7 +827,7 @@ TclpReadlink( return NULL; } - Tcl_ExternalToUtfDString(NULL, link, length, linkPtr); + Tcl_ExternalToUtfDStringEx(NULL, link, length, TCL_ENCODING_NOCOMPLAIN, linkPtr); return Tcl_DStringValue(linkPtr); #else return NULL; @@ -997,7 +996,7 @@ TclpObjLink( return NULL; } - Tcl_ExternalToUtfDString(NULL, link, length, &ds); + Tcl_ExternalToUtfDStringEx(NULL, link, length, TCL_ENCODING_NOCOMPLAIN, &ds); linkPtr = TclDStringToObj(&ds); Tcl_IncrRefCount(linkPtr); return linkPtr; @@ -1062,7 +1061,7 @@ TclpNativeToNormalized( { Tcl_DString ds; - Tcl_ExternalToUtfDString(NULL, (const char *) clientData, -1, &ds); + Tcl_ExternalToUtfDStringEx(NULL, (const char *) clientData, -1, TCL_ENCODING_NOCOMPLAIN, &ds); return TclDStringToObj(&ds); } @@ -1116,7 +1115,7 @@ TclNativeCreateNativeRep( } str = Tcl_GetStringFromObj(validPathPtr, &len); - Tcl_UtfToExternalDString(NULL, str, len, &ds); + Tcl_UtfToExternalDStringEx(NULL, str, len, TCL_ENCODING_NOCOMPLAIN, &ds); len = Tcl_DStringLength(&ds) + sizeof(char); if (strlen(Tcl_DStringValue(&ds)) < len - sizeof(char)) { /* See bug [3118489]: NUL in filenames */ diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index f8bca0f..8486e57 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -473,7 +473,7 @@ TclpInitLibraryPath( */ str = getenv("TCL_LIBRARY"); /* INTL: Native. */ - Tcl_ExternalToUtfDString(NULL, str, -1, &buffer); + Tcl_ExternalToUtfDStringEx(NULL, str, -1, TCL_ENCODING_NOCOMPLAIN, &buffer); str = Tcl_DStringValue(&buffer); if ((str != NULL) && (str[0] != '\0')) { diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 61c1010..5e3b7f4 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -388,8 +388,8 @@ InitializeHostName( Tcl_DStringSetLength(&inDs, 256); if (gethostname(Tcl_DStringValue(&inDs), Tcl_DStringLength(&inDs)) == 0) { - Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&inDs), -1, - &ds); + Tcl_ExternalToUtfDStringEx(NULL, Tcl_DStringValue(&inDs), -1, + TCL_ENCODING_NOCOMPLAIN, &ds); } Tcl_DStringFree(&inDs); } -- cgit v0.12 From d2abd44f2bc2abbd42bda4643478e51c2ae04e3d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 22 Mar 2022 08:16:01 +0000 Subject: Add UTF-16 versions of Tcl_UniCharLength/Tcl_NumUtfChars/Tcl_UtfAtIndex. Needed for Tk's glyph_indexing_2, and possibly other extensions sticking at TCL_UTF_MAX=3 --- generic/tcl.decls | 15 ++++++++-- generic/tclDecls.h | 47 ++++++++++++++++++++++++-------- generic/tclInt.h | 2 +- generic/tclStringObj.c | 46 ++++++++++++++++++++++++++++--- generic/tclStubInit.c | 9 ++++-- generic/tclUtf.c | 74 ++++++++++++++++++++++++++++++++++++++++++++++++++ 6 files changed, 170 insertions(+), 23 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 5a03bd2..98419d6 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -1162,7 +1162,7 @@ declare 311 { const Tcl_Time *timePtr) } declare 312 { - size_t Tcl_NumUtfChars(const char *src, size_t length) + size_t TclNumUtfChars(const char *src, size_t length) } declare 313 { size_t Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, @@ -1206,7 +1206,7 @@ declare 324 { int Tcl_UniCharToUtf(int ch, char *buf) } declare 325 { - const char *Tcl_UtfAtIndex(const char *src, size_t index) + const char *TclUtfAtIndex(const char *src, size_t index) } declare 326 { int TclUtfCharComplete(const char *src, size_t length) @@ -1396,7 +1396,7 @@ declare 379 { size_t numChars) } declare 380 { - size_t Tcl_GetCharLength(Tcl_Obj *objPtr) + size_t TclGetCharLength(Tcl_Obj *objPtr) } declare 381 { int Tcl_GetUniChar(Tcl_Obj *objPtr, size_t index) @@ -2516,6 +2516,15 @@ declare 660 { declare 668 { size_t Tcl_UniCharLen(const int *uniStr) } +declare 669 { + size_t Tcl_NumUtfChars(const char *src, size_t length) +} +declare 670 { + size_t Tcl_GetCharLength(Tcl_Obj *objPtr) +} +declare 671 { + const char *Tcl_UtfAtIndex(const char *src, size_t index) +} # ----- BASELINE -- FOR -- 8.7.0 ----- # diff --git a/generic/tclDecls.h b/generic/tclDecls.h index cc33cf8..81ce6f8 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -828,7 +828,7 @@ EXTERN void Tcl_ConditionNotify(Tcl_Condition *condPtr); EXTERN void Tcl_ConditionWait(Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr, const Tcl_Time *timePtr); /* 312 */ -EXTERN size_t Tcl_NumUtfChars(const char *src, size_t length); +EXTERN size_t TclNumUtfChars(const char *src, size_t length); /* 313 */ EXTERN size_t Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, size_t charsToRead, int appendFlag); @@ -857,7 +857,7 @@ EXTERN int Tcl_UniCharToUpper(int ch); /* 324 */ EXTERN int Tcl_UniCharToUtf(int ch, char *buf); /* 325 */ -EXTERN const char * Tcl_UtfAtIndex(const char *src, size_t index); +EXTERN const char * TclUtfAtIndex(const char *src, size_t index); /* 326 */ EXTERN int TclUtfCharComplete(const char *src, size_t length); /* 327 */ @@ -996,7 +996,7 @@ EXTERN Tcl_Obj * Tcl_NewUnicodeObj(const Tcl_UniChar *unicode, EXTERN void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, size_t numChars); /* 380 */ -EXTERN size_t Tcl_GetCharLength(Tcl_Obj *objPtr); +EXTERN size_t TclGetCharLength(Tcl_Obj *objPtr); /* 381 */ EXTERN int Tcl_GetUniChar(Tcl_Obj *objPtr, size_t index); /* Slot 382 is reserved */ @@ -1774,6 +1774,12 @@ EXTERN int Tcl_AsyncMarkFromSignal(Tcl_AsyncHandler async, /* Slot 667 is reserved */ /* 668 */ EXTERN size_t Tcl_UniCharLen(const int *uniStr); +/* 669 */ +EXTERN size_t Tcl_NumUtfChars(const char *src, size_t length); +/* 670 */ +EXTERN size_t Tcl_GetCharLength(Tcl_Obj *objPtr); +/* 671 */ +EXTERN const char * Tcl_UtfAtIndex(const char *src, size_t index); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2097,7 +2103,7 @@ typedef struct TclStubs { void (*tcl_MutexUnlock) (Tcl_Mutex *mutexPtr); /* 309 */ void (*tcl_ConditionNotify) (Tcl_Condition *condPtr); /* 310 */ void (*tcl_ConditionWait) (Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr, const Tcl_Time *timePtr); /* 311 */ - size_t (*tcl_NumUtfChars) (const char *src, size_t length); /* 312 */ + size_t (*tclNumUtfChars) (const char *src, size_t length); /* 312 */ size_t (*tcl_ReadChars) (Tcl_Channel channel, Tcl_Obj *objPtr, size_t charsToRead, int appendFlag); /* 313 */ void (*reserved314)(void); void (*reserved315)(void); @@ -2110,7 +2116,7 @@ typedef struct TclStubs { int (*tcl_UniCharToTitle) (int ch); /* 322 */ int (*tcl_UniCharToUpper) (int ch); /* 323 */ int (*tcl_UniCharToUtf) (int ch, char *buf); /* 324 */ - const char * (*tcl_UtfAtIndex) (const char *src, size_t index); /* 325 */ + const char * (*tclUtfAtIndex) (const char *src, size_t index); /* 325 */ int (*tclUtfCharComplete) (const char *src, size_t length); /* 326 */ size_t (*tcl_UtfBackslash) (const char *src, int *readPtr, char *dst); /* 327 */ const char * (*tcl_UtfFindFirst) (const char *src, int ch); /* 328 */ @@ -2165,7 +2171,7 @@ typedef struct TclStubs { void (*tcl_RegExpGetInfo) (Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr); /* 377 */ Tcl_Obj * (*tcl_NewUnicodeObj) (const Tcl_UniChar *unicode, size_t numChars); /* 378 */ void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, size_t numChars); /* 379 */ - size_t (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 380 */ + size_t (*tclGetCharLength) (Tcl_Obj *objPtr); /* 380 */ int (*tcl_GetUniChar) (Tcl_Obj *objPtr, size_t index); /* 381 */ void (*reserved382)(void); Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, size_t first, size_t last); /* 383 */ @@ -2454,6 +2460,9 @@ typedef struct TclStubs { void (*reserved666)(void); void (*reserved667)(void); size_t (*tcl_UniCharLen) (const int *uniStr); /* 668 */ + size_t (*tcl_NumUtfChars) (const char *src, size_t length); /* 669 */ + size_t (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 670 */ + const char * (*tcl_UtfAtIndex) (const char *src, size_t index); /* 671 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3046,8 +3055,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_ConditionNotify) /* 310 */ #define Tcl_ConditionWait \ (tclStubsPtr->tcl_ConditionWait) /* 311 */ -#define Tcl_NumUtfChars \ - (tclStubsPtr->tcl_NumUtfChars) /* 312 */ +#define TclNumUtfChars \ + (tclStubsPtr->tclNumUtfChars) /* 312 */ #define Tcl_ReadChars \ (tclStubsPtr->tcl_ReadChars) /* 313 */ /* Slot 314 is reserved */ @@ -3070,8 +3079,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_UniCharToUpper) /* 323 */ #define Tcl_UniCharToUtf \ (tclStubsPtr->tcl_UniCharToUtf) /* 324 */ -#define Tcl_UtfAtIndex \ - (tclStubsPtr->tcl_UtfAtIndex) /* 325 */ +#define TclUtfAtIndex \ + (tclStubsPtr->tclUtfAtIndex) /* 325 */ #define TclUtfCharComplete \ (tclStubsPtr->tclUtfCharComplete) /* 326 */ #define Tcl_UtfBackslash \ @@ -3176,8 +3185,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_NewUnicodeObj) /* 378 */ #define Tcl_SetUnicodeObj \ (tclStubsPtr->tcl_SetUnicodeObj) /* 379 */ -#define Tcl_GetCharLength \ - (tclStubsPtr->tcl_GetCharLength) /* 380 */ +#define TclGetCharLength \ + (tclStubsPtr->tclGetCharLength) /* 380 */ #define Tcl_GetUniChar \ (tclStubsPtr->tcl_GetUniChar) /* 381 */ /* Slot 382 is reserved */ @@ -3736,6 +3745,12 @@ extern const TclStubs *tclStubsPtr; /* Slot 667 is reserved */ #define Tcl_UniCharLen \ (tclStubsPtr->tcl_UniCharLen) /* 668 */ +#define Tcl_NumUtfChars \ + (tclStubsPtr->tcl_NumUtfChars) /* 669 */ +#define Tcl_GetCharLength \ + (tclStubsPtr->tcl_GetCharLength) /* 670 */ +#define Tcl_UtfAtIndex \ + (tclStubsPtr->tcl_UtfAtIndex) /* 671 */ #endif /* defined(USE_TCL_STUBS) */ @@ -3937,6 +3952,14 @@ extern const TclStubs *tclStubsPtr; # define Tcl_UtfToUniChar Tcl_UtfToChar16 # undef Tcl_UniCharLen # define Tcl_UniCharLen Tcl_Char16Len +#if !defined(BUILD_tcl) +# undef Tcl_NumUtfChars +# define Tcl_NumUtfChars TclNumUtfChars +# undef Tcl_GetCharLength +# define Tcl_GetCharLength TclGetCharLength +# undef Tcl_UtfAtIndex +# define Tcl_UtfAtIndex TclUtfAtIndex +#endif #endif #if defined(USE_TCL_STUBS) # define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \ diff --git a/generic/tclInt.h b/generic/tclInt.h index 596e1cb..055c497 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4668,7 +4668,7 @@ MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[]; *---------------------------------------------------------------- */ -#define TclNumUtfChars(numChars, bytes, numBytes) \ +#define TclNumUtfChars_NOTUSED(numChars, bytes, numBytes) \ do { \ size_t _count, _i = (numBytes); \ unsigned char *_str = (unsigned char *) (bytes); \ diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index c8d9df7..76d43a6 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -394,6 +394,7 @@ Tcl_NewUnicodeObj( *---------------------------------------------------------------------- */ +#undef Tcl_GetCharLength size_t Tcl_GetCharLength( Tcl_Obj *objPtr) /* The String object to get the num chars @@ -440,12 +441,49 @@ Tcl_GetCharLength( */ if (numChars == TCL_INDEX_NONE) { - TclNumUtfChars(numChars, objPtr->bytes, objPtr->length); + numChars = Tcl_NumUtfChars(objPtr->bytes, objPtr->length); stringPtr->numChars = numChars; } return numChars; } +size_t +TclGetCharLength( + Tcl_Obj *objPtr) /* The String object to get the num chars + * of. */ +{ + size_t numChars = 0; + + /* + * Quick, no-shimmer return for short string reps. + */ + + if ((objPtr->bytes) && (objPtr->length < 2)) { + /* 0 bytes -> 0 chars; 1 byte -> 1 char */ + return objPtr->length; + } + + /* + * Optimize the case where we're really dealing with a bytearray object; + * we don't need to convert to a string to perform the get-length operation. + * + * Starting in Tcl 8.7, we check for a "pure" bytearray, because the + * machinery behind that test is using a proper bytearray ObjType. We + * could also compute length of an improper bytearray without shimmering + * but there's no value in that. We *want* to shimmer an improper bytearray + * because improper bytearrays have worthless internal reps. + */ + + if (TclIsPureByteArray(objPtr)) { + (void) Tcl_GetByteArrayFromObj(objPtr, &numChars); + } else { + numChars = TclNumUtfChars(objPtr->bytes, objPtr->length); + } + + return numChars; +} + + /* *---------------------------------------------------------------------- * @@ -543,7 +581,7 @@ Tcl_GetUniChar( */ if (stringPtr->numChars == TCL_INDEX_NONE) { - TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length); + stringPtr->numChars = Tcl_NumUtfChars(objPtr->bytes, objPtr->length); } if (stringPtr->numChars == objPtr->length) { return (unsigned char) objPtr->bytes[index]; @@ -709,7 +747,7 @@ Tcl_GetRange( */ if (stringPtr->numChars == TCL_INDEX_NONE) { - TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length); + stringPtr->numChars = Tcl_NumUtfChars(objPtr->bytes, objPtr->length); } if (stringPtr->numChars == objPtr->length) { if (last >= stringPtr->numChars) { @@ -4045,7 +4083,7 @@ ExtendUnicodeRepWithString( numOrigChars = stringPtr->numChars; } if (numAppendChars == TCL_INDEX_NONE) { - TclNumUtfChars(numAppendChars, bytes, numBytes); + numAppendChars = Tcl_NumUtfChars(bytes, numBytes); } needed = numOrigChars + numAppendChars; diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index ea7083f..6704df8 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1005,7 +1005,7 @@ const TclStubs tclStubs = { Tcl_MutexUnlock, /* 309 */ Tcl_ConditionNotify, /* 310 */ Tcl_ConditionWait, /* 311 */ - Tcl_NumUtfChars, /* 312 */ + TclNumUtfChars, /* 312 */ Tcl_ReadChars, /* 313 */ 0, /* 314 */ 0, /* 315 */ @@ -1018,7 +1018,7 @@ const TclStubs tclStubs = { Tcl_UniCharToTitle, /* 322 */ Tcl_UniCharToUpper, /* 323 */ Tcl_UniCharToUtf, /* 324 */ - Tcl_UtfAtIndex, /* 325 */ + TclUtfAtIndex, /* 325 */ TclUtfCharComplete, /* 326 */ Tcl_UtfBackslash, /* 327 */ Tcl_UtfFindFirst, /* 328 */ @@ -1073,7 +1073,7 @@ const TclStubs tclStubs = { Tcl_RegExpGetInfo, /* 377 */ Tcl_NewUnicodeObj, /* 378 */ Tcl_SetUnicodeObj, /* 379 */ - Tcl_GetCharLength, /* 380 */ + TclGetCharLength, /* 380 */ Tcl_GetUniChar, /* 381 */ 0, /* 382 */ Tcl_GetRange, /* 383 */ @@ -1362,6 +1362,9 @@ const TclStubs tclStubs = { 0, /* 666 */ 0, /* 667 */ Tcl_UniCharLen, /* 668 */ + Tcl_NumUtfChars, /* 669 */ + Tcl_GetCharLength, /* 670 */ + Tcl_UtfAtIndex, /* 671 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclUtf.c b/generic/tclUtf.c index e353b7f..6c6940c 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -799,6 +799,7 @@ Tcl_UtfCharComplete( *--------------------------------------------------------------------------- */ +#undef Tcl_NumUtfChars size_t Tcl_NumUtfChars( const char *src, /* The UTF-8 string to measure. */ @@ -851,6 +852,58 @@ Tcl_NumUtfChars( return i; } +size_t +TclNumUtfChars( + const char *src, /* The UTF-8 string to measure. */ + size_t length) /* The length of the string in bytes, or + * TCL_INDEX_NONE for strlen(src). */ +{ + unsigned short ch = 0; + size_t i = 0; + + if (length == TCL_INDEX_NONE) { + /* string is NUL-terminated, so TclUtfToUniChar calls are safe. */ + while (*src != '\0') { + src += Tcl_UtfToChar16(src, &ch); + i++; + } + } else { + /* Will return value between 0 and length. No overflow checks. */ + + /* Pointer to the end of string. Never read endPtr[0] */ + const char *endPtr = src + length; + /* Pointer to last byte where optimization still can be used */ + const char *optPtr = endPtr - 4; + + /* + * Optimize away the call in this loop. Justified because... + * when (src <= optPtr), (endPtr - src) >= (endPtr - optPtr) + * By initialization above (endPtr - optPtr) = TCL_UTF_MAX + * So (endPtr - src) >= TCL_UTF_MAX, and passing that to + * Tcl_UtfCharComplete we know will cause return of 1. + */ + while (src <= optPtr + /* && Tcl_UtfCharComplete(src, endPtr - src) */ ) { + src += Tcl_UtfToChar16(src, &ch); + i++; + } + /* Loop over the remaining string where call must happen */ + while (src < endPtr) { + if (Tcl_UtfCharComplete(src, endPtr - src)) { + src += Tcl_UtfToChar16(src, &ch); + } else { + /* + * src points to incomplete UTF-8 sequence + * Treat first byte as character and count it + */ + src++; + } + i++; + } + } + return i; +} + /* *--------------------------------------------------------------------------- * @@ -1167,6 +1220,7 @@ Tcl_UniCharAtIndex( *--------------------------------------------------------------------------- */ +#undef Tcl_UtfAtIndex const char * Tcl_UtfAtIndex( const char *src, /* The UTF-8 string. */ @@ -1195,6 +1249,26 @@ Tcl_UtfAtIndex( return src; } +const char * +TclUtfAtIndex( + const char *src, /* The UTF-8 string. */ + size_t index) /* The position of the desired character. */ +{ + unsigned short ch = 0; + size_t len = 0; + + if (index != TCL_INDEX_NONE) { + while (index--) { + src += (len = Tcl_UtfToChar16(src, &ch)); + } + if ((ch >= 0xD800) && (len < 3)) { + /* Index points at character following high Surrogate */ + src += Tcl_UtfToChar16(src, &ch); + } + } + return src; +} + /* *--------------------------------------------------------------------------- * -- cgit v0.12 From f13079289a274d0195bb0a57b34fa61bd1775e28 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 22 Mar 2022 17:06:57 +0000 Subject: Put back TclNumUtfChars (as TclNumUtfCharsM) macro for speedup --- generic/tclInt.h | 2 +- generic/tclStringObj.c | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 055c497..8c6d5f0 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4668,7 +4668,7 @@ MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[]; *---------------------------------------------------------------- */ -#define TclNumUtfChars_NOTUSED(numChars, bytes, numBytes) \ +#define TclNumUtfCharsM(numChars, bytes, numBytes) \ do { \ size_t _count, _i = (numBytes); \ unsigned char *_str = (unsigned char *) (bytes); \ diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 76d43a6..7e65ef1 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -441,7 +441,7 @@ Tcl_GetCharLength( */ if (numChars == TCL_INDEX_NONE) { - numChars = Tcl_NumUtfChars(objPtr->bytes, objPtr->length); + TclNumUtfCharsM(numChars, objPtr->bytes, objPtr->length); stringPtr->numChars = numChars; } return numChars; @@ -581,7 +581,7 @@ Tcl_GetUniChar( */ if (stringPtr->numChars == TCL_INDEX_NONE) { - stringPtr->numChars = Tcl_NumUtfChars(objPtr->bytes, objPtr->length); + TclNumUtfCharsM(stringPtr->numChars, objPtr->bytes, objPtr->length); } if (stringPtr->numChars == objPtr->length) { return (unsigned char) objPtr->bytes[index]; @@ -747,7 +747,7 @@ Tcl_GetRange( */ if (stringPtr->numChars == TCL_INDEX_NONE) { - stringPtr->numChars = Tcl_NumUtfChars(objPtr->bytes, objPtr->length); + TclNumUtfCharsM(stringPtr->numChars, objPtr->bytes, objPtr->length); } if (stringPtr->numChars == objPtr->length) { if (last >= stringPtr->numChars) { @@ -4083,7 +4083,7 @@ ExtendUnicodeRepWithString( numOrigChars = stringPtr->numChars; } if (numAppendChars == TCL_INDEX_NONE) { - numAppendChars = Tcl_NumUtfChars(bytes, numBytes); + TclNumUtfCharsM(numAppendChars, bytes, numBytes); } needed = numOrigChars + numAppendChars; -- cgit v0.12 From 4fcff1f053c279076fb2bc1507dac8a26b3c562b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 22 Mar 2022 23:18:23 +0000 Subject: Simplyfy Tcl_UtfAtIndex --- generic/tclUtf.c | 25 ++++++------------------- 1 file changed, 6 insertions(+), 19 deletions(-) diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 6c6940c..09e464f 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -1226,25 +1226,12 @@ Tcl_UtfAtIndex( const char *src, /* The UTF-8 string. */ size_t index) /* The position of the desired character. */ { - Tcl_UniChar ch = 0; -#if TCL_UTF_MAX < 4 - size_t len = 0; -#endif + int ch = 0; if (index != TCL_INDEX_NONE) { while (index--) { -#if TCL_UTF_MAX < 4 - src += (len = TclUtfToUniChar(src, &ch)); -#else - src += TclUtfToUniChar(src, &ch); -#endif + src += Tcl_UtfToUniChar(src, &ch); } -#if TCL_UTF_MAX < 4 - if ((ch >= 0xD800) && (len < 3)) { - /* Index points at character following high Surrogate */ - src += TclUtfToUniChar(src, &ch); - } -#endif } return src; } @@ -1261,10 +1248,10 @@ TclUtfAtIndex( while (index--) { src += (len = Tcl_UtfToChar16(src, &ch)); } - if ((ch >= 0xD800) && (len < 3)) { - /* Index points at character following high Surrogate */ - src += Tcl_UtfToChar16(src, &ch); - } + if ((ch >= 0xD800) && (len < 3)) { + /* Index points at character following high Surrogate */ + src += Tcl_UtfToChar16(src, &ch); + } } return src; } -- cgit v0.12 From db3553f6b2e985ce55fa6c42cb0bf268a06cdc70 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 24 Mar 2022 14:28:10 +0000 Subject: Add UTF-16 versions of Tcl_GetRange/Tcl_GetUniChar --- generic/tcl.decls | 10 ++++-- generic/tclDecls.h | 31 ++++++++++++++----- generic/tclStringObj.c | 83 ++++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclStubInit.c | 6 ++-- 4 files changed, 118 insertions(+), 12 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 98419d6..d4f1c59 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -1399,14 +1399,14 @@ declare 380 { size_t TclGetCharLength(Tcl_Obj *objPtr) } declare 381 { - int Tcl_GetUniChar(Tcl_Obj *objPtr, size_t index) + int TclGetUniChar(Tcl_Obj *objPtr, size_t index) } # Removed in 9.0, replaced by macro. #declare 382 { # Tcl_UniChar *Tcl_GetUnicode(Tcl_Obj *objPtr) #} declare 383 { - Tcl_Obj *Tcl_GetRange(Tcl_Obj *objPtr, size_t first, size_t last) + Tcl_Obj *TclGetRange(Tcl_Obj *objPtr, size_t first, size_t last) } # Removed in 9.0 #declare 384 { @@ -2525,6 +2525,12 @@ declare 670 { declare 671 { const char *Tcl_UtfAtIndex(const char *src, size_t index) } +declare 672 { + Tcl_Obj *Tcl_GetRange(Tcl_Obj *objPtr, size_t first, size_t last) +} +declare 673 { + int Tcl_GetUniChar(Tcl_Obj *objPtr, size_t index) +} # ----- BASELINE -- FOR -- 8.7.0 ----- # diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 81ce6f8..1345c6c 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -998,10 +998,10 @@ EXTERN void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, /* 380 */ EXTERN size_t TclGetCharLength(Tcl_Obj *objPtr); /* 381 */ -EXTERN int Tcl_GetUniChar(Tcl_Obj *objPtr, size_t index); +EXTERN int TclGetUniChar(Tcl_Obj *objPtr, size_t index); /* Slot 382 is reserved */ /* 383 */ -EXTERN Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, size_t first, +EXTERN Tcl_Obj * TclGetRange(Tcl_Obj *objPtr, size_t first, size_t last); /* Slot 384 is reserved */ /* 385 */ @@ -1780,6 +1780,11 @@ EXTERN size_t Tcl_NumUtfChars(const char *src, size_t length); EXTERN size_t Tcl_GetCharLength(Tcl_Obj *objPtr); /* 671 */ EXTERN const char * Tcl_UtfAtIndex(const char *src, size_t index); +/* 672 */ +EXTERN Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, size_t first, + size_t last); +/* 673 */ +EXTERN int Tcl_GetUniChar(Tcl_Obj *objPtr, size_t index); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2172,9 +2177,9 @@ typedef struct TclStubs { Tcl_Obj * (*tcl_NewUnicodeObj) (const Tcl_UniChar *unicode, size_t numChars); /* 378 */ void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, size_t numChars); /* 379 */ size_t (*tclGetCharLength) (Tcl_Obj *objPtr); /* 380 */ - int (*tcl_GetUniChar) (Tcl_Obj *objPtr, size_t index); /* 381 */ + int (*tclGetUniChar) (Tcl_Obj *objPtr, size_t index); /* 381 */ void (*reserved382)(void); - Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, size_t first, size_t last); /* 383 */ + Tcl_Obj * (*tclGetRange) (Tcl_Obj *objPtr, size_t first, size_t last); /* 383 */ void (*reserved384)(void); int (*tcl_RegExpMatchObj) (Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); /* 385 */ void (*tcl_SetNotifier) (const Tcl_NotifierProcs *notifierProcPtr); /* 386 */ @@ -2463,6 +2468,8 @@ typedef struct TclStubs { size_t (*tcl_NumUtfChars) (const char *src, size_t length); /* 669 */ size_t (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 670 */ const char * (*tcl_UtfAtIndex) (const char *src, size_t index); /* 671 */ + Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, size_t first, size_t last); /* 672 */ + int (*tcl_GetUniChar) (Tcl_Obj *objPtr, size_t index); /* 673 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3187,11 +3194,11 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_SetUnicodeObj) /* 379 */ #define TclGetCharLength \ (tclStubsPtr->tclGetCharLength) /* 380 */ -#define Tcl_GetUniChar \ - (tclStubsPtr->tcl_GetUniChar) /* 381 */ +#define TclGetUniChar \ + (tclStubsPtr->tclGetUniChar) /* 381 */ /* Slot 382 is reserved */ -#define Tcl_GetRange \ - (tclStubsPtr->tcl_GetRange) /* 383 */ +#define TclGetRange \ + (tclStubsPtr->tclGetRange) /* 383 */ /* Slot 384 is reserved */ #define Tcl_RegExpMatchObj \ (tclStubsPtr->tcl_RegExpMatchObj) /* 385 */ @@ -3751,6 +3758,10 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_GetCharLength) /* 670 */ #define Tcl_UtfAtIndex \ (tclStubsPtr->tcl_UtfAtIndex) /* 671 */ +#define Tcl_GetRange \ + (tclStubsPtr->tcl_GetRange) /* 672 */ +#define Tcl_GetUniChar \ + (tclStubsPtr->tcl_GetUniChar) /* 673 */ #endif /* defined(USE_TCL_STUBS) */ @@ -3959,6 +3970,10 @@ extern const TclStubs *tclStubsPtr; # define Tcl_GetCharLength TclGetCharLength # undef Tcl_UtfAtIndex # define Tcl_UtfAtIndex TclUtfAtIndex +# undef Tcl_GetRange +# define Tcl_GetRange TclGetRange +# undef Tcl_GetUniChar +# define Tcl_GetUniChar TclGetUniChar #endif #endif #if defined(USE_TCL_STUBS) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 7e65ef1..dc64fcd 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -612,6 +612,40 @@ Tcl_GetUniChar( #endif return ch; } + +int +TclGetUniChar( + Tcl_Obj *objPtr, /* The object to get the Unicode charater + * from. */ + size_t index) /* Get the index'th Unicode character. */ +{ + int ch = 0; + + /* + * Optimize the case where we're really dealing with a bytearray object + * we don't need to convert to a string to perform the indexing operation. + */ + + if (TclIsPureByteArray(objPtr)) { + size_t length = 0; + unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length); + if (index >= length) { + return -1; + } + + return bytes[index]; + } + + size_t numChars = TclNumUtfChars(objPtr->bytes, objPtr->length); + + if (index >= numChars) { + return -1; + } + const char *begin = TclUtfAtIndex(objPtr->bytes, index); + Tcl_UtfToUniChar(begin, &ch); + return ch; +} + /* *---------------------------------------------------------------------- @@ -792,6 +826,55 @@ Tcl_GetRange( #endif return Tcl_NewUnicodeObj(stringPtr->unicode + first, last - first + 1); } + +Tcl_Obj * +TclGetRange( + Tcl_Obj *objPtr, /* The Tcl object to find the range of. */ + size_t first, /* First index of the range. */ + size_t last) /* Last index of the range. */ +{ + Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */ + size_t length = 0; + + if (first == TCL_INDEX_NONE) { + first = TCL_INDEX_START; + } + if (last + 2 <= first + 1) { + return Tcl_NewObj(); + } + + /* + * Optimize the case where we're really dealing with a bytearray object + * we don't need to convert to a string to perform the substring operation. + */ + + if (TclIsPureByteArray(objPtr)) { + unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length); + + if (last >= length) { + last = length - 1; + } + if (last < first) { + TclNewObj(newObjPtr); + return newObjPtr; + } + return Tcl_NewByteArrayObj(bytes + first, last - first + 1); + } + + size_t numChars = TclNumUtfChars(objPtr->bytes, objPtr->length); + + if (last >= numChars) { + last = numChars - 1; + } + if (last < first) { + TclNewObj(newObjPtr); + return newObjPtr; + } + const char *begin = TclUtfAtIndex(objPtr->bytes, first); + const char *end = TclUtfAtIndex(objPtr->bytes, last + 1); + return Tcl_NewStringObj(begin, end - begin); +} + /* *---------------------------------------------------------------------- diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 6704df8..704c51a 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1074,9 +1074,9 @@ const TclStubs tclStubs = { Tcl_NewUnicodeObj, /* 378 */ Tcl_SetUnicodeObj, /* 379 */ TclGetCharLength, /* 380 */ - Tcl_GetUniChar, /* 381 */ + TclGetUniChar, /* 381 */ 0, /* 382 */ - Tcl_GetRange, /* 383 */ + TclGetRange, /* 383 */ 0, /* 384 */ Tcl_RegExpMatchObj, /* 385 */ Tcl_SetNotifier, /* 386 */ @@ -1365,6 +1365,8 @@ const TclStubs tclStubs = { Tcl_NumUtfChars, /* 669 */ Tcl_GetCharLength, /* 670 */ Tcl_UtfAtIndex, /* 671 */ + Tcl_GetRange, /* 672 */ + Tcl_GetUniChar, /* 673 */ }; /* !END!: Do not edit above this line. */ -- cgit v0.12 From 0dba465244f6e7cc0396e739ead01dd2575aaf2b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 24 Mar 2022 22:55:32 +0000 Subject: Bugfix for TclGetCharLength(): Make sure objPtr->bytes is filled --- generic/tclStringObj.c | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index dc64fcd..7cee05d 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -477,6 +477,7 @@ TclGetCharLength( if (TclIsPureByteArray(objPtr)) { (void) Tcl_GetByteArrayFromObj(objPtr, &numChars); } else { + Tcl_GetString(objPtr); numChars = TclNumUtfChars(objPtr->bytes, objPtr->length); } -- cgit v0.12 From f768cd1df73e1d1801bef8b03e89609d1bb6f885 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 25 Mar 2022 08:20:31 +0000 Subject: Put back Tcl_AppendUnicodeToObj() --- ChangeLog.1999 | 2 +- generic/tcl.decls | 9 ++++----- generic/tclCmdMZ.c | 38 +++++++++++++++++++------------------- generic/tclDecls.h | 9 ++++++--- generic/tclExecute.c | 6 +++--- generic/tclInt.decls | 5 ----- generic/tclIntDecls.h | 9 +++------ generic/tclStringObj.c | 10 +++++----- generic/tclStubInit.c | 6 +++--- generic/tclTestObj.c | 2 +- 10 files changed, 45 insertions(+), 51 deletions(-) diff --git a/ChangeLog.1999 b/ChangeLog.1999 index 3bf4e9a..4d88b61 100644 --- a/ChangeLog.1999 +++ b/ChangeLog.1999 @@ -1226,7 +1226,7 @@ 1999-06-09 Scott Stanton * generic/tclUnicodeObj.c: Lots of cleanup and simplification. Fixed - several memory bugs. Added TclAppendUnicodeToObj. + several memory bugs. Added Tcl_AppendUnicodeToObj. * generic/tclInt.h: Added declarations for various Unicode string functions. diff --git a/generic/tcl.decls b/generic/tcl.decls index d4f1c59..731baa8 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -1408,11 +1408,10 @@ declare 381 { declare 383 { Tcl_Obj *TclGetRange(Tcl_Obj *objPtr, size_t first, size_t last) } -# Removed in 9.0 -#declare 384 { -# void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, -# int length) -#} +declare 384 { + void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, + size_t length) +} declare 385 { int Tcl_RegExpMatchObj(Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 85174ec..534a5ae 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -624,8 +624,8 @@ Tcl_RegsubObjCmd( resultPtr = Tcl_NewUnicodeObj(wstring, 0); Tcl_IncrRefCount(resultPtr); for (; wstring < wend; wstring++) { - TclAppendUnicodeToObj(resultPtr, wsubspec, wsublen); - TclAppendUnicodeToObj(resultPtr, wstring, 1); + Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen); + Tcl_AppendUnicodeToObj(resultPtr, wstring, 1); numMatches++; } wlen = 0; @@ -641,14 +641,14 @@ Tcl_RegsubObjCmd( Tcl_IncrRefCount(resultPtr); } if (p != wstring) { - TclAppendUnicodeToObj(resultPtr, p, wstring - p); + Tcl_AppendUnicodeToObj(resultPtr, p, wstring - p); p = wstring + slen; } else { p += slen; } wstring = p - 1; - TclAppendUnicodeToObj(resultPtr, wsubspec, wsublen); + Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen); numMatches++; } } @@ -751,7 +751,7 @@ Tcl_RegsubObjCmd( * specified. */ - TclAppendUnicodeToObj(resultPtr, wstring, offset); + Tcl_AppendUnicodeToObj(resultPtr, wstring, offset); } } numMatches++; @@ -764,7 +764,7 @@ Tcl_RegsubObjCmd( Tcl_RegExpGetInfo(regExpr, &info); start = info.matches[0].start; end = info.matches[0].end; - TclAppendUnicodeToObj(resultPtr, wstring + offset, start); + Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, start); /* * In command-prefix mode, the substitutions are added as quoted @@ -839,7 +839,7 @@ Tcl_RegsubObjCmd( */ if (offset < wlen) { - TclAppendUnicodeToObj(resultPtr, wstring + offset, 1); + Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); } offset++; } @@ -868,7 +868,7 @@ Tcl_RegsubObjCmd( idx = ch - '0'; } else if ((ch == '\\') || (ch == '&')) { *wsrc = ch; - TclAppendUnicodeToObj(resultPtr, wfirstChar, + Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar + 1); *wsrc = '\\'; wfirstChar = wsrc + 2; @@ -882,7 +882,7 @@ Tcl_RegsubObjCmd( } if (wfirstChar != wsrc) { - TclAppendUnicodeToObj(resultPtr, wfirstChar, + Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar); } @@ -890,7 +890,7 @@ Tcl_RegsubObjCmd( subStart = info.matches[idx].start; subEnd = info.matches[idx].end; if ((subStart != TCL_INDEX_NONE) && (subEnd != TCL_INDEX_NONE)) { - TclAppendUnicodeToObj(resultPtr, + Tcl_AppendUnicodeToObj(resultPtr, wstring + offset + subStart, subEnd - subStart); } } @@ -902,7 +902,7 @@ Tcl_RegsubObjCmd( } if (wfirstChar != wsrc) { - TclAppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar); + Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar); } if (end == 0) { @@ -912,7 +912,7 @@ Tcl_RegsubObjCmd( */ if (offset < wlen) { - TclAppendUnicodeToObj(resultPtr, wstring + offset, 1); + Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); } offset++; } else { @@ -924,7 +924,7 @@ Tcl_RegsubObjCmd( */ if (offset < wlen) { - TclAppendUnicodeToObj(resultPtr, wstring + offset, 1); + Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); } offset++; } @@ -949,7 +949,7 @@ Tcl_RegsubObjCmd( resultPtr = objv[1]; Tcl_IncrRefCount(resultPtr); } else if (offset < wlen) { - TclAppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset); + Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset); } if (objc == 4) { if (Tcl_ObjSetVar2(interp, objv[3], NULL, resultPtr, @@ -2112,14 +2112,14 @@ StringMapCmd( (length2==1 || strCmpFn(ustring1, ustring2, length2) == 0)) { if (p != ustring1) { - TclAppendUnicodeToObj(resultPtr, p, ustring1-p); + Tcl_AppendUnicodeToObj(resultPtr, p, ustring1-p); p = ustring1 + length2; } else { p += length2; } ustring1 = p - 1; - TclAppendUnicodeToObj(resultPtr, mapString, mapLen); + Tcl_AppendUnicodeToObj(resultPtr, mapString, mapLen); } } } @@ -2165,7 +2165,7 @@ StringMapCmd( * Put the skipped chars onto the result first. */ - TclAppendUnicodeToObj(resultPtr, p, ustring1-p); + Tcl_AppendUnicodeToObj(resultPtr, p, ustring1-p); p = ustring1 + length2; } else { p += length2; @@ -2181,7 +2181,7 @@ StringMapCmd( * Append the map value to the unicode string. */ - TclAppendUnicodeToObj(resultPtr, + Tcl_AppendUnicodeToObj(resultPtr, mapStrings[index+1], mapLens[index+1]); break; } @@ -2198,7 +2198,7 @@ StringMapCmd( * Put the rest of the unmapped chars onto result. */ - TclAppendUnicodeToObj(resultPtr, p, ustring1 - p); + Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p); } Tcl_SetObjResult(interp, resultPtr); done: diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 1345c6c..d95b965 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1003,7 +1003,9 @@ EXTERN int TclGetUniChar(Tcl_Obj *objPtr, size_t index); /* 383 */ EXTERN Tcl_Obj * TclGetRange(Tcl_Obj *objPtr, size_t first, size_t last); -/* Slot 384 is reserved */ +/* 384 */ +EXTERN void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, + const Tcl_UniChar *unicode, size_t length); /* 385 */ EXTERN int Tcl_RegExpMatchObj(Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); @@ -2180,7 +2182,7 @@ typedef struct TclStubs { int (*tclGetUniChar) (Tcl_Obj *objPtr, size_t index); /* 381 */ void (*reserved382)(void); Tcl_Obj * (*tclGetRange) (Tcl_Obj *objPtr, size_t first, size_t last); /* 383 */ - void (*reserved384)(void); + void (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, size_t length); /* 384 */ int (*tcl_RegExpMatchObj) (Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); /* 385 */ void (*tcl_SetNotifier) (const Tcl_NotifierProcs *notifierProcPtr); /* 386 */ Tcl_Mutex * (*tcl_GetAllocMutex) (void); /* 387 */ @@ -3199,7 +3201,8 @@ extern const TclStubs *tclStubsPtr; /* Slot 382 is reserved */ #define TclGetRange \ (tclStubsPtr->tclGetRange) /* 383 */ -/* Slot 384 is reserved */ +#define Tcl_AppendUnicodeToObj \ + (tclStubsPtr->tcl_AppendUnicodeToObj) /* 384 */ #define Tcl_RegExpMatchObj \ (tclStubsPtr->tcl_RegExpMatchObj) /* 385 */ #define Tcl_SetNotifier \ diff --git a/generic/tclExecute.c b/generic/tclExecute.c index d3b9dac..2c08b7d 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5297,14 +5297,14 @@ TEBCresume( memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * length2) == 0)) { if (p != ustring1) { - TclAppendUnicodeToObj(objResultPtr, p, ustring1-p); + Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1-p); p = ustring1 + length2; } else { p += length2; } ustring1 = p - 1; - TclAppendUnicodeToObj(objResultPtr, ustring3, length3); + Tcl_AppendUnicodeToObj(objResultPtr, ustring3, length3); } } if (p != ustring1) { @@ -5312,7 +5312,7 @@ TEBCresume( * Put the rest of the unmapped chars onto result. */ - TclAppendUnicodeToObj(objResultPtr, p, ustring1 - p); + Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1 - p); } doneStringMap: TRACE_WITH_OBJ(("%.20s %.20s %.20s => ", diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 2d91d0a..79694a7 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -478,11 +478,6 @@ declare 234 { declare 235 { void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr) } -# TIP 542 -declare 236 { - void TclAppendUnicodeToObj(Tcl_Obj *objPtr, - const Tcl_UniChar *unicode, size_t length) -} # TIP #285: Script cancellation support. declare 237 { diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 48cec3d..bf05a0e 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -500,9 +500,7 @@ EXTERN Var * TclVarHashCreateVar(TclVarHashTable *tablePtr, /* 235 */ EXTERN void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr); -/* 236 */ -EXTERN void TclAppendUnicodeToObj(Tcl_Obj *objPtr, - const Tcl_UniChar *unicode, size_t length); +/* Slot 236 is reserved */ /* 237 */ EXTERN int TclResetCancellation(Tcl_Interp *interp, int force); /* 238 */ @@ -819,7 +817,7 @@ typedef struct TclIntStubs { void (*tclGetSrcInfoForPc) (CmdFrame *contextPtr); /* 233 */ Var * (*tclVarHashCreateVar) (TclVarHashTable *tablePtr, const char *key, int *newPtr); /* 234 */ void (*tclInitVarHashTable) (TclVarHashTable *tablePtr, Namespace *nsPtr); /* 235 */ - void (*tclAppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, size_t length); /* 236 */ + void (*reserved236)(void); int (*tclResetCancellation) (Tcl_Interp *interp, int force); /* 237 */ int (*tclNRInterpProc) (void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 238 */ int (*tclNRInterpProcCore) (Tcl_Interp *interp, Tcl_Obj *procNameObj, size_t skip, ProcErrorProc *errorProc); /* 239 */ @@ -1211,8 +1209,7 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclVarHashCreateVar) /* 234 */ #define TclInitVarHashTable \ (tclIntStubsPtr->tclInitVarHashTable) /* 235 */ -#define TclAppendUnicodeToObj \ - (tclIntStubsPtr->tclAppendUnicodeToObj) /* 236 */ +/* Slot 236 is reserved */ #define TclResetCancellation \ (tclIntStubsPtr->tclResetCancellation) /* 237 */ #define TclNRInterpProc \ diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 7cee05d..b5c6520 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -1331,7 +1331,7 @@ Tcl_AppendToObj( /* *---------------------------------------------------------------------- * - * TclAppendUnicodeToObj -- + * Tcl_AppendUnicodeToObj -- * * This function appends a Unicode string to an object in the most * efficient manner possible. Length must be >= 0. @@ -1346,7 +1346,7 @@ Tcl_AppendToObj( */ void -TclAppendUnicodeToObj( +Tcl_AppendUnicodeToObj( Tcl_Obj *objPtr, /* Points to the object to append to. */ const Tcl_UniChar *unicode, /* The unicode string to append to the * object. */ @@ -1355,7 +1355,7 @@ TclAppendUnicodeToObj( String *stringPtr; if (Tcl_IsShared(objPtr)) { - Tcl_Panic("%s called with shared object", "TclAppendUnicodeToObj"); + Tcl_Panic("%s called with shared object", "Tcl_AppendUnicodeToObj"); } if (length == 0) { @@ -3012,7 +3012,7 @@ TclStringRepeat( Tcl_AppendObjToObj(objResultPtr, objResultPtr); done *= 2; } - TclAppendUnicodeToObj(objResultPtr, Tcl_GetUnicode(objResultPtr), + Tcl_AppendUnicodeToObj(objResultPtr, Tcl_GetUnicode(objResultPtr), (count - done) * length); } else { /* @@ -4116,7 +4116,7 @@ TclStringReplace( Tcl_AppendObjToObj(result, insertPtr); } if (first + count < (size_t)numChars) { - TclAppendUnicodeToObj(result, ustring + first + count, + Tcl_AppendUnicodeToObj(result, ustring + first + count, numChars - first - count); } diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 704c51a..9f052e3 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -81,7 +81,7 @@ static void uniCodePanic() { # define TclGetUnicodeFromObj (Tcl_UniChar *(*)(Tcl_Obj *, int *))(void *)uniCodePanic # define Tcl_NewUnicodeObj (Tcl_Obj *(*)(const Tcl_UniChar *, size_t))(void *)uniCodePanic # define Tcl_SetUnicodeObj (void(*)(Tcl_Obj *, const Tcl_UniChar *, size_t))(void *)uniCodePanic -# define TclAppendUnicodeToObj (void(*)(Tcl_Obj *, const Tcl_UniChar *, size_t))(void *)uniCodePanic +# define Tcl_AppendUnicodeToObj (void(*)(Tcl_Obj *, const Tcl_UniChar *, size_t))(void *)uniCodePanic #endif #define TclUtfCharComplete Tcl_UtfCharComplete @@ -528,7 +528,7 @@ static const TclIntStubs tclIntStubs = { TclGetSrcInfoForPc, /* 233 */ TclVarHashCreateVar, /* 234 */ TclInitVarHashTable, /* 235 */ - TclAppendUnicodeToObj, /* 236 */ + 0, /* 236 */ TclResetCancellation, /* 237 */ TclNRInterpProc, /* 238 */ TclNRInterpProcCore, /* 239 */ @@ -1077,7 +1077,7 @@ const TclStubs tclStubs = { TclGetUniChar, /* 381 */ 0, /* 382 */ TclGetRange, /* 383 */ - 0, /* 384 */ + Tcl_AppendUnicodeToObj, /* 384 */ Tcl_RegExpMatchObj, /* 385 */ Tcl_SetNotifier, /* 386 */ Tcl_GetAllocMutex, /* 387 */ diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index 7ea1723..388eae6 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -1377,7 +1377,7 @@ TeststringobjCmd( return TCL_ERROR; } - TclAppendUnicodeToObj(varPtr[varIndex], unicode + length, size - length); + Tcl_AppendUnicodeToObj(varPtr[varIndex], unicode + length, size - length); Tcl_SetObjResult(interp, varPtr[varIndex]); break; } -- cgit v0.12 From 60e9b38dfbeb8b382fd60528363fe726331ac4db Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 29 Mar 2022 19:40:33 +0000 Subject: Add UTF-16 versions of Tcl_NumUtfChars/Tcl_UtfAtIndex to the stub table. Should have been part of TIP #542. Needed for Tk's "glyph_indexing_2" branch --- generic/tcl.decls | 10 ++++-- generic/tclDecls.h | 35 ++++++++++++++----- generic/tclInt.h | 4 +-- generic/tclStringObj.c | 8 ++--- generic/tclStubInit.c | 7 ++-- generic/tclUtf.c | 91 +++++++++++++++++++++++++++++++++++++++++--------- 6 files changed, 122 insertions(+), 33 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 5a03bd2..b943edd 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -1162,7 +1162,7 @@ declare 311 { const Tcl_Time *timePtr) } declare 312 { - size_t Tcl_NumUtfChars(const char *src, size_t length) + size_t TclNumUtfChars(const char *src, size_t length) } declare 313 { size_t Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, @@ -1206,7 +1206,7 @@ declare 324 { int Tcl_UniCharToUtf(int ch, char *buf) } declare 325 { - const char *Tcl_UtfAtIndex(const char *src, size_t index) + const char *TclUtfAtIndex(const char *src, size_t index) } declare 326 { int TclUtfCharComplete(const char *src, size_t length) @@ -2516,6 +2516,12 @@ declare 660 { declare 668 { size_t Tcl_UniCharLen(const int *uniStr) } +declare 669 { + size_t Tcl_NumUtfChars(const char *src, size_t length) +} +declare 671 { + const char *Tcl_UtfAtIndex(const char *src, size_t index) +} # ----- BASELINE -- FOR -- 8.7.0 ----- # diff --git a/generic/tclDecls.h b/generic/tclDecls.h index cc33cf8..3e2b8cb 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -828,7 +828,7 @@ EXTERN void Tcl_ConditionNotify(Tcl_Condition *condPtr); EXTERN void Tcl_ConditionWait(Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr, const Tcl_Time *timePtr); /* 312 */ -EXTERN size_t Tcl_NumUtfChars(const char *src, size_t length); +EXTERN size_t TclNumUtfChars(const char *src, size_t length); /* 313 */ EXTERN size_t Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, size_t charsToRead, int appendFlag); @@ -857,7 +857,7 @@ EXTERN int Tcl_UniCharToUpper(int ch); /* 324 */ EXTERN int Tcl_UniCharToUtf(int ch, char *buf); /* 325 */ -EXTERN const char * Tcl_UtfAtIndex(const char *src, size_t index); +EXTERN const char * TclUtfAtIndex(const char *src, size_t index); /* 326 */ EXTERN int TclUtfCharComplete(const char *src, size_t length); /* 327 */ @@ -1774,6 +1774,11 @@ EXTERN int Tcl_AsyncMarkFromSignal(Tcl_AsyncHandler async, /* Slot 667 is reserved */ /* 668 */ EXTERN size_t Tcl_UniCharLen(const int *uniStr); +/* 669 */ +EXTERN size_t Tcl_NumUtfChars(const char *src, size_t length); +/* Slot 670 is reserved */ +/* 671 */ +EXTERN const char * Tcl_UtfAtIndex(const char *src, size_t index); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2097,7 +2102,7 @@ typedef struct TclStubs { void (*tcl_MutexUnlock) (Tcl_Mutex *mutexPtr); /* 309 */ void (*tcl_ConditionNotify) (Tcl_Condition *condPtr); /* 310 */ void (*tcl_ConditionWait) (Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr, const Tcl_Time *timePtr); /* 311 */ - size_t (*tcl_NumUtfChars) (const char *src, size_t length); /* 312 */ + size_t (*tclNumUtfChars) (const char *src, size_t length); /* 312 */ size_t (*tcl_ReadChars) (Tcl_Channel channel, Tcl_Obj *objPtr, size_t charsToRead, int appendFlag); /* 313 */ void (*reserved314)(void); void (*reserved315)(void); @@ -2110,7 +2115,7 @@ typedef struct TclStubs { int (*tcl_UniCharToTitle) (int ch); /* 322 */ int (*tcl_UniCharToUpper) (int ch); /* 323 */ int (*tcl_UniCharToUtf) (int ch, char *buf); /* 324 */ - const char * (*tcl_UtfAtIndex) (const char *src, size_t index); /* 325 */ + const char * (*tclUtfAtIndex) (const char *src, size_t index); /* 325 */ int (*tclUtfCharComplete) (const char *src, size_t length); /* 326 */ size_t (*tcl_UtfBackslash) (const char *src, int *readPtr, char *dst); /* 327 */ const char * (*tcl_UtfFindFirst) (const char *src, int ch); /* 328 */ @@ -2454,6 +2459,9 @@ typedef struct TclStubs { void (*reserved666)(void); void (*reserved667)(void); size_t (*tcl_UniCharLen) (const int *uniStr); /* 668 */ + size_t (*tcl_NumUtfChars) (const char *src, size_t length); /* 669 */ + void (*reserved670)(void); + const char * (*tcl_UtfAtIndex) (const char *src, size_t index); /* 671 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3046,8 +3054,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_ConditionNotify) /* 310 */ #define Tcl_ConditionWait \ (tclStubsPtr->tcl_ConditionWait) /* 311 */ -#define Tcl_NumUtfChars \ - (tclStubsPtr->tcl_NumUtfChars) /* 312 */ +#define TclNumUtfChars \ + (tclStubsPtr->tclNumUtfChars) /* 312 */ #define Tcl_ReadChars \ (tclStubsPtr->tcl_ReadChars) /* 313 */ /* Slot 314 is reserved */ @@ -3070,8 +3078,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_UniCharToUpper) /* 323 */ #define Tcl_UniCharToUtf \ (tclStubsPtr->tcl_UniCharToUtf) /* 324 */ -#define Tcl_UtfAtIndex \ - (tclStubsPtr->tcl_UtfAtIndex) /* 325 */ +#define TclUtfAtIndex \ + (tclStubsPtr->tclUtfAtIndex) /* 325 */ #define TclUtfCharComplete \ (tclStubsPtr->tclUtfCharComplete) /* 326 */ #define Tcl_UtfBackslash \ @@ -3736,6 +3744,11 @@ extern const TclStubs *tclStubsPtr; /* Slot 667 is reserved */ #define Tcl_UniCharLen \ (tclStubsPtr->tcl_UniCharLen) /* 668 */ +#define Tcl_NumUtfChars \ + (tclStubsPtr->tcl_NumUtfChars) /* 669 */ +/* Slot 670 is reserved */ +#define Tcl_UtfAtIndex \ + (tclStubsPtr->tcl_UtfAtIndex) /* 671 */ #endif /* defined(USE_TCL_STUBS) */ @@ -3937,6 +3950,12 @@ extern const TclStubs *tclStubsPtr; # define Tcl_UtfToUniChar Tcl_UtfToChar16 # undef Tcl_UniCharLen # define Tcl_UniCharLen Tcl_Char16Len +#if !defined(BUILD_tcl) +# undef Tcl_NumUtfChars +# define Tcl_NumUtfChars TclNumUtfChars +# undef Tcl_UtfAtIndex +# define Tcl_UtfAtIndex TclUtfAtIndex +#endif #endif #if defined(USE_TCL_STUBS) # define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \ diff --git a/generic/tclInt.h b/generic/tclInt.h index 1eb486e..edd0172 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4666,12 +4666,12 @@ MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[]; * of counting along a string of all one-byte characters. The ANSI C * "prototype" for this macro is: * - * MODULE_SCOPE void TclNumUtfChars(int numChars, const char *bytes, + * MODULE_SCOPE void TclNumUtfCharsM(int numChars, const char *bytes, * size_t numBytes); *---------------------------------------------------------------- */ -#define TclNumUtfChars(numChars, bytes, numBytes) \ +#define TclNumUtfCharsM(numChars, bytes, numBytes) \ do { \ size_t _count, _i = (numBytes); \ unsigned char *_str = (unsigned char *) (bytes); \ diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index c8d9df7..2755cf6 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -440,7 +440,7 @@ Tcl_GetCharLength( */ if (numChars == TCL_INDEX_NONE) { - TclNumUtfChars(numChars, objPtr->bytes, objPtr->length); + TclNumUtfCharsM(numChars, objPtr->bytes, objPtr->length); stringPtr->numChars = numChars; } return numChars; @@ -543,7 +543,7 @@ Tcl_GetUniChar( */ if (stringPtr->numChars == TCL_INDEX_NONE) { - TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length); + TclNumUtfCharsM(stringPtr->numChars, objPtr->bytes, objPtr->length); } if (stringPtr->numChars == objPtr->length) { return (unsigned char) objPtr->bytes[index]; @@ -709,7 +709,7 @@ Tcl_GetRange( */ if (stringPtr->numChars == TCL_INDEX_NONE) { - TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length); + TclNumUtfCharsM(stringPtr->numChars, objPtr->bytes, objPtr->length); } if (stringPtr->numChars == objPtr->length) { if (last >= stringPtr->numChars) { @@ -4045,7 +4045,7 @@ ExtendUnicodeRepWithString( numOrigChars = stringPtr->numChars; } if (numAppendChars == TCL_INDEX_NONE) { - TclNumUtfChars(numAppendChars, bytes, numBytes); + TclNumUtfCharsM(numAppendChars, bytes, numBytes); } needed = numOrigChars + numAppendChars; diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index ea7083f..59036ec 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1005,7 +1005,7 @@ const TclStubs tclStubs = { Tcl_MutexUnlock, /* 309 */ Tcl_ConditionNotify, /* 310 */ Tcl_ConditionWait, /* 311 */ - Tcl_NumUtfChars, /* 312 */ + TclNumUtfChars, /* 312 */ Tcl_ReadChars, /* 313 */ 0, /* 314 */ 0, /* 315 */ @@ -1018,7 +1018,7 @@ const TclStubs tclStubs = { Tcl_UniCharToTitle, /* 322 */ Tcl_UniCharToUpper, /* 323 */ Tcl_UniCharToUtf, /* 324 */ - Tcl_UtfAtIndex, /* 325 */ + TclUtfAtIndex, /* 325 */ TclUtfCharComplete, /* 326 */ Tcl_UtfBackslash, /* 327 */ Tcl_UtfFindFirst, /* 328 */ @@ -1362,6 +1362,9 @@ const TclStubs tclStubs = { 0, /* 666 */ 0, /* 667 */ Tcl_UniCharLen, /* 668 */ + Tcl_NumUtfChars, /* 669 */ + 0, /* 670 */ + Tcl_UtfAtIndex, /* 671 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclUtf.c b/generic/tclUtf.c index e353b7f..09e464f 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -799,6 +799,7 @@ Tcl_UtfCharComplete( *--------------------------------------------------------------------------- */ +#undef Tcl_NumUtfChars size_t Tcl_NumUtfChars( const char *src, /* The UTF-8 string to measure. */ @@ -851,6 +852,58 @@ Tcl_NumUtfChars( return i; } +size_t +TclNumUtfChars( + const char *src, /* The UTF-8 string to measure. */ + size_t length) /* The length of the string in bytes, or + * TCL_INDEX_NONE for strlen(src). */ +{ + unsigned short ch = 0; + size_t i = 0; + + if (length == TCL_INDEX_NONE) { + /* string is NUL-terminated, so TclUtfToUniChar calls are safe. */ + while (*src != '\0') { + src += Tcl_UtfToChar16(src, &ch); + i++; + } + } else { + /* Will return value between 0 and length. No overflow checks. */ + + /* Pointer to the end of string. Never read endPtr[0] */ + const char *endPtr = src + length; + /* Pointer to last byte where optimization still can be used */ + const char *optPtr = endPtr - 4; + + /* + * Optimize away the call in this loop. Justified because... + * when (src <= optPtr), (endPtr - src) >= (endPtr - optPtr) + * By initialization above (endPtr - optPtr) = TCL_UTF_MAX + * So (endPtr - src) >= TCL_UTF_MAX, and passing that to + * Tcl_UtfCharComplete we know will cause return of 1. + */ + while (src <= optPtr + /* && Tcl_UtfCharComplete(src, endPtr - src) */ ) { + src += Tcl_UtfToChar16(src, &ch); + i++; + } + /* Loop over the remaining string where call must happen */ + while (src < endPtr) { + if (Tcl_UtfCharComplete(src, endPtr - src)) { + src += Tcl_UtfToChar16(src, &ch); + } else { + /* + * src points to incomplete UTF-8 sequence + * Treat first byte as character and count it + */ + src++; + } + i++; + } + } + return i; +} + /* *--------------------------------------------------------------------------- * @@ -1167,34 +1220,42 @@ Tcl_UniCharAtIndex( *--------------------------------------------------------------------------- */ +#undef Tcl_UtfAtIndex const char * Tcl_UtfAtIndex( const char *src, /* The UTF-8 string. */ size_t index) /* The position of the desired character. */ { - Tcl_UniChar ch = 0; -#if TCL_UTF_MAX < 4 - size_t len = 0; -#endif + int ch = 0; if (index != TCL_INDEX_NONE) { while (index--) { -#if TCL_UTF_MAX < 4 - src += (len = TclUtfToUniChar(src, &ch)); -#else - src += TclUtfToUniChar(src, &ch); -#endif + src += Tcl_UtfToUniChar(src, &ch); } -#if TCL_UTF_MAX < 4 - if ((ch >= 0xD800) && (len < 3)) { - /* Index points at character following high Surrogate */ - src += TclUtfToUniChar(src, &ch); - } -#endif } return src; } +const char * +TclUtfAtIndex( + const char *src, /* The UTF-8 string. */ + size_t index) /* The position of the desired character. */ +{ + unsigned short ch = 0; + size_t len = 0; + + if (index != TCL_INDEX_NONE) { + while (index--) { + src += (len = Tcl_UtfToChar16(src, &ch)); + } + if ((ch >= 0xD800) && (len < 3)) { + /* Index points at character following high Surrogate */ + src += Tcl_UtfToChar16(src, &ch); + } + } + return src; +} + /* *--------------------------------------------------------------------------- * -- cgit v0.12 From b1a8dc460f2e7f8a7ff436f52729f729ead3b92d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 30 Mar 2022 12:13:01 +0000 Subject: Fix limit-checking on first/last arguments for Tcl_GetRange(). Was not correctly forward-merged from core-8-branch (there it's correct) --- generic/tclStringObj.c | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 2755cf6..da3f8ee 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -674,9 +674,6 @@ Tcl_GetRange( if (first == TCL_INDEX_NONE) { first = TCL_INDEX_START; } - if (last + 2 <= first + 1) { - return Tcl_NewObj(); - } /* * Optimize the case where we're really dealing with a bytearray object @@ -689,7 +686,7 @@ Tcl_GetRange( if (last >= length) { last = length - 1; } - if (last < first) { + if (last + 1 < first + 1) { TclNewObj(newObjPtr); return newObjPtr; } @@ -715,7 +712,7 @@ Tcl_GetRange( if (last >= stringPtr->numChars) { last = stringPtr->numChars - 1; } - if (last < first) { + if (last + 1 < first + 1) { TclNewObj(newObjPtr); return newObjPtr; } @@ -736,7 +733,7 @@ Tcl_GetRange( if (last >= stringPtr->numChars) { last = stringPtr->numChars - 1; } - if (last < first) { + if (last + 1 < first + 1) { TclNewObj(newObjPtr); return newObjPtr; } -- cgit v0.12 From d0fec7532c33f0b3da8057e2e0fda10524f22905 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 1 Apr 2022 10:29:45 +0000 Subject: Add UTF-16 versions of Tcl_GetCharLength/Tcl_GetRange/Tcl_GetUniChar to the stub table. Should have been part of TIP #542. Needed for Tk's "glyph_indexing_2" branch --- generic/tcl.decls | 15 ++++-- generic/tclDecls.h | 49 ++++++++++++++------ generic/tclStringObj.c | 121 ++++++++++++++++++++++++++++++++++++++++++++++++- generic/tclStubInit.c | 10 ++-- generic/tclUtf.c | 3 +- 5 files changed, 172 insertions(+), 26 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index b943edd..d4f1c59 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -1396,17 +1396,17 @@ declare 379 { size_t numChars) } declare 380 { - size_t Tcl_GetCharLength(Tcl_Obj *objPtr) + size_t TclGetCharLength(Tcl_Obj *objPtr) } declare 381 { - int Tcl_GetUniChar(Tcl_Obj *objPtr, size_t index) + int TclGetUniChar(Tcl_Obj *objPtr, size_t index) } # Removed in 9.0, replaced by macro. #declare 382 { # Tcl_UniChar *Tcl_GetUnicode(Tcl_Obj *objPtr) #} declare 383 { - Tcl_Obj *Tcl_GetRange(Tcl_Obj *objPtr, size_t first, size_t last) + Tcl_Obj *TclGetRange(Tcl_Obj *objPtr, size_t first, size_t last) } # Removed in 9.0 #declare 384 { @@ -2519,9 +2519,18 @@ declare 668 { declare 669 { size_t Tcl_NumUtfChars(const char *src, size_t length) } +declare 670 { + size_t Tcl_GetCharLength(Tcl_Obj *objPtr) +} declare 671 { const char *Tcl_UtfAtIndex(const char *src, size_t index) } +declare 672 { + Tcl_Obj *Tcl_GetRange(Tcl_Obj *objPtr, size_t first, size_t last) +} +declare 673 { + int Tcl_GetUniChar(Tcl_Obj *objPtr, size_t index) +} # ----- BASELINE -- FOR -- 8.7.0 ----- # diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 3e2b8cb..1345c6c 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -996,12 +996,12 @@ EXTERN Tcl_Obj * Tcl_NewUnicodeObj(const Tcl_UniChar *unicode, EXTERN void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, size_t numChars); /* 380 */ -EXTERN size_t Tcl_GetCharLength(Tcl_Obj *objPtr); +EXTERN size_t TclGetCharLength(Tcl_Obj *objPtr); /* 381 */ -EXTERN int Tcl_GetUniChar(Tcl_Obj *objPtr, size_t index); +EXTERN int TclGetUniChar(Tcl_Obj *objPtr, size_t index); /* Slot 382 is reserved */ /* 383 */ -EXTERN Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, size_t first, +EXTERN Tcl_Obj * TclGetRange(Tcl_Obj *objPtr, size_t first, size_t last); /* Slot 384 is reserved */ /* 385 */ @@ -1776,9 +1776,15 @@ EXTERN int Tcl_AsyncMarkFromSignal(Tcl_AsyncHandler async, EXTERN size_t Tcl_UniCharLen(const int *uniStr); /* 669 */ EXTERN size_t Tcl_NumUtfChars(const char *src, size_t length); -/* Slot 670 is reserved */ +/* 670 */ +EXTERN size_t Tcl_GetCharLength(Tcl_Obj *objPtr); /* 671 */ EXTERN const char * Tcl_UtfAtIndex(const char *src, size_t index); +/* 672 */ +EXTERN Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, size_t first, + size_t last); +/* 673 */ +EXTERN int Tcl_GetUniChar(Tcl_Obj *objPtr, size_t index); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2170,10 +2176,10 @@ typedef struct TclStubs { void (*tcl_RegExpGetInfo) (Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr); /* 377 */ Tcl_Obj * (*tcl_NewUnicodeObj) (const Tcl_UniChar *unicode, size_t numChars); /* 378 */ void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, size_t numChars); /* 379 */ - size_t (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 380 */ - int (*tcl_GetUniChar) (Tcl_Obj *objPtr, size_t index); /* 381 */ + size_t (*tclGetCharLength) (Tcl_Obj *objPtr); /* 380 */ + int (*tclGetUniChar) (Tcl_Obj *objPtr, size_t index); /* 381 */ void (*reserved382)(void); - Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, size_t first, size_t last); /* 383 */ + Tcl_Obj * (*tclGetRange) (Tcl_Obj *objPtr, size_t first, size_t last); /* 383 */ void (*reserved384)(void); int (*tcl_RegExpMatchObj) (Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); /* 385 */ void (*tcl_SetNotifier) (const Tcl_NotifierProcs *notifierProcPtr); /* 386 */ @@ -2460,8 +2466,10 @@ typedef struct TclStubs { void (*reserved667)(void); size_t (*tcl_UniCharLen) (const int *uniStr); /* 668 */ size_t (*tcl_NumUtfChars) (const char *src, size_t length); /* 669 */ - void (*reserved670)(void); + size_t (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 670 */ const char * (*tcl_UtfAtIndex) (const char *src, size_t index); /* 671 */ + Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, size_t first, size_t last); /* 672 */ + int (*tcl_GetUniChar) (Tcl_Obj *objPtr, size_t index); /* 673 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3184,13 +3192,13 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_NewUnicodeObj) /* 378 */ #define Tcl_SetUnicodeObj \ (tclStubsPtr->tcl_SetUnicodeObj) /* 379 */ -#define Tcl_GetCharLength \ - (tclStubsPtr->tcl_GetCharLength) /* 380 */ -#define Tcl_GetUniChar \ - (tclStubsPtr->tcl_GetUniChar) /* 381 */ +#define TclGetCharLength \ + (tclStubsPtr->tclGetCharLength) /* 380 */ +#define TclGetUniChar \ + (tclStubsPtr->tclGetUniChar) /* 381 */ /* Slot 382 is reserved */ -#define Tcl_GetRange \ - (tclStubsPtr->tcl_GetRange) /* 383 */ +#define TclGetRange \ + (tclStubsPtr->tclGetRange) /* 383 */ /* Slot 384 is reserved */ #define Tcl_RegExpMatchObj \ (tclStubsPtr->tcl_RegExpMatchObj) /* 385 */ @@ -3746,9 +3754,14 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_UniCharLen) /* 668 */ #define Tcl_NumUtfChars \ (tclStubsPtr->tcl_NumUtfChars) /* 669 */ -/* Slot 670 is reserved */ +#define Tcl_GetCharLength \ + (tclStubsPtr->tcl_GetCharLength) /* 670 */ #define Tcl_UtfAtIndex \ (tclStubsPtr->tcl_UtfAtIndex) /* 671 */ +#define Tcl_GetRange \ + (tclStubsPtr->tcl_GetRange) /* 672 */ +#define Tcl_GetUniChar \ + (tclStubsPtr->tcl_GetUniChar) /* 673 */ #endif /* defined(USE_TCL_STUBS) */ @@ -3953,8 +3966,14 @@ extern const TclStubs *tclStubsPtr; #if !defined(BUILD_tcl) # undef Tcl_NumUtfChars # define Tcl_NumUtfChars TclNumUtfChars +# undef Tcl_GetCharLength +# define Tcl_GetCharLength TclGetCharLength # undef Tcl_UtfAtIndex # define Tcl_UtfAtIndex TclUtfAtIndex +# undef Tcl_GetRange +# define Tcl_GetRange TclGetRange +# undef Tcl_GetUniChar +# define Tcl_GetUniChar TclGetUniChar #endif #endif #if defined(USE_TCL_STUBS) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index da3f8ee..107640b 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -446,6 +446,44 @@ Tcl_GetCharLength( return numChars; } +size_t +TclGetCharLength( + Tcl_Obj *objPtr) /* The String object to get the num chars + * of. */ +{ + size_t numChars = 0; + + /* + * Quick, no-shimmer return for short string reps. + */ + + if ((objPtr->bytes) && (objPtr->length < 2)) { + /* 0 bytes -> 0 chars; 1 byte -> 1 char */ + return objPtr->length; + } + + /* + * Optimize the case where we're really dealing with a bytearray object; + * we don't need to convert to a string to perform the get-length operation. + * + * Starting in Tcl 8.7, we check for a "pure" bytearray, because the + * machinery behind that test is using a proper bytearray ObjType. We + * could also compute length of an improper bytearray without shimmering + * but there's no value in that. We *want* to shimmer an improper bytearray + * because improper bytearrays have worthless internal reps. + */ + + if (TclIsPureByteArray(objPtr)) { + (void) Tcl_GetByteArrayFromObj(objPtr, &numChars); + } else { + Tcl_GetString(objPtr); + numChars = TclNumUtfChars(objPtr->bytes, objPtr->length); + } + + return numChars; +} + + /* *---------------------------------------------------------------------- * @@ -574,6 +612,40 @@ Tcl_GetUniChar( #endif return ch; } + +int +TclGetUniChar( + Tcl_Obj *objPtr, /* The object to get the Unicode charater + * from. */ + size_t index) /* Get the index'th Unicode character. */ +{ + int ch = 0; + + /* + * Optimize the case where we're really dealing with a bytearray object + * we don't need to convert to a string to perform the indexing operation. + */ + + if (TclIsPureByteArray(objPtr)) { + size_t length = 0; + unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length); + if (index >= length) { + return -1; + } + + return bytes[index]; + } + + size_t numChars = TclNumUtfChars(objPtr->bytes, objPtr->length); + + if (index >= numChars) { + return -1; + } + const char *begin = TclUtfAtIndex(objPtr->bytes, index); +#undef Tcl_UtfToUniChar + Tcl_UtfToUniChar(begin, &ch); + return ch; +} /* *---------------------------------------------------------------------- @@ -751,6 +823,51 @@ Tcl_GetRange( #endif return Tcl_NewUnicodeObj(stringPtr->unicode + first, last - first + 1); } + +Tcl_Obj * +TclGetRange( + Tcl_Obj *objPtr, /* The Tcl object to find the range of. */ + size_t first, /* First index of the range. */ + size_t last) /* Last index of the range. */ +{ + Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */ + size_t length = 0; + + if (first == TCL_INDEX_NONE) { + first = TCL_INDEX_START; + } + + /* + * Optimize the case where we're really dealing with a bytearray object + * we don't need to convert to a string to perform the substring operation. + */ + + if (TclIsPureByteArray(objPtr)) { + unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length); + + if (last >= length) { + last = length - 1; + } + if (last + 1 < first + 1) { + TclNewObj(newObjPtr); + return newObjPtr; + } + return Tcl_NewByteArrayObj(bytes + first, last - first + 1); + } + + size_t numChars = TclNumUtfChars(objPtr->bytes, objPtr->length); + + if (last >= numChars) { + last = numChars - 1; + } + if (last + 1 < first + 1) { + TclNewObj(newObjPtr); + return newObjPtr; + } + const char *begin = TclUtfAtIndex(objPtr->bytes, first); + const char *end = TclUtfAtIndex(objPtr->bytes, last + 1); + return Tcl_NewStringObj(begin, end - begin); +} /* *---------------------------------------------------------------------- @@ -1206,7 +1323,7 @@ Tcl_AppendToObj( /* *---------------------------------------------------------------------- * - * TclAppendUnicodeToObj -- + * Tcl_AppendUnicodeToObj -- * * This function appends a Unicode string to an object in the most * efficient manner possible. Length must be >= 0. @@ -1230,7 +1347,7 @@ TclAppendUnicodeToObj( String *stringPtr; if (Tcl_IsShared(objPtr)) { - Tcl_Panic("%s called with shared object", "TclAppendUnicodeToObj"); + Tcl_Panic("%s called with shared object", "Tcl_AppendUnicodeToObj"); } if (length == 0) { diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 59036ec..704c51a 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1073,10 +1073,10 @@ const TclStubs tclStubs = { Tcl_RegExpGetInfo, /* 377 */ Tcl_NewUnicodeObj, /* 378 */ Tcl_SetUnicodeObj, /* 379 */ - Tcl_GetCharLength, /* 380 */ - Tcl_GetUniChar, /* 381 */ + TclGetCharLength, /* 380 */ + TclGetUniChar, /* 381 */ 0, /* 382 */ - Tcl_GetRange, /* 383 */ + TclGetRange, /* 383 */ 0, /* 384 */ Tcl_RegExpMatchObj, /* 385 */ Tcl_SetNotifier, /* 386 */ @@ -1363,8 +1363,10 @@ const TclStubs tclStubs = { 0, /* 667 */ Tcl_UniCharLen, /* 668 */ Tcl_NumUtfChars, /* 669 */ - 0, /* 670 */ + Tcl_GetCharLength, /* 670 */ Tcl_UtfAtIndex, /* 671 */ + Tcl_GetRange, /* 672 */ + Tcl_GetUniChar, /* 673 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 09e464f..6f43dc4 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -799,7 +799,6 @@ Tcl_UtfCharComplete( *--------------------------------------------------------------------------- */ -#undef Tcl_NumUtfChars size_t Tcl_NumUtfChars( const char *src, /* The UTF-8 string to measure. */ @@ -1220,7 +1219,6 @@ Tcl_UniCharAtIndex( *--------------------------------------------------------------------------- */ -#undef Tcl_UtfAtIndex const char * Tcl_UtfAtIndex( const char *src, /* The UTF-8 string. */ @@ -1230,6 +1228,7 @@ Tcl_UtfAtIndex( if (index != TCL_INDEX_NONE) { while (index--) { + /* Make use of the #undef Tcl_UtfToUniChar above, which already handles UCS4. */ src += Tcl_UtfToUniChar(src, &ch); } } -- cgit v0.12 From 18ce686ba411d43ed7e95ce8d497e04c38d1414e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 4 Apr 2022 14:09:51 +0000 Subject: In tclCkalloc.c, count malloc/free's using size_t in stead of unsigned int. --- generic/tclCkalloc.c | 38 +++++++++++++++++++------------------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index 6a6ed31..9ecce13 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -71,7 +71,7 @@ struct mem_header { static struct mem_header *allocHead = NULL; /* List of allocated structures */ -#define GUARD_VALUE 0141 +#define GUARD_VALUE 0x61 /* * The following macro determines the amount of guard space *above* each chunk @@ -89,14 +89,14 @@ static struct mem_header *allocHead = NULL; /* List of allocated structures */ #define BODY_OFFSET \ ((size_t) (&((struct mem_header *) 0)->body)) -static unsigned int total_mallocs = 0; -static unsigned int total_frees = 0; +static size_t total_mallocs = 0; +static size_t total_frees = 0; static size_t current_bytes_malloced = 0; static size_t maximum_bytes_malloced = 0; static size_t current_malloc_packets = 0; static size_t maximum_malloc_packets = 0; -static unsigned int break_on_malloc = 0; -static unsigned int trace_on_at_malloc = 0; +static size_t break_on_malloc = 0; +static size_t trace_on_at_malloc = 0; static int alloc_tracing = FALSE; static int init_malloced_bodies = TRUE; #ifdef MEM_VALIDATE @@ -186,8 +186,8 @@ TclDumpMemoryInfo( return 0; } sprintf(buf, - "total mallocs %10u\n" - "total frees %10u\n" + "total mallocs %10" TCL_Z_MODIFIER "u\n" + "total frees %10" TCL_Z_MODIFIER "u\n" "current packets allocated %10" TCL_Z_MODIFIER "u\n" "current bytes allocated %10" TCL_Z_MODIFIER "u\n" "maximum packets allocated %10" TCL_Z_MODIFIER "u\n" @@ -406,7 +406,7 @@ Tcl_DbCkalloc( } /* Don't let size argument to TclpAlloc overflow */ - if (size <= UINT_MAX - offsetof(struct mem_header, body) - 1U - HIGH_GUARD_SIZE) { + if (size <= (size_t)-2 - offsetof(struct mem_header, body) - HIGH_GUARD_SIZE) { result = (struct mem_header *) TclpAlloc(size + offsetof(struct mem_header, body) + 1U + HIGH_GUARD_SIZE); } @@ -451,7 +451,7 @@ Tcl_DbCkalloc( total_mallocs++; if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) { (void) fflush(stdout); - fprintf(stderr, "reached malloc trace enable point (%u)\n", + fprintf(stderr, "reached malloc trace enable point (%" TCL_Z_MODIFIER "u)\n", total_mallocs); fflush(stderr); alloc_tracing = TRUE; @@ -466,7 +466,7 @@ Tcl_DbCkalloc( if (break_on_malloc && (total_mallocs >= break_on_malloc)) { break_on_malloc = 0; (void) fflush(stdout); - Tcl_Panic("reached malloc break limit (%u)", total_mallocs); + Tcl_Panic("reached malloc break limit (%" TCL_Z_MODIFIER "u)", total_mallocs); } current_malloc_packets++; @@ -496,7 +496,7 @@ Tcl_AttemptDbCkalloc( } /* Don't let size argument to TclpAlloc overflow */ - if (size <= UINT_MAX - offsetof(struct mem_header, body) - 1U - HIGH_GUARD_SIZE) { + if (size <= (size_t)-2 - offsetof(struct mem_header, body) - HIGH_GUARD_SIZE) { result = (struct mem_header *) TclpAlloc(size + offsetof(struct mem_header, body) + 1U + HIGH_GUARD_SIZE); } @@ -540,7 +540,7 @@ Tcl_AttemptDbCkalloc( total_mallocs++; if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) { (void) fflush(stdout); - fprintf(stderr, "reached malloc trace enable point (%d)\n", + fprintf(stderr, "reached malloc trace enable point (%" TCL_Z_MODIFIER "u)\n", total_mallocs); fflush(stderr); alloc_tracing = TRUE; @@ -555,7 +555,7 @@ Tcl_AttemptDbCkalloc( if (break_on_malloc && (total_mallocs >= break_on_malloc)) { break_on_malloc = 0; (void) fflush(stdout); - Tcl_Panic("reached malloc break limit (%d)", total_mallocs); + Tcl_Panic("reached malloc break limit (%" TCL_Z_MODIFIER "u)", total_mallocs); } current_malloc_packets++; @@ -845,19 +845,19 @@ MemoryCmd( return TCL_OK; } if (strcmp(TclGetString(objv[1]),"break_on_malloc") == 0) { - int value; + Tcl_WideInt value; if (objc != 3) { goto argError; } - if (Tcl_GetIntFromObj(interp, objv[2], &value) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[2], &value) != TCL_OK) { return TCL_ERROR; } - break_on_malloc = (unsigned int) value; + break_on_malloc = value; return TCL_OK; } if (strcmp(TclGetString(objv[1]),"info") == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%-25s %10u\n%-25s %10u\n%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n", + "%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n", "total mallocs", total_mallocs, "total frees", total_frees, "current packets allocated", current_malloc_packets, "current bytes allocated", current_bytes_malloced, @@ -930,11 +930,11 @@ MemoryCmd( } if (strcmp(TclGetString(objv[1]),"trace_on_at_malloc") == 0) { - int value; + Tcl_WideInt value; if (objc != 3) { goto argError; } - if (Tcl_GetIntFromObj(interp, objv[2], &value) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[2], &value) != TCL_OK) { return TCL_ERROR; } trace_on_at_malloc = value; -- cgit v0.12 From 27aba5645ca809827fd1a655677fc1080f8dcb03 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 11 Apr 2022 15:13:12 +0000 Subject: CC_NONE -> CC_NULL. Otherwise, there's a conflict with Windows headers --- generic/regc_locale.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/generic/regc_locale.c b/generic/regc_locale.c index 4b1a1e8..d22fd50 100644 --- a/generic/regc_locale.c +++ b/generic/regc_locale.c @@ -1013,7 +1013,7 @@ cclass( }; enum classes { - CC_NONE = -1, + CC_NULL = -1, CC_ALNUM, CC_ALPHA, CC_ASCII, CC_BLANK, CC_CNTRL, CC_DIGIT, CC_GRAPH, CC_LOWER, CC_PRINT, CC_PUNCT, CC_SPACE, CC_UPPER, CC_XDIGIT } index; @@ -1031,7 +1031,7 @@ cclass( * Map the name to the corresponding enumerated value. */ - index = CC_NONE; + index = CC_NULL; for (namePtr=classNames,i=0 ; *namePtr!=NULL ; namePtr++,i++) { if ((strlen(*namePtr) == len) && (strncmp(*namePtr, np, len) == 0)) { index = (enum classes)i; @@ -1053,7 +1053,7 @@ cclass( */ switch(index) { - case CC_NONE: + case CC_NULL: ERR(REG_ECTYPE); return NULL; case CC_ALNUM: -- cgit v0.12 From 612617685a38e7bd7f80dce2f0f2e7b69b4db48e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 12 Apr 2022 10:54:37 +0000 Subject: Fix breakage in tclInterp.c --- generic/tclInterp.c | 23 ++++++++++------------- 1 file changed, 10 insertions(+), 13 deletions(-) diff --git a/generic/tclInterp.c b/generic/tclInterp.c index ccb0aae..cfa6b7c 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -617,7 +617,6 @@ NRInterpCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Interp *childInterp; - int index; static const char *const options[] = { "alias", "aliases", "bgerror", "cancel", "children", "create", "debug", "delete", @@ -649,20 +648,20 @@ NRInterpCmd( OPT_SLAVES, #endif OPT_TARGET, OPT_TRANSFER - } index1; + } index; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(NULL, objv[1], options, - "option", 0, &index1) != TCL_OK) { + "option", 0, &index) != TCL_OK) { /* Don't report the "slaves" option as possibility */ Tcl_GetIndexFromObj(interp, objv[1], optionsNoSlaves, - "option", 0, &index1); + "option", 0, &index); return TCL_ERROR; } - switch (index1) { + switch (index) { case OPT_ALIAS: { Tcl_Interp *parentInterp; @@ -717,12 +716,11 @@ NRInterpCmd( }; enum optionCancelEnum { OPT_UNWIND, OPT_LAST - }; + } idx; flags = 0; for (i = 2; i < objc; i++) { - enum optionCancelEnum idx; if (TclGetString(objv[i])[0] != '-') { break; } @@ -950,7 +948,7 @@ NRInterpCmd( }; enum hiddenOption { OPT_GLOBAL, OPT_NAMESPACE, OPT_LAST - }; + } idx; namespaceName = NULL; for (i = 3; i < objc; i++) { @@ -958,12 +956,12 @@ NRInterpCmd( break; } if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions, "option", - 0, &index) != TCL_OK) { + 0, &idx) != TCL_OK) { return TCL_ERROR; } - if (index == OPT_GLOBAL) { + if (idx == OPT_GLOBAL) { namespaceName = "::"; - } else if (index == OPT_NAMESPACE) { + } else if (idx == OPT_NAMESPACE) { if (++i == objc) { /* There must be more arguments. */ break; } else { @@ -4677,9 +4675,8 @@ ChildTimeLimitCmd( }; enum Options { OPT_CMD, OPT_GRAN, OPT_MILLI, OPT_SEC - }; + } index; Interp *iPtr = (Interp *) interp; - int index; ScriptLimitCallbackKey key; ScriptLimitCallback *limitCBPtr; Tcl_HashEntry *hPtr; -- cgit v0.12 From 514ebbd809f0096609a5971c1861a99460e77e73 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 12 Apr 2022 13:53:03 +0000 Subject: Code formatting --- generic/regc_locale.c | 2 +- generic/tclAssembly.c | 2 +- generic/tclCompExpr.c | 2 +- generic/tclExecute.c | 2 +- generic/tclStrToD.c | 2 +- generic/tclTestObj.c | 2 +- unix/tclLoadDyld.c | 2 +- 7 files changed, 7 insertions(+), 7 deletions(-) diff --git a/generic/regc_locale.c b/generic/regc_locale.c index d22fd50..c90014f 100644 --- a/generic/regc_locale.c +++ b/generic/regc_locale.c @@ -1052,7 +1052,7 @@ cclass( * Now compute the character class contents. */ - switch(index) { + switch (index) { case CC_NULL: ERR(REG_ECTYPE); return NULL; diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 975906c..1ffcf07 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -1819,7 +1819,7 @@ CompileEmbeddedScript( envPtr->maxStackDepth = 0; StartBasicBlock(assemEnvPtr, BB_FALLTHRU, NULL); - switch(instPtr->tclInstCode) { + switch (instPtr->tclInstCode) { case INST_EVAL_STK: TclCompileScript(interp, tokenPtr->start, tokenPtr->size, envPtr); break; diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index d58dd24..87d9a71 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -1730,7 +1730,7 @@ ConvertTreeToTokens( scanned = ParseLexeme(start, numBytes, &lexeme, NULL); - switch(nodePtr->lexeme) { + switch (nodePtr->lexeme) { case OPEN_PAREN: case COMMA: case COLON: diff --git a/generic/tclExecute.c b/generic/tclExecute.c index d3b9dac..42e8008 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -7135,7 +7135,7 @@ TEBCresume( { /* Read the wall clock */ Tcl_WideInt wval; Tcl_Time now; - switch(TclGetUInt1AtPtr(pc+1)) { + switch (TclGetUInt1AtPtr(pc+1)) { case 0: /* clicks */ #ifdef TCL_WIDE_CLICKS wval = TclpGetWideClicks(); diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index a29ad07..15aeaf4 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -3827,7 +3827,7 @@ ShouldBankerRoundUpToNext( } r = mp_cmp_mag(&temp, S); mp_clear(&temp); - switch(r) { + switch (r) { case MP_EQ: return isodd; case MP_GT: diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index cb3fc79..c4f9e1f 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -878,7 +878,7 @@ TestlistobjCmd( 0, &cmdIndex) != TCL_OK) { return TCL_ERROR; } - switch(cmdIndex) { + switch (cmdIndex) { case LISTOBJ_SET: if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { Tcl_SetListObj(varPtr[varIndex], objc-3, objv+3); diff --git a/unix/tclLoadDyld.c b/unix/tclLoadDyld.c index 24240af..c2339db 100644 --- a/unix/tclLoadDyld.c +++ b/unix/tclLoadDyld.c @@ -106,7 +106,7 @@ static const char * DyldOFIErrorMsg( int err) { - switch(err) { + switch (err) { case NSObjectFileImageSuccess: return NULL; case NSObjectFileImageFailure: -- cgit v0.12 From 05b9aa05c1439506d60f983b5dc4e37ed339f02b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 26 Apr 2022 12:11:49 +0000 Subject: Missing macro's for Tcl_GetBytesFromObj() (TIP #568), only can handle size_t * this way --- generic/tclDecls.h | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 559d67c..c5f89b5 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -3908,9 +3908,12 @@ extern const TclStubs *tclStubsPtr; #undef Tcl_GetStringFromObj #undef Tcl_GetUnicodeFromObj #undef Tcl_GetByteArrayFromObj +#undef Tcl_GetBytesFromObj #if defined(USE_TCL_STUBS) #define Tcl_GetStringFromObj(objPtr, sizePtr) \ (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tclGetStringFromObj(objPtr, (int *)(sizePtr)) : tclStubsPtr->tcl_GetStringFromObj(objPtr, (size_t *)(sizePtr))) +#define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \ + (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tclGetBytesFromObj(interp, objPtr, (int *)(sizePtr)) : tclStubsPtr->tcl_GetBytesFromObj(interp, objPtr, (size_t *)(sizePtr))) #define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tclGetBytesFromObj(NULL, objPtr, (int *)(sizePtr)) : tclStubsPtr->tcl_GetBytesFromObj(NULL, objPtr, (size_t *)(sizePtr))) #define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \ @@ -3920,8 +3923,10 @@ extern const TclStubs *tclStubsPtr; #else #define Tcl_GetStringFromObj(objPtr, sizePtr) \ (sizeof(*(sizePtr)) <= sizeof(int) ? (TclGetStringFromObj)(objPtr, (int *)(sizePtr)) : (Tcl_GetStringFromObj)(objPtr, (size_t *)(sizePtr))) +#define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \ + (sizeof(*(sizePtr)) <= sizeof(int) ? (TclGetBytesFromObj)(interp, objPtr, (int *)(sizePtr)) : (Tcl_GetBytesFromObj)(interp, objPtr, (size_t *)(sizePtr))) #define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ - (sizeof(*(sizePtr)) <= sizeof(int) ? (TclGetBytesFromObj)(NULL, objPtr, (int *)(sizePtr)) : Tcl_GetBytesFromObj(NULL, objPtr, (size_t *)(sizePtr))) + (sizeof(*(sizePtr)) <= sizeof(int) ? (TclGetBytesFromObj)(NULL, objPtr, (int *)(sizePtr)) : (Tcl_GetBytesFromObj)(NULL, objPtr, (size_t *)(sizePtr))) #define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \ (sizeof(*(sizePtr)) <= sizeof(int) ? (TclGetUnicodeFromObj)(objPtr, (int *)(sizePtr)) : Tcl_GetUnicodeFromObj(objPtr, (size_t *)(sizePtr))) #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ -- cgit v0.12 From 257691ef7309a95aa418da8017492f3c4c223fd6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 26 Apr 2022 12:22:51 +0000 Subject: Tcl_GetIndexFromObjStruct -> Tcl_GetIndexFromObj. Don't use braces around (Tcl_GetBytesFromObj) --- generic/tclExecute.c | 2 +- generic/tclIO.c | 4 ++-- generic/tclStringObj.c | 6 +++--- generic/tclTimer.c | 4 ++-- generic/tclZipfs.c | 9 ++++----- generic/tclZlib.c | 18 +++++++++--------- 6 files changed, 21 insertions(+), 22 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 42e8008..23c3ef5 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5113,7 +5113,7 @@ TEBCresume( TclNewObj(objResultPtr); } else if (TclIsPureByteArray(valuePtr)) { objResultPtr = Tcl_NewByteArrayObj( - (Tcl_GetBytesFromObj)(NULL, valuePtr, NULL)+index, 1); + Tcl_GetBytesFromObj(NULL, valuePtr, (size_t *)NULL)+index, 1); } else if (valuePtr->bytes && slength == valuePtr->length) { objResultPtr = Tcl_NewStringObj((const char *) valuePtr->bytes+index, 1); diff --git a/generic/tclIO.c b/generic/tclIO.c index 57e1a66..4cf6a7e 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -4573,7 +4573,7 @@ Tcl_GetsObj( if ((statePtr->encoding == NULL) && ((statePtr->inputTranslation == TCL_TRANSLATE_LF) || (statePtr->inputTranslation == TCL_TRANSLATE_CR)) - && (Tcl_GetBytesFromObj)(NULL, objPtr, NULL) != NULL) { + && Tcl_GetBytesFromObj(NULL, objPtr, (size_t *)NULL) != NULL) { return TclGetsObjBinary(chan, objPtr); } @@ -5843,7 +5843,7 @@ DoReadChars( && (statePtr->inEofChar == '\0'); if (appendFlag) { - if (binaryMode && (NULL == Tcl_GetBytesFromObj(NULL, objPtr, NULL))) { + if (binaryMode && (NULL == Tcl_GetBytesFromObj(NULL, objPtr, (size_t *)NULL))) { binaryMode = 0; } } else { diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 107640b..c5e018f 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -1460,7 +1460,7 @@ Tcl_AppendObjToObj( */ TclAppendBytesToByteArray(objPtr, - (Tcl_GetBytesFromObj)(NULL, appendObjPtr, NULL), lengthSrc); + Tcl_GetBytesFromObj(NULL, appendObjPtr, (size_t *)NULL), lengthSrc); return; } @@ -2975,7 +2975,7 @@ TclStringRepeat( done *= 2; } TclAppendBytesToByteArray(objResultPtr, - (Tcl_GetBytesFromObj)(NULL, objResultPtr, NULL), + Tcl_GetBytesFromObj(NULL, objResultPtr, (size_t *)NULL), (count - done) * length); } else if (unichar) { /* @@ -3852,7 +3852,7 @@ TclStringReverse( if (!inPlace || Tcl_IsShared(objPtr)) { objPtr = Tcl_NewByteArrayObj(NULL, numBytes); } - ReverseBytes((Tcl_GetBytesFromObj)(NULL, objPtr, NULL), from, numBytes); + ReverseBytes(Tcl_GetBytesFromObj(NULL, objPtr, (size_t *)NULL), from, numBytes); return objPtr; } diff --git a/generic/tclTimer.c b/generic/tclTimer.c index 90301aa..0e6324c 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -818,8 +818,8 @@ Tcl_AfterObjCmd( */ if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) { - if (Tcl_GetIndexFromObjStruct(NULL, objv[1], afterSubCmds, - sizeof(char *), "", 0, &index) != TCL_OK) { + if (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0, &index) + != TCL_OK) { const char *arg = TclGetString(objv[1]); Tcl_SetObjResult(interp, Tcl_ObjPrintf( diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index 269d8bc..85b57a5 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -2409,7 +2409,7 @@ ZipFSMkKeyObjCmd( } passObj = Tcl_NewByteArrayObj(NULL, 264); - passBuf = Tcl_GetBytesFromObj(NULL, passObj, NULL); + passBuf = Tcl_GetBytesFromObj(NULL, passObj, (size_t *)NULL); while (len > 0) { int ch = pw[len - 1]; @@ -3776,8 +3776,8 @@ ZipFSListObjCmd( if (objc == 3) { int idx; - if (Tcl_GetIndexFromObjStruct(interp, objv[1], options, - sizeof(char *), "option", 0, &idx) != TCL_OK) { + if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", + 0, &idx) != TCL_OK) { return TCL_ERROR; } switch (idx) { @@ -4998,8 +4998,7 @@ ZipFSMatchInDirectoryProc( Tcl_HashEntry *hPtr; Tcl_HashSearch search; Tcl_Obj *normPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); - int scnt, l, dirOnly = -1, prefixLen, strip = 0, mounts = 0; - int len; + int scnt, l, dirOnly = -1, prefixLen, strip = 0, mounts = 0, len; char *pat, *prefix, *path; Tcl_DString dsPref, *prefixBuf = NULL; diff --git a/generic/tclZlib.c b/generic/tclZlib.c index fa87a10..8a95fd5 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -496,8 +496,8 @@ GenerateHeader( if (GetValue(interp, dictObj, "type", &value) != TCL_OK) { goto error; - } else if (value != NULL && Tcl_GetIndexFromObjStruct(interp, value, types, - sizeof(char *), "type", TCL_EXACT, &headerPtr->header.text) != TCL_OK) { + } else if (value != NULL && Tcl_GetIndexFromObj(interp, value, types, + "type", TCL_EXACT, &headerPtr->header.text) != TCL_OK) { goto error; } @@ -1155,7 +1155,7 @@ Tcl_ZlibStreamSetCompressionDictionary( ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle; if (compressionDictionaryObj && (NULL == Tcl_GetBytesFromObj(NULL, - compressionDictionaryObj, NULL))) { + compressionDictionaryObj, (size_t *)NULL))) { /* Missing or invalid compression dictionary */ compressionDictionaryObj = NULL; } @@ -1972,8 +1972,8 @@ ZlibCmd( Tcl_WrongNumArgs(interp, 1, objv, "command arg ?...?"); return TCL_ERROR; } - if (Tcl_GetIndexFromObjStruct(interp, objv[1], commands, - sizeof(char *), "command", 0, &command) != TCL_OK) { + if (Tcl_GetIndexFromObj(interp, objv[1], commands, "command", 0, + &command) != TCL_OK) { return TCL_ERROR; } @@ -2351,7 +2351,7 @@ ZlibStreamSubcmd( } if (compDictObj) { - if (NULL == (Tcl_GetBytesFromObj)(interp, compDictObj, NULL)) { + if (NULL == Tcl_GetBytesFromObj(interp, compDictObj, (size_t *)NULL)) { return TCL_ERROR; } } @@ -2533,7 +2533,7 @@ ZlibPushSubcmd( } } - if (compDictObj && (NULL == (Tcl_GetBytesFromObj)(interp, compDictObj, NULL))) { + if (compDictObj && (NULL == Tcl_GetBytesFromObj(interp, compDictObj, (size_t *)NULL))) { return TCL_ERROR; } @@ -3330,7 +3330,7 @@ ZlibTransformSetOption( /* not used */ TclNewStringObj(compDictObj, value, strlen(value)); Tcl_IncrRefCount(compDictObj); - if (NULL == (Tcl_GetBytesFromObj)(interp, compDictObj, NULL)) { + if (NULL == Tcl_GetBytesFromObj(interp, compDictObj, (size_t *)NULL)) { Tcl_DecrRefCount(compDictObj); return TCL_ERROR; } @@ -3721,7 +3721,7 @@ ZlibStackChannelTransform( if (compDictObj != NULL) { cd->compDictObj = Tcl_DuplicateObj(compDictObj); Tcl_IncrRefCount(cd->compDictObj); - (Tcl_GetBytesFromObj)(NULL, cd->compDictObj, NULL); + Tcl_GetBytesFromObj(NULL, cd->compDictObj, (size_t *)NULL); } if (format == TCL_ZLIB_FORMAT_RAW) { -- cgit v0.12 From 5c0af8783c940374355b648f2a47176f6c48af25 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 17 May 2022 17:02:17 +0000 Subject: Doc fix --- doc/StringObj.3 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/StringObj.3 b/doc/StringObj.3 index 156618b..c9bdd4a 100644 --- a/doc/StringObj.3 +++ b/doc/StringObj.3 @@ -40,7 +40,7 @@ Tcl_UniChar * int \fBTcl_GetUniChar\fR(\fIobjPtr, index\fR) .sp -int +size_t \fBTcl_GetCharLength\fR(\fIobjPtr\fR) .sp Tcl_Obj * -- cgit v0.12 From 2e04ff831d043373741c9252f3ff791bbc2bbda9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 18 May 2022 09:06:12 +0000 Subject: doc fix --- doc/SplitPath.3 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/SplitPath.3 b/doc/SplitPath.3 index c011194..5dae109 100644 --- a/doc/SplitPath.3 +++ b/doc/SplitPath.3 @@ -72,7 +72,7 @@ Then you should eventually free the storage with a call like the following: .PP .CS -Tcl_Free((char *) argv); +Tcl_Free(argv); .CE .PP \fBTcl_JoinPath\fR is the inverse of \fBTcl_SplitPath\fR: it takes a -- cgit v0.12 From b4b177bc926f1e246054462ba147e0448a0a95e3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 19 May 2022 11:00:04 +0000 Subject: Elaborate TIP #481 implementation: Make clear that Tcl_GetUnicodeFromObj and Tcl_GetStringFromObj panic if lengthPtr points to an int and length > INT_MAX. Also if sizeof(int) == sizeof(size_t), prefer the size_t variant of the functions --- doc/StringObj.3 | 7 +++++-- generic/tclDecls.h | 16 ++++++++-------- generic/tclObj.c | 6 +++++- generic/tclStringObj.c | 4 ++++ 4 files changed, 22 insertions(+), 11 deletions(-) diff --git a/doc/StringObj.3 b/doc/StringObj.3 index c9bdd4a..2526a01 100644 --- a/doc/StringObj.3 +++ b/doc/StringObj.3 @@ -188,7 +188,9 @@ Even in the limited situations where writing to this pointer is acceptable, one should take care to respect the copy-on-write semantics required by \fBTcl_Obj\fR's, with appropriate calls to \fBTcl_IsShared\fR and \fBTcl_DuplicateObj\fR prior to any -in-place modification of the string representation. +in-place modification of the string representation. If \fIlengthPtr\fR +points to an \fBint\fR variable, and the string has more than 2^31 bytes, +a panic will result. The procedure \fBTcl_GetString\fR is used in the common case where the caller does not need the length of the string representation. @@ -200,7 +202,8 @@ value as a Unicode string. This is given by the returned pointer and byte pointer is owned by the value manager and should not be modified by the caller. The procedure \fBTcl_GetUnicode\fR is used in the common case where the caller does not need the length of the unicode string -representation. +representation. If \fIlengthPtr\fR points to an \fBint\fR variable, +and the string has more than 2^31 unicode characters, a panic will result. .PP \fBTcl_GetUniChar\fR returns the \fIindex\fR'th character in the value's Unicode representation. If the index is out of range or diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 0995678..02c365e 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -3916,24 +3916,24 @@ extern const TclStubs *tclStubsPtr; #undef Tcl_GetBytesFromObj #if defined(USE_TCL_STUBS) #define Tcl_GetStringFromObj(objPtr, sizePtr) \ - (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tclGetStringFromObj(objPtr, (int *)(sizePtr)) : tclStubsPtr->tcl_GetStringFromObj(objPtr, (size_t *)(sizePtr))) + ((sizeof(*(sizePtr)) <= sizeof(int) && sizeof(int) != sizeof(size_t)) ? tclStubsPtr->tclGetStringFromObj(objPtr, (int *)(sizePtr)) : tclStubsPtr->tcl_GetStringFromObj(objPtr, (size_t *)(sizePtr))) #define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \ - (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tclGetBytesFromObj(interp, objPtr, (int *)(sizePtr)) : tclStubsPtr->tcl_GetBytesFromObj(interp, objPtr, (size_t *)(sizePtr))) + ((sizeof(*(sizePtr)) <= sizeof(int)) ? tclStubsPtr->tclGetBytesFromObj(interp, objPtr, (int *)(sizePtr)) : tclStubsPtr->tcl_GetBytesFromObj(interp, objPtr, (size_t *)(sizePtr))) #define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ - (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tclGetBytesFromObj(NULL, objPtr, (int *)(sizePtr)) : tclStubsPtr->tcl_GetBytesFromObj(NULL, objPtr, (size_t *)(sizePtr))) + ((sizeof(*(sizePtr)) <= sizeof(int)) ? tclStubsPtr->tclGetBytesFromObj(NULL, objPtr, (int *)(sizePtr)) : tclStubsPtr->tcl_GetBytesFromObj(NULL, objPtr, (size_t *)(sizePtr))) #define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \ - (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tclGetUnicodeFromObj(objPtr, (int *)(sizePtr)) : tclStubsPtr->tcl_GetUnicodeFromObj(objPtr, (size_t *)(sizePtr))) + ((sizeof(*(sizePtr)) <= sizeof(int)) ? tclStubsPtr->tclGetUnicodeFromObj(objPtr, (int *)(sizePtr)) : tclStubsPtr->tcl_GetUnicodeFromObj(objPtr, (size_t *)(sizePtr))) #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ (tclStubsPtr->tcl_GetIndexFromObjStruct((interp), (objPtr), (tablePtr), (offset), (msg), (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr))) #else #define Tcl_GetStringFromObj(objPtr, sizePtr) \ - (sizeof(*(sizePtr)) <= sizeof(int) ? (TclGetStringFromObj)(objPtr, (int *)(sizePtr)) : (Tcl_GetStringFromObj)(objPtr, (size_t *)(sizePtr))) + ((sizeof(*(sizePtr)) <= sizeof(int) && sizeof(int) != sizeof(size_t)) ? (TclGetStringFromObj)(objPtr, (int *)(sizePtr)) : (Tcl_GetStringFromObj)(objPtr, (size_t *)(sizePtr))) #define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \ - (sizeof(*(sizePtr)) <= sizeof(int) ? (TclGetBytesFromObj)(interp, objPtr, (int *)(sizePtr)) : (Tcl_GetBytesFromObj)(interp, objPtr, (size_t *)(sizePtr))) + ((sizeof(*(sizePtr)) <= sizeof(int) && sizeof(int) != sizeof(size_t)) ? (TclGetBytesFromObj)(interp, objPtr, (int *)(sizePtr)) : (Tcl_GetBytesFromObj)(interp, objPtr, (size_t *)(sizePtr))) #define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ - (sizeof(*(sizePtr)) <= sizeof(int) ? (TclGetBytesFromObj)(NULL, objPtr, (int *)(sizePtr)) : (Tcl_GetBytesFromObj)(NULL, objPtr, (size_t *)(sizePtr))) + ((sizeof(*(sizePtr)) <= sizeof(int) && sizeof(int) != sizeof(size_t)) ? (TclGetBytesFromObj)(NULL, objPtr, (int *)(sizePtr)) : (Tcl_GetBytesFromObj)(NULL, objPtr, (size_t *)(sizePtr))) #define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \ - (sizeof(*(sizePtr)) <= sizeof(int) ? (TclGetUnicodeFromObj)(objPtr, (int *)(sizePtr)) : Tcl_GetUnicodeFromObj(objPtr, (size_t *)(sizePtr))) + ((sizeof(*(sizePtr)) <= sizeof(int) && sizeof(int) != sizeof(size_t)) ? (TclGetUnicodeFromObj)(objPtr, (int *)(sizePtr)) : Tcl_GetUnicodeFromObj(objPtr, (size_t *)(sizePtr))) #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ ((Tcl_GetIndexFromObjStruct)((interp), (objPtr), (tablePtr), (offset), (msg), (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr))) #endif diff --git a/generic/tclObj.c b/generic/tclObj.c index b4d6332..300e408 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -1675,7 +1675,11 @@ TclGetStringFromObj( } } if (lengthPtr != NULL) { - *lengthPtr = (objPtr->length < INT_MAX)? objPtr->length: INT_MAX; + if (objPtr->length > INT_MAX) { + Tcl_Panic("Tcl_GetStringFromObj with 'int' lengthPtr" + "cannot handle such long strings. Please use 'size_t'"); + } + *lengthPtr = (int)objPtr->length; } return objPtr->bytes; } diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index a3ee1c3..d0bac17 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -686,6 +686,10 @@ TclGetUnicodeFromObj( } if (lengthPtr != NULL) { + if (stringPtr->numChars > INT_MAX) { + Tcl_Panic("Tcl_GetUnicodeFromObj with 'int' lengthPtr" + "cannot handle such long strings. Please use 'size_t'"); + } *lengthPtr = (int)stringPtr->numChars; } return stringPtr->unicode; -- cgit v0.12 From 53a20bbf1cf609252a8ec050ed68a139687e7ad0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 19 May 2022 14:51:03 +0000 Subject: TIP #481: Also prefer size_t functions when lengthPtr == NULL --- generic/tclDecls.h | 38 ++++++++++++++++++++++++++++---------- 1 file changed, 28 insertions(+), 10 deletions(-) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 02c365e..1b8de88 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -3916,26 +3916,44 @@ extern const TclStubs *tclStubsPtr; #undef Tcl_GetBytesFromObj #if defined(USE_TCL_STUBS) #define Tcl_GetStringFromObj(objPtr, sizePtr) \ - ((sizeof(*(sizePtr)) <= sizeof(int) && sizeof(int) != sizeof(size_t)) ? tclStubsPtr->tclGetStringFromObj(objPtr, (int *)(sizePtr)) : tclStubsPtr->tcl_GetStringFromObj(objPtr, (size_t *)(sizePtr))) + ((sizePtr) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ + tclStubsPtr->tclGetStringFromObj(objPtr, (int *)(void *)(sizePtr)) : \ + tclStubsPtr->tcl_GetStringFromObj(objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \ - ((sizeof(*(sizePtr)) <= sizeof(int)) ? tclStubsPtr->tclGetBytesFromObj(interp, objPtr, (int *)(sizePtr)) : tclStubsPtr->tcl_GetBytesFromObj(interp, objPtr, (size_t *)(sizePtr))) + ((sizePtr) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ + tclStubsPtr->tclGetBytesFromObj(interp, objPtr, (int *)(void *)(sizePtr)) : \ + tclStubsPtr->tcl_GetBytesFromObj(interp, objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ - ((sizeof(*(sizePtr)) <= sizeof(int)) ? tclStubsPtr->tclGetBytesFromObj(NULL, objPtr, (int *)(sizePtr)) : tclStubsPtr->tcl_GetBytesFromObj(NULL, objPtr, (size_t *)(sizePtr))) + ((sizePtr) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ + tclStubsPtr->tclGetBytesFromObj(NULL, objPtr, (int *)(void *)(sizePtr)) : \ + tclStubsPtr->tcl_GetBytesFromObj(NULL, objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \ - ((sizeof(*(sizePtr)) <= sizeof(int)) ? tclStubsPtr->tclGetUnicodeFromObj(objPtr, (int *)(sizePtr)) : tclStubsPtr->tcl_GetUnicodeFromObj(objPtr, (size_t *)(sizePtr))) + ((sizePtr) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ + tclStubsPtr->tclGetUnicodeFromObj(objPtr, (int *)(void *)(sizePtr)) : \ + tclStubsPtr->tcl_GetUnicodeFromObj(objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ - (tclStubsPtr->tcl_GetIndexFromObjStruct((interp), (objPtr), (tablePtr), (offset), (msg), (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr))) + (tclStubsPtr->tcl_GetIndexFromObjStruct((interp), (objPtr), (tablePtr), (offset), (msg), \ + (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr))) #else #define Tcl_GetStringFromObj(objPtr, sizePtr) \ - ((sizeof(*(sizePtr)) <= sizeof(int) && sizeof(int) != sizeof(size_t)) ? (TclGetStringFromObj)(objPtr, (int *)(sizePtr)) : (Tcl_GetStringFromObj)(objPtr, (size_t *)(sizePtr))) + ((sizePtr) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ + (TclGetStringFromObj)(objPtr, (int *)(void *)(sizePtr)) : \ + (Tcl_GetStringFromObj)(objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \ - ((sizeof(*(sizePtr)) <= sizeof(int) && sizeof(int) != sizeof(size_t)) ? (TclGetBytesFromObj)(interp, objPtr, (int *)(sizePtr)) : (Tcl_GetBytesFromObj)(interp, objPtr, (size_t *)(sizePtr))) + ((sizePtr) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ + (TclGetBytesFromObj)(interp, objPtr, (int *)(void *)(sizePtr)) : \ + (Tcl_GetBytesFromObj)(interp, objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ - ((sizeof(*(sizePtr)) <= sizeof(int) && sizeof(int) != sizeof(size_t)) ? (TclGetBytesFromObj)(NULL, objPtr, (int *)(sizePtr)) : (Tcl_GetBytesFromObj)(NULL, objPtr, (size_t *)(sizePtr))) + ((sizePtr) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ + (TclGetBytesFromObj)(NULL, objPtr, (int *)(void *)(sizePtr)) : \ + (Tcl_GetBytesFromObj)(NULL, objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \ - ((sizeof(*(sizePtr)) <= sizeof(int) && sizeof(int) != sizeof(size_t)) ? (TclGetUnicodeFromObj)(objPtr, (int *)(sizePtr)) : Tcl_GetUnicodeFromObj(objPtr, (size_t *)(sizePtr))) + ((sizePtr) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ + (TclGetUnicodeFromObj)(objPtr, (int *)(void *)(sizePtr)) : \ + Tcl_GetUnicodeFromObj(objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ - ((Tcl_GetIndexFromObjStruct)((interp), (objPtr), (tablePtr), (offset), (msg), (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr))) + ((Tcl_GetIndexFromObjStruct)((interp), (objPtr), (tablePtr), (offset), (msg), \ + (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr))) #endif #ifdef TCL_MEM_DEBUG -- cgit v0.12 From 089be89dd5b219a8d5156723b99478293c835f9a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 24 May 2022 12:45:10 +0000 Subject: Compiler warning when USE_DTRACE=1 --- generic/tclProc.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/generic/tclProc.c b/generic/tclProc.c index 613225c..cd52cbf 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -1692,9 +1692,9 @@ TclNRInterpProcCore( #ifdef USE_DTRACE if (TCL_DTRACE_PROC_ARGS_ENABLED()) { - int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; + size_t l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; const char *a[10]; - int i; + size_t i; for (i = 0 ; i < 10 ; i++) { a[i] = (l < iPtr->varFramePtr->objc ? @@ -1713,7 +1713,7 @@ TclNRInterpProcCore( TclDecrRefCount(info); } if (TCL_DTRACE_PROC_ENTRY_ENABLED()) { - int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; + size_t l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; TCL_DTRACE_PROC_ENTRY(l < iPtr->varFramePtr->objc ? TclGetString(iPtr->varFramePtr->objv[l]) : NULL, @@ -1721,7 +1721,7 @@ TclNRInterpProcCore( (Tcl_Obj **)(iPtr->varFramePtr->objv + l + 1)); } if (TCL_DTRACE_PROC_ENTRY_ENABLED()) { - int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; + size_t l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; TCL_DTRACE_PROC_ENTRY(l < iPtr->varFramePtr->objc ? TclGetString(iPtr->varFramePtr->objv[l]) : NULL, -- cgit v0.12 From 3790a1ab40e5274f20e00f2c1709e7f8fec9319f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 25 May 2022 22:26:49 +0000 Subject: See [https://github.com/tcltk/tcl/pull/14] --- .github/dependabot.yml | 6 ++++++ 1 file changed, 6 insertions(+) create mode 100644 .github/dependabot.yml diff --git a/.github/dependabot.yml b/.github/dependabot.yml new file mode 100644 index 0000000..203f3c8 --- /dev/null +++ b/.github/dependabot.yml @@ -0,0 +1,6 @@ +version: 2 +updates: +- package-ecosystem: "github-actions" + directory: "/" + schedule: + interval: "weekly" -- cgit v0.12 From 0e71952f875f6b305ed4b7505a4d05afa4249dc5 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 26 May 2022 20:53:34 +0000 Subject: [https://github.com/tcltk/tcl/pull/16] --- .github/workflows/onefiledist.yml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/.github/workflows/onefiledist.yml b/.github/workflows/onefiledist.yml index 95c6b82..05ca83c 100644 --- a/.github/workflows/onefiledist.yml +++ b/.github/workflows/onefiledist.yml @@ -34,7 +34,7 @@ jobs: tar -cf tclsh${TCL_PATCHLEVEL}_snapshot.tar tclsh${TCL_PATCHLEVEL}_snapshot working-directory: 1dist - name: Upload - uses: actions/upload-artifact@v2 + uses: actions/upload-artifact@v3 with: name: Tclsh ${{ env.TCL_PATCHLEVEL }} Linux single-file build (snapshot) path: 1dist/*.tar @@ -96,7 +96,7 @@ jobs: "contents/" working-directory: 1dist - name: Upload - uses: actions/upload-artifact@v2 + uses: actions/upload-artifact@v3 with: name: Tclsh ${{ env.TCL_PATCHLEVEL }} macOS single-file build (snapshot) path: 1dist/*.dmg @@ -140,7 +140,7 @@ jobs: cp ../win/tclsh*.exe tclsh${TCL_PATCHLEVEL}_snapshot.exe working-directory: 1dist - name: Upload - uses: actions/upload-artifact@v2 + uses: actions/upload-artifact@v3 with: name: Tclsh ${{ env.TCL_PATCHLEVEL }} Windows single-file build (snapshot) path: '1dist/*_snapshot.exe' -- cgit v0.12 From 9140182bbe121ce870cbcaa4d4a250dc0231ceb4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 26 May 2022 21:12:11 +0000 Subject: Eliminate warnings in tclProc.c with USE_DTRACE. Try to eliminate warnings with gcc 4.8.5, which i is unhappy with macros that explicitly test (&foo) as booleans --- generic/tclDecls.h | 16 ++++++++-------- generic/tclProc.c | 8 ++++---- 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 1b8de88..d2ecd17 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -3916,19 +3916,19 @@ extern const TclStubs *tclStubsPtr; #undef Tcl_GetBytesFromObj #if defined(USE_TCL_STUBS) #define Tcl_GetStringFromObj(objPtr, sizePtr) \ - ((sizePtr) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ + (((sizePtr) != NULL) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ tclStubsPtr->tclGetStringFromObj(objPtr, (int *)(void *)(sizePtr)) : \ tclStubsPtr->tcl_GetStringFromObj(objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \ - ((sizePtr) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ + (((sizePtr) != NULL) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ tclStubsPtr->tclGetBytesFromObj(interp, objPtr, (int *)(void *)(sizePtr)) : \ tclStubsPtr->tcl_GetBytesFromObj(interp, objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ - ((sizePtr) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ + (((sizePtr) != NULL) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ tclStubsPtr->tclGetBytesFromObj(NULL, objPtr, (int *)(void *)(sizePtr)) : \ tclStubsPtr->tcl_GetBytesFromObj(NULL, objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \ - ((sizePtr) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ + (((sizePtr) != NULL) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ tclStubsPtr->tclGetUnicodeFromObj(objPtr, (int *)(void *)(sizePtr)) : \ tclStubsPtr->tcl_GetUnicodeFromObj(objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ @@ -3936,19 +3936,19 @@ extern const TclStubs *tclStubsPtr; (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr))) #else #define Tcl_GetStringFromObj(objPtr, sizePtr) \ - ((sizePtr) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ + (((sizePtr) != NULL) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ (TclGetStringFromObj)(objPtr, (int *)(void *)(sizePtr)) : \ (Tcl_GetStringFromObj)(objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \ - ((sizePtr) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ + (((sizePtr) != NULL) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ (TclGetBytesFromObj)(interp, objPtr, (int *)(void *)(sizePtr)) : \ (Tcl_GetBytesFromObj)(interp, objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ - ((sizePtr) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ + (((sizePtr) != NULL) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ (TclGetBytesFromObj)(NULL, objPtr, (int *)(void *)(sizePtr)) : \ (Tcl_GetBytesFromObj)(NULL, objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \ - ((sizePtr) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ + (((sizePtr) != NULL) && (sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \ (TclGetUnicodeFromObj)(objPtr, (int *)(void *)(sizePtr)) : \ Tcl_GetUnicodeFromObj(objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ diff --git a/generic/tclProc.c b/generic/tclProc.c index 3f42be8..74323c8 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -1692,9 +1692,9 @@ TclNRInterpProcCore( #ifdef USE_DTRACE if (TCL_DTRACE_PROC_ARGS_ENABLED()) { - size_t l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; + int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; const char *a[10]; - size_t i; + int i; for (i = 0 ; i < 10 ; i++) { a[i] = (l < iPtr->varFramePtr->objc ? @@ -1713,7 +1713,7 @@ TclNRInterpProcCore( TclDecrRefCount(info); } if (TCL_DTRACE_PROC_ENTRY_ENABLED()) { - size_t l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; + int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; TCL_DTRACE_PROC_ENTRY(l < iPtr->varFramePtr->objc ? TclGetString(iPtr->varFramePtr->objv[l]) : NULL, @@ -1721,7 +1721,7 @@ TclNRInterpProcCore( (Tcl_Obj **)(iPtr->varFramePtr->objv + l + 1)); } if (TCL_DTRACE_PROC_ENTRY_ENABLED()) { - size_t l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; + int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; TCL_DTRACE_PROC_ENTRY(l < iPtr->varFramePtr->objc ? TclGetString(iPtr->varFramePtr->objv[l]) : NULL, -- cgit v0.12 From 54f8e4453de7195ba93211ba1b84dabe59a24a39 Mon Sep 17 00:00:00 2001 From: bch Date: Thu, 26 May 2022 21:41:29 +0000 Subject: documentation spelling error --- doc/msgcat.n | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/msgcat.n b/doc/msgcat.n index ac6dde7..76d275b 100644 --- a/doc/msgcat.n +++ b/doc/msgcat.n @@ -73,7 +73,7 @@ the application source code. New languages or locales may be provided by adding a new file to the message catalog. .PP -\fBmsgcat\fR distinguises packages by its namespace. +\fBmsgcat\fR distinguishes packages by its namespace. Each package has its own message catalog and configuration settings in \fBmsgcat\fR. .PP A \fIlocale\fR is a specification string describing a user language like \fBde_ch\fR for Swiss German. -- cgit v0.12 From c54b502e0d4673f4250097cdc2358cac90c56ecc Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 26 May 2022 22:31:39 +0000 Subject: [https://github.com/tcltk/tcl/pull/15] and typo --- .github/workflows/linux-build.yml | 2 +- .github/workflows/mac-build.yml | 4 ++-- .github/workflows/win-build.yml | 4 ++-- generic/tclDate.c | 2 +- generic/tclGetDate.y | 2 +- 5 files changed, 7 insertions(+), 7 deletions(-) diff --git a/.github/workflows/linux-build.yml b/.github/workflows/linux-build.yml index b94ed97..0bbfbd2 100644 --- a/.github/workflows/linux-build.yml +++ b/.github/workflows/linux-build.yml @@ -19,7 +19,7 @@ jobs: working-directory: unix steps: - name: Checkout - uses: actions/checkout@v2 + uses: actions/checkout@v3 - name: Prepare run: touch tclStubInit.c working-directory: generic diff --git a/.github/workflows/mac-build.yml b/.github/workflows/mac-build.yml index 8593989..5b0c657 100644 --- a/.github/workflows/mac-build.yml +++ b/.github/workflows/mac-build.yml @@ -11,7 +11,7 @@ jobs: working-directory: macosx steps: - name: Checkout - uses: actions/checkout@v2 + uses: actions/checkout@v3 - name: Prepare run: touch tclStubInit.c working-directory: generic @@ -37,7 +37,7 @@ jobs: working-directory: unix steps: - name: Checkout - uses: actions/checkout@v2 + uses: actions/checkout@v3 - name: Prepare run: | touch tclStubInit.c diff --git a/.github/workflows/win-build.yml b/.github/workflows/win-build.yml index 79a7e68..9a0ac98 100644 --- a/.github/workflows/win-build.yml +++ b/.github/workflows/win-build.yml @@ -19,7 +19,7 @@ jobs: # Using powershell means we need to explicitly stop on failure steps: - name: Checkout - uses: actions/checkout@v2 + uses: actions/checkout@v3 - name: Init MSVC uses: ilammy/msvc-dev-cmd@v1 - name: Build ${{ matrix.cfgopt }} @@ -58,7 +58,7 @@ jobs: # Using powershell means we need to explicitly stop on failure steps: - name: Checkout - uses: actions/checkout@v2 + uses: actions/checkout@v3 - name: Install MSYS2 and Make run: choco install msys2 make - name: Prepare diff --git a/generic/tclDate.c b/generic/tclDate.c index 8d37f3d..0971c8c 100644 --- a/generic/tclDate.c +++ b/generic/tclDate.c @@ -2749,7 +2749,7 @@ int TclClockOldscanObjCmd( ClientData clientData, /* Unused */ Tcl_Interp *interp, /* Tcl interpreter */ - int objc, /* Count of paraneters */ + int objc, /* Count of parameters */ Tcl_Obj *CONST *objv) /* Parameters */ { Tcl_Obj *result, *resultElement; diff --git a/generic/tclGetDate.y b/generic/tclGetDate.y index 551b1ed..df1b5d3 100644 --- a/generic/tclGetDate.y +++ b/generic/tclGetDate.y @@ -966,7 +966,7 @@ int TclClockOldscanObjCmd( ClientData clientData, /* Unused */ Tcl_Interp *interp, /* Tcl interpreter */ - int objc, /* Count of paraneters */ + int objc, /* Count of parameters */ Tcl_Obj *CONST *objv) /* Parameters */ { Tcl_Obj *result, *resultElement; -- cgit v0.12 From 0cdb72e2c3cb4bc204ea8b2b9af2c5315e419107 Mon Sep 17 00:00:00 2001 From: bch Date: Fri, 27 May 2022 00:21:51 +0000 Subject: msgcat documentation: reflect code --- doc/msgcat.n | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/doc/msgcat.n b/doc/msgcat.n index 76d275b..c39dc87 100644 --- a/doc/msgcat.n +++ b/doc/msgcat.n @@ -224,9 +224,7 @@ As an example, the user may prefer French or English text. This may be configure This group of commands manage the list of loaded locales for packages not setting a package locale. .PP .RS -The subcommand \fBget\fR returns the list of currently loaded locales. -.PP -The subcommand \fBpresent\fR requires the argument \fIlocale\fR and returns true, if this locale is loaded. +The subcommand \fBloaded\fR returns the list of currently loaded locales. .PP The subcommand \fBclear\fR removes all locales and their data, which are not in the current preference list. .RE @@ -235,7 +233,7 @@ The subcommand \fBclear\fR removes all locales and their data, which are not in . .VS "TIP 412" Searches the specified directory for files that match -the language specifications returned by \fB::msgcat::mcloadedlocales get\fR +the language specifications returned by \fB::msgcat::mcloadedlocales loaded\fR (or \fBmsgcat::mcpackagelocale preferences\fR if a package locale is set) (note that these are all lowercase), extended by the file extension .QW .msg . Each matching file is -- cgit v0.12 From 7592daa03ddb6f5d6b6881b06f2485f5cb07cbe5 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 27 May 2022 16:39:25 +0000 Subject: Use more Tcl_ObjCmdProc/Tcl_MethodCallProc typedefs --- generic/tclCompile.h | 16 ++----- generic/tclOOInt.h | 126 ++++++++++++++------------------------------------- 2 files changed, 38 insertions(+), 104 deletions(-) diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 30b364d..ae30c19 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1192,18 +1192,10 @@ MODULE_SCOPE void TclReleaseByteCode(ByteCode *codePtr); MODULE_SCOPE void TclReleaseLiteral(Tcl_Interp *interp, Tcl_Obj *objPtr); MODULE_SCOPE void TclInvalidateCmdLiteral(Tcl_Interp *interp, const char *name, Namespace *nsPtr); -MODULE_SCOPE int TclSingleOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int TclSortingOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int TclVariadicOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int TclNoIdentOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclSingleOpCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclSortingOpCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclVariadicOpCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNoIdentOpCmd; #ifdef TCL_COMPILE_DEBUG MODULE_SCOPE void TclVerifyGlobalLiteralTable(Interp *iPtr); MODULE_SCOPE void TclVerifyLocalLiteralTable(CompileEnv *envPtr); diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 521152e..9488271 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -65,12 +65,12 @@ typedef struct Method { * tuned in their behaviour. */ -typedef int (TclOO_PreCallProc)(ClientData clientData, Tcl_Interp *interp, +typedef int (TclOO_PreCallProc)(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, Tcl_CallFrame *framePtr, int *isFinished); -typedef int (TclOO_PostCallProc)(ClientData clientData, Tcl_Interp *interp, +typedef int (TclOO_PostCallProc)(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, Tcl_Namespace *namespacePtr, int result); -typedef void (TclOO_PmCDDeleteProc)(ClientData clientData); -typedef ClientData (TclOO_PmCDCloneProc)(ClientData clientData); +typedef void (TclOO_PmCDDeleteProc)(void *clientData); +typedef void *(TclOO_PmCDCloneProc)(void *clientData); /* * Procedure-like methods have the following extra information. @@ -447,98 +447,40 @@ typedef struct { */ MODULE_SCOPE int TclOOInit(Tcl_Interp *interp); -MODULE_SCOPE int TclOODefineObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOOObjDefObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineConstructorObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineDefnNsObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineDeleteMethodObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineDestructorObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineExportObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineForwardObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineMethodObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineRenameMethodObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineUnexportObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineClassObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineSelfObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineObjSelfObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefinePrivateObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOOUnknownDefinition(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOOCopyObjectCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOONextObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOONextToObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOOSelfObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); +MODULE_SCOPE Tcl_ObjCmdProc TclOODefineObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOOObjDefObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOODefineConstructorObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOODefineDefnNsObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOODefineDeleteMethodObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOODefineDestructorObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOODefineExportObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOODefineForwardObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOODefineMethodObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOODefineRenameMethodObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOODefineUnexportObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOODefineClassObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOODefineSelfObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOODefineObjSelfObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOODefinePrivateObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOOUnknownDefinition; +MODULE_SCOPE Tcl_ObjCmdProc TclOOCopyObjectCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOONextObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOONextToObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOOSelfObjCmd; /* * Method implementations (in tclOOBasic.c). */ -MODULE_SCOPE int TclOO_Class_Constructor(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Class_Create(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Class_CreateNs(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Class_New(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Object_Destroy(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Object_Eval(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Object_LinkVar(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Object_Unknown(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Object_VarName(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); +MODULE_SCOPE Tcl_MethodCallProc TclOO_Class_Constructor; +MODULE_SCOPE Tcl_MethodCallProc TclOO_Class_Create; +MODULE_SCOPE Tcl_MethodCallProc TclOO_Class_CreateNs; +MODULE_SCOPE Tcl_MethodCallProc TclOO_Class_New; +MODULE_SCOPE Tcl_MethodCallProc TclOO_Object_Destroy; +MODULE_SCOPE Tcl_MethodCallProc TclOO_Object_Eval; +MODULE_SCOPE Tcl_MethodCallProc TclOO_Object_LinkVar; +MODULE_SCOPE Tcl_MethodCallProc TclOO_Object_Unknown; +MODULE_SCOPE Tcl_MethodCallProc TclOO_Object_VarName; /* * Private definitions, some of which perhaps ought to be exposed properly or @@ -587,7 +529,7 @@ MODULE_SCOPE int TclOOGetSortedMethodList(Object *oPtr, const char ***stringsPtr); MODULE_SCOPE int TclOOInit(Tcl_Interp *interp); MODULE_SCOPE void TclOOInitInfo(Tcl_Interp *interp); -MODULE_SCOPE int TclOOInvokeContext(ClientData clientData, +MODULE_SCOPE int TclOOInvokeContext(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclNRObjectContextInvokeNext(Tcl_Interp *interp, -- cgit v0.12 From f59ed66aa0377383e55af5a7a55adde90f5220b1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 29 May 2022 21:02:30 +0000 Subject: Function prototypes are not always needed/useful --- generic/tclCkalloc.c | 17 ----------------- unix/dltest/pkga.c | 9 --------- unix/dltest/pkgb.c | 11 ----------- unix/dltest/pkgc.c | 9 --------- unix/dltest/pkgd.c | 9 --------- unix/dltest/pkgua.c | 10 ---------- 6 files changed, 65 deletions(-) diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index 18a6400..0ad2c46 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -128,19 +128,6 @@ static Tcl_Mutex *ckallocMutexPtr; static int ckallocInit = 0; /* - * Prototypes for procedures defined in this file: - */ - -static int CheckmemCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int MemoryCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static void ValidateMemory(struct mem_header *memHeaderP, - const char *file, int line, int nukeGuards); - -/* *---------------------------------------------------------------------- * * TclInitDbCkalloc -- @@ -980,10 +967,6 @@ MemoryCmd( * *---------------------------------------------------------------------- */ -static int CheckmemCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); - static int CheckmemCmd( TCL_UNUSED(void *), diff --git a/unix/dltest/pkga.c b/unix/dltest/pkga.c index e00f996..37782ea 100644 --- a/unix/dltest/pkga.c +++ b/unix/dltest/pkga.c @@ -14,15 +14,6 @@ #include "tcl.h" /* - * Prototypes for procedures defined later in this file: - */ - -static int Pkga_EqObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int Pkga_QuoteObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); - -/* *---------------------------------------------------------------------- * * Pkga_EqObjCmd -- diff --git a/unix/dltest/pkgb.c b/unix/dltest/pkgb.c index ebed46d..d28036f 100644 --- a/unix/dltest/pkgb.c +++ b/unix/dltest/pkgb.c @@ -15,17 +15,6 @@ #include "tcl.h" /* - * Prototypes for procedures defined later in this file: - */ - -static int Pkgb_SubObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int Pkgb_UnsafeObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int Pkgb_DemoObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); - -/* *---------------------------------------------------------------------- * * Pkgb_SubObjCmd -- diff --git a/unix/dltest/pkgc.c b/unix/dltest/pkgc.c index 2b46986..cd92cf7 100644 --- a/unix/dltest/pkgc.c +++ b/unix/dltest/pkgc.c @@ -15,15 +15,6 @@ #include "tcl.h" /* - * Prototypes for procedures defined later in this file: - */ - -static int Pkgc_SubObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int Pkgc_UnsafeObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); - -/* *---------------------------------------------------------------------- * * Pkgc_SubObjCmd -- diff --git a/unix/dltest/pkgd.c b/unix/dltest/pkgd.c index ef0035f..0c98ec4 100644 --- a/unix/dltest/pkgd.c +++ b/unix/dltest/pkgd.c @@ -15,15 +15,6 @@ #include "tcl.h" /* - * Prototypes for procedures defined later in this file: - */ - -static int Pkgd_SubObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int Pkgd_UnsafeObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); - -/* *---------------------------------------------------------------------- * * Pkgd_SubObjCmd -- diff --git a/unix/dltest/pkgua.c b/unix/dltest/pkgua.c index a822541..6d64352 100644 --- a/unix/dltest/pkgua.c +++ b/unix/dltest/pkgua.c @@ -14,16 +14,6 @@ #include "tcl.h" /* - * Prototypes for procedures defined later in this file: - */ - -static int PkguaEqObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int PkguaQuoteObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static void CommandDeleted(ClientData clientData); - -/* * In the following hash table we are going to store a struct that holds all * the command tokens created by Tcl_CreateObjCommand in an interpreter, * indexed by the interpreter. In this way, we can find which command tokens -- cgit v0.12