From 4b3814f7527e7b7cb252b96ebfdc47badfbe4e2e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 17 Mar 2021 15:01:54 +0000 Subject: Simplify UtfToUtfProc() and UtfToUtf16Proc(): Using TclUtfToUCS4() internally means that we don't have to keep track of internal state any more (Tcl_EncodingState) Also, add (HMODULE) cast (back) in tclZipfs.c --- generic/tclEncoding.c | 89 ++++++++++++++++++--------------------------------- generic/tclZipfs.c | 2 +- 2 files changed, 32 insertions(+), 59 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index ea2d6fa..7569ce4 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2275,11 +2275,7 @@ UtfToUtfProc( const char *src, /* Source string in UTF-8. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ - Tcl_EncodingState *statePtr,/* Place for conversion routine to store state - * information used during a piecewise - * conversion. Contents of statePtr are - * initialized and/or reset by conversion - * routine under control of flags argument. */ + TCL_UNUSED(Tcl_EncodingState *), char *dst, /* Output buffer in which converted string is * stored. */ int dstLen, /* The maximum length of output buffer in @@ -2302,11 +2298,8 @@ UtfToUtfProc( const char *srcStart, *srcEnd, *srcClose; const char *dstStart, *dstEnd; int result, numChars, charLimit = INT_MAX; - int *chPtr = (int *) statePtr; + int ch; - if (flags & TCL_ENCODING_START) { - *statePtr = 0; - } result = TCL_OK; srcStart = src; @@ -2343,7 +2336,6 @@ UtfToUtfProc( */ *dst++ = *src++; - *chPtr = 0; /* reset surrogate handling */ } else if (pureNullMode == 1 && UCHAR(*src) == 0xC0 && (src + 1 < srcEnd) && UCHAR(*(src+1)) == 0x80) { /* @@ -2351,7 +2343,6 @@ UtfToUtfProc( */ *dst++ = 0; - *chPtr = 0; /* reset surrogate handling */ src += 2; } else if (!Tcl_UtfCharComplete(src, srcEnd - src)) { /* @@ -2360,26 +2351,26 @@ UtfToUtfProc( * incomplete char its bytes are made to represent themselves. */ - *chPtr = UCHAR(*src); + ch = UCHAR(*src); src += 1; - dst += Tcl_UniCharToUtf(*chPtr, dst); + dst += Tcl_UniCharToUtf(ch, dst); } else { - src += TclUtfToUCS4(src, chPtr); - if ((*chPtr | 0x7FF) == 0xDFFF) { + src += TclUtfToUCS4(src, &ch); + if ((ch | 0x7FF) == 0xDFFF) { /* A surrogate character is detected, handle especially */ - int low = *chPtr; + int low = ch; size_t len = (src <= srcEnd-3) ? TclUtfToUCS4(src, &low) : 0; - if (((low & ~0x3FF) != 0xDC00) || (*chPtr & 0x400)) { - *dst++ = (char) (((*chPtr >> 12) | 0xE0) & 0xEF); - *dst++ = (char) (((*chPtr >> 6) | 0x80) & 0xBF); - *dst++ = (char) ((*chPtr | 0x80) & 0xBF); + if (((low & ~0x3FF) != 0xDC00) || (ch & 0x400)) { + *dst++ = (char) (((ch >> 12) | 0xE0) & 0xEF); + *dst++ = (char) (((ch >> 6) | 0x80) & 0xBF); + *dst++ = (char) ((ch | 0x80) & 0xBF); continue; } src += len; - dst += Tcl_UniCharToUtf(*chPtr, dst); - *chPtr = low; + dst += Tcl_UniCharToUtf(ch, dst); + ch = low; } - dst += Tcl_UniCharToUtf(*chPtr, dst); + dst += Tcl_UniCharToUtf(ch, dst); } } @@ -2506,11 +2497,7 @@ UtfToUtf16Proc( const char *src, /* Source string in UTF-8. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ - Tcl_EncodingState *statePtr,/* Place for conversion routine to store state - * information used during a piecewise - * conversion. Contents of statePtr are - * initialized and/or reset by conversion - * routine under control of flags argument. */ + TCL_UNUSED(Tcl_EncodingState *), char *dst, /* Output buffer in which converted string is * stored. */ int dstLen, /* The maximum length of output buffer in @@ -2529,11 +2516,8 @@ UtfToUtf16Proc( { const char *srcStart, *srcEnd, *srcClose, *dstStart, *dstEnd; int result, numChars; - Tcl_UniChar *chPtr = (Tcl_UniChar *) statePtr; + int ch; - if (flags & TCL_ENCODING_START) { - *statePtr = 0; - } srcStart = src; srcEnd = src + srcLen; srcClose = srcEnd; @@ -2559,38 +2543,27 @@ UtfToUtf16Proc( result = TCL_CONVERT_NOSPACE; break; } - src += TclUtfToUniChar(src, chPtr); - + src += TclUtfToUCS4(src, &ch); if (clientData) { -#if TCL_UTF_MAX > 3 - if (*chPtr <= 0xFFFF) { - *dst++ = (*chPtr & 0xFF); - *dst++ = (*chPtr >> 8); + if (ch <= 0xFFFF) { + *dst++ = (ch & 0xFF); + *dst++ = (ch >> 8); } else { - *dst++ = (((*chPtr - 0x10000) >> 10) & 0xFF); - *dst++ = (((*chPtr - 0x10000) >> 18) & 0x3) | 0xD8; - *dst++ = (*chPtr & 0xFF); - *dst++ = ((*chPtr >> 8) & 0x3) | 0xDC; + *dst++ = (((ch - 0x10000) >> 10) & 0xFF); + *dst++ = (((ch - 0x10000) >> 18) & 0x3) | 0xD8; + *dst++ = (ch & 0xFF); + *dst++ = ((ch >> 8) & 0x3) | 0xDC; } -#else - *dst++ = (*chPtr & 0xFF); - *dst++ = (*chPtr >> 8); -#endif } else { -#if TCL_UTF_MAX > 3 - if (*chPtr <= 0xFFFF) { - *dst++ = (*chPtr >> 8); - *dst++ = (*chPtr & 0xFF); + if (ch <= 0xFFFF) { + *dst++ = (ch >> 8); + *dst++ = (ch & 0xFF); } else { - *dst++ = (((*chPtr - 0x10000) >> 18) & 0x3) | 0xD8; - *dst++ = (((*chPtr - 0x10000) >> 10) & 0xFF); - *dst++ = ((*chPtr >> 8) & 0x3) | 0xDC; - *dst++ = (*chPtr & 0xFF); + *dst++ = (((ch - 0x10000) >> 18) & 0x3) | 0xD8; + *dst++ = (((ch - 0x10000) >> 10) & 0xFF); + *dst++ = ((ch >> 8) & 0x3) | 0xDC; + *dst++ = (ch & 0xFF); } -#else - *dst++ = (*chPtr >> 8); - *dst++ = (*chPtr & 0xFF); -#endif } } *srcReadPtr = src - srcStart; diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index ce06a8e..feb5324 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -3746,7 +3746,7 @@ TclZipfs_TclLibrary(void) #if !defined(STATIC_BUILD) #if defined(_WIN32) || defined(__CYGWIN__) - hModule = TclWinGetTclInstance(); + hModule = (HMODULE)TclWinGetTclInstance(); GetModuleFileNameW(hModule, wName, MAX_PATH); #ifdef __CYGWIN__ cygwin_conv_path(3, wName, dllName, sizeof(dllName)); -- cgit v0.12 From c84e03a7a89d44077d777f0cc9dced8c20045f65 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 18 Mar 2021 09:12:18 +0000 Subject: More simplification of UtfToUtfProc(). Get rid of wrapper functions UtfIntToUtfExtProc/UtfExtToUtfIntProc. This can be handled by additional flags. --- generic/tclEncoding.c | 150 ++++++++------------------------------------------ 1 file changed, 24 insertions(+), 126 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 7569ce4..c682128 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -220,14 +220,7 @@ static size_t unilen(const char *src); static Tcl_EncodingConvertProc Utf16ToUtfProc; static Tcl_EncodingConvertProc UtfToUtf16Proc; static Tcl_EncodingConvertProc UtfToUcs2Proc; -static int UtfToUtfProc(ClientData clientData, - const char *src, int srcLen, int flags, - Tcl_EncodingState *statePtr, char *dst, - int dstLen, int *srcReadPtr, - int *dstWrotePtr, int *dstCharsPtr, - int pureNullMode); -static Tcl_EncodingConvertProc UtfIntToUtfExtProc; -static Tcl_EncodingConvertProc UtfExtToUtfIntProc; +static Tcl_EncodingConvertProc UtfToUtfProc; static Tcl_EncodingConvertProc Iso88591FromUtfProc; static Tcl_EncodingConvertProc Iso88591ToUtfProc; @@ -517,6 +510,10 @@ FillEncodingFileMap(void) *--------------------------------------------------------------------------- */ +/* Those flags must not conflict with other TCL_ENCODING_* flags in tcl.h */ +#define TCL_ENCODING_LE 0x40 /* Little-endian encoding */ +#define TCL_ENCODING_EXTERNAL 0x80 /* Converting from internal to external variant */ + void TclInitEncodingSubsystem(void) { @@ -525,7 +522,7 @@ TclInitEncodingSubsystem(void) unsigned size; unsigned short i; union { - char c; + unsigned char c; short s; } isLe; @@ -533,7 +530,7 @@ TclInitEncodingSubsystem(void) return; } - isLe.s = 1; + isLe.s = TCL_ENCODING_LE; Tcl_MutexLock(&encodingMutex); Tcl_InitHashTable(&encodingTable, TCL_STRING_KEYS); Tcl_MutexUnlock(&encodingMutex); @@ -553,8 +550,8 @@ TclInitEncodingSubsystem(void) tclIdentityEncoding = Tcl_CreateEncoding(&type); type.encodingName = "utf-8"; - type.toUtfProc = UtfExtToUtfIntProc; - type.fromUtfProc = UtfIntToUtfExtProc; + type.toUtfProc = UtfToUtfProc; + type.fromUtfProc = UtfToUtfProc; type.freeProc = NULL; type.nullSize = 1; type.clientData = NULL; @@ -565,7 +562,7 @@ TclInitEncodingSubsystem(void) type.freeProc = NULL; type.nullSize = 2; type.encodingName = "ucs-2le"; - type.clientData = INT2PTR(1); + type.clientData = INT2PTR(TCL_ENCODING_LE); Tcl_CreateEncoding(&type); type.encodingName = "ucs-2be"; type.clientData = INT2PTR(0); @@ -579,7 +576,7 @@ TclInitEncodingSubsystem(void) type.freeProc = NULL; type.nullSize = 2; type.encodingName = "utf-16le"; - type.clientData = INT2PTR(1); + type.clientData = INT2PTR(TCL_ENCODING_LE); Tcl_CreateEncoding(&type); type.encodingName = "utf-16be"; type.clientData = INT2PTR(0); @@ -1331,7 +1328,7 @@ Tcl_UtfToExternalDString( flags = TCL_ENCODING_START | TCL_ENCODING_END; while (1) { result = encodingPtr->fromUtfProc(encodingPtr->clientData, src, - srcLen, flags, &state, dst, dstLen, &srcRead, &dstWrote, + srcLen, flags | TCL_ENCODING_EXTERNAL, &state, dst, dstLen, &srcRead, &dstWrote, &dstChars); soFar = dst + dstWrote - Tcl_DStringValue(dstPtr); @@ -1433,7 +1430,7 @@ Tcl_UtfToExternal( dstLen -= encodingPtr->nullSize; result = encodingPtr->fromUtfProc(encodingPtr->clientData, src, srcLen, - flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, + flags | TCL_ENCODING_EXTERNAL, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr); if (encodingPtr->nullSize == 2) { dst[*dstWrotePtr + 1] = '\0'; @@ -2156,104 +2153,6 @@ BinaryProc( /* *------------------------------------------------------------------------- * - * UtfIntToUtfExtProc -- - * - * Convert from UTF-8 to UTF-8. While converting null-bytes from the - * Tcl's internal representation (0xC0, 0x80) to the official - * representation (0x00). See UtfToUtfProc for details. - * - * Results: - * Returns TCL_OK if conversion was successful. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static int -UtfIntToUtfExtProc( - ClientData clientData, - const char *src, /* Source string in UTF-8. */ - int srcLen, /* Source string length in bytes. */ - int flags, /* Conversion control flags. */ - Tcl_EncodingState *statePtr,/* Place for conversion routine to store state - * information used during a piecewise - * conversion. Contents of statePtr are - * initialized and/or reset by conversion - * routine under control of flags argument. */ - char *dst, /* Output buffer in which converted string - * is stored. */ - int dstLen, /* The maximum length of output buffer in - * bytes. */ - int *srcReadPtr, /* Filled with the number of bytes from the - * source string that were converted. This may - * be less than the original source length if - * there was a problem converting some source - * characters. */ - int *dstWrotePtr, /* Filled with the number of bytes that were - * stored in the output buffer as a result of - * the conversion. */ - int *dstCharsPtr) /* Filled with the number of characters that - * correspond to the bytes stored in the - * output buffer. */ -{ - return UtfToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, - srcReadPtr, dstWrotePtr, dstCharsPtr, 1); -} - -/* - *------------------------------------------------------------------------- - * - * UtfExtToUtfIntProc -- - * - * Convert from UTF-8 to UTF-8 while converting null-bytes from the - * official representation (0x00) to Tcl's internal representation (0xC0, - * 0x80). See UtfToUtfProc for details. - * - * Results: - * Returns TCL_OK if conversion was successful. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static int -UtfExtToUtfIntProc( - ClientData clientData, - const char *src, /* Source string in UTF-8. */ - int srcLen, /* Source string length in bytes. */ - int flags, /* Conversion control flags. */ - Tcl_EncodingState *statePtr,/* Place for conversion routine to store state - * information used during a piecewise - * conversion. Contents of statePtr are - * initialized and/or reset by conversion - * routine under control of flags argument. */ - char *dst, /* Output buffer in which converted string is - * stored. */ - int dstLen, /* The maximum length of output buffer in - * bytes. */ - int *srcReadPtr, /* Filled with the number of bytes from the - * source string that were converted. This may - * be less than the original source length if - * there was a problem converting some source - * characters. */ - int *dstWrotePtr, /* Filled with the number of bytes that were - * stored in the output buffer as a result of - * the conversion. */ - int *dstCharsPtr) /* Filled with the number of characters that - * correspond to the bytes stored in the - * output buffer. */ -{ - return UtfToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, - srcReadPtr, dstWrotePtr, dstCharsPtr, 0); -} - -/* - *------------------------------------------------------------------------- - * * UtfToUtfProc -- * * Convert from UTF-8 to UTF-8. Note that the UTF-8 to UTF-8 translation @@ -2288,12 +2187,9 @@ UtfToUtfProc( int *dstWrotePtr, /* Filled with the number of bytes that were * stored in the output buffer as a result of * the conversion. */ - int *dstCharsPtr, /* Filled with the number of characters that + int *dstCharsPtr) /* Filled with the number of characters that * correspond to the bytes stored in the * output buffer. */ - int pureNullMode) /* Convert embedded nulls from internal - * representation to real null-bytes or vice - * versa. Also combine or separate surrogate pairs */ { const char *srcStart, *srcEnd, *srcClose; const char *dstStart, *dstEnd; @@ -2329,15 +2225,15 @@ UtfToUtfProc( result = TCL_CONVERT_NOSPACE; break; } - if (UCHAR(*src) < 0x80 && !(UCHAR(*src) == 0 && pureNullMode == 0)) { + if ((UCHAR(*src - 1) < 0x7F) && !(flags & TCL_ENCODING_EXTERNAL)) { /* * Copy 7bit characters, but skip null-bytes when we are in input * mode, so that they get converted to 0xC080. */ *dst++ = *src++; - } else if (pureNullMode == 1 && UCHAR(*src) == 0xC0 && - (src + 1 < srcEnd) && UCHAR(*(src+1)) == 0x80) { + } else if (UCHAR(*src) == 0xC0 && (src + 1 < srcEnd) + && UCHAR(src[1]) == 0x80 && (flags & TCL_ENCODING_EXTERNAL)) { /* * Convert 0xC080 to real nulls when we are in output mode. */ @@ -2398,7 +2294,7 @@ UtfToUtfProc( static int Utf16ToUtfProc( - ClientData clientData, /* != NULL means LE, == NUL means BE */ + ClientData clientData, /* additional flags, e.g. TCL_ENCODING_LE */ const char *src, /* Source string in Unicode. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ @@ -2424,6 +2320,7 @@ Utf16ToUtfProc( int result, numChars, charLimit = INT_MAX; unsigned short ch; + flags |= PTR2INT(clientData); if (flags & TCL_ENCODING_CHAR_LIMIT) { charLimit = *dstCharsPtr; } @@ -2435,7 +2332,7 @@ Utf16ToUtfProc( srcLen--; } /* If last code point is a high surrogate, we cannot handle that yet */ - if ((srcLen >= 2) && ((src[srcLen - (clientData?1:2)] & 0xFC) == 0xD8)) { + if ((srcLen >= 2) && ((src[srcLen - ((flags & TCL_ENCODING_LE)?1:2)] & 0xFC) == 0xD8)) { result = TCL_CONVERT_MULTIBYTE; srcLen-= 2; } @@ -2452,7 +2349,7 @@ Utf16ToUtfProc( break; } - if (clientData) { + if (flags & TCL_ENCODING_LE) { ch = (src[1] & 0xFF) << 8 | (src[0] & 0xFF); } else { ch = (src[0] & 0xFF) << 8 | (src[1] & 0xFF); @@ -2590,7 +2487,7 @@ UtfToUtf16Proc( static int UtfToUcs2Proc( - ClientData clientData, /* != NULL means LE, == NUL means BE */ + ClientData clientData, /* additional flags, e.g. TCL_ENCODING_LE */ const char *src, /* Source string in UTF-8. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ @@ -2618,6 +2515,7 @@ UtfToUcs2Proc( #endif Tcl_UniChar ch = 0; + flags |= PTR2INT(clientData); srcStart = src; srcEnd = src + srcLen; srcClose = srcEnd; @@ -2661,7 +2559,7 @@ UtfToUcs2Proc( * casting dst to a Tcl_UniChar. [Bug 1122671] */ - if (clientData) { + if (flags & TCL_ENCODING_LE) { *dst++ = (ch & 0xFF); *dst++ = (ch >> 8); } else { -- cgit v0.12 From 3aa4b20ea8f659c593c8ab827efc535856cd540a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 18 Mar 2021 09:36:27 +0000 Subject: Remove incorrect/useless comment --- generic/tclIORChan.c | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index dd24b0f..c48c904 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -58,8 +58,7 @@ static int ReflectSetOption(ClientData clientData, const char *newValue); /* - * The C layer channel type/driver definition used by the reflection. This is - * a version 3 structure. + * The C layer channel type/driver definition used by the reflection. */ static const Tcl_ChannelType tclRChannelType = { -- cgit v0.12 From a3ae9d7e5701156f675454df19664b0c220271b0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 18 Mar 2021 12:05:56 +0000 Subject: Fix [2860859e84]: Misleading description in README file --- tools/README | 19 +++++++------------ 1 file changed, 7 insertions(+), 12 deletions(-) diff --git a/tools/README b/tools/README index f4bf627..a37c2f4 100644 --- a/tools/README +++ b/tools/README @@ -9,17 +9,12 @@ uniClass.tcl -- Script for generating regexp class tables from the Tcl "string is" classes Generating HTML files. -The tcl-tk-man-html.tcl script from Robert Critchlow -generates a nice set of HTML with good cross references. -Use it like - tclsh tcl-tk-man-html.tcl --htmldir=/tmp/tcl8.2 +The tcltk-man2html.tcl script generates a nice set of HTML with +good cross references. Use it like + cd unix + ./configure + make html This script is very picky about the organization of man pages, effectively acting as a style enforcer. - -Generating Windows Help Files: -1) Build tcl in the ../unix directory -2) On UNIX, (after autoconf and configure), do - make - this converts the Nroff to RTF files. -2) On Windows, convert the RTF to a Help doc, do - nmake helpfile +The resulting documentation can be found at + /tmp/dist/tcl/html -- cgit v0.12 From 2b7eb65f53e75a84e02c3b5da96c45bbefc6ff8a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 18 Mar 2021 13:20:47 +0000 Subject: Suggested fix for [0221b993a1]: Tcl command [update idletasks] doesn't skip main loop in Tcl_DoOneEvent --- generic/tclEvent.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclEvent.c b/generic/tclEvent.c index bf3be38..52cd351 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -1513,7 +1513,7 @@ Tcl_UpdateObjCmd( } switch ((enum updateOptionsEnum) optionIndex) { case OPT_IDLETASKS: - flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT; + flags = TCL_IDLE_EVENTS|TCL_DONT_WAIT; break; default: Tcl_Panic("Tcl_UpdateObjCmd: bad option index to UpdateOptions"); -- cgit v0.12 From 8390478dbf758e04f04223c4db37e62c1ca1d519 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 18 Mar 2021 14:46:57 +0000 Subject: Fix [8663689908]. Final documentation fix, implementation was already fixed earlier. --- doc/re_syntax.n | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/re_syntax.n b/doc/re_syntax.n index 9a9e2b0..ef8c570 100644 --- a/doc/re_syntax.n +++ b/doc/re_syntax.n @@ -446,7 +446,7 @@ commonly-used character classes: .TP \fB\ew\fR . -\fB[[:alnum:]_]\fR (note underscore) +\fB[[:alnum:]_\eu203F\eu2040\eu2054\euFE33\euFE34\euFE4D\euFE4E\euFE4F\euFF3F]\fR (including punctuation connector characters) .TP \fB\eD\fR . @@ -458,7 +458,7 @@ commonly-used character classes: .TP \fB\eW\fR . -\fB[^[:alnum:]_]\fR (note underscore) +\fB[^[:alnum:]_\eu203F\eu2040\eu2054\euFE33\euFE34\euFE4D\euFE4E\euFE4F\euFF3F]\fR (including punctuation connector characters) .RE .PP Within bracket expressions, -- cgit v0.12 From e6d6e2962de378b019acce96758ea25fb4566243 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 18 Mar 2021 21:17:46 +0000 Subject: Delete some useless code. Was only place where we fed an uncontrolled value to %f, and it was actually a conversion we didn't need to do at all. --- generic/tclIndexObj.c | 2 -- 1 file changed, 2 deletions(-) diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 7e23931..d7dfb71 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -1328,7 +1328,6 @@ PrintUsage( int width, numSpaces; #define NUM_SPACES 20 static const char spaces[] = " "; - char tmp[TCL_DOUBLE_SPACE]; Tcl_Obj *msg; /* @@ -1378,7 +1377,6 @@ PrintUsage( case TCL_ARGV_FLOAT: Tcl_AppendPrintfToObj(msg, "\n\t\tDefault value: %g", *((double *) infoPtr->dstPtr)); - sprintf(tmp, "%g", *((double *) infoPtr->dstPtr)); break; case TCL_ARGV_STRING: { char *string = *((char **) infoPtr->dstPtr); -- cgit v0.12 From f2cb38dda94341ddbb64b3b72efdeeb62ec610be Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 18 Mar 2021 21:35:09 +0000 Subject: Handle the encoding of filenames in ZIPs correctly. (This is awful. The awful isn't Tcl's fault. Terrible spec...) --- generic/tclEncoding.c | 55 +++++++++----- generic/tclZipfs.c | 199 ++++++++++++++++++++++++++++++++++++++++++++------ 2 files changed, 215 insertions(+), 39 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index c682128..4f08a17 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -512,7 +512,7 @@ FillEncodingFileMap(void) /* Those flags must not conflict with other TCL_ENCODING_* flags in tcl.h */ #define TCL_ENCODING_LE 0x40 /* Little-endian encoding */ -#define TCL_ENCODING_EXTERNAL 0x80 /* Converting from internal to external variant */ +#define TCL_ENCODING_EXTERNAL 0x80 /* Converting from internal to external variant */ void TclInitEncodingSubsystem(void) @@ -1328,8 +1328,8 @@ Tcl_UtfToExternalDString( flags = TCL_ENCODING_START | TCL_ENCODING_END; while (1) { result = encodingPtr->fromUtfProc(encodingPtr->clientData, src, - srcLen, flags | TCL_ENCODING_EXTERNAL, &state, dst, dstLen, &srcRead, &dstWrote, - &dstChars); + srcLen, flags | TCL_ENCODING_EXTERNAL, &state, dst, dstLen, + &srcRead, &dstWrote, &dstChars); soFar = dst + dstWrote - Tcl_DStringValue(dstPtr); if (result != TCL_CONVERT_NOSPACE) { @@ -1430,8 +1430,8 @@ Tcl_UtfToExternal( dstLen -= encodingPtr->nullSize; result = encodingPtr->fromUtfProc(encodingPtr->clientData, src, srcLen, - flags | TCL_ENCODING_EXTERNAL, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, - dstCharsPtr); + flags | TCL_ENCODING_EXTERNAL, statePtr, dst, dstLen, srcReadPtr, + dstWrotePtr, dstCharsPtr); if (encodingPtr->nullSize == 2) { dst[*dstWrotePtr + 1] = '\0'; } @@ -2244,23 +2244,32 @@ UtfToUtfProc( /* * Always check before using TclUtfToUCS4. Not doing can so * cause it run beyond the end of the buffer! If we happen such an - * incomplete char its bytes are made to represent themselves. + * incomplete char its bytes are made to represent themselves + * unless the user has explicitly asked to be told. */ + if (flags & TCL_ENCODING_STOPONERROR) { + result = TCL_CONVERT_MULTIBYTE; + break; + } ch = UCHAR(*src); src += 1; dst += Tcl_UniCharToUtf(ch, dst); } else { src += TclUtfToUCS4(src, &ch); if ((ch | 0x7FF) == 0xDFFF) { - /* A surrogate character is detected, handle especially */ + /* + * A surrogate character is detected, handle especially. + */ + int low = ch; size_t len = (src <= srcEnd-3) ? TclUtfToUCS4(src, &low) : 0; + if (((low & ~0x3FF) != 0xDC00) || (ch & 0x400)) { - *dst++ = (char) (((ch >> 12) | 0xE0) & 0xEF); - *dst++ = (char) (((ch >> 6) | 0x80) & 0xBF); - *dst++ = (char) ((ch | 0x80) & 0xBF); - continue; + *dst++ = (char) (((ch >> 12) | 0xE0) & 0xEF); + *dst++ = (char) (((ch >> 6) | 0x80) & 0xBF); + *dst++ = (char) ((ch | 0x80) & 0xBF); + continue; } src += len; dst += Tcl_UniCharToUtf(ch, dst); @@ -2326,13 +2335,21 @@ Utf16ToUtfProc( } result = TCL_OK; - /* check alignment with utf-16 (2 == sizeof(UTF-16)) */ + /* + * Check alignment with utf-16 (2 == sizeof(UTF-16)) + */ + if ((srcLen % 2) != 0) { result = TCL_CONVERT_MULTIBYTE; srcLen--; } - /* If last code point is a high surrogate, we cannot handle that yet */ - if ((srcLen >= 2) && ((src[srcLen - ((flags & TCL_ENCODING_LE)?1:2)] & 0xFC) == 0xD8)) { + + /* + * If last code point is a high surrogate, we cannot handle that yet. + */ + + if ((srcLen >= 2) && + ((src[srcLen - ((flags & TCL_ENCODING_LE)?1:2)] & 0xFC) == 0xD8)) { result = TCL_CONVERT_MULTIBYTE; srcLen-= 2; } @@ -2354,10 +2371,12 @@ Utf16ToUtfProc( } else { ch = (src[0] & 0xFF) << 8 | (src[1] & 0xFF); } + /* * Special case for 1-byte utf chars for speed. Make sure we work with * unsigned short-size data. */ + if (ch && ch < 0x80) { *dst++ = (ch & 0xFF); } else { @@ -2967,7 +2986,9 @@ Iso88591FromUtfProc( break; } #if TCL_UTF_MAX <= 3 - if ((ch >= 0xD800) && (len < 3)) len = 4; + if ((ch >= 0xD800) && (len < 3)) { + len = 4; + } #endif /* * Plunge on, using '?' as a fallback character. @@ -3012,7 +3033,7 @@ TableFreeProc( ClientData clientData) /* TableEncodingData that specifies * encoding. */ { - TableEncodingData *dataPtr = (TableEncodingData *)clientData; + TableEncodingData *dataPtr = (TableEncodingData *) clientData; /* * Make sure we aren't freeing twice on shutdown. [Bug 219314] @@ -3070,7 +3091,7 @@ EscapeToUtfProc( * correspond to the bytes stored in the * output buffer. */ { - EscapeEncodingData *dataPtr = (EscapeEncodingData *)clientData; + EscapeEncodingData *dataPtr = (EscapeEncodingData *) clientData; const char *prefixBytes, *tablePrefixBytes, *srcStart, *srcEnd; const unsigned short *const *tableToUnicode; const Encoding *encodingPtr; diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index feb5324..0b1963b 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -47,6 +47,7 @@ #define ZIPFS_VOLUME_LEN 9 #define ZIPFS_APP_MOUNT "//zipfs:/app" #define ZIPFS_ZIP_MOUNT "//zipfs:/lib/tcl" +#define ZIPFS_FALLBACK_ENCODING "cp437" /* * Various constants and offsets found in ZIP archive files @@ -262,11 +263,19 @@ static struct { int wrmax; /* Maximum write size of a file; only written * to from Tcl code in a trusted interpreter, * so NOT protected by mutex. */ + char *fallbackEntryEncoding;/* The fallback encoding for ZIP entries when + * they are believed to not be UTF-8; only + * written to from Tcl code in a trusted + * interpreter, so not protected by mutex. */ + Tcl_Encoding utf8; /* The UTF-8 encoding that we prefer to use + * for the strings (especially filenames) + * embedded in a ZIP. Other encodings are used + * dynamically. */ int idCount; /* Counter for channel names */ Tcl_HashTable fileHash; /* File name to ZipEntry mapping */ Tcl_HashTable zipHash; /* Mount to ZipFile mapping */ } ZipFS = { - 0, 0, 0, DEFAULT_WRITE_MAX_SIZE, 0, + 0, 0, 0, DEFAULT_WRITE_MAX_SIZE, NULL, NULL, 0, {0,{0,0,0,0},0,0,0,0,0,0,0,0,0}, {0,{0,0,0,0},0,0,0,0,0,0,0,0,0} }; @@ -686,6 +695,115 @@ CountSlashes( /* *------------------------------------------------------------------------- * + * DecodeZipEntryText -- + * + * Given a sequence of bytes from an entry in a ZIP central directory, + * convert that into a Tcl string. This is complicated because we don't + * actually know what encoding is in use! So we try to use UTF-8, and if + * that goes wrong, we fall back to a user-specified encoding, or to an + * encoding we specify (Windows code page 437), or to ISO 8859-1 if + * absolutely nothing else works. + * + * During Tcl startup, we skip the user-specified encoding and cp437, as + * we may well not have any loadable encodings yet. Tcl's own library + * files ought to be using ASCII filenames. + * + * Results: + * The decoded filename; the filename is owned by the argument DString. + * + * Side effects: + * Updates dstPtr. + * + *------------------------------------------------------------------------- + */ + +static char * +DecodeZipEntryText( + const unsigned char *inputBytes, + unsigned int inputLength, + Tcl_DString *dstPtr) +{ + Tcl_Encoding encoding; + const char *src; + char *dst; + int dstLen, srcLen = inputLength, flags; + Tcl_EncodingState state; + + Tcl_DStringInit(dstPtr); + if (inputLength < 1) { + return Tcl_DStringValue(dstPtr); + } + + /* + * We can't use Tcl_ExternalToUtfDString at this point; it has no way to + * fail. So we use this modified version of it that can report encoding + * errors to us (so we can fall back to something else). + * + * The utf-8 encoding is implemented internally, and so is guaranteed to + * be present. + */ + + src = (const char *) inputBytes; + dst = Tcl_DStringValue(dstPtr); + dstLen = dstPtr->spaceAvl - 1; + flags = TCL_ENCODING_START | TCL_ENCODING_END | + TCL_ENCODING_STOPONERROR; /* Special flag! */ + + while (1) { + int srcRead, dstWrote; + int result = Tcl_ExternalToUtf(NULL, ZipFS.utf8, src, srcLen, flags, + &state, dst, dstLen, &srcRead, &dstWrote, NULL); + int soFar = dst + dstWrote - Tcl_DStringValue(dstPtr); + + if (result == TCL_OK) { + Tcl_DStringSetLength(dstPtr, soFar); + return Tcl_DStringValue(dstPtr); + } else if (result != TCL_CONVERT_NOSPACE) { + break; + } + + flags &= ~TCL_ENCODING_START; + src += srcRead; + srcLen -= srcRead; + if (Tcl_DStringLength(dstPtr) == 0) { + Tcl_DStringSetLength(dstPtr, dstLen); + } + Tcl_DStringSetLength(dstPtr, 2 * Tcl_DStringLength(dstPtr) + 1); + dst = Tcl_DStringValue(dstPtr) + soFar; + dstLen = Tcl_DStringLength(dstPtr) - soFar - 1; + } + + /* + * Something went wrong. Fall back to another encoding. Those *can* use + * Tcl_ExternalToUtfDString(). + */ + + encoding = NULL; + if (ZipFS.fallbackEntryEncoding) { + encoding = Tcl_GetEncoding(NULL, ZipFS.fallbackEntryEncoding); + } + if (!encoding) { + encoding = Tcl_GetEncoding(NULL, ZIPFS_FALLBACK_ENCODING); + } + if (!encoding) { + /* + * Fallback to internal encoding that always converts all bytes. + * Should only happen when a filename isn't UTF-8 and we've not got + * our encodings initialised for some reason. + */ + + encoding = Tcl_GetEncoding(NULL, "iso8859-1"); + } + + char *converted = Tcl_ExternalToUtfDString(encoding, + (const char *) inputBytes, inputLength, dstPtr); + Tcl_FreeEncoding(encoding); + return converted; +} + +/* + *------------------------------------------------------------------------- + * * CanonicalPath -- * * This function computes the canonical path from a directory and file @@ -1546,9 +1664,7 @@ ZipFSCatalogFilesystem( pathlen = ZipReadShort(start, end, q + ZIP_CENTRAL_PATHLEN_OFFS); comlen = ZipReadShort(start, end, q + ZIP_CENTRAL_FCOMMENTLEN_OFFS); extra = ZipReadShort(start, end, q + ZIP_CENTRAL_EXTRALEN_OFFS); - Tcl_DStringSetLength(&ds, 0); - Tcl_DStringAppend(&ds, (char *) q + ZIP_CENTRAL_HEADER_LEN, pathlen); - path = Tcl_DStringValue(&ds); + path = DecodeZipEntryText(q + ZIP_CENTRAL_HEADER_LEN, pathlen, &ds); if ((pathlen > 0) && (path[pathlen - 1] == '/')) { Tcl_DStringSetLength(&ds, pathlen - 1); path = Tcl_DStringValue(&ds); @@ -1738,6 +1854,10 @@ ZipfsSetup(void) Tcl_InitHashTable(&ZipFS.zipHash, TCL_STRING_KEYS); ZipFS.idCount = 1; ZipFS.wrmax = DEFAULT_WRITE_MAX_SIZE; + ZipFS.fallbackEntryEncoding = + Tcl_Alloc(strlen(ZIPFS_FALLBACK_ENCODING) + 1); + strcpy(ZipFS.fallbackEntryEncoding, ZIPFS_FALLBACK_ENCODING); + ZipFS.utf8 = Tcl_GetEncoding(NULL, "utf-8"); ZipFS.initialized = 1; } @@ -2357,6 +2477,9 @@ RandomChar( * input file is added to the given fileHash table for later creation of * the central ZIP directory. * + * Tcl *always* encodes filenames in the ZIP as UTF-8. Similarly, it + * would always encode comments as UTF-8, if it supported comments. + * * Results: * A standard Tcl result. * @@ -2371,7 +2494,8 @@ static int ZipAddFile( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Obj *pathObj, /* Actual name of the file to add. */ - const char *name, /* Name to use in the ZIP archive. */ + const char *name, /* Name to use in the ZIP archive, in Tcl's + * internal encoding. */ Tcl_Channel out, /* The open ZIP archive being built. */ const char *passwd, /* Password for encoding the file, or NULL if * the file is to be unprotected. */ @@ -2386,7 +2510,10 @@ ZipAddFile( Tcl_HashEntry *hPtr; ZipEntry *z; z_stream stream; - const char *zpath; + Tcl_DString zpathDs; /* Buffer for the encoded filename. */ + const char *zpathExt; /* Filename in external encoding (true + * UTF-8). */ + const char *zpathTcl; /* Filename in Tcl's internal encoding. */ int crc, flush, zpathlen; size_t nbyte, nbytecompr, len, olen, align = 0; long long headerStartOffset, dataStartOffset, dataEndOffset; @@ -2399,23 +2526,31 @@ ZipAddFile( * nothing to do. */ - zpath = name; - while (zpath && zpath[0] == '/') { - zpath++; + zpathTcl = name; + while (zpathTcl && zpathTcl[0] == '/') { + zpathTcl++; } - if (!zpath || (zpath[0] == '\0')) { + if (!zpathTcl || (zpathTcl[0] == '\0')) { return TCL_OK; } - zpathlen = strlen(zpath); + /* + * Convert to encoded form. Note that we use strlen() here; if someone's + * crazy enough to embed NULs in filenames, they deserve what they get! + */ + + zpathExt = Tcl_UtfToExternalDString(ZipFS.utf8, zpathTcl, -1, &zpathDs); + zpathlen = strlen(zpathExt); if (zpathlen + ZIP_CENTRAL_HEADER_LEN > bufsize) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "path too long for \"%s\"", Tcl_GetString(pathObj))); ZIPFS_ERROR_CODE(interp, "PATH_LEN"); + Tcl_DStringFree(&zpathDs); return TCL_ERROR; } in = Tcl_FSOpenFileChannel(interp, pathObj, "rb", 0); if (!in) { + Tcl_DStringFree(&zpathDs); #ifdef _WIN32 /* hopefully a directory */ if (strcmp("permission denied", Tcl_PosixError(interp)) == 0) { @@ -2443,6 +2578,7 @@ ZipAddFile( while (1) { len = Tcl_Read(in, buf, bufsize); if (len == ERROR_LENGTH) { + Tcl_DStringFree(&zpathDs); if (nbyte == 0 && errno == EISDIR) { Tcl_Close(interp, in); return TCL_OK; @@ -2463,6 +2599,7 @@ ZipAddFile( Tcl_SetObjResult(interp, Tcl_ObjPrintf("seek error on \"%s\": %s", Tcl_GetString(pathObj), Tcl_PosixError(interp))); Tcl_Close(interp, in); + Tcl_DStringFree(&zpathDs); return TCL_ERROR; } @@ -2479,7 +2616,7 @@ ZipAddFile( */ memset(buf, '\0', ZIP_LOCAL_HEADER_LEN); - memcpy(buf + ZIP_LOCAL_HEADER_LEN, zpath, zpathlen); + memcpy(buf + ZIP_LOCAL_HEADER_LEN, zpathExt, zpathlen); len = zpathlen + ZIP_LOCAL_HEADER_LEN; if ((size_t) Tcl_Write(out, buf, len) != len) { writeErrorWithChannelOpen: @@ -2487,6 +2624,7 @@ ZipAddFile( "write error on \"%s\": %s", Tcl_GetString(pathObj), Tcl_PosixError(interp))); Tcl_Close(interp, in); + Tcl_DStringFree(&zpathDs); return TCL_ERROR; } @@ -2563,6 +2701,7 @@ ZipAddFile( "compression init error on \"%s\"", Tcl_GetString(pathObj))); ZIPFS_ERROR_CODE(interp, "DEFLATE_INIT"); Tcl_Close(interp, in); + Tcl_DStringFree(&zpathDs); return TCL_ERROR; } @@ -2585,6 +2724,7 @@ ZipAddFile( ZIPFS_ERROR_CODE(interp, "DEFLATE"); deflateEnd(&stream); Tcl_Close(interp, in); + Tcl_DStringFree(&zpathDs); return TCL_ERROR; } olen = sizeof(obuf) - stream.avail_out; @@ -2625,6 +2765,7 @@ ZipAddFile( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "seek error: %s", Tcl_PosixError(interp))); Tcl_Close(interp, in); + Tcl_DStringFree(&zpathDs); return TCL_ERROR; } nbytecompr = (passwd ? 12 : 0); @@ -2660,8 +2801,10 @@ ZipAddFile( Tcl_TruncateChannel(out, dataEndOffset); } Tcl_Close(interp, in); + Tcl_DStringFree(&zpathDs); + zpathExt = NULL; - hPtr = Tcl_CreateHashEntry(fileHash, zpath, &isNew); + hPtr = Tcl_CreateHashEntry(fileHash, zpathTcl, &isNew); if (!isNew) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "non-unique path name \"%s\"", Tcl_GetString(pathObj))); @@ -2758,8 +2901,8 @@ ZipFSFind( * should be skipped. * * Returns: - * Pointer to the name, which will be in memory owned by one of the - * argument objects. + * Pointer to the name (in Tcl's internal encoding), which will be in + * memory owned by one of the argument objects. * * Side effects: * None (if Tcl_Objs have string representations) @@ -2772,8 +2915,10 @@ ComputeNameInArchive( Tcl_Obj *pathObj, /* The path to the origin file */ Tcl_Obj *directNameObj, /* User-specified name for use in the ZIP * archive */ - const char *strip, /* A prefix to strip */ - int slen) /* The length of the prefix */ + const char *strip, /* A prefix to strip; may be NULL if no + * stripping need be done. */ + int slen) /* The length of the prefix; must be 0 if no + * stripping need be done. */ { const char *name; int len; @@ -2811,6 +2956,9 @@ ComputeNameInArchive( * file. It's the core of the implementation of [zipfs mkzip], [zipfs * mkimg], [zipfs lmkzip] and [zipfs lmkimg]. * + * Tcl *always* encodes filenames in the ZIP as UTF-8. Similarly, it + * would always encode comments as UTF-8, if it supported comments. + * * Results: * A standard Tcl result. * @@ -3023,6 +3171,9 @@ ZipFSMkZipOrImg( dataStartOffset = Tcl_Tell(out); if (mappingList == NULL && stripPrefix != NULL) { strip = Tcl_GetStringFromObj(stripPrefix, &slen); + if (!slen) { + strip = NULL; + } } for (i = 0; i < (size_t) lobjc; i += (mappingList ? 2 : 1)) { Tcl_Obj *pathObj = lobjv[i]; @@ -3047,25 +3198,27 @@ ZipFSMkZipOrImg( for (i = 0; i < (size_t) lobjc; i += (mappingList ? 2 : 1)) { const char *name = ComputeNameInArchive(lobjv[i], (mappingList ? lobjv[i + 1] : NULL), strip, slen); + Tcl_DString ds; - if (name[0] == '\0') { - continue; - } hPtr = Tcl_FindHashEntry(&fileHash, name); if (!hPtr) { continue; } z = (ZipEntry *) Tcl_GetHashValue(hPtr); - len = strlen(z->name); + + name = Tcl_UtfToExternalDString(ZipFS.utf8, z->name, -1, &ds); + len = Tcl_DStringLength(&ds); SerializeCentralDirectoryEntry(start, end, (unsigned char *) buf, z, len, dataStartOffset); if ((Tcl_Write(out, buf, ZIP_CENTRAL_HEADER_LEN) != ZIP_CENTRAL_HEADER_LEN) - || ((size_t) Tcl_Write(out, z->name, len) != len)) { + || ((size_t) Tcl_Write(out, name, len) != len)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "write error: %s", Tcl_PosixError(interp))); + Tcl_DStringFree(&ds); goto done; } + Tcl_DStringFree(&ds); count++; } @@ -5517,6 +5670,8 @@ TclZipfs_Init( if (!Tcl_IsSafe(interp)) { Tcl_LinkVar(interp, "::tcl::zipfs::wrmax", (char *) &ZipFS.wrmax, TCL_LINK_INT); + Tcl_LinkVar(interp, "::tcl::zipfs::fallbackEntryEncoding", + (char *) &ZipFS.fallbackEntryEncoding, TCL_LINK_STRING); } ensemble = TclMakeEnsemble(interp, "zipfs", Tcl_IsSafe(interp) ? (initMap + 4) : initMap); -- cgit v0.12 From fff5060d945d7ee8f74e84dea9b0f703e2bae424 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 19 Mar 2021 09:20:26 +0000 Subject: Change Tcl_StaticPackage's "pkgName" argument to "prefix" and improve documentation, describing better what this argument does. --- doc/StaticPkg.3 | 8 +++--- doc/load.n | 71 +++++++++++++++++++++++++-------------------------- doc/unload.n | 36 +++++++++++++------------- generic/tcl.decls | 2 +- generic/tclDecls.h | 4 +-- generic/tclInt.decls | 2 +- generic/tclIntDecls.h | 4 +-- generic/tclLoad.c | 62 ++++++++++++++++++++++---------------------- generic/tclTest.c | 2 +- tests/load.test | 2 +- 10 files changed, 96 insertions(+), 97 deletions(-) diff --git a/doc/StaticPkg.3 b/doc/StaticPkg.3 index 41e2d65..bd00ab7 100644 --- a/doc/StaticPkg.3 +++ b/doc/StaticPkg.3 @@ -13,7 +13,7 @@ Tcl_StaticPackage \- make a statically linked package available via the 'load' c .nf \fB#include \fR .sp -\fBTcl_StaticPackage\fR(\fIinterp, pkgName, initProc, safeInitProc\fR) +\fBTcl_StaticPackage\fR(\fIinterp, prefix, initProc, safeInitProc\fR) .SH ARGUMENTS .AS Tcl_PackageInitProc *safeInitProc .AP Tcl_Interp *interp in @@ -21,9 +21,9 @@ 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 "const char" *prefix in +Prefix for library initialization function; 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. diff --git a/doc/load.n b/doc/load.n index b592bb3..54d90a3 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,21 @@ 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 +procedure will have the form \fIpfx\fB_Init\fR, where \fIpfx\fR +is the same as \fIprefix\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 +are converted to lower case. For example, if \fIprefix\fR is \fBfoo\fR or \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 \fIpfx\fB_SafeInit\fR +instead of \fIpfx\fB_Init\fR. +The \fIpfx\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 +61,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 +73,36 @@ 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 +The \fBload\fR command also supports libraries that are statically +linked with the application, if those libraries have been registered by calling the \fBTcl_StaticPackage\fR procedure. -If \fIfileName\fR is an empty string, then \fIpackageName\fR must +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. 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, 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 +The \fBload\fR command first searches for a statically loaded library (one that has been registered by calling the \fBTcl_StaticPackage\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 +110,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 @@ -154,7 +153,7 @@ The following is a minimal extension: .CS #include #include -static int fooCmd(ClientData clientData, +static int fooCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { printf("called with %d arguments\en", objc); return TCL_OK; diff --git a/doc/unload.n b/doc/unload.n index 0a8e99b..61caca1 100644 --- a/doc/unload.n +++ b/doc/unload.n @@ -13,9 +13,9 @@ unload \- Unload machine code .SH SYNOPSIS \fBunload \fR?\fIswitches\fR? \fIfileName\fR .br -\fBunload \fR?\fIswitches\fR? \fIfileName packageName\fR +\fBunload \fR?\fIswitches\fR? \fIfileName prefix\fR .br -\fBunload \fR?\fIswitches\fR? \fIfileName packageName interp\fR +\fBunload \fR?\fIswitches\fR? \fIfileName prefix interp\fR .BE .SH DESCRIPTION .PP @@ -24,7 +24,7 @@ with \fBload\fR from the application's address space. \fIfileName\fR is the name of the file containing the library file to be unload; it must be the same as the filename provided to \fBload\fR for loading the library. -The \fIpackageName\fR argument is the name of the package (as +The \fIprefix\fR argument is the prefix (as determined by or passed to \fBload\fR), and is used to compute the name of the unload procedure; if not supplied, it is computed from \fIfileName\fR in the same manner as \fBload\fR. @@ -66,12 +66,12 @@ proper reference count. \fBunload\fR works in the opposite direction. As a first step, \fBunload\fR will check whether the library is unloadable: an unloadable library exports a special unload procedure. The name of the unload 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_Unload\fR, where \fIpkg\fR -is the same as \fIpackageName\fR except that the first letter is +procedure will have the form \fIpfx\fB_Unload\fR, where \fIpfx\fR +is the same as \fIprefix\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 +are converted to lower case. For example, if \fIprefix\fR is \fBfoo\fR or \fBFOo\fR, the initialization procedure's name will be \fBFoo_Unload\fR. If the target interpreter is a safe interpreter, then the name @@ -114,19 +114,19 @@ the \fIflags\fR argument will be set to \fBTCL_UNLOAD_DETACH_FROM_PROCESS\fR. .PP The \fBunload\fR command cannot unload libraries that are statically linked with the application. -If \fIfileName\fR is an empty string, then the \fIpackageName\fR argument must +If \fIfileName\fR is an empty string, then the \fIprefix\fR argument 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 \fBunload libxyz4.2.so\fR uses the module -name \fBxyz\fR and the command \fBunload bin/last.so {}\fR uses the -module name \fBlast\fR. +If \fIprefix\fR is omitted or specified as an empty string, +Tcl tries to guess the prefix. 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, converted to titlecase as the prefix. +For example, the command \fBunload libxyz4.2.so\fR uses the prefix +\fBXyz\fR and the command \fBunload bin/last.so {}\fR uses the +prefix \fBLast\fR. .SH "PORTABILITY ISSUES" .TP \fBUnix\fR\0\0\0\0\0 diff --git a/generic/tcl.decls b/generic/tcl.decls index 6583aff..05cecdd 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -861,7 +861,7 @@ declare 243 { void Tcl_SplitPath(const char *path, int *argcPtr, CONST84 char ***argvPtr) } declare 244 { - void Tcl_StaticPackage(Tcl_Interp *interp, const char *pkgName, + void Tcl_StaticPackage(Tcl_Interp *interp, const char *prefix, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc) } declare 245 { diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 89c2808..37764da 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -725,7 +725,7 @@ EXTERN void Tcl_SplitPath(const char *path, int *argcPtr, CONST84 char ***argvPtr); /* 244 */ EXTERN void Tcl_StaticPackage(Tcl_Interp *interp, - const char *pkgName, + const char *prefix, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 245 */ @@ -2121,7 +2121,7 @@ typedef struct TclStubs { void (*tcl_SourceRCFile) (Tcl_Interp *interp); /* 241 */ int (*tcl_SplitList) (Tcl_Interp *interp, const char *listStr, int *argcPtr, CONST84 char ***argvPtr); /* 242 */ void (*tcl_SplitPath) (const char *path, int *argcPtr, CONST84 char ***argvPtr); /* 243 */ - void (*tcl_StaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 244 */ + void (*tcl_StaticPackage) (Tcl_Interp *interp, const char *prefix, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 244 */ int (*tcl_StringMatch) (const char *str, const char *pattern); /* 245 */ int (*tcl_TellOld) (Tcl_Channel chan); /* 246 */ int (*tcl_TraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 247 */ diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 3c3b50a..6e36971 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -1040,7 +1040,7 @@ declare 256 { } declare 257 { - void TclStaticPackage(Tcl_Interp *interp, const char *pkgName, + void TclStaticPackage(Tcl_Interp *interp, const char *prefix, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc) } diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index b7ac0e7..27fbb86 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -640,7 +640,7 @@ EXTERN int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Obj *part2Ptr, const int flags); /* 257 */ EXTERN void TclStaticPackage(Tcl_Interp *interp, - const char *pkgName, + const char *prefix, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* Slot 258 is reserved */ @@ -909,7 +909,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 (*tclStaticPackage) (Tcl_Interp *interp, const char *prefix, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 257 */ void (*reserved258)(void); void (*reserved259)(void); void (*tclUnusedStubEntry) (void); /* 260 */ diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 9ca2e7a..a6fd7ec 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -122,7 +122,7 @@ Tcl_LoadObjCmd( { Tcl_Interp *target; LoadedPackage *pkgPtr, *defaultPtr; - Tcl_DString pkgName, tmp, initName, safeInitName; + Tcl_DString prefix, tmp, initName, safeInitName; Tcl_DString unloadName, safeUnloadName; InterpPackage *ipFirstPtr, *ipPtr; int code, namesMatch, filesMatch, offset; @@ -167,7 +167,7 @@ Tcl_LoadObjCmd( } fullFileName = Tcl_GetString(objv[1]); - Tcl_DStringInit(&pkgName); + Tcl_DStringInit(&prefix); Tcl_DStringInit(&initName); Tcl_DStringInit(&safeInitName); Tcl_DStringInit(&unloadName); @@ -222,20 +222,20 @@ Tcl_LoadObjCmd( if (packageName == NULL) { namesMatch = 0; } else { - TclDStringClear(&pkgName); - Tcl_DStringAppend(&pkgName, packageName, -1); + TclDStringClear(&prefix); + Tcl_DStringAppend(&prefix, packageName, -1); TclDStringClear(&tmp); Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1); - Tcl_UtfToLower(Tcl_DStringValue(&pkgName)); + Tcl_UtfToLower(Tcl_DStringValue(&prefix)); Tcl_UtfToLower(Tcl_DStringValue(&tmp)); if (strcmp(Tcl_DStringValue(&tmp), - Tcl_DStringValue(&pkgName)) == 0) { + Tcl_DStringValue(&prefix)) == 0) { namesMatch = 1; } else { namesMatch = 0; } } - TclDStringClear(&pkgName); + TclDStringClear(&prefix); filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0); if (filesMatch && (namesMatch || (packageName == NULL))) { @@ -300,7 +300,7 @@ Tcl_LoadObjCmd( */ if (packageName != NULL) { - Tcl_DStringAppend(&pkgName, packageName, -1); + Tcl_DStringAppend(&prefix, packageName, -1); } else { int retc; @@ -308,7 +308,7 @@ Tcl_LoadObjCmd( * Threading note - this call used to be protected by a mutex. */ - retc = TclGuessPackageName(fullFileName, &pkgName); + retc = TclGuessPackageName(fullFileName, &prefix); if (!retc) { Tcl_Obj *splitPtr, *pkgGuessPtr; int pElements; @@ -353,7 +353,7 @@ Tcl_LoadObjCmd( code = TCL_ERROR; goto done; } - Tcl_DStringAppend(&pkgName, pkgGuess, p - pkgGuess); + Tcl_DStringAppend(&prefix, pkgGuess, p - pkgGuess); Tcl_DecrRefCount(splitPtr); } } @@ -364,21 +364,21 @@ Tcl_LoadObjCmd( * lower-case. */ - Tcl_DStringSetLength(&pkgName, - Tcl_UtfToTitle(Tcl_DStringValue(&pkgName))); + Tcl_DStringSetLength(&prefix, + Tcl_UtfToTitle(Tcl_DStringValue(&prefix))); /* * Compute the names of the two initialization functions, based on the * package name. */ - TclDStringAppendDString(&initName, &pkgName); + TclDStringAppendDString(&initName, &prefix); TclDStringAppendLiteral(&initName, "_Init"); - TclDStringAppendDString(&safeInitName, &pkgName); + TclDStringAppendDString(&safeInitName, &prefix); TclDStringAppendLiteral(&safeInitName, "_SafeInit"); - TclDStringAppendDString(&unloadName, &pkgName); + TclDStringAppendDString(&unloadName, &prefix); TclDStringAppendLiteral(&unloadName, "_Unload"); - TclDStringAppendDString(&safeUnloadName, &pkgName); + TclDStringAppendDString(&safeUnloadName, &prefix); TclDStringAppendLiteral(&safeUnloadName, "_SafeUnload"); /* @@ -405,9 +405,9 @@ Tcl_LoadObjCmd( len = strlen(fullFileName) + 1; pkgPtr->fileName = ckalloc(len); memcpy(pkgPtr->fileName, fullFileName, len); - len = (unsigned) Tcl_DStringLength(&pkgName) + 1; + len = (unsigned) Tcl_DStringLength(&prefix) + 1; pkgPtr->packageName = ckalloc(len); - memcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName), len); + memcpy(pkgPtr->packageName, Tcl_DStringValue(&prefix), len); pkgPtr->loadHandle = loadHandle; pkgPtr->initProc = initProc; pkgPtr->safeInitProc = (Tcl_PackageInitProc *) @@ -501,7 +501,7 @@ Tcl_LoadObjCmd( Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipPtr); done: - Tcl_DStringFree(&pkgName); + Tcl_DStringFree(&prefix); Tcl_DStringFree(&initName); Tcl_DStringFree(&safeInitName); Tcl_DStringFree(&unloadName); @@ -536,7 +536,7 @@ Tcl_UnloadObjCmd( { Tcl_Interp *target; /* Which interpreter to unload from. */ LoadedPackage *pkgPtr, *defaultPtr; - Tcl_DString pkgName, tmp; + Tcl_DString prefix, tmp; Tcl_PackageUnloadProc *unloadProc; InterpPackage *ipFirstPtr, *ipPtr; int i, index, code, complain = 1, keepLibrary = 0; @@ -594,7 +594,7 @@ Tcl_UnloadObjCmd( } fullFileName = Tcl_GetString(objv[i]); - Tcl_DStringInit(&pkgName); + Tcl_DStringInit(&prefix); Tcl_DStringInit(&tmp); packageName = NULL; @@ -646,20 +646,20 @@ Tcl_UnloadObjCmd( if (packageName == NULL) { namesMatch = 0; } else { - TclDStringClear(&pkgName); - Tcl_DStringAppend(&pkgName, packageName, -1); + TclDStringClear(&prefix); + Tcl_DStringAppend(&prefix, packageName, -1); TclDStringClear(&tmp); Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1); - Tcl_UtfToLower(Tcl_DStringValue(&pkgName)); + Tcl_UtfToLower(Tcl_DStringValue(&prefix)); Tcl_UtfToLower(Tcl_DStringValue(&tmp)); if (strcmp(Tcl_DStringValue(&tmp), - Tcl_DStringValue(&pkgName)) == 0) { + Tcl_DStringValue(&prefix)) == 0) { namesMatch = 1; } else { namesMatch = 0; } } - TclDStringClear(&pkgName); + TclDStringClear(&prefix); filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0); if (filesMatch && (namesMatch || (packageName == NULL))) { @@ -899,7 +899,7 @@ Tcl_UnloadObjCmd( } done: - Tcl_DStringFree(&pkgName); + Tcl_DStringFree(&prefix); Tcl_DStringFree(&tmp); if (!complain && (code != TCL_OK)) { code = TCL_OK; @@ -932,7 +932,7 @@ Tcl_StaticPackage( * already been loaded into the given * interpreter by calling the appropriate init * proc. */ - const char *pkgName, /* Name of package (must be properly + const char *prefix, /* Prefix (must be properly * capitalized: first letter upper case, * others lower case). */ Tcl_PackageInitProc *initProc, @@ -957,7 +957,7 @@ Tcl_StaticPackage( for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { if ((pkgPtr->initProc == initProc) && (pkgPtr->safeInitProc == safeInitProc) - && (strcmp(pkgPtr->packageName, pkgName) == 0)) { + && (strcmp(pkgPtr->packageName, prefix) == 0)) { break; } } @@ -972,8 +972,8 @@ Tcl_StaticPackage( pkgPtr = ckalloc(sizeof(LoadedPackage)); pkgPtr->fileName = ckalloc(1); pkgPtr->fileName[0] = 0; - pkgPtr->packageName = ckalloc(strlen(pkgName) + 1); - strcpy(pkgPtr->packageName, pkgName); + pkgPtr->packageName = ckalloc(strlen(prefix) + 1); + strcpy(pkgPtr->packageName, prefix); pkgPtr->loadHandle = NULL; pkgPtr->initProc = initProc; pkgPtr->safeInitProc = safeInitProc; diff --git a/generic/tclTest.c b/generic/tclTest.c index 2c29cda..a759e74 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -4185,7 +4185,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) { diff --git a/tests/load.test b/tests/load.test index c79ddf4..b13f1f4 100644 --- a/tests/load.test +++ b/tests/load.test @@ -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 -- cgit v0.12 From d5479489aab71c267a1371d2ac1d0674a15a0c61 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 19 Mar 2021 12:58:41 +0000 Subject: Fully implement TCL_ENCODING_STOPONERROR flag for Utf2Utf encoder/decoder. --- generic/tclEncoding.c | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 688d46e..4eabbda 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2225,7 +2225,7 @@ UtfToUtfProc( result = TCL_CONVERT_NOSPACE; break; } - if ((UCHAR(*src - 1) < 0x7F) && !(flags & TCL_ENCODING_EXTERNAL)) { + if (UCHAR(*src) < 0x80 && !(UCHAR(*src) == 0 && !(flags & TCL_ENCODING_EXTERNAL))) { /* * Copy 7bit characters, but skip null-bytes when we are in input * mode, so that they get converted to 0xC080. @@ -2256,14 +2256,19 @@ UtfToUtfProc( src += 1; dst += Tcl_UniCharToUtf(ch, dst); } else { - src += TclUtfToUCS4(src, &ch); + size_t len = TclUtfToUCS4(src, &ch); + if ((len < 2) && (ch != 0) && (flags & TCL_ENCODING_STOPONERROR)) { + result = TCL_CONVERT_SYNTAX; + break; + } + src += len; if ((ch | 0x7FF) == 0xDFFF) { /* * A surrogate character is detected, handle especially. */ int low = ch; - size_t len = (src <= srcEnd-3) ? TclUtfToUCS4(src, &low) : 0; + len = (src <= srcEnd-3) ? TclUtfToUCS4(src, &low) : 0; if (((low & ~0x3FF) != 0xDC00) || (ch & 0x400)) { *dst++ = (char) (((ch >> 12) | 0xE0) & 0xEF); -- cgit v0.12 From dd9f3c1246178a54af32d25015227a5a1a7dced8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 21 Mar 2021 09:27:07 +0000 Subject: Implement TCL_ENCODING_STOPONERROR flag for UtfToUtf encoder/decoder. Backported from 8.7 --- generic/tclEncoding.c | 32 +++++++++++++++++++++++++------- 1 file changed, 25 insertions(+), 7 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index f1529e1..012c954 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2345,15 +2345,24 @@ UtfToUtfProc( /* * Always check before using TclUtfToUniChar. Not doing can so * cause it run beyond the end of the buffer! If we happen such an - * incomplete char its bytes are made to represent themselves. + * incomplete char its bytes are made to represent themselves + * unless the user has explicitly asked to be told. */ + if (flags & TCL_ENCODING_STOPONERROR) { + result = TCL_CONVERT_MULTIBYTE; + break; + } *chPtr = UCHAR(*src); src += 1; dst += Tcl_UniCharToUtf(*chPtr, dst); } else { size_t len = TclUtfToUniChar(src, chPtr); - + if ((len < 2) && (flags & TCL_ENCODING_STOPONERROR) && (*chPtr != 0) + && ((*chPtr & ~0x7FF) != 0xD800)) { + result = TCL_CONVERT_SYNTAX; + break; + } src += len; if ((*chPtr & ~0x7FF) == 0xD800) { Tcl_UniChar low; @@ -2453,8 +2462,13 @@ UnicodeToUtfProc( result = TCL_CONVERT_MULTIBYTE; srcLen--; } - /* If last code point is a high surrogate, we cannot handle that yet */ - if ((srcLen >= 2) && ((src[srcLen - (clientData?1:2)] & 0xFC) == 0xD8)) { + + /* + * If last code point is a high surrogate, we cannot handle that yet. + */ + + if ((srcLen >= 2) && + ((src[srcLen - (clientData?1:2)] & 0xFC) == 0xD8)) { result = TCL_CONVERT_MULTIBYTE; srcLen-= 2; } @@ -2476,10 +2490,12 @@ UnicodeToUtfProc( } else { ch = (src[0] & 0xFF) << 8 | (src[1] & 0xFF); } + /* * Special case for 1-byte utf chars for speed. Make sure we work with * unsigned short-size data. */ + if (ch && ch < 0x80) { *dst++ = (ch & 0xFF); } else { @@ -3015,7 +3031,9 @@ Iso88591FromUtfProc( break; } #if TCL_UTF_MAX == 4 - if ((ch >= 0xD800) && (len < 3)) len = 4; + if ((ch >= 0xD800) && (len < 3)) { + len = 4; + } #endif /* * Plunge on, using '?' as a fallback character. @@ -3060,7 +3078,7 @@ TableFreeProc( ClientData clientData) /* TableEncodingData that specifies * encoding. */ { - TableEncodingData *dataPtr = (TableEncodingData *)clientData; + TableEncodingData *dataPtr = (TableEncodingData *) clientData; /* * Make sure we aren't freeing twice on shutdown. [Bug 219314] @@ -3118,7 +3136,7 @@ EscapeToUtfProc( * correspond to the bytes stored in the * output buffer. */ { - EscapeEncodingData *dataPtr = (EscapeEncodingData *)clientData; + EscapeEncodingData *dataPtr = (EscapeEncodingData *) clientData; const char *prefixBytes, *tablePrefixBytes, *srcStart, *srcEnd; const unsigned short *const *tableToUnicode; const Encoding *encodingPtr; -- cgit v0.12 From 9e6945739aa490d624e42622e9e0f5f2d695c80b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 22 Mar 2021 10:00:06 +0000 Subject: Rename internal variables, making it more clear that tclLoad.c is not part of Tcl's "package" mechanism. --- generic/tclLoad.c | 324 +++++++++++++++++++++++++++--------------------------- 1 file changed, 162 insertions(+), 162 deletions(-) diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 8b92ac3..0fd21c0 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -21,13 +21,13 @@ * freed. */ -typedef struct LoadedPackage { +typedef struct LoadedLibrary { 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, * properly capitalized (first letter UC, - * others LC), no "_", as in "Net". + * others LC), as in "Net". * Malloc-ed. */ Tcl_LoadHandle loadHandle; /* Token for the loaded file which should be * passed to (*unLoadProcPtr)() when the file @@ -55,23 +55,23 @@ typedef struct LoadedPackage { * in trusted interpreters. */ int safeInterpRefCount; /* How many times the library has been loaded * in safe interpreters. */ - struct LoadedPackage *nextPtr; + struct LoadedLibrary *nextPtr; /* Next in list of all libraries loaded into * this application process. NULL means end of * list. */ -} LoadedPackage; +} LoadedLibrary; /* * TCL_THREADS - * There is a global list of libraries that is anchored at firstPackagePtr. + * There is a global list of libraries 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 libraries loaded into * this process. */ -TCL_DECLARE_MUTEX(packageMutex) +TCL_DECLARE_MUTEX(libraryMutex) /* * The following structure represents a particular library that has been @@ -81,13 +81,13 @@ TCL_DECLARE_MUTEX(packageMutex) * first library (if any). */ -typedef struct InterpPackage { - LoadedPackage *pkgPtr; /* Points to detailed information about +typedef struct InterpLibrary { + LoadedLibrary *libraryPtr; /* Points to detailed information about * library. */ - struct InterpPackage *nextPtr; + struct InterpLibrary *nextPtr; /* Next library in this interpreter, or NULL * for end of list. */ -} InterpPackage; +} InterpLibrary; /* * Prototypes for functions that are private to this file: @@ -121,10 +121,10 @@ Tcl_LoadObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Interp *target; - LoadedPackage *pkgPtr, *defaultPtr; + LoadedLibrary *libraryPtr, *defaultPtr; Tcl_DString pfx, 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; @@ -215,17 +215,17 @@ Tcl_LoadObjCmd( * only no statically loaded library with the same prefix. */ - Tcl_MutexLock(&packageMutex); + Tcl_MutexLock(&libraryMutex); defaultPtr = NULL; - for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { + for (libraryPtr = firstLibraryPtr; libraryPtr != NULL; libraryPtr = libraryPtr->nextPtr) { if (prefix == NULL) { namesMatch = 0; } else { TclDStringClear(&pfx); Tcl_DStringAppend(&pfx, prefix, -1); TclDStringClear(&tmp); - Tcl_DStringAppend(&tmp, pkgPtr->prefix, -1); + Tcl_DStringAppend(&tmp, libraryPtr->prefix, -1); Tcl_UtfToLower(Tcl_DStringValue(&pfx)); Tcl_UtfToLower(Tcl_DStringValue(&tmp)); if (strcmp(Tcl_DStringValue(&tmp), @@ -237,12 +237,12 @@ Tcl_LoadObjCmd( } TclDStringClear(&pfx); - filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0); + 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)) { /* @@ -251,17 +251,17 @@ Tcl_LoadObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "file \"%s\" is already loaded for prefix \"%s\"", - fullFileName, pkgPtr->prefix)); + 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; } /* @@ -270,17 +270,17 @@ Tcl_LoadObjCmd( * there's nothing for us to do. */ - if (pkgPtr != NULL) { - ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL); + if (libraryPtr != NULL) { + ipFirstPtr = (InterpLibrary *)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 library is a static one. @@ -388,10 +388,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; } @@ -400,31 +400,31 @@ Tcl_LoadObjCmd( * Create a new record to describe this library. */ - pkgPtr = (LoadedPackage *)ckalloc(sizeof(LoadedPackage)); + libraryPtr = (LoadedLibrary *)ckalloc(sizeof(LoadedLibrary)); len = strlen(fullFileName) + 1; - pkgPtr->fileName = (char *)ckalloc(len); - memcpy(pkgPtr->fileName, fullFileName, len); + libraryPtr->fileName = (char *)ckalloc(len); + memcpy(libraryPtr->fileName, fullFileName, len); len = Tcl_DStringLength(&pfx) + 1; - pkgPtr->prefix = (char *)ckalloc(len); - memcpy(pkgPtr->prefix, Tcl_DStringValue(&pfx), len); - pkgPtr->loadHandle = loadHandle; - pkgPtr->initProc = initProc; - pkgPtr->safeInitProc = (Tcl_PackageInitProc *) + libraryPtr->prefix = (char *)ckalloc(len); + memcpy(libraryPtr->prefix, Tcl_DStringValue(&pfx), 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 @@ -440,27 +440,27 @@ Tcl_LoadObjCmd( */ if (Tcl_IsSafe(target)) { - if (pkgPtr->safeInitProc == NULL) { + if (libraryPtr->safeInitProc == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't use library in a safe interpreter: no" - " %s_SafeInit procedure", pkgPtr->prefix)); + " %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 library to interpreter: no %s_Init procedure", - pkgPtr->prefix)); + libraryPtr->prefix)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "ENTRYPOINT", NULL); code = TCL_ERROR; goto done; } - code = pkgPtr->initProc(target); + code = libraryPtr->initProc(target); } /* @@ -493,22 +493,22 @@ 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 library may have introduced additional * static libraries at the head of the linked list! */ - ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL); - ipPtr = (InterpPackage *)ckalloc(sizeof(InterpPackage)); - ipPtr->pkgPtr = pkgPtr; + ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL); + ipPtr = (InterpLibrary *)ckalloc(sizeof(InterpLibrary)); + ipPtr->libraryPtr = libraryPtr; ipPtr->nextPtr = ipFirstPtr; Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipPtr); @@ -547,10 +547,10 @@ Tcl_UnloadObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Interp *target; /* Which interpreter to unload from. */ - LoadedPackage *pkgPtr, *defaultPtr; + LoadedLibrary *libraryPtr, *defaultPtr; Tcl_DString pfx, 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 = ""; @@ -649,10 +649,10 @@ Tcl_UnloadObjCmd( * only no statically loaded library with the same prefix. */ - 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 (prefix == NULL) { @@ -661,7 +661,7 @@ Tcl_UnloadObjCmd( TclDStringClear(&pfx); Tcl_DStringAppend(&pfx, prefix, -1); TclDStringClear(&tmp); - Tcl_DStringAppend(&tmp, pkgPtr->prefix, -1); + Tcl_DStringAppend(&tmp, libraryPtr->prefix, -1); Tcl_UtfToLower(Tcl_DStringValue(&pfx)); Tcl_UtfToLower(Tcl_DStringValue(&tmp)); if (strcmp(Tcl_DStringValue(&tmp), @@ -673,18 +673,18 @@ Tcl_UnloadObjCmd( } TclDStringClear(&pfx); - filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0); + 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 library. @@ -698,7 +698,7 @@ Tcl_UnloadObjCmd( code = TCL_ERROR; goto done; } - if (pkgPtr == NULL) { + if (libraryPtr == NULL) { /* * The DLL pointed by the provided filename has never been loaded. */ @@ -718,10 +718,10 @@ Tcl_UnloadObjCmd( */ code = TCL_ERROR; - if (pkgPtr != NULL) { - ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL); + if (libraryPtr != NULL) { + ipFirstPtr = (InterpLibrary *)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; } @@ -743,12 +743,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)); @@ -757,9 +757,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)); @@ -768,7 +768,7 @@ Tcl_UnloadObjCmd( code = TCL_ERROR; goto done; } - unloadProc = pkgPtr->unloadProc; + unloadProc = libraryPtr->unloadProc; } /* @@ -783,10 +783,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--; @@ -809,34 +809,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... @@ -850,21 +850,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; } } @@ -874,16 +874,16 @@ 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->pkgPtr == defaultPtr) { + if (ipPtr->libraryPtr == defaultPtr) { ipFirstPtr = ipFirstPtr->nextPtr; } else { - InterpPackage *ipPrevPtr; + InterpLibrary *ipPrevPtr; for (ipPrevPtr = ipPtr; ipPtr != NULL; ipPrevPtr = ipPtr, ipPtr = ipPtr->nextPtr) { - if (ipPtr->pkgPtr == defaultPtr) { + if (ipPtr->libraryPtr == defaultPtr) { ipPrevPtr->nextPtr = ipPtr->nextPtr; break; } @@ -895,7 +895,7 @@ Tcl_UnloadObjCmd( ckfree(defaultPtr->prefix); ckfree(defaultPtr); ckfree(ipPtr); - Tcl_MutexUnlock(&packageMutex); + Tcl_MutexUnlock(&libraryMutex); } else { code = TCL_ERROR; } @@ -957,42 +957,42 @@ Tcl_StaticPackage( * the library can't be used in safe * interpreters. */ { - LoadedPackage *pkgPtr; - InterpPackage *ipPtr, *ipFirstPtr; + LoadedLibrary *libraryPtr; + InterpLibrary *ipPtr, *ipFirstPtr; /* * Check to see if someone else has already reported this library as * 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->prefix, prefix) == 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 library is not yet recorded as being loaded statically, add it * to the list now. */ - if (pkgPtr == NULL) { - pkgPtr = (LoadedPackage *)ckalloc(sizeof(LoadedPackage)); - pkgPtr->fileName = (char *)ckalloc(1); - pkgPtr->fileName[0] = 0; - pkgPtr->prefix = (char *)ckalloc(strlen(prefix) + 1); - strcpy(pkgPtr->prefix, prefix); - 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 *)ckalloc(sizeof(LoadedLibrary)); + libraryPtr->fileName = (char *)ckalloc(1); + libraryPtr->fileName[0] = 0; + libraryPtr->prefix = (char *)ckalloc(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) { @@ -1002,9 +1002,9 @@ Tcl_StaticPackage( * 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->pkgPtr == pkgPtr) { + if (ipPtr->libraryPtr == libraryPtr) { return; } } @@ -1014,8 +1014,8 @@ Tcl_StaticPackage( * loaded. */ - ipPtr = (InterpPackage *)ckalloc(sizeof(InterpPackage)); - ipPtr->pkgPtr = pkgPtr; + ipPtr = (InterpLibrary *)ckalloc(sizeof(InterpLibrary)); + ipPtr->libraryPtr = libraryPtr; ipPtr->nextPtr = ipFirstPtr; Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc, ipPtr); } @@ -1055,21 +1055,21 @@ TclGetLoadedPackagesEx( */ { Tcl_Interp *target; - LoadedPackage *pkgPtr; - InterpPackage *ipPtr; + LoadedLibrary *libraryPtr; + InterpLibrary *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->prefix, -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; } @@ -1078,7 +1078,7 @@ TclGetLoadedPackagesEx( 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 libraries. @@ -1087,10 +1087,10 @@ TclGetLoadedPackagesEx( resultObj = NULL; for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { - pkgPtr = ipPtr->pkgPtr; + libraryPtr = ipPtr->libraryPtr; - if (!strcmp(prefix, pkgPtr->prefix)) { - resultObj = Tcl_NewStringObj(pkgPtr->fileName, -1); + if (!strcmp(prefix, libraryPtr->prefix)) { + resultObj = Tcl_NewStringObj(libraryPtr->fileName, -1); break; } } @@ -1108,9 +1108,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->prefix, -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); @@ -1122,7 +1122,7 @@ TclGetLoadedPackagesEx( * * 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. * @@ -1130,20 +1130,20 @@ TclGetLoadedPackagesEx( * 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; ckfree(ipPtr); @@ -1157,7 +1157,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. @@ -1171,18 +1171,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) /* @@ -1192,14 +1192,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 - ckfree(pkgPtr->fileName); - ckfree(pkgPtr->prefix); - ckfree(pkgPtr); + ckfree(libraryPtr->fileName); + ckfree(libraryPtr->prefix); + ckfree(libraryPtr); } } -- cgit v0.12 From d63f456a83dd1cbb7dedd7fd1148a89f0905bcd0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 22 Mar 2021 10:04:12 +0000 Subject: Fix incorrect comment: underscore ('_') is allowed in a packageName --- generic/tclLoad.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 2891884..e1c21b0 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -27,7 +27,7 @@ typedef struct LoadedPackage { * 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". + * others LC), as in "Net". * Malloc-ed. */ Tcl_LoadHandle loadHandle; /* Token for the loaded file which should be * passed to (*unLoadProcPtr)() when the file -- cgit v0.12 From 6c6a470c2bc258d42f224373a084ee2a4d61e9a6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 22 Mar 2021 17:07:01 +0000 Subject: Rename MODULESCOPE TclGetLoadedPackagesEx() to TclGetLoadedLibraries() --- generic/tclCmdIL.c | 2 +- generic/tclInt.h | 2 +- generic/tclLoad.c | 4 ++-- generic/tclStubInit.c | 2 +- library/safe.tcl | 4 ++-- 5 files changed, 7 insertions(+), 7 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index beb55c0..d3588aa 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -1700,7 +1700,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.h b/generic/tclInt.h index 1d192ff..75167df 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3044,7 +3044,7 @@ MODULE_SCOPE Tcl_Obj * TclGetSourceFromFrame(CmdFrame *cfPtr, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE char * TclGetStringStorage(Tcl_Obj *objPtr, unsigned int *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/tclLoad.c b/generic/tclLoad.c index 0fd21c0..afad897 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -1024,7 +1024,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). @@ -1043,7 +1043,7 @@ 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 diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index f0056eb..b66af58 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -309,7 +309,7 @@ static int TclGetLoadedPackages( * otherwise, just return info about this * interpreter. */ { - return TclGetLoadedPackagesEx(interp, targetName, NULL); + return TclGetLoadedLibraries(interp, targetName, NULL); } mp_err TclBN_mp_div_3(const mp_int *a, mp_int *c, unsigned int *d) { diff --git a/library/safe.tcl b/library/safe.tcl index 27033b2..3c01f75 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -1029,14 +1029,14 @@ proc ::safe::AliasLoad {child file args} { # Determine what kind of load is requested if {$file eq ""} { - # static library loading + # 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 library loading disabled\ + Log $child "static loading disabled\ (trying to load $prefix to $target)" return -code error "permission denied (static library)" } -- cgit v0.12 From 79b9ab1039274a64062f7a8b3a0931b72e79682d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 28 Mar 2021 20:09:51 +0000 Subject: Change TCL_ENCODING_EXTERNAL flag into TCL_ENCODING_MODIFIED, but with opposite meaning. Simplify code. --- generic/tclEncoding.c | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 4eabbda..3f03bf4 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -511,8 +511,8 @@ FillEncodingFileMap(void) */ /* Those flags must not conflict with other TCL_ENCODING_* flags in tcl.h */ -#define TCL_ENCODING_LE 0x40 /* Little-endian encoding */ -#define TCL_ENCODING_EXTERNAL 0x80 /* Converting from internal to external variant */ +#define TCL_ENCODING_MODIFIED 0x20 /* Converting NULL bytes to 0xC0 0x80 */ +#define TCL_ENCODING_LE 0x80 /* Little-endian encoding, for ucs-2/utf-16 only */ void TclInitEncodingSubsystem(void) @@ -1137,7 +1137,7 @@ Tcl_ExternalToUtfDString( srcLen = encodingPtr->lengthProc(src); } - flags = TCL_ENCODING_START | TCL_ENCODING_END; + flags = TCL_ENCODING_START | TCL_ENCODING_END | TCL_ENCODING_MODIFIED; while (1) { result = encodingPtr->toUtfProc(encodingPtr->clientData, src, srcLen, @@ -1253,18 +1253,17 @@ Tcl_ExternalToUtf( dstLen--; } + flags |= TCL_ENCODING_MODIFIED; do { - int savedFlags = flags; Tcl_EncodingState savedState = *statePtr; result = encodingPtr->toUtfProc(encodingPtr->clientData, src, srcLen, - flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, + flags , statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr); if (*dstCharsPtr <= maxChars) { break; } dstLen = Tcl_UtfAtIndex(dst, maxChars) - dst + (TCL_UTF_MAX - 1); - flags = savedFlags; *statePtr = savedState; } while (1); if (!noTerminate) { @@ -1328,7 +1327,7 @@ Tcl_UtfToExternalDString( flags = TCL_ENCODING_START | TCL_ENCODING_END; while (1) { result = encodingPtr->fromUtfProc(encodingPtr->clientData, src, - srcLen, flags | TCL_ENCODING_EXTERNAL, &state, dst, dstLen, + srcLen, flags, &state, dst, dstLen, &srcRead, &dstWrote, &dstChars); soFar = dst + dstWrote - Tcl_DStringValue(dstPtr); @@ -1430,7 +1429,7 @@ Tcl_UtfToExternal( dstLen -= encodingPtr->nullSize; result = encodingPtr->fromUtfProc(encodingPtr->clientData, src, srcLen, - flags | TCL_ENCODING_EXTERNAL, statePtr, dst, dstLen, srcReadPtr, + flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr); if (encodingPtr->nullSize == 2) { dst[*dstWrotePtr + 1] = '\0'; @@ -2225,7 +2224,7 @@ UtfToUtfProc( result = TCL_CONVERT_NOSPACE; break; } - if (UCHAR(*src) < 0x80 && !(UCHAR(*src) == 0 && !(flags & TCL_ENCODING_EXTERNAL))) { + if (UCHAR(*src) < 0x80 && !(UCHAR(*src) == 0 && (flags & TCL_ENCODING_MODIFIED))) { /* * Copy 7bit characters, but skip null-bytes when we are in input * mode, so that they get converted to 0xC080. @@ -2233,7 +2232,7 @@ UtfToUtfProc( *dst++ = *src++; } else if (UCHAR(*src) == 0xC0 && (src + 1 < srcEnd) - && UCHAR(src[1]) == 0x80 && (flags & TCL_ENCODING_EXTERNAL)) { + && UCHAR(src[1]) == 0x80 && !(flags & TCL_ENCODING_MODIFIED)) { /* * Convert 0xC080 to real nulls when we are in output mode. */ -- cgit v0.12